diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..5ea9182 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,2 @@ +*.h linguist-language=C +*.ms linguist-language=Scheme diff --git a/.github/workflows/build.sh b/.github/workflows/build.sh new file mode 100755 index 0000000..c6f6efd --- /dev/null +++ b/.github/workflows/build.sh @@ -0,0 +1,12 @@ +#!/bin/bash +set -e -o pipefail +./configure -m="$TARGET_MACHINE" +make -j $(getconf _NPROCESSORS_ONLN) +case "$TARGET_MACHINE" in + *a6nt) + curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x64.dll > "$TARGET_MACHINE"/bin/"$TARGET_MACHINE"/iconv.dll + ;; + *i3nt) + curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x86.dll > "$TARGET_MACHINE"/bin/"$TARGET_MACHINE"/iconv.dll + ;; +esac diff --git a/.github/workflows/summary b/.github/workflows/summary new file mode 100644 index 0000000..1f21e16 --- /dev/null +++ b/.github/workflows/summary @@ -0,0 +1,4 @@ +-------- o=0 -------- +-------- o=3 -------- +-------- o=3 cp0=t -------- +-------- o=3 cp0=t eval=interpret rmg=2 -------- diff --git a/.github/workflows/test.sh b/.github/workflows/test.sh new file mode 100755 index 0000000..274b5c3 --- /dev/null +++ b/.github/workflows/test.sh @@ -0,0 +1,7 @@ +#!/bin/bash +if test -n "$PARALLEL_MATS" ; then + njobs="$PARALLEL_MATS" +else + njobs="$(getconf _NPROCESSORS_ONLN)" +fi +make -C "$TARGET_MACHINE"/mats -j "$njobs" partialx diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 0000000..9748216 --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,74 @@ +--- +name: test +on: [push, pull_request] +jobs: + test: + strategy: + fail-fast: false + matrix: + config: + - machine: a6osx + os: macos-11 + - machine: ta6osx + os: macos-11 + - machine: i3le + os: ubuntu-20.04 + - machine: ti3le + os: ubuntu-20.04 + - machine: a6le + os: ubuntu-20.04 + - machine: ta6le + os: ubuntu-20.04 + - machine: i3nt + os: windows-2019 + - machine: i3nt + os: windows-2022 + - machine: ti3nt + os: windows-2019 + - machine: ti3nt + os: windows-2022 + - machine: a6nt + os: windows-2019 + - machine: a6nt + os: windows-2022 + - machine: ta6nt + os: windows-2019 + - machine: ta6nt + os: windows-2022 + runs-on: ${{ matrix.config.os }} + env: + TARGET_MACHINE: ${{ matrix.config.machine }} + defaults: + run: + shell: bash + working-directory: ${{ github.workspace }} + steps: + - name: Configure git on Windows + if: ${{ runner.os == 'Windows' }} + run: git config --global core.autocrlf false + - name: Checkout + uses: actions/checkout@v2 + - name: Setup 32-bit Linux + if: ${{ endsWith(matrix.config.machine, 'i3le') }} + run: | + sudo dpkg --add-architecture i386 + sudo apt-get update + sudo apt-get install gcc-multilib lib32ncurses5-dev uuid-dev:i386 + - name: Build Chez Scheme + run: .github/workflows/build.sh + - name: Run tests + timeout-minutes: 30 + run: .github/workflows/test.sh + - name: Archive workspace + if: always() + run: tar -c -h -z -f $TARGET_MACHINE.tgz $TARGET_MACHINE + - name: Upload archive + if: always() + uses: actions/upload-artifact@v2 + with: + name: ${{ matrix.config.machine }} + path: ${{ matrix.config.machine }}.tgz + - name: Check test results + run: | + cat $TARGET_MACHINE/mats/summary + diff -q .github/workflows/summary $TARGET_MACHINE/mats/summary diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..cff68cc --- /dev/null +++ b/.gitignore @@ -0,0 +1,51 @@ +*~ +.*.sw? +.sw? +/Makefile +/TAGS +/a6le/ +/a6nt/ +/a6osx/ +/bin/ +/i3le/ +/i3nt/ +/i3osx/ +/ta6le/ +/ta6nt/ +/ta6osx/ +/ti3le/ +/ti3nt/ +/ti3osx/ +/xc-*/ +*.*run +/csug/math/csug/ +/csug/Makefile +/csug/*.aux +/csug/*.html +/csug/*.tex +/csug/csug.ans +/csug/csug.bbl +/csug/csug.blg +/csug/*.haux +/csug/csug.htoc +/csug/*.idx +/csug/csug.ilg +/csug/csug.ind +/csug/csug.pdf +/csug/*.rfm +/csug/csug.sfm +/csug/csug.toc +/csug/*.hidx +/csug/libslisted* +/csug/libsrecorded* +/csug/*.log +/release_notes/math/release_notes/ +/release_notes/Makefile +/release_notes/*.tex +/release_notes/*.aux +/release_notes/*.haux +/release_notes/*.html +/release_notes/*.htoc +/release_notes/*.htoc +/release_notes/*.log +/release_notes/release_notes.pdf diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..e69e19b --- /dev/null +++ b/.gitmodules @@ -0,0 +1,12 @@ +[submodule "zlib"] + path = zlib + url = https://github.com/madler/zlib.git +[submodule "nanopass"] + path = nanopass + url = https://github.com/nanopass/nanopass-framework-scheme.git +[submodule "stex"] + path = stex + url = https://github.com/dybvig/stex +[submodule "lz4"] + path = lz4 + url = https://github.com/lz4/lz4.git diff --git a/BUILDING b/BUILDING new file mode 100644 index 0000000..ba20c67 --- /dev/null +++ b/BUILDING @@ -0,0 +1,368 @@ +Building Chez Scheme Version 9.5.9 +Copyright 1984-2022 Cisco Systems, Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +---------------------------------------------------------------------------- + +This directory contains the sources for Chez Scheme, plus boot and header +files for various supported machine types. + +BASICS + +Building and installing Chez Scheme on a recent version of Linux or OS X +is typically as simple as installing the prerequisites listed below and +running (Windows build instructions appear under the heading WINDOWS +later in this file): + +./configure +sudo make install + +This should not take more than a minute or so, after which the commands +'scheme' and 'petite' can be used to run Chez Scheme and Petite Chez +Scheme, while 'man scheme' and 'man petite' can be used to view the +manual pages. Chez Scheme and Petite Chez Scheme are terminal-based +programs, not GUIs. They both incorporate sophisticated command-line +editing reminiscent of tcsh but with support for expressions that span +multiple lines. + +Prerequisites: + +* GNU Make +* gcc +* Header files and libraries for ncurses [unless --disable-curses] +* Header files and libraries for X windows [unless --disable-x11] +* Header files and libraries for uuid + +Uninstalling on Unix-like systems is as simple as running: + +sudo make uninstall + +BUILDING VERSION 9.5 AND EARLIER + +If the environment variable CHEZSCHEMELIBDIRS is set, please unset +it before running make. Depending on the variable's value, it can +cause the build process to fail. + +DETAILS + +The sources for Chez Scheme come in two parts: + +* A set of Scheme source files found in the subdirectory s. Compiling + these produces the boot files petite.boot and scheme.boot, along with + two header files, equates.h and scheme.h. + +* A set of C source files found in the subdirectory c. Compiling and + linking these files produces the executable scheme (scheme.exe under + Windows). Compiling the C sources requires the two header files + produced by compiling the Scheme sources. + +Since the Scheme sources can be compiled only by a working version of +Chez Scheme, it's not actually possible to build Chez Scheme from source. +That's why the boot and header files are packaged with the sources. + +'./configure' attempts to determine what type of machine it's on and, +if successful, creates several files and directories: + +* The directory nanopass containing the Nanopass Infrastructure, + retrieved from GitHub. + +* A make file, Makefile, in the root (top level) directory. + +* A "workarea", or subdirectory named for the machine type (e.g., + a6le for nonthreaded 64-bit linux). The workarea is a mirror of + the root directory, with subdirectories named c, s, and so on. + Compilation takes place in the workarea. + +* Within the workarea, the files Makefile, Mf-install, and Mf-boot. + +'./configure' recognizes various options for controlling the type +of build and the installation location. For example, '--threads' +requests a build with support for native threads, '--32' requests +a 32-bit build, and '--installprefix ' specifies the +installation root. './configure --help' prints the supported +options. + +The make file supports several targets: + +'make' or 'make build' + compiles and links the C sources to produce the executable, then + bootstraps the Scheme sources. Bootstrapping involves using the + freshly built scheme executable along with the distributed boot files + to compile the Scheme sources. If the new boot files are equivalent + to the old boot files, the system is bootstrapped. Otherwise, the new + boot files are used to create a newer set, and those are compared. + If this succeeds, the system is bootstrapped. Otherwise, the make + fails. This should not fail unless the distributed boot files are + out of sync with the sources. + + When you make a modification to the system that causes the C side to + get out of sync with the Scheme side so that the build fails, try + the following from $W if you have a recent version of Chez Scheme + installed in your path: + + make -C s clean all patchfile=patch Scheme=scheme SCHEMEHEAPDIRS={see below} + make build + + Set SCHEMEHEAPDIRS to /usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m on + Unix-like systems and to %x/../../boot/%m on Windows systems. + + Alternatively, if you have a build before the changes at full path + , use + + make from-orig ORIG= + + To run Chez Scheme without installing, you need to tell the + executable where to find the boot files. The run target of the + makefile will do that + + make run + + or this can be done manually via command-line arguments, e.g.: + + $W/bin/$M/scheme -b $W/boot/$M/petite.boot -b $W/boot/$M/scheme.boot + + or by setting the SCHEMEHEAPDIRS variable to point to the directory + containing the boot files. For example, in bash: + + SCHEMEHEAPDIRS=$W/boot/$M $W/bin/$M/scheme + + and in tcsh: + + setenv SCHEMEHEAPDIRS "$W/boot/$M" + $W/bin/$M/scheme + + In all cases, $W should be replaced with the name of the workarea, + and $M should be replaced with the machine type. (Unless the default + is overridden via an argument to ./configure, $W is the same as $M.) + +'sudo make install' + runs the build plus installs the resulting executables, boot files, + example files, and manual pages. If the installprefix used with + './configure' is writable by the current user, then 'sudo' is not + necessary. + +'sudo make uninstall' + uninstalls the executables, boot files, example files, and manual pages. + As with 'make install', if the installprefix used with './configure' is + writable by the current user, then 'sudo' is not necessary. + +'make test' + runs the build plus runs a set of test programs in various different + ways, e.g., with different compiler options. It can take 20 minutes + to more than an hour, depending on the speed of the machine and number + of parallel targets executed by make (as configured, e.g., by the -j + flag). + + NB: A complete run does not imply no errors occurred. To check for + errors, look at the file $W/mats/summary, where $W is the name of the + workarea created by ./configure. $W/mats/summary should contain one + line per test run, something like this: + + -------- o=0 -------- + -------- o=3 -------- + -------- o=0 cp0=t -------- + -------- o=3 cp0=t -------- + -------- o=0 spi=t p=t -------- + -------- o=3 spi=t p=t -------- + -------- o=0 eval=interpret -------- + -------- o=3 eval=interpret -------- + -------- o=0 cp0=t eval=interpret -------- + -------- o=3 cp0=t eval=interpret -------- + -------- o=0 ehc=t eoc=f -------- + -------- o=3 ehc=t eval=interpret -------- + + If there is anything else in $W/mats/summary, something unexpected + occurred. + +'make bootfiles' + runs the build plus uses the locally built system to recreate the + distributed boot and header files for each supported machine type. + It should be run whenever modifications made to the Scheme sources + are to be committed to the source-code repository so that up-to-date + boot and header files can be committed as well. 'make bootfiles' + can take 5 minutes or more. + + 'make bootfiles' builds boot files for each machine type for which + a subdirectory exists in the top-level boot directory. To build + for a supported machine type that isn't built by default, simply + add the appropriate subdirectory, i.e., 'mkdir boot/$M', where M + is the machine type, before running 'make bootfiles'. You can + also run '(cd $W ; make -f Mf-boot $M.boot)', where W is the name + of a built work area for the host machine type, to build just the + boot files for machine-type M. + +'make docs' + runs the build plus generates HTML and PDF versions of the Chez Scheme + Users Guide and the release notes. Unlike the other build targets, + the documentation is not built in the workarea, but rather in the + 'csug' and 'release_notes' directories. + + Building the documentation requires a few prerequisites not required + to build the rest of Chez Scheme. The following must be available + in your PATH: + * A TeX distribution (including latex, pdflatex, dvips, and gs) + * ppmtogif and pnmcrop (from Netpbm) + An X11 installation is not required, but ppmtogif does require an + 'rgb.txt' file, which it will automatically locate in the common + X11 installation locations. If ppmtogif fails because it cannot find + an rgb.txt file, you can use the RGBDEF environment variable to + specify the path to a file. If your system has an emacs installation, + then you can find an rgb.txt file in the 'etc' directory of the emacs + installation. If your system has a vim installation, then it might + contain an rgb.txt in $VIMRUNTIME. + +'sudo make install-docs' + builds the documentation as with 'make docs' and installs it. If the installcsug and + installreleasenotes directories used with './configure' are writable by the current + user, then 'sudo' is not necessary. + +'make clean' + removes binaries from the workarea. + +'make distclean' + removes nanopass, Makefile, built documentation, and all workareas. + +OTHER UNIX VARIANTS + +To build on Unix variants other than Linux and OS X, you will first +need to build boot files on a Linux or OS X machine. On that machine, +after building Chez Scheme, create boot files for the target machine + with: + + make boot XM= + +Copy the generated boot/ directory to the target machine, +adding to or replacing the boot directory with pre-built boot files +there, and then build as on Linux. + +Remember to use gmake if make is not GNU make. If you run into linker +trouble, try running configure with --libkernel so that the build +avoids running ld directly. + +On OpenBSD, Chez Scheme must be built and installed on a filesystem +that is mounted with wxallowed. + +On NetBSD, note that the makefiles run "paxctl +m" to enable WX pages +(i.e., pages that have both write and execute enabled). + +WINDOWS + +Building Chez Scheme under 64-bit Windows with Bash/WSL, MinGW/MSYS, +or Cygwin follows the instructions above, except that 'make install' +and 'make uninstall' are not supported. Alternatively, the main Chez +Scheme executable can be built from the Windows command line or +cross-compiled using MinGW as described further below. + +On Bash/WSL, the build directory must be in a location with a Windows +path such as /mnt/c, and the 'OS' environment variable must be set to +'Windows_NT' to indicate a build for Windows, as opposed to a build +for Linux on Windows: + +env OS=Windows_NT ./configure +env OS=Windows_NT make + +Prerequisites: + +* Bash/WSL, MinGW/MSYS, or Cygwin with bash, git, grep, make, sed, etc. +* Microsoft Visual Studio 2022, 2019, 2017, or 2015 +* WiX Toolset (for making an install) + +Be sure that git config core.autocrlf is set to false. + +If you're using Visual Studio 2022 or 2019, install "Desktop +development with C++" on the "Workloads" tabs and the "C++ 2022 [or +2019] Redistributable MSMs" on the "Individual components" tab under +the "Compilers, build tools, and runtimes" section. + +To run Chez Scheme or Petite Chez Scheme from a Windows command prompt, +set PATH: + +set PATH=$W\bin\$M;%PATH% + +again with $W and $M replaced with the workarea name and machine +type, and start Chez Scheme with the command "scheme" or Petite +Chez with the command "petite". + +The executables are dynamically linked against the Microsoft Visual +C++ run-time library vcruntime140.dll. If you distribute the +executables to a different system, be sure to include the +redistributable run-time library. + +Making an Install for Windows + +cd wininstall +make workareas +make + +This will create workareas and compile binaries for the a6nt, i3nt, +ta6nt, and ti3nt configurations and then include them in a single +Windows installer package Chez Scheme.exe. The package also includes +example files and the redistributable Microsoft Visual C++ run-time +libraries. + +Testing under Windows + +The iconv tests in mats/io.ms require that a 32-bit or 64-bit (as +appropriate) iconv.dll, libiconv.dll, or libiconv-2.dll implementing +GNU libiconv be located in $W\bin\$M or the path. Windows sources for +libiconv can be found at: + +http://gnuwin32.sourceforge.net/packages/libiconv.htm + +An alternative that uses the Windows API can be found at: + +https://github.com/burgerrg/win-iconv/releases + +If the DLL is not present, the iconv tests will fail. No other tests +should be affected. + +Unset the TZ environment variable before running the tests, because +the Cygwin values are incompatible with the Microsoft C Runtime +Library. + +Use 'make test' described above to run the tests. + +WINDOWS EXECUTABLE VIA COMMAND PROMPT + +To build the Chez Scheme executable using Microsoft Visual Studio, +first set up command-line tools. The c\vs.bat script can help if you +supply amd64 for a 64-bit build or x86 for a 32-bit build: + + c\vs.bat amd64 + +Then, run c\build/bat with a machine name, either ta6nt (64-bit +threaded), a6nt (64-bit non-threaded), ti3nt (32-bit threaded), or +i3nt (32-bit non-threaded): + + c\build.bat ta6nt + +The resulting executable in \bin\ relies on +bootfiles in ..\boot\ relative to the executable. + +CROSS-COMPILING THE WINDOWS EXECUTABLE + +To cross-compile the main Chez Scheme executable for Windows using +MinGW, specify suitable build tools to configure, perhaps using +--toolprefix= like this: + + ./configure -m=ta6nt --threads --toolprefix=x86_64-w64-mingw32- + +Then, make with c/Mf- while supplying cross=t and o=o, +possibly like this: + + (cd ta6nt/c && make -f Mf-ta6nt cross=t o=o) + +The executable is written to /bin/, and it should be +installed with bootfiles in ../boot// relative to the +executable. diff --git a/CHARTER.md b/CHARTER.md new file mode 100644 index 0000000..2ce1a8e --- /dev/null +++ b/CHARTER.md @@ -0,0 +1,55 @@ +# Chez Scheme Project Charter (the “Charter”) + +This Charter sets forth the responsibilities and procedures for +technical contribution to, and oversight of, the Chez Scheme Project +(the “Project”). Participation in the Project is open to all in a +fair, reasonable, and non-discriminatory manner. Contributors to +the Project must comply with the terms of this Charter. + +1. Governance + * The Project will involve Contributors and Committers. + Contributors include anyone in the technical community who + contributes code, documentation, or other technical artifacts + to the Project. Committers are Contributors who have the + ability to commit code directly to the Project’s main branch + or repository. + * The Committers shall be responsible for technical oversight + and other decision making of the Project. The Committers will + seek to make decisions by consensus. Except where otherwise + specified below, if a consensus cannot be reached, Project + decisions shall be made by a two-thirds vote of the Committers. + * A unanimous vote of the Committers shall be required for any + change or amendment to this Charter. + +2. Technical Policy + * Any Committer may review a pull request and accept, reject, + or solicit modifications to the request, at the Committer’s + sole discretion. For changes that might be highly impactful + or controversial, Committers are encouraged, but not required, + to seek consensus from the other Committers before proceeding. + Committers are not required to respond to every pull request, + but shall make reasonable efforts to do so. + * Any existing Committer may nominate a Contributor with the + demonstrated experience, knowledge, and commitment to the + Project to become a new Committer. A nominee can become a + Committer only by a unanimous vote of the existing Committers. + * Any Committer may resign at any time by giving notice to the + other Committers. Any Committer may also be removed at any + time by a unanimous vote of the other Committers. + +3. Intellectual Property Policy + * All new inbound code contributions to the Project shall be + made under the [Apache 2.0 license] + (http://www.apache.org/licenses/LICENSE-2.0). + * By submitting a contribution, a Contributor certifies that + the Contributor is the sole creator of the contribution and/or + has the right under all applicable intellectual property laws + to provide the contribution to the Project under the terms of + the Apache 2.0 license. + * If a Contributor wishes to contribute existing source code + covered by an open-source license other than Apache 2.0, the + Contributor must seek an exception from the Committers. + Exceptions shall be approved only by a unanimous vote of the + Committers and duly recorded in the file NOTICE. + * All outbound code will be made available under the Apache 2.0 + license. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..e63df22 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,94 @@ +# Contributing to Chez Scheme + +Chez Scheme is a work in progress, and we invite contributions from +anyone who is interested in putting forth the necessary effort. +One or more of the committers will review pull requests for +compatibility with the principles and guidance given below. Details +on pull-request processing are given in [the governance +document](CHARTER.md). + +Our core principles are pretty simple: we try to make Chez Scheme +reliable and efficient. + +Reliability means behaving as designed and documented. We have no +"known bugs" list, preferring instead careful design, coding, and +testing practices that prevent most bugs and fixing bugs that do +occur as they are discovered. A Scheme program run using Chez +Scheme can crash due to bugs in the program, but it should not crash +due to bugs in the implementation. + +Efficiency means performing at a high level, consuming minimal cpu +time and memory. Performance should be a continuous function, with +no cliffs or surprises, and should scale well as program or problem +size grow. Performance should be balanced across features, not +good in one area and bad in another. Compile time is important as +well as run time, so compiler optimizations are generally expected +to pay their own way, i.e., indirectly benefit compiler performance +enough to cover the direct cost of the optimization. + +We attempt to achieve the core principles through careful control +over growth, testing, and documentation. + +Like the Scheme language itself, a good implementation is not built +by piling up features but by providing enabling building blocks. +So when asked to add a new feature, we first look for a way to +achieve the same effect with existing functionality or smaller +extensions that are more generally applicable. + +Chez Scheme is tested in two ways: implicitly by bootstrapping +itself and explicitly via a suite of tests. The suite of tests is +about as large as the code base for the implementation, and it is +often the case that more lines of test code than implementation +code are added to support a new feature. We also benchmark the +system whenever we make a change that might materially affect +performance. + +This project also includes documentation for Chez Scheme in the +form of a manual page, a user's guide, and release notes, and we +try to set high standards for this documentation. A feature isn't +fully implemented until it has been documented. Writing documentation +often exposes unnecessary complexity in the design and bugs in the +implementation, particularly in corner cases. + +Consistent with these principles, we naturally want Chez Scheme to +evolve in various useful ways to, among other things: + +* increase utility +* improve user friendliness +* support new standards +* run on new platforms + +Backward compatibility should be maintained whenever feasible but +must sometimes take a back seat to progress in a system whose +lifetime is measured in decades. + +Please keep in mind the following guidance when preparing contributions: + +* Appropriate tests and documentation changes should be included + with all code changes. + +* Coding structure (including indentation) should be consistent + with the existing code base. This implies that contributors should + study the existing code before contributing. + +* Spend the time required to make the code as clean, clear, and + efficient as possible. All other things equal, shorter code is + preferable to longer code. Although some people believe more klocs + equals more value, code quality is in fact inversely proportional + to code size. + +* All changes must be described in LOG as well as via git commit + messages and/or github pull request logs. The revision-control + system might change over time, but the LOG should always be present. + +* Some contributions may be more appropriately published as projects + of their own. If you are contributing a significant extension built + using Chez Scheme, consider whether your contribution is such an + independent project. An example of such a project is the [Nanopass + Framework](http://github.com/nanopass/nanopass-framework-scheme) + which is both used by Chez Scheme and was initially written using + Chez Scheme, but evolves separately. + +Before investing significant effort preparing a contribution, +consider running the idea by one of the committers for additional +guidance and advice. diff --git a/LOG b/LOG new file mode 100644 index 0000000..1b3f7b6 --- /dev/null +++ b/LOG @@ -0,0 +1,2341 @@ +9.4 changes: +- updated version to 9.4 + bintar README NOTICE makefiles/Mf-install.in scheme.1.in + c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt + mats/bldnt.bat workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/csug.stex +- added missing include + killme.c +- added new mat verifying that primitives raise exceptions for invalid + arguments based on primdata.ss signatures. fixed some of those + signatures, which weren't otherwise used except for arity checking. + fixed some issues turned up by the test with who reports errors + and how. + primdata.ss, 5_1.ss, 7.ss, compile.ss, cpnanopass.ss, fasl.ss, + interpret.ss, io.ss, record.ss, syntax.ss, + primvars.ms, 5_1.ms, 7.ms, 8.ms, record.ms, mats/Mf-base, + root-experr*, patch* +- string comparisons (string=?, string-cidate test in mat time&date-printing to work regardless of + what locale (and time zone) the host machine has set. + date.ms +- fixed date->time-utc to honor the zone-offset field when converting a date + object to a time-utc object. + stats.c, + date.ms +- fixed incorrect handling of library-extension when searching wpo files + compile.ss, + 7.ms +- modified floatify_normalize to properly round denormalized results. + obviated scale_float in the process. + number.c, + ieee.ms +- fixed 0eNNNN for large NNNN to produce 0.0 rather than infinity + strnum.ss, + 5_3.ms +- the reader now raises an exception with condition type implementation + restriction (among the other usual lexical condition types), and + string->number now raises #f, for #e@, where and are + nonzero integers, since Chez Scheme can't represent polar numbers other + than 0@ and @0 exactly. @ still produces an inexact result, + i.e., we're still extending the set of inexact numeric constants beyond + what R6RS dictates. doing this required a rework of $str->num, which + turned into a fairly extensive rewrite that fixed up a few other minor + issues (like r6rs:string->number improperly allowing 1/2e10) and + eliminated the need for consumers to call $str->num twice in cases + where it can actually produce a number. added some related new tests, + including several found missing by profiling. added a couple of + checks to number->string the absence of which was causing argument + errors to be reported by other routines. + strnum.ss, exceptions.ss, read.ss + 5_3.ms, 6.ms, root-experr*, patch* +- added pdhtml flag, which if set to t causes profile-dump-html to be + called at the end of a mat run. + mats/Mf-base +- compile-whole-program and compile-whole-library now copy the hash-bang + line from the wpo file (if it has one) to the object file. + compile.ss, + 7.ms +- stex is now a submodule. csug/Makefile and release_notes/Makefile + set and use the required Scheme and STEXLIB variables accordingly. + they default the machine type to a6le, but this can be overridden + and is by the generated top-level Makefile. the generated top-level + Makefile now has a new docs target that runs make in both csug and + release_notes, and an updated distclean target that cleans the same. + the annoying csug Makefile .fig.pdf rule redefinition is now gone. + copyright.stex and csug.stex now list May 2016 as the revision month + and date; this will have to be updated for future releases. + configure, makefiles/Makefile.in, + csug/Makefile, copyright.stex, csug.stex, + release_notes/Makefile +- added custom install options. workarea creates an empty config.h, + and configure creates a config.h that sets the default scheme heap + path and scheme-script name based on the actual configuration. + configure, newrelease, workarea, checkin, + c/Mf-base, scheme.c, main.c, + Mf-install.in +- renamed the installed example directory from lib to examples. + Mf-install.in, + scheme.1.in +- added force option to gzip during man page install to prevent gzip from + asking for permission to overwrite existing man page files. + Mf-install.in +- removed ~/lib/csv%v/%m from the default scheme heap path on unix-like + systems. documented inclusion of %x\..\..\boot\%m in the Windows + default scheme heap path. + main.c, + use.stex +- added new configuration options: --installbin, --installlib, + --installschemename, --installpetitename, and --installscriptname. + configure +- updated the example library link to the nanopass framework. + CONTRIBUTING.md +- now cleaning up petite.1 and scheme.1 left behind by make install + Makefile-workarea.in, checkin +- now removing workarea after cleaning csug and release_notes so + Mf-stex (included from csug/Makefile and release_notes/Makefile) + doesn't complain trying to determine the machine type. + Makefile.in +- added installsh support for --ifdiff so the csug make file can use it + for the install target. + installsh, + csug/Makefile +- added instructions for building (cross-compiling) a boot file for + a supported machine type for which a boot file is not built by default. + BUILDING +- corrected CHEZSCHEMELIBS and CHEZSCHEMEEXTS index entries to be + CHEZSCHEMELIBDIRS and CHEZSCHEMELIBEXTS. + use.stex +- updated to curl stex version 1.2.1 + configure +- updated the fix to S_mktime to work on windows. the struct tm + structure on windows does not have the tm_gmtoff field used in the + mac and linux version of the code. + stats.c +- updated the Windows makefiles for building and testing to remove links for + files that no longer exist, which was getting in the way of creating links + for files that do exist. Also updated the build batch file for Windows to + compile the nanopass framework separately before building the rest of the + scheme compiler and libraries. + s/Mf-{a6,i3,ta6,ti3}nt, s/bldnt.bat, + mats/Mf-{a6,i3,ta6,ti3}nt +- updated the read me to include a link to the Chez Scheme project page. + README.md +- fixed embarrassing typo in read me. + README.md +- profiler's html output refresh: mark the files as HTML5 rather + than HTML4; use target attributes rather than onclick events to + open links in specific windows; add a missing table row element; + replace the deprecated name attribute with an id attribute (and + replace the anchors with spans); and replace the deprecated valign + attribute with a style attribute. + pdhtml.ss + +9.4.1 changes: +- updated version to 9.4.1 + bintar BUILDING NOTICE makefiles/Mf-install.in scheme.1.in + c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt + mats/bldnt.bat workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/csug.stex +- updated newrelease to produce the correct log-entry format and + fixed the existing 9.4.1 log entry + newrelease, LOG +- replaced a couple of tabs + number.c +- updated the descriptions of statistics and related functions to + reflect the Version 9.3.1 change from sstats structures to sstats + records, with sstats times represented as time objects and sstats + bytes and counts represented as exact integers; also updated the + sstats-difference description to reflect that it no longer coerces + negative differences to zero. added a corresponding release note. + system.stex, + release_notes.stex +- added a cast to eliminate a warning + c/number.c +- fixed bug in Windows version of directory-separator-predicate when + path-* procedures are passed a path that is not a string. + s/6.ss +- fixed bug in cp0 on Windows with $foreign-wchar?. + s/cp0.ss +- Cygwin is now used on Windows, updated mats, eliminated unused killme + BUILDING c/*nt c/Mf-base c/scheme.exe.manifest configure + examples/Makefile mats/6.ms mats/Mf-* mats/foreign.ms mats/ftype.ms + mats/patch-* mats/windows.ms s/Mf-*nt s/Mf-base workarea + release_notes.stex +- fixed spelling of non-existent + s/syntax.ss +- now forcing zlib configuration before compiling files that depend on + the zlib header files, since zlib's configure script can modify the + header files. removed ZlibInclude variable, which no longer serves + a purpose. + c/Mf-*, c/Makefile.*nt +- removed unnecessary datestamp.c target + c/Mf.*nt +- fixed unnecessary blocking in expeditor on Windows. + c/expeditor.c +- eliminated a couple of thread-safety issues and limitations on the + sizes of pathnames produced by expansion of tilde (home-directory) + prefixes by replacing S_pathname, S_pathname_impl, and S_homedir + with S_malloc_pathname, which always mallocs space for the result. + one thread-safety issue involved the use of static strings for expanded + pathnames and affected various file-system operations. the other + affected the file open routines and involved use of the incoming + pathname while deactivated. the incoming pathname is sometimes if not + always a pointer into a Scheme bytevector, which can be overwritten if a + collection occurs while the thread is deactivated. the size limitation + corresponded to the use of the static strings, which were limited to + PATH_MAX bytes. (PATH_MAX typically isn't actually the maximum path + length in contemporary operating systems.) eliminated similar issues + for wide pathnames under Windows by adding S_malloc_wide_pathname. + consumers of the old routines have been modified to use the new + routines and to free the result strings. the various file operations + now consistently treat a pathname with an unresolvable home directory + as a pathname that happens to start with a tilde. eliminated unused + foreign-symbol binding of "(cs)pathname" to S_pathname. + io.c, externs.h, new_io.c, prim5.c, scheme.c, prim.c +- various places where a call to close or gzclose was retried when + the close operation was interrupted no longer do so, since this can + cause problems when another thread has reallocated the same file + descriptor. + new_io.c +- now using vcvarsall type x86_amd64 rather than amd64 when the + former appears to supported and the latter does not, as is the + case with VS Express 2015. + c/Mf-a6nt, c/Mf-ta6nt +- commented out one of the thread mats that consistently causes + indefinite delays under Windows and OpenBSD due to starvation. + thread.ms +- increased wait time for a couple of subprocess responses + 6.ms +- added call to collector to close files opened during iconv mats + specifically for when mats are run under Windows with no iconv dll. + io.ms +- fixed typo: VC/bin/vcvars64.bat => VC/bin/amd64/vcvars64.bat + c/Mf-a6nt, c/Mf-ta6nt +- scheme_mutex_t now uses volatile keyword for owner and count fields + because these fields can be accessed from multiple threads + concurrently. Updated $yield and $thread-check in mats/thread.ms to + be more tolerant of timing variability. + c/types.h, mats/thread.ms, release_notes.stex +- fixed three instances of unchecked mallocs reported by laqrix in + github issue #77. + io.c, schlib.c, thread.c +- continue the profiler's html output refresh: refine the styling + (and palette) and update CSUG to match. update the CSUG screenshots + to reflect the refined look. + s/pdhtml.ss + csug/system.stex + csug/canned/profilehtml-orig.png + csug/canned/profilehtml.png + csug/canned/fatfibhtml-orig.png + csug/canned/fatfibhtml.png +- add unicode support to the expression editor. entry and display now work + except that combining characters are not treated correctly for + line-wrapping. this addresses github issue #32 and part of issue #81. + c/expeditor.c, s/expeditor.ss +- moved s_ee_write_char function within the WIN32 check to allow the unicode + change to compile on windows. unicode is not yet supported in the windows + version of the repl. + c/expeditor.c +- reworked the S_create_thread_object to print an error and exit when + allocating the thread context fails from Sactivate_thread. before + this change, the error was raised on the main thread, which resulted + in strange behavior at best. also added who argument to + S_create_thread_object to allow it to report either Sactivate_thread + or fork-thread led to the error. + externs.h, schsig.c, scheme.c, thread.c +- fixed a bug in cpvalid resulting in it leaving behind a cpvalid-defer + form for later passes to choke on. also fixed cp0 to print the correct + name for cpvalid when it does this. + cpvalid.ss, cp0.ss, + misc.ms +- updated the prototype for s_ee_write_char to match the definition + expeditor.c +- fixed a side-effect preservation bug with non-trivial test-context + not-like patterns. + cp0.ss, + cp0.ms, 4.ms +- instead of default-exception handler, new-cafe establishes a handler + that calls the current value of base-exception-handler so the handler + can be overridden, as we do in our own make files. + cafe.ss, + 7.ms +- fixed a bug in case and exclusive-cond syntax-error calls causing an + exception in syntax-error instead of the intended error message. + syntax.ss +- added tests for the case and exclusive-cond syntax-error calls + 4.ms, root-experr-compile-0-f-f-f +- added print-extended-identifiers parameter. when #t, symbols like + 1+ and +++ print without escapes. + priminfo.ss, print.ss, + 6.ms +- added descriptions of print-extended-identifiers to the user's guide + and release notes. updated the release notes to account for a couple + of other log entries. + release_notes.stex, + intro.stex, io.stex +- updated the sockets example to work with the current version of Chez. + Change the foreign procedure definitions to use the more portable int + rather than integer-32. Switch to a custom port + [make-custom-binary-input/output-port] rather than a generic port + [make-input/output-port], which resulted in deleting quite a bit of + code. Fix various compiler warnings in the C code, and along the way, + fix a signedness bug in c_write that could have resulted in not writing + the full buffer (but reporting that it did) in the case of errors from + write. + examples/csocket.c, examples/socket.ss +- use high-precision clock time on Windows 8 and up + c/stats.c +- fixed profiling code that keyed profiling locations off of only the + bfp to instead key off of both the bfp and efp. + pdhtml.ss +- added Windows installer using the WiX Toolset + BUILDING, install/* (new) +- fix typo in ordinal format for 12 + format.ss, + format.ms +- renamed install directory to wininstall to avoid conflict with + top-level Makefile + BUILDING, install/* (removed), wininstall/* (new) +- updated zlib to version 1.2.11 + configure +- added procedure-arity-mask to report the allowed argument counts of + a compiled function. On a procedure from interpret or from one of + the trace procedures or syntactic forms, procedure-arity-mask + may report counts that are not actually allowed by the source + procedure. + cmacros.ss, compile.ss, cpnanopass.ss, mkheader.ss, primdata.ss, + prims.ss, strip.ss, + fasl.c, gc.c, globals.h, prim.c, prim5.c, scheme.c, schsig.c, + misc.ms, root-experr*, + objects.stex +- for non-win32 systems, now setting al register to a count of the + floating-point register arguments as required for varargs functions + by the System V ABI. + x86_64.ss, + foreign.ms +- added a missing quote mark in new printf mat Windows case + foreign.ms +- added travis-ci automation script and a 'partialx' testing target to + allow us to perform more than a single run of testing without running + afoul of travis-ci's 50-minute build timeout. 'partialx' tests six + of the twelve configurations tested by 'allx'. + .travis.yml (new), + mats/Mf-base +- paired the 'partialx' down to just four test configurations, with one + interpreter run, to try to get the threaded builds into line with + travis-ci's timeout. + mats/Mf-base +- eliminated some direct assumptions that a vector's type/length field + is a fixnum and added meta-asserts to verify that it is in a couple of + others, to facilitate future changes to vector typing. vectors are + now treated essentially like fxvectors, strings, and bytevectors. + cmacros.ss, cpnanopass.ss, prims.ss, mkheader.ss, + alloc.c, gc.c, scheme.c +- fixed a few comments to refer to scheme.c rather than main.c + externs.h, globals.h, thread.c +- for 64-bit Windows systems, now copying foreign-procedure + double-precision floating-point register arguments to integer + registers as required for varargs functions. Windows does not + support single-precision floating-point arguments as varargs. + foreign.ms, np-languages.ss, x86_64.ss +- added an optional timeout argument to condition-wait + externs.h, stats.c, thread.c, thread.h, csug/threads.stex, + primvars.ms, thread.ms, release_notes.stex, + date.ss, primdata.ss, prims.ss +- added immutable strings, vectors, fxvector, bytevectors, and boxes + 5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cpnanopass.ss, + fasl.ss, library.ss, mkheader.ss, primdata.ss, prims.ss, + externs.h, types.h, alloc.c, fasl.c, gc.c, scheme.c, + 5_5.ms, 5_6.ms, bytevector.ms, misc.ms, root-experr* + objects.stex +- various tweaks to the immutable object support; also taught cp0 + to simplify ($fxu< (most-positive-fixnum) e) => (fx< e 0) so we + don't have any incentive in special casing length checks where + the maximum length happens to be (most-positive-fixnum). + 5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cp0.ss, cpnanopass.ss, + mkheader.ss, primdata.ss, prims.ss, + fasl.c, gc.c, types.h + root-experr*, patch* +- generated bytevector=? procedure now gets out quickly on eq + arguments. cp0 optimizes away a number of additional equality + operations at optimize-level 3 (including bytevector=?) when + applied to the same variable references, as it already did for + eq?, eqv?, and equal?, at all optimize levels. + cpnanopass.ss, cp0.ss, primdata.ss, + cp0.ms +- updated bullyx patches + patch* +- updated release notes and tweaked user's guide. + release-notes.stex, objects.stex +- fixed typo: fxvector-immutable-flag used in place of + bytevector-immutable-flag in computation of type-immutable-bytevector + cmacros.ss +- reallocated typed-object types, using previously unused tag #b010 + for strings and giving bytevectors both #b001 and #b101 (the + latter for immutable bytevectors) so that the maximum bytevector + length on 32-bit machines is once again the most-positive fixnum. + treating bytevectors rather than strings or fxvectors (or even + vectors) special in this regard is appropriate since the maximum + number of bytes in a bytevector is maximum-length x 1 rather than + maximum-length x 4 for strings, fxvectors, and vectors on 32-bit + machines. with this change on 32-bit machines, a vector can + occupy up to 1/2 of virtual memory, strings and fxvectors 1/4, + and bytevectors 1/8. + cmacros.ss +- added record-type-equal-procedure, record-type-hash-procedure, + record-equal-procedure, and record-hash-procedure to enable + per-type customization of the behavior of equal? and equal-hash + for a record value + 5_1.ss, newhash.ss, primdata.ss, + record.ms, root-experr*, + objects.stex +- adding dropped changes + record.ss, + root-experr* +- added entry for record-type-equal-procedure and friends + release_notes.stex +- changed copyright year to 2017 + 7.ss, scheme.1.in, comments of many files +- expanded the CSUG description of the handling of command-line + arguments not recognized as standard options and added a description + of the same to the COMMAND-LINE OPTIONS section of the man page. + did a bit of minor cleanup elsewhere in the man page. + use.stex, scheme.1.in +- destroy_thread now processes guardian entries + thread.c, 4.ms, release_notes.stex +- mutexes and conditions are now freed when no longer used via + $close-resurrected-mutexes&conditions, $keep-live primitive added + externs.h, prim5.c, thread.c, 4.ms, thread.ms, release_notes.stex, + 7.ss, cpnanopass.ss, np-languages.ss, primdata.ss, prims.ss +- fix reduction for map and for-each with optimization level 3 + to drop the expression, check that procedure has the correct + arity and is discardable or unsafe. + Also add a simplification for for-each with empty lists + with optimization level 2. + cp0.ss, 4.ms, primdata.ss +- fix invalid memory reference when enum-set-indexer procedure is not + passed a symbol + enum.ss, enum.ms, root-experr*, release_notes.stex +- fix overflow detection for fxsll, fxarithmetic-shift-left, and + fxarithmetic-shift + library.ss, fx.ms, release_notes.stex +- added ephemeron pairs and changed weak hashtables to use + ephemeron pairs for key--value mapping to avoid the key-in-value + problem + prims.ss, primdata.ss, newhash.ss, fasl.ss, mkheader.ss + cmacro.ss, prim5.c, fasl.c, gc.c, gcwrapper.c, types.h, + 4.ms, hash.ms, objects.stex, smgmt.stex, csug.bib +- check_dirty_ephemeron now puts ephemerons whose keys haven't yet + been seen on the pending list rather than the trigger lists. + gc.c +- removed scan of space_ephemeron from check_heap because check_heap + as written can't handle the two link fields properly. + gcwrapper.c +- in the ephemerons mat that checks interaction between mutation and + collection, added generation arguments to the first two collect + calls so they always collect into the intended generation. + 4.ms +- updated allx and bullyx patches + patch* +- fix strip-fasl-file for immutable strings and vectors, + fix an $oops call, and fix a vector-index increment in hashing + strip.ss, 7.ss, newhash.ss, misc.ms +- fix signature of fxbit-set? + primdata.ss +- more optimizations for map and for-each with explicit list + extend the reductions for map and for-each when the arguments are + explicit lists like (list 1 2 3 ...) or '(1 2 3 ...). + cp0.ss, + 4.ms +- reverted to the preceding version of cp0 due to failure to preserve + the expected evaluation order in one of the mats; removed the + corresponding equivalent-expansion tests. + cp0.ss, + 4.ms +- restored the map and for-each optimizations with a fix for the + evaluation-order bug. + cp0.ss, + 4.ms +- added date-dst? to access the previously-hidden DST information in + date records, and added date-zone-name to provide a time zone name. + date.ss, primdata.ss, + stats.c, + date.ms, root-experr*, patch-compile*, + system.stex +- fixed a bug in flonum-extractor, which on 64-bit machines was using an + 8-byte read instead of a 4-byte read to pick up the 4 highest-order + bytes of a little-endian flonum, potentially reading past the end of + mapped memory for flonums produced by taking the imaginary part of an + inexact complexnum (which, unlike other flonums, are not aligned on + 16-byte boundaries). The 8-byte load would also have failed to produce + correct results on 64-bit big-endian machines (of which we presently + have none) because the offsets passed to flonum-extractor assume the + bits are in the lowest-order 4 bytes of the extracted field. + cp0.ss, + misc.ms, + release_notes.stex +- support Windows build on Bash/WSL + BUILDING, configure, workarea, c/vs.bat (new), mats/vs.bat (new), + c/Mf-*nt, mats/Mf-*, s/Mf-base +- fix c/version.h for FreeBSD (machine types i3fb, ti3fb, a6fb, ta6fb) +- fix reference to libc.so to be libc.so.7 for FreeBSD (machine types + i3fb, ti3fb, a6fb, ta6fb) + foreign.ms +- added CC option to configure for selecting the compiler + configure, + c/Mf-* +- Suppress warnings from implicit fall-through in case labels. + Mf-{a6,arm32,i3,ppc,ta6,ti3,tpp32}le +- added bytevector-compress and bytevector-uncompress + bytevector.ss, primdata.ss, new-io.c, prim5.c, externs.h, + objects.stex, release_notes.stex, + bytevector.ms, root-experr* +- fixed typo in S_abnormal_exit + schsig.c +- don't remove the pariah form in the cp0 pass + cp0.ss, + misc.ms +- revert use of ephemerons in weak hashtables, add ephemeron + hashtables + newhash.ss, hashtable-types.ss, library.ss, primdata.ss, + fasl.ss, fasl.c, gc.c, globals.h, + hash.ms, objects.stex, release_notes.stex +- fixed pariah mat + misc.ms +- minor wordsmithing and fix for an overfull hbox + objects.stex, system.stex +- fix (define-values () ....) to expand to a definition + syntax.ss, 3.ms +- added optional line and column components to a source object, a + locate-source-object-source function that uses the new components, + a current-locate-source-object-source parameter to control looking up + line and column information, a current-make-source-object parameter to + control location recording, an optional use-cache argument to + locate-source, and a 'source-object message for code and continuation + inspectors + read.ss, syntax.ss, 7.ss, compile.ss, cpnanopass.ss, exceptions.ss, + inspect.ss, primdata.ss, prims.ss, print.ss, cmacros.ss, types.ss, + mat.ss, 8.ms, root-experr*, + syntax.stex, debug.stex, system.stex, release_notes.stex +- fixed broken mats on Windows caused by Bash/WSL changes + 7.ms, ftype.ms +- added "ez-grammar" example program + examples/ez-grammar.ss, examples/ez-grammar-test.ss, + examples/Makefile, examples.ms +- updated ez-grammar-test to write temp files to current directory and delete them when finished + examples/ez-grammar-test.ss +- added support for Microsoft Visual Studio 2017 on Windows + BUILDING, c/Mf-a6nt, c/Mf-ta6nt, c/vs.bat, + mats/Mf-a6nt, mats/Mf-ta6nt, mats/ftype.ms +- added support for building Windows installs with Bash/WSL + wininstall/Makefile, candle.bat, light.bat +- added support for building with Visual Studio 2017's BuildTools + c/vs.bat +- check for git before using to get submodules + configure +- fixed windows installer failure when vcredist is not preinstalled by + using the vcredist merge module, split the 32 and 64 bit MSIs and + added a wix bundle to combine the MSIs into a single exe installer, + added a batch script for locating Visual Studio's vcredist merge + modules, updated installer paths and names. + wininstall/* +- fixed np-normalize-context pass to process trivs list in mvset forms + in tail and predicate context and added regression tests. Thanks to + @marcomaggi for reporting the bug and @yjqww6 for providing a + simplified test and finding the initial solution. + cpnanopass.ss, + 3.ms +- removed a useless check in foreign-alloc + record.ss +- fix cp0 reduction of fx[+-*]/carry and their signatures + cp0.ss + primdata.ss + fx.ms +- renamed s_gettime => S_gettime to remain consistent with the + convention that the only undocumented externs are prefixed with + S_. + externs.h, stats.c, thread.c +- added version number to scheme.1.in trailer; updated date. + scheme.1.in, newrelease +- removed version update of no-longer-existing bldnt.bat. "fixed" + sed patterns to replace \? with * for the benefit of the deficient + mac sed. + newrelease + +9.5 changes: +- updated version to 9.5 + bintar BUILDING NOTICE makefiles/Mf-install.in scheme.1.in + c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt + workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/csug.stex +- updated release notes and fixed user's guide overfull hbox. + release-notes.stex, syntax.stex +- updated install target to do something more sensible + release_notes/Makefile + +9.5.1 changes: +- updated version to 9.5.1 + bintar BUILDING NOTICE makefiles/Mf-install.in scheme.1.in + c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt + workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/csug.stex csug/use.stex + examples/ez-grammar-test.ss examples/socket.ss + wininstall/Makefile wininstall/*nt.wxs +- Added setting of CHEZSCHEMELIBDIRS to s and mats make files so that + an existing setting will not interfere with the build process, and + added a note to BUILDING that CHEZSCHEMELIBDIRS should be unset in + Version 9.5 and before. + s/Mf-base, mats/Mf-base, BUILDING +- the $case macro used by r6rs:case and case now unconditionally trims + redundant keys and expands into exclusive-cond rather than cond. + it catches references to => before expanding into exclusive-cond + to avoid supporting => as an undocumented and useless extension + of the case syntax. the r6rs:case and case macros now require + multiple clauses rather than leaving the enforcement to exclusive-cond, + and the exclusive-cond macro now requires multiple clauses rather + than leaving the enforcement to cond. + syntax.ss, + 4.ms, root-experr*, patch* +- ifdef'd out include of xlocale.h for glibc, since the glibc + locale.h includes xlocale.h or, in glibc 2.26, its replacement. + expeditor.c +- Updated CSUG to replace \INSERTREVISIONMONTHSPACEYEAR with the current + month and year at the time of generation. + csug.stex, copyright.stex +- Updated configuration to set machine types in the CSUG and release notes + make files, and updated distclean target to remove these files. + configure, makefiles/Makefile-csug.in (renamed from csug/Makefile), + makefiles/Makefile-release_notes.in + (renamed from release_notes/Makefile), + makefiles/Makefile +- added pass-time tracking for pre-cpnanopass passes to compile. + compile.ss +- added inline handler for fxdiv-and-mod + cp0.ss, primdata.ss +- changed order in which return-point operations are done (adjust + sfp first, then store return values, then restore local saves) to + avoid storing return values to homes beyond the end of the stack + in cases where adjusting sfp might result in a call to dooverflood. + cpnanopass.ss, np-languages.ss +- removed unused {make-,}asm-return-registers bindings + cpnanopass.ss +- corrected the max-fv value field of the lambda produced by the + hand-coded bytevector=? handler. + cpnanopass.ss +- reduced live-pointer and inspector free-variable mask computation + overhead + cpnanopass.ss +- moved regvec cset copies to driver so they aren't copied each + time a uvar is assigned to a register. removed checks for + missing register csets, since registers always have csets. + cpnanopass.ss +- added closure-rep else clause in record-inspector-information!. + cpnanopass.ss +- augmented tree representation with a constant representation + for full trees to reduce the overhead of manipulating trees or + subtrees with all bits set. + cpnanopass.ss +- tree-for-each now takes start and end offsets; this cuts the + cost of traversing and applying the action when the range of + applicable offsets is other than 0..tree-size. + cpnanopass.ss +- introduced the notion of poison variables to reduce the cost of + register/frame allocation for procedures with large sets of local + variables. When the number of local variables exceeds a given + limit (currently hardwired to 1000), each variable with a large + live range is considered poison. A reasonable set of variables + with large live ranges (the set of poison variables) is computed + by successive approximation to avoid excessive overhead. Poison + variables directly conflict with all spillables, and all non-poison + spillables indirectly conflict with all poison spillables through + a shared poison-cset. Thus poison variables cannot live in the + same location as any other variable, i.e., they poison the location. + Conflicts between frame locations and poison variables are handled + normally, which allows poison variables to be assigned to + move-related frame homes. Poison variables are spilled prior to + register allocation, so conflicts between registers and poison + variables are not represented. move relations between poison + variables and frame variables are recorded as usual, but other + move relations involving poison variables are not recorded. + cpnanopass.ss, np-languages.ss +- changed the way a uvar's degree is decremented by remove-victim!. + instead of checking for a conflict between each pair of victim + and keeper and decrementing when the conflict is found, remove-victim! + now decrements the degree of each var in each victim's conflict + set. while this might decrement other victims' degrees unnecessarily, + it can be much less expensive when large numbers of variables are + involved, since the number of conflicts between two non-poison + variables should be small due to the selection process for + (non-)poison variables and the fact that the unspillables introduced + by instruction selection should also have few conflicts. That + is, it reduces the worst-case complexity of decrementing degrees + from O(n^2) to O(n). + cpnanopass.ss +- took advice in compute-degree! comment to increment the uvars in + each registers csets rather than looping over the registers for + each uvar asking whether the register conflicts with the uvar. + cpnanopass.ss +- assign-new-frame! now zeros out save-weight for local saves, since + once they are explicitly saved and restored, they are no longer + call-live and thus have no save cost. + cpnanopass.ss +- desensitized the let-values source-caching timing test slightly + 8.ms +- updated allx, bullyx patches + patch* +- attempt to stabilize timing tests let-values source-caching + test and ephemeron gc test while resensitizing the former + 8.ms, 4.ms +- various formatting and comment corrections + workarea, + s/Mf-base, bytevector.ss, cpnanopass.ss, date.ss, + 5_6.ms, examples.ms +- updated newrelease to handle mats/Mf-*nt + newrelease mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt +- fixed gather-filedata's sort of profile entries. for any two + entries x and y in the list produced by the sort call, if x's + bfp = y's bfp, x should come before y if x's efp < y's efp. + The idea is that enclosing entries should always come later + in the list. this affects only languages where two expressions + can start at the same character position. + pdhtml.ss +- expanded capability of ez-grammar with support for simple + parsing of binary operators w/precedence and associativity + and automatically generated markdown grammar descriptions. + ez-grammar-test.ss now also doubles as a test of pdhtml for + algebraic languages. + mats/examples.ms, + examples/ez-grammar.ss, examples/ez-grammar-test.ss, + examples/Makefile +- maybe-compile-{file,program,library} and automatic import + compilation now treat a malformed object file as if it were + not present and needs to be regenerated. A malformed object + file (particularly a truncated one) might occur if the compiling + processes is killed or aborts before it has a chance to delete + a partial object file. + syntax.ss, + 7.ms +- fix signature of bytevector-[u/s]16-native-set! + primdata.ss +- fix enumerate signature + primdata.ss +- added support for Visual Studio 2017.15.5 + wininstall/locate-vcredist.bat +- fixed substring-fill! and vector-fill! to return void, reflecting the + documented return value of unspecified value. Also changes substring-fill! + to use define-who instead of repeating 'substring-fill! in all the error + messages. + 5_4.ss, 5_6.ss +- fix mat of substring-fill! + after the recent change, the result of substring-fill! is void + 5_5.ms +- fix a few signatures + primdata.ss +- fix comment about Sscheme_program + main.c +- fix even? and odd? to error on exceptional flonums + 5_3.ss, 5_3.ms, fl.ms, root-experr*, patch* +- fix bug in date->time-utc caused by incorrect use of difftime in Windows + stats.c, date.ms, release_notes.stex +- Check that first argument of map is a procedure in cp02 expansion + to raise the same error that the non expanded version + cp0.ss +- avoid building the result list in a map that is called for effect + cp0.ss +- added tests to ensure the optimize-level version 2 of map and for-each raise + a non-procedure exception when the first argument is not a procedure, even + when the rest of the program is compiled at optimize level 3. + 4.ms, root-experr-compile-0-f-f-f, patch-compile-0-t-f-f, + patch-compile-0-f-t-f, patch-interpret-0-f-t-f, patch-interpret-0-f-f-f, + patch-interpret-3-f-t-f, patch-interpret-3-f-f-f +- fix bounds checking with an immediate index on immutable vectors, + fxvectors, strings, and bytevectors + cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms +- fix a few signatures + primdata.ss +- more staid and consistent Mf-cross main target + Mf-cross +- cpletrec now replaces the incoming prelexes with new ones so + that it doesn't have to alter the flags on the incoming ones, since + the same expander output is passed through the compiler twice while + compiling a file with macro definitions or libraries. we were + getting away without this just by luck. + cpletrec.ss +- pure? and ivory? now return #t for a primref only if the prim is + declared to be a proc, since some non-proc prims are mutable, e.g., + $active-threads and $collect-request-pending. + cp0.ss +- $error-handling-mode? and $eol-style? are now properly declared to + be procs rather than system state variables. + primdata.ss +- the new pass $check-prelex-flags verifies that prelex referenced, + multiply-referenced, and assigned flags are set when they + should be. (it doesn't, however, complain if a flag is set + when it need not be.) when the new system parameter + $enable-check-prelex-flags is set, $check-prelex-flags is + called after each major pass that produces Lsrc forms to verify + that the flags are set correctly in the output of the pass. + this parameter is unset by default but set when running the + mats. + cprep.ss, back.ss, compile.ss, primdata.ss, + mats/Mf-base +- removed the unnecessary set of prelex referenced flag from the + build-ref routines when we've just established that it is set. + syntax.ss, compile.ss +- equivalent-expansion? now prints differences to the current output + port to aid in debugging. + mat.ss +- the nanopass that patches calls to library globals into calls to + their local counterparts during whole-program optimization now + creates new prelexes and sets the prelex referenced, multiply + referenced, and assigned flags on the new prelexes rather than + destructively setting flags on the incoming prelexes. The + only known problems this fixes are (1) the multiply referenced + flag was not previously being set for cross-library calls when + it should have been, resulting in overly aggressive inlining + of library exports during whole-program optimization, and (2) + the referenced flag could sometimes be set for library exports + that aren't actually used in the final program, which could + prevent some unreachable code from being eliminated. + compile.ss +- added support for specifying default record-equal and + record-hash procedures. + primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss, + gc.c, + record.ms +- added missing call to relocate for subset-mode tc field, which + wasn't burning us because the only valid non-false value, the + symbol system, is in the static generation after the initial heap + compaction. + gc.c +- added a lambda-commonization pass that runs after the other + source optimizations, particularly inlining, and a new parameter + that controls how hard it works. the value of commonization-level + ranges from 0 through 9, with 0 disabling commonization and 9 + maximizing it. The default value is 0 (disabled). At present, + for non-zero level n, the commonizer attempts to commonize + lambda expressions consisting of 2^(10-n) or more nodes. + commonization of one or more lambda expressions requires that + they have identical structure down to the leaf nodes for quote + expressions, references to unassigned variables, and primitives. + So that various downstream optimizations aren't disabled, there + are some additional restrictions, the most important of which + being that call-position expressions must be identical. The + commonizer works by abstracting the code into a helper that + takes the values of the differing leaf nodes as arguments. + the name of the helper is formed by concatenating the names of + the original procedures, separated by '&', and this is the name + that will show up in a stack trace. The source location will + be that of one of the original procedures. Profiling inhibits + commonization, because commonization requires profile source + locations to be identical. + cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss, + primdata.ss, s/Mf-base, + mats/Mf-base +- cpletrec now always produces a letrec rather than a let for + single immutable lambda bindings, even when not recursive, for + consistent expand/optimize output whether the commonizer is + run or not. + cpletrec.ss, + record.ms +- trans-make-ftype-pointer no longer generates a call to + $verify-ftype-address if the address expression is a call to + ftype-pointer-address. + ftype.ss +- Remove special case for (#2%map p '()) in cp0 + so the reduced version checks that p is a procedure. + Also make the same change for #2%for-each. + cp0.ss, 4.ms +- Mitigate a race condition in Windows when deleting files and directories. + windows.c +- add (& ftype) argument/result for foreign-procedure, which supports + struct arguments and results for foreign calls + syntax.ss, ftype.ss, cpnanopass.ss, x86.ss, x86_64.ss, + base-lang.ss, np-languages.ss, cprep.ss, primdata.ss, + schlib.c, prim.c, externs.h + mats/foreign4.c, mats/foreign.ms mats/Mf-* + foreign.stex, release_notes.stex +- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which + the signal handler could trip over the NULL jumpbuf in a CCHAIN record. + schlib.c +- install equates.h, kernel.o, and main.o on unix-like systems + Mf-install.in +- standalone export form now handles (import import-spec ...) + 8.ms, syntax.ss, release_notes.stex +- add collect-rendezvous + prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex, release_notes.stex +- added identifier? checks to detect attempts to use non-identifier + field names in define-record-type field specs. + syntax.ss, + record.ms, root-experr* +- fixed an issue with the library system where an exception that occurs + during visit or revisit left the library in an inconsistent state that + caused it to appear that it was still in the process of running. This + manifested in it raising a cyclic dependency exception, even though + there really is not a cyclic dependency. The various library + management functions involved will now reset the part of the library + when an exception occurs. This also means that if the library visit + or revisit failed for a transient reason (such as a missing or + incorrect library version that can be fixed by updating the + library-directories) it is now possible to recover from these errors. + expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss, + 8.ms +- Added -Wno-implicit-fallthrough flag to macOS C makefiles. + c/Mf-a6osx, c/Mf-i3osx, c/Mf-ta6osx, c/Mf-ti3osx +- handle compiled library code in boot files once base boot is loaded + globals.h, scheme.c, 7.ss, 7.ms, primdata.ss +- add newline to (import-notify) message in compile-whole-library and + compile-whole-program + compile.ss +- add a __collect_safe convention for foreign procedures and callables + to automate thread [de]activation + syntax.ss, ftype.ss, x86.ss, x86_64.ss, ppc32.ss, + cmacros.ss, base-lang.ss, np-languages.ss, cprep.ss, cpcommonize.ss, + cp0.ss, cpcheck.ss, cpvalid.ss, interpret.ss, cpletrec.ss, + thread.c, prim.c, externs.h, foreign.stex, release_notes.stex, + mats/Mf-t*, foreign.ms, foreign4.c +- Don't install equates.h + Mf-install.in, wininstall/*nt.wxs +- Windows install now sets HeapSearchPath in the registry + wininstall/product.wxs +- Use Windows path separator character when finding boot files on Windows. + scheme.c +- Propagate enable-check-prelex-flags to separate-eval sub-process in tests. + mats.ss +- Reject attempts to visit libraries that compile-whole-program has rendered + invisible due to libs-visible? flag. + compile.ss, 7.ms, root-experr-compile-0-f-f-f, root-experr-compile-2-f-f-f, + patch-compile-0-f-t-f, patch-compile-0-t-f-f, patch-interpret-0-f-f-f, + patch-interpret-0-f-t-f, patch-interpret-3-f-f-f, patch-interpret-3-f-t-f +- Double FMTBUFSIZE to fix compilation with gcc-8 + c/prim5.c +- Improved Unicode support for command-line arguments, environment + variables, the C interface and error messages, and the Windows + registry, DLL loading, and process creation + scheme.h, alloc.c, externs.h, fasl.c, foreign.c, io.c, main.c, + prim5.c, scheme.c, schlib.c, schsig.c, stats.c, system.h, + version.h, windows.c, foreign.stex, system.stex, mkheader.ss, + prims.ss +- Repair x86_64 `&` foreign-procedure result type handling for types of a + small size that is not a multiple of the word size + x86_64.ss, foreign.ms, foreign4.c +- Avoid an occasional invalid memory violation on Windows in S_call_help + schlib.c +- Updated csug socket code to match that in examples folder + csug/foreign.stex, examples/socket.ss +- add an option --disable-x11 + c/version.h, configure +- allow s_ee_get_clipboard to use the pastebuffer on macOS even when X11 is not + available. + expeditor.c +- Adjust cp0 to not replace a procedure name from a let wrapper + cp0.ss, misc.ms +- allx now runs all up to three (rather than two) times to eliminate + bootstrap failures after small changes like the recent change to + procedure names, so we don't have to rebuild the boot files as often. + Mf-base +- Fix tests for cp0 procedure-name change + misc.ms, patch-compile-0-f-t-f, patch-interpret-0-f-t-f +- add load-compiled-from-port and Sregister_boot_file_fd for loading modes + based on open files instead of paths + 7.ss, primdata.ss, mkheader.ss, scheme.c + 7.ms, foreign.stex, system.stex +- auto-config improvement, detect if X11 exist on Mac OS X + configure +- added box-cas! and vector-cas! + prims.ss, cpnanopass.ss, np-languages.ss, + cmacros.ss, library.ss, primdata.ss + x86_64.ss x86.ss, ppc32.ss, arm32.ss, + 5_6.ms, 5_8.ms, root-experr*, + objects.stex, release_notes.stex +- add generate-procedure-source-information + cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss, + primdata.ss, prims.ss, misc.ms, + system.stex, release_notes.stex +- fix boot_call and the invoke code object to handle multiple values + scheme.c, cpnanopass.ss, 7.ms, release_notes.stex, system.stex +- the compiler now uses a temporary variable to hold the return + value of a nested call across the restore-local-saves form to + properly handle the case where the destination lvalue is an mref + whose base and/or index is a local save. + cpnanopass.ss, + misc.ms +- flush expand-output and expand/optimize-output ports + compile.ss +- clarify "unknown module" error message in determine-module-imports + syntax.ss +- restore the import code on reset to provide consistent error message + syntax.ss, 8.ms +- add uninstall target + Makefile.in, Makefile-workarea.in, Mf-install.in +- add PDB files for Windows + c/*nt, wininstall/*nt.wxs +- use uuid_generate on unix-like systems for S_unique_id + BUILDING, c/Mf-*le, stats.c, objects.stex, release_notes.stex +- when thread_get_room exhausts the local allocation area, it now + goes through a common path with S_get_more_room to allocate a new + local allocation area when appropriate. this can greatly reduce + the use of global allocation (and the number of tc mutex acquires + in threaded builds) when a lot of small objects are allocated by + C code with no intervening Scheme-side allocation or dirty writes. + alloc.c, types.h, externs.h +- made Windows filename handling in directory-list, file-access-time, + file-change-time, file-directory?, file-exists?, file-modification-time, + get-mode, and path-absolute more consistent with + https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file + 6.ss, 6.ms, io.stex, release_notes.stex +- fix handling of calling code's address for locking around a callable, + where the cp register copy in the thread context could be changed + in the callable prep before S_call_help gets it + cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms +- added initialization of seginfo sorted and trigger_ephemerons fields. + segment.c +- redirecting output of first two checkboot runs to /dev/null so the + ignored exception, if any, does not show up in the make output. + s/Mf-base +- fixed 7.ms to specify the relative path of testfile.boot + 7.ms +- profile counts are now maintained even for code that has been + reclaimed by the collector and must be released explicitly by the + programmer via (profile-release-counters). + pdhtml.ss, primdata.ss, + globals.h, externs.h, fasl.c, prim5.c, prim.c, alloc.c, scheme.c, + misc.ms, + release_notes.stex, system.stex +- clarified required use of scheme-start to start an application + packaged as a boot file and added a short "myecho" example. + use.stex +- fixed a bug in cp0 bug that could fold the apply of a primitive, where + the last argument is not a list, as if it were a call to the primitive + with those arguments + cp0.ss, cp0.ms +- fix allocation of string/bytevector for a foreign-callable argument + or foreign-call return + cpnanopass.ss, foreign.ms, foreign2.c +- foreign-callable code objects are now flagged as "templates", and + the collector now refuses to discard relocation information for + code objects marked as templates when copying them to the static + generation. + cmacros.ss, cpnanopass.ss, + gc.c, + 7.ms +- add hashtable-cells and add a size argument to hashtable-keys, + hashtable-values, and hashtable-entries + newhash.ss, primdata.ss, + hash.ms, root-experr*, patch*, + objects.stex, release_notes.stex +- the body of load-library is now wrapped in a $pass-time with + to show the time spent loading libraries separately from the time + spent in expand. + syntax.ss +- interpret now plays the pass-time game + interpret.ss +- added compile-time-value? predicate and + compile-time-value-value accessor + syntax.ss, primdata.ss, + 8.ms, primvars.ms, root-experr* +- $pass-stats now returns accurate stats for the currently timed + pass. + 7.ss +- compile-whole-program and compile-whole-library now propagate + recompile info from the named wpo file to the object file + to support maybe-compile-program and maybe-compile-library in + the case where compile-whole-{program,library} overwrites the + original object file. + compile.ss, + 7.ms, mat.ss, primvars.ms +- replaced the ancient and unusable bintar with one that creates + a useful tarball for binary installs + bintar +- generated Mf-install InstallBin (InstallLib, InstallMan) now + correctly indirects through InstallPrefix if the --installbin + (--installlib, --installman) configure flag is not present. + configure +- removed definition of generate-procedure-source-information + patch.ss +- guardian tconc cells are now allocated in generation 0 in the hope + that they can be released more quickly. + gc.c +- added ftype-guardian syntax: (ftype-guardian A) creates a new + guardian for ftype pointers of type A, the first base field (or + one of the first base fields in the case of unions) of which must + be a word-sized integer with native endianness representing a + reference count. ftype pointers are registered with and retrieved + from the guardian just like objects are registered with and + retrieved from any guardian. the difference is that the garbage + collector decrements the reference count before resurrecting an + ftype pointer and resurrects only those whose reference counts + become zero, i.e., are ready for deallocation. + ftype.ss, cp0.ss, cmacros.ss, cpnanopass.ss, prims.ss, primdata.ss, + gc.c, + 4.ms, root-experr* +- fixed a bug in automatic recompilation handling of missing include + files specified with absolute pathnames or pathnames starting with + "./" or "..": was erroring out in file-modification-time with a + file-not-found or other exception rather than recompiling. + syntax.ss, + 7.ms, root-experr*, patch* +- changed inline vector-for-each and string-for-each code to + put the last call to the procedure in tail position, as was + already done for the library definitions and for the inline + code for for-each. + cp0.ss, + 5_4.ms, 5_6.ms +- the compiler now generates better inline code for the bytevector + procedure. instead of one byte memory write for each argument, + it writes up to 4 (32-bit machines) or 8 (64-bit machines) bytes + at a time, which almost always results in fewer instructions and + fewer writes. + cpnanopass.ss, + bytevector.ms +- packaged unchanging implicit reader arguments into a single record + to reduce the number of arguments. + read.ss +- recoded run-vector to handle zero-length vectors. it appears + we're not presently generating empty vectors (representing empty + groups), but the fasl format permits them. + 7.ss +- reverted the earlier change to restore indirection through + InstallPrefix, since it didn't and can't play well with the + generated config.h. Instead removed InstallPrefix entirely so + it isn't an attractive hazard. + configure, makefiles/Mf-install.in +- fixed bug in inline-lists: wasn't setting multiply-referenced flag + on p to account for the procedure? check at optimize-level 2. + cpletrec.ss +- fixed bug in check-prelex-flags: was hardwiring $cpcheck-prelex-flags + "after" argument to 'uncprep rather than passing along its argument. + compile.ss +- commented out local definition of sorry! so that problems detected + by $cpcheck-prelex-flags actually result in a raised exception. + cprep.ss +- exposed the default-library-search-handler and a library-search-handler + parameter to permit more control over the search for libraries during + import, compile-whole-library, and compile-whole-program + syntax.ss, primdata.ss, + 8.ms, + libraries.stex +- added fix for whole program/library compilation bug with help from + @owaddell who originally reported the problem in issue 386. this bug + arises from the way the parts of the combined library, and their + binary dependencies, are invoked when one of the constituent libraries + is invoked. consider, for example, a combined library that contains + (A) and (B), where (B) depends on a binary library (C). depending on + the sort order of (A) and (B), which may be unconstrained in the + partial ordering established by library dependencies, invoking (A) may + result in the invoke code for (B) being run first, without (B) ever + being explicitly invoked. this can result in bindings required from + (C) by the invoke code in (B) to be unbound. even in the case where + (A) comes before (B) in the topological sort, if they are combined + into the same cluster, (B)'s invoke code will be run as part of + invoking (A). the solution is two part: first we extend the invoke + requirements of the first library in the cluster to include the binary + libraries that precede it in the topological sort and add a dependency + on the first library in the cluster to all of the other libraries in + the cluster. this means no matter which library in the cluster is + invoked first, it will cause the first library to be invoked, in turn + ensuring the binary libraries that precede it are invoked. when there + are multiple clusters, a dependency is added from each cluster to the + first library in the cluster that precedes it. this ensures that + invoking a library in a later cluster first, will still cause all of + the dependencies of the previous clusters to be invoked. ultimately, + these extra dependencies enforce an ordering on the invocation of the + source and binary libraries that matches the topological sort, even if + the topological sort was under constrained. to maintain the property + that import requirements are a superset of the invoke and visit + requirements, we also extend the import requirements to include the + extended invoke requirements. the import requirements are also added + to the dependency graph to further constrain the topological sort and + ensure that we do not introduce artificial cycles in the import graph. + compile.ss, + 7.ms, + root-experr*, patch* +- fixed failure to install examples for tarball installs + Mf-install.in +- improved packaging support: + replaced bintar script with bintar directory and make file; + tarballs are created via "make create-tarball" and are placed in + the workarea's bintar directory. added rpm directory and make + file for creating RPMs via "make create-rpm". added pkg directory + and make file for creating OSX packages via "make create-pkg". + bintar (removed), bintar/Makefile (new), rpm/Makefile (new), + pkg/Makefile (new), pkg/rmpkg (new), workarea, checkin, newrelease, + Makefile.in, Makefile-workarea.in. +- improved error message for compile-whole-program and + compile-whole-library when a top-level expression is discovered while + processing a wpo file. + compile.ss +- minor build and new-release updates + checkin, newrelease, Makefile.in, Makefile-workarea.in +- added library-search-handler, compile-whole-library, and improved + packaging to the release notes. + release_notes/release_notes.stex + +9.5.2 changes: +- updated version to 9.5.2 + bintar/Makefile rpm/Makefile pkg/Makefile BUILDING NOTICE + makefiles/Mf-install.in makefiles/Makefile-csug.in scheme.1.in + c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt + mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea + c/scheme.rc s/7.ss s/cmacros.ss release_notes/release_notes.stex + csug/copyright.stex csug/csug.stex rpm/Makefile pkg/Makefile + wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs + wininstall/ta6nt.wxs wininstall/ti3nt.wxs +- fixed handling of bintar, rpm, pkg make files + newrelease +- fixed a bug in the fasl representation and reading of mutually + recursive ftypes where one of the members of the cycle is the + parent of another, which manifested in the fasl reader raising + bogus "incompatible record type" exceptions. (The bug could also + affect other record-type descriptors with cycles involving parent + rtds and "extra" fields.) object files created before this fix + are incompatible with builds with this fix, and objects files + created after this fix are incompatible builds without this fix. + fasl.ss, strip.ss, + fasl.c, + ftype.ms, + release_notes.stex + +9.5.3 changes: +- updated version to 9.5.3 + BUILDING NOTICE makefiles/Mf-install.in makefiles/Makefile-csug.in + scheme.1.in c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt + c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt + mats/Mf-ti3nt workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/copyright.stex csug/csug.stex + bintar/Makefile rpm/Makefile pkg/Makefile wininstall/Makefile + wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs + wininstall/ti3nt.wxs +- fixed welcome text and copyright year in macOS package + newrelease pkg/Makefile release_notes.stex +- update Windows spin-loop count for deleting files and directories + windows.c +- install a file containing revision information alongside boot files; + embed git revision in exported source archives + bintar/Makefile Mf-install.in wininstall/*nt.wxs + s/Mf-base s/.gitattributes s/update-revision +- ignore multiple-value return from interleaved init expressions in + top-level-program + syntax.ss, 8.ms +- add name fields for mutexes and condition variables, now `make-mutex` and + `make-condition` accept an optional argument `name`, which must be a + symbol or #f. The name, if not #f, is printed every time the object is + printed, which is useful for debugging + primdata.ss prims.ss print.ss + thread.ms threads.stex +- change the default compression mode to LZ4 and add a compress-format + parameter to select a compression format for output; input infers the + compression format + io.ss, bytevector.ss, back.ss, primdata.ss, + compress.c (new), new-io.c, fasl.c, scheme.c, compress.h (new), + externs.h, system.h, expeditor.c, configure, Mf-*, Makefile.*nt, + workarea, mat.ss, io.ms, io.stex, objects.stex, release_notes.stex, + root-experr*, patch* +- added compress-level parameter to select a compression level for + file writing and changed the default for lz4 compression to do a + better job compressing. finished splitting glz input routines + apart from glz output routines and did a bit of other restructuring. + removed gzxfile struct-as-bytevector wrapper and moved its fd + into glzFile. moved DEACTIVATE to before glzdopen_input calls + in S_new_open_input_fd and S_compress_input_fd, since glzdopen_input + reads from the file and could block. the compress format and now + level are now recorded directly the thread context. replaced + as-gz? flag bit in compressed bytevector header word with a small + number of bits recording the compression format at the bottom of + the header word. flushed a couple of bytevector compression mats + that depended on the old representation. (these last few changes + should make adding new compression formats easier.) added + s-directory build options to choose whether to compress and, if + so, the format and level. + compress-io.h, compress-io.c, new-io.c, equates.h, system.h, + scheme.c, gc.c, + io.ss, cmacros.ss, back.ss, bytevector.ss, primdata.ss, s/Mf-base, + io.ms, mat.ss, bytevector.ms, root-experr*, + release_notes.stex, io.stex, system.stex, objects.stex +- improved the effectiveness of LZ4 boot-file compression to within + 15% of gzip by increasing the lz4 output-port in_buffer size to + 1<<18. With the previous size (1<<14) LZ4-compressed boot files + were about 50% larger. set the lz4 input-port in_buffer and + out_buffer sizes to 1<<12 and 1<<14. there's no clear win at + present for larger input-port buffer sizes. + compress-io.c +- To reduce the memory hit for the increased output-port in_buffer + size and the corresponding increase in computed out_buffer size, + one output-side out_buffer is now allocated (lazily) per thread + and stored in the thread context. The other buffers are now + directly a part of the lz4File_out and lz4File_in structures + rather than allocated separately. + compress-io.c, scheme.c, gc.c, + cmacros.ss +- split out the buffer emit code from glzwrite_lz4 into a + separate glzemit_lz4 helper that is now also used by gzclose + so we can avoid dealing with a NULL buffer in glzwrite_lz4. + glzwrite_lz4 also uses it to writing large buffers directly and + avoid the memcpy. + compress-io.c +- replaced lz4File_out and lz4File_in mode enumeration with the + compress format and inputp boolean. using switch to check and + raising exceptions for unexpected values to further simplify + adding new compression formats in the future. + compress-io.c +- replaced the never-defined struct lz4File pointer in glzFile + union with the more specific struct lz4File_in_r and Lz4File_out_r + pointers. + compress-io.h, compress-io.c +- added free of lz4 structures to gzclose. also changed file-close + logic generally so that (1) port is marked closed before anything is + freed to avoid dangling pointers in the case of an interrupt or + error, and (2) structures are freed even in the case of a write + or close error, before the error is reported. also now mallocing + glz and lz4 structures after possibility of errors have passed where + possible and freeing them when not. + compress-io.c, + io.ss +- added return-value checks to malloc calls and to a couple of other + C-library calls. + compress-io.c +- corrected EINTR checks to look at errno rather than return codes. + compress-io.c +- added S_ prefixes to the glz* exports + externs.h, compress-io.c, new-io.c, scheme.c, fasl.c +- added entries for mutex-name and mutex-thread + threads.stex +- fix record-ref reduction in cp0 + in expressions like + (record-ref ... (begin (newline) (record ...))) + the reduction was dropping the possible side effect expressions + in this case the (newline). + cp0.ss +- zero?, fxzero?, positive?, fxpositive?, etc., now go through + (a suitably modified) relop-length so that, for example, + (zero? (length x)) results in the same code as (null? x). added + correctness tests for these and all of the other predicates that + go through relop-length. + cpnanopass.ss, 5_2.ms +- assertion-violationf and friends now show the who, message, and + irritants in the original call when who or message is found not to + be of the right type. + exceptions.ss +- fix incorrect uses of fxzero? x86.ss backend, since a 32-bit + immediate is not necessarily a fixnum + x86.ss +- added MinGW/MSYS build support for Windows and configuration for + Travis-CI testing of all Windows builds + BUILDING, .travis*, wininstall/Makefile +- fix multiply of -2^30 with itself on 64-bit platforms + number.c, 5_3.ms, release_notes.stex +- fixed typo in description of case macro + csug/control.stex +- fix signatures of $annotation-options, $fasl-strip-options, + $file-options, and $library-requirements-options + primdata.ss +- small fix in relop-length to enable the optimization + cpnanopass.ss +- make test for relop-length more sensitive + 5_2.ms +- added support for Microsoft Visual Studio 2019 on Windows + BUILDING, c/vs.bat, wininstall/locate-vcredist.bat +- fixed open-string-input-port on immutable strings + cpnanopass.ss, io.ms, release_notes.stex +- use setenv rather than putenv on non WIN32 environments + prim5.c, system.stex +- restore {Free,Open,Net}BSD build, support Windows cross-compile + via MinGW, add configuration options, and add helper makefile targets + expeditor.c, thread.c, stats.c, statics.c, scheme.c, main.c, types.h, + externs.h, globals.h, nocurses.h, version.h, system.h, segment.h, + a6ob.def, ta6ob.def, a6nb.def, ta6nb.def, i3nt.def, ti3nt.def, + c/Mf-*, build.bat, makefiles/Makefile.in, makefiles/Mf-install.in, + s/update-revision, BUILDING +- export `ee-backward-delete-sexp` binding in the expression-editor module. + expeditor.ss +- fix ee_read_char to handle ^@ properly + expeditor.c +- prevent access before start of array + scheme.c +- remove dead stores in files + compress-io.c, new-io.c +- fixed tab character in makefiles + c/Mf-*nt +- use case-insensitive search for ".exe" on Windows + c/scheme.c +- fix __collect_safe for x86_64 and floating-point arguments or results + x86_64.ss, foreign.ms, release_notes.stex +- annotations are now preserved in object files for debug + only, for profiling only, for both, or not at all, depending + on the settings of generate-inspector-information and + compile-profile. in particular, when inspector information + is not enabled but profiling is, source information does + not leak into error messages and inspector output, though it is + still available via the profile tools. The mechanics of this + involved repurposing the fasl a? parameter to hold an annotation + flags value when it is not #f and remaking annotations with + new flags if necessary before emitting them. + compile.ss, fasl.ss, misc.ms +- altered a number of mats to produce correct results even + when the 's' directory is profiled. + misc.ms, cp0.ms, record.ms +- profile-release-counters is now generation-friendly; that is, + it doesn't look for dropped code objects in generations that have + not been collected since the last call to profile-release-counters. + also, it no longer allocates memory when it releases counters. + pdhtml.ss, + gc.c, gcwrapper.c, globals.h, prim5.c +- removed unused entry points S_ifile, S_ofile, and S_iofile + alloc.c, externs.h +- mats that test loading profile info into the compiler's database + to guide optimization now weed out preexisting entries, in case + the 's' directory is profiled. + 4.ms, mat.ss, misc.ms, primvars.ms +- counters for dropped code objects are now released at the start + of each mat group. + mat.ss +- replaced ehc (enable-heap-check) option with hci (heap-check-interval) + option that allows heap checks to be performed periodically rather + than on each collection. hci=0 is equivalent to ehc=f (disabling + heap checks) and hci=1 is equivalent to ehc=t (enabling heap + checks every collection), while hci=100 enables heap checks only + every 100th collection. allx and bullyx mats use this feature + to reduce heap-checking overhead to a more reasonable level. this + is particularly important when the 's' directory is profiled, + since the amount of static memory to be checked is greatly increased + due to the counters. + mats/Mf-base, mat.ss, primvars.ms +- added a mat that calls #%show-allocation, which was otherwise not + being tested. + misc.ms +- removed a broken primvars mat and updated two others. in each case, + the mat was looking for information about primitives in the wrong + (i.e., old) place and silently succeeding when it didn't find any + primitives to test. the revised mats (along with a few others) now + check to make sure at least one identifier has the information they + look for. the removed mat was checking for library information that + is now compiled in, so the mat is now unnecessary. the others were + (not) doing argument-error checks. fixing these turned up a handful of + problems that have also been fixed: a couple of unbound variables in the + mat driver, two broken primdata declarations, a tardy argument check + by profile-load-data, and a bug in char-ready?, which was requiring + an argument rather than defaulting it to the current input port. + primdata.ss, pdhtml.ss, io.ms, + primdvars.ms, 4.ms, 6.ms, misc.ms, patch* +- added initial support for recording coverage information. when the + new parameter generate-covin-files is set, the compiler generates + .covin files containing the universe of all source objects for which + profile forms are present in the expander output. when profiling + and generation of covin files are enabled in the 's' directory, the + mats optionally generate .covout files for each mat file giving + the subset of the universe covered by the mat file, along with an + all.covout in each mat output directory aggregating the coverage + for the directory and another all.covout in the top-level mat + directory aggregating the coverage for all directories. + back.ss, compile.ss, cprep.ss, primdata.ss, s/Mf-base, + mat.ss, mats/Mf-base, mats/primvars.ms +- support for generating covout files is now built in. with-coverage-output + gathers and dumps coverage information, and aggregate-coverage-output + combines (aggregates) covout files. + pdhtml.ss, primdata.ss, compile.ss, + mat.ss, mats/Mf-base, primvars.ms +- profile-clear now adjusts active coverage trackers to avoid losing + coverage information. + pdhtml.ss, + prim5.c +- nested with-coverage calls are now supported. + pdhtml.ss +- switched to a more compact representation for covin and covout files; + reduces disk space (compressed or not) by about a factor of four + and read time by about a factor of two with no increase in write time. + primdata.ss, pdhtml.ss, cprep.ss, compile.ss, + mat.ss, mats/Mf-base +- added support for determining coverage for an entire run, including + coverage for expressions hit during boot time. 'all' mats now produce + run.covout files in each output directory, and 'allx' mats produce + an aggregate run.covout file in the mat directory. + pdhtml.ss, + mat.ss, mats/Mf-base +- profile-release-counters now adjusts active coverage trackers to + account for the counters that have been released. + pdhtml.ss, + prim5.c +- replaced the artificial "examples" target with a real "build-examples" + target so make won't think it always has to mats that depend upon + the examples directory having been compiled. mats make clean now + runs make clean in the examples directory. + mats/Mf-base +- importing a library from an object file now just visits the object + file rather than doing a full load so that the run-time code for + the library is not retained. The run-time code is still read + because the current fasl format forces the entire file to be read, + but not retaining the code can lower heap size and garbage-collection + cost, particularly when many object-code libraries are imported. + The downside is that the file must be revisited if the run-time + code turns out to be required. This change exposed several + places where the code was failing to check if a revisit is needed. + syntax.ss, + 7.ms, 8.ms, misc.ms, root-experr* +- fixed typos: was passing unquoted load rather than quoted load + to $load-library along one path (where it is loading source code + and therefore irrelevant), and was reporting src-path rather than + obj-path in a message about failing to define a library. + syntax.ss +- compile-file and friends now put all recompile information in + the first fasl object after the header so the library manager can + find it without loading the entire fasl file. The library manager + now does so. It also now checks to see if library object files + need to be recreated before loading them rather than loading them and + possibly recompiling them after discovering they are out of date, since + the latter requires loading the full object file even if it's out of + date, while the former takes advantage of the ability to extract just + recompile information. as well as reducing overhead, this eliminates + possibly undesirable side effects, such as creation and registration + of out-of-date nongenerative record-type descriptors. because the + library manager expects to find recompile information at the front of + an object file, it will not find all recompile information if object + files are "catted" together. also, compile-file has to hold in memory + the object code for all expressions in the file so that it can emit the + unified recompile information, rather than writing to the object file + incrementally, which can significantly increase the memory required + to compile a large file full of individual top-level forms. This does + not affect top-level programs, which were already handled as a whole, + or a typical library file that contains just a single library form. + compile.ss, syntax.ss +- the library manager now checks include files before library dependencies + when compile-imported-libraries is false (as it already did when + compile-imported-libraries is true) in case a source change affects + the set of imported libraries. (A library change can affect the set + of include files as well, but checking dependencies before include + files can cause unneeded libraries to be loaded.) The include-file + check is based on recompile-info rather than dependencies, but the + library checks are still based on dependencies. + syntax.ss +- fixed check for binding of scheme-version. (the check prevents + premature treatment of recompile-info records as Lexpand forms + to be passed to $interpret-backend.) + scheme.c +- strip-fasl-file now preserves recompile-info when compile-time info + is stripped. + strip.ss +- removed include-req* from library/ct-info and ctdesc records; it + is no longer needed now that all recompile information is maintained + separately. + expand-lang.ss, syntax.ss, compile.ss, cprep.ss, syntax.ss +- changed the fasl format and reworked a lot of code in the expander, + compiler, fasl writer, and fasl reader to allow the fasl reader + to skip past run-time information when it isn't needed and + compile-time information when it isn't needed. Skipping past + still involves reading and decoding when encrypted, but the fasl + reader no longer parses or allocates code and data in the portions + to be skipped. Side effects of associating record uids with rtds + are also avoided, as are the side effects of interning symbols + present only in the skipped data. Skipping past code objects + also reduces or eliminates the need to synchronize data and + instruction caches. Since the fasl reader no longer returns + compile-time (visit) or run-time (revisit) code and data when not + needed, the fasl reader no longer wraps these objects in a pair + with a 0 or 1 visit or revisit marker. To support this change, + the fasl writer generates separate top-level fasl entries (and + graphs) for separate forms in the same top-level source form + (e.g., begin or library). This reliably breaks eq-ness of shared + structure across these forms, which was previously broken only + when visit or revisit code was loaded at different times (this + is an incompatible change). Because of the change, fasl "groups" + are no longer needed, so they are no longer handled. + 7.ss, cmacros.ss, compile.ss, expand-lang.ss, strip.ss, + externs.h, fasl.c, scheme.c, + hash.ms +- the change above is surfaced in an optional fasl-read "situation" + argument (visit, revisit, or load). The default is load. visit + causes it to skip past revisit code and data; revisit causes it + to skip past visit code and data; and load causes it not to skip + past either. visit-revisit data produced by (eval-when (visit + revisit) ---) is never skipped. + 7.ss, primdata.ss, + io.stex +- to improve compile-time and run-time error checking, the + Lexpand recompile-info, library/rt-info, library-ct-info, and + program-info forms have been replaced with list-structured forms, + e.g., (recompile-info ,rcinfo). + expand-lang.ss, compile.ss, cprep.ss, interpret.ss, syntax.ss +- added visit-compiled-from-port and revisit-compiled-from-port + to complement the existing load-compiled-from-port. + 7.ss, primdata.ss, + 7.ms, + system.stex +- increased amount read when seeking an lz4-compressed input + file from 32 to 1024 bytes at a time + compress-io.c +- replaced the fasl a? parameter value #t with an "all" flag value + so it's value is consistently a mask. + cmacros.ss, fasl.ss, compile.ss +- split off profile mats into a separate file + misc.ms, profile.ms (new), root-experr*, mats/Mf-base +- added coverage percent computations to mat allx/bullyx output + mat.ss, mats/Mf-base, primvars.ms +- replaced coverage tables with more generic and generally useful + source tables, which map source objects to arbitrary values. + pdhtml.ss, compile.ss, cprep.ss, primdata.ss, + mat.ss, mats/Mf-base, primvars.ms, profile.ms, + syntax.stex +- reduced profile counting overhead by using calls to fold-left + instead of calls to apply and map and by using fixnum operations + for profile counts on 64-bit machines. + pdhtml.ss +- used a critical section to fix a race condition in the calculations + of profile counts that sometimes resulted in bogus (including + negative) counts, especially when the 's' directory is profiled. + pdhtml.ss +- added discard flag to declaration for hashtable-size + primdata.ss +- redesigned the printed representation of source tables and rewrote + get-source-table! to read and store incrementally to reduce memory + overhead. + compile.ss +- added generate-covin-files to the set of parameters preserved + by compile-file, etc. + compile.ss, + system.stex +- moved covop argument before the undocumented machine and hostop + arguments to compile-port and compile-to-port. removed the + undocumented ofn argument from compile-to-port; using + (port-name ip) instead. + compile.ss, primdata.ss, + 7.ms, + system.stex +- compile-port now tries to come up with a file position to supply + to make-read, which it can do if the port's positions are character + positions (presently string ports) or if the port is positioned + at zero. + compile.ss +- audited the argument-type-error fuzz mat exceptions and fixed a + host of problems this turned up (entries follow). added #f as + an invalid argument for every type for which #f is indeed invalid + to catch places where the maybe- prefix was missing on the argument + type. the mat tries hard to determine if the condition raised + (if any) as the result of an invalid argument is appropriate and + redirects the remainder to the mat-output (.mo) file prefixed + with 'Expected error', causing them to show up in the expected + error output so developers will be encouraged to audit them in + the future. + primvars.ms, mat.ss +- added an initial symbol? test on machine type names so we produce + an invalid machine type error message rather than something + confusing like "machine type #f is not supported". + compile.ss +- fixed declarations for many primitives that were specified as + accepting arguments of more general types than they actually + accept, such as number -> real for various numeric operations, + symbol -> endianness for various bytevector operations, + time -> time-utc for time-utc->date, and list -> list-of-string-pairs + for default-library-search-handler. also replaced some of the + sub-xxxx types with specific types such as sub-symbol -> endianness + in utf16->string, but only where they were causing issues with + the primvars argument-type-error fuzz mat. (this should be done + more generally.) + primdata.ss +- fixed incorrect who arguments (was map instead of fold-right, + current-date instead of time-utc->date); switched to using + define-who/set-who! generally. + 4.ss, date.ss +- append! now checks all arguments before any mutation + 5_2.ss +- with-source-path now properly supplies itself as who for the + string? argument check; callers like load now do their own checks. + 7.ss +- added missing integer? check to $fold-bytevector-native-ref whose + lack could have resulted in a compile-time error. + cp0.ss +- fixed typo in output-port-buffer-mode error message + io.ss +- fixed who argument (was fx< rather than fx maybe-timeout) + primdata.ms +- added "invalid code page ~s" to set of messages considered valid + argument-type-check error messages, for Windows multibyte->string + and string->multibyte. + primvars.ms +- used with-object-file to restore accidentally dropped close-port in + compile-whole-program and compile-whole-library + compile.ss +- initialized variable to enable compilation with gcc 9.1.0 at -O3 + c/scheme.c +- added missing Inner wrappers around the library/ct-info and + library-rt-info records in the code for compile-whole-xxx. + compile.ss, + 7.ms +- local-eval-hook now calls eval rather than interpret when profiling + is enabled, so local transformer code can be profiled. + syntax.ss, + profile.ms +- fix compiler bug related to call-with-values and a first argument + whose body result is compiled to an allocation, inline form, or + foreign call + cpnanopass.ss, 3.ms +- improved error reporting for library compilation-instance errors: + now including the name of the object file from which the "wrong" + compilation instance was loaded, if it was loaded from (or compiled + to) an object file and the original importing library, if it was + previously loaded from an object file due to a library import. + syntax.ss, 7.ss, interpret.ss, + 8.ms, root-experr* +- removed situation and for-input? arguments from $make-load-binary, + since the only consumer always passes 'load and #f. + 7.ss, + scheme.c +- $separate-eval now prints the stderr and stdout of the subprocess + to help in diagnosing separate-eval and separate-compile issues. + mat.ss +- added unregister-guardian, which can be used to unregister + the unresurrected objects registered with any guardian. guardian? + can be used to distinguish guardian procedures from other objects. + cp0.ss, cmacros.ss, cpnanopass.ss, ftype.ss, primdata.ss, + prims.ss, + gcwrapper.c, prim.c, externs.h, + 4.ms, primvars.ms + release_notes.stex + smgmt.stex, threads.stex +- added verify-loadability. given a situation (visit, revisit, + or load) and zero or more pathnames (each of which may be optionally + paired with a library search path), verity-loadability checks + whether the set of object files named by those pathnames and any + additional object files required by library requirements in the + given situation can be loaded together. it raises an exception + in each case where actually attempting to load the files would + raise an exception and additionally in cases where loading files + would result in the compilation or loading of source files in + place of the object files. if the check is successful, + verity-loadability returns an unspecified value. in either case, + although portions of the object files are read, none of the + information read from the object files is retained, and none of + the object code is read, so there are no side effects other than + the file operations and possibly the raising of an exception. + library and program info records are now moved to the top of each + object file produced by one of the file compilation routines, + just after recompile info, with a marker to allow verity-loadability + to stop reading once it reads all such records. this change is + not entirely backward compatible; the repositioning of the records + can be detected by a call to list-library made from a loaded file + before the definition of one or more libraries. it is fully + backward compatible for typical library files that contain a + single library definition and nothing else. adding this feature + required changes to the object-file format and corresponding + changes in the compiler and library manager. it also required + moving cross-library optimization information from library/ct-info + records (which verity-loadability must read) to the invoke-code + for each library (which verity-loadability does not read) to + avoid reading and permanently associating record-type descriptors + in the code with their uids. + compile.ss, syntax.ss, expand-lang.ss, primdata.ss, 7.ss, + 7.ms, misc.ms, root-experr*, patch*, + system.stex, release_notes.stex +- fixed a bug that bit only with the compiler compiled at + optimize-level 2: add-library/rt-records was building a library/ct-info + wrapper rather than a library/rt-info wrapper. + compile.ss +- fixed a bug in visit-library that could result in an indefinite + recursion: it was not checking to make sure the call to $visit + actually added compile-time info to the libdesc record. it's not + clear, however, whether the libdesc record can be missing + compile-time information on entry to visit-library, so the code + that calls $visit (and now checks for compile-time information + having been added) might not be reachable. ditto for + revisit-library. + syntax.ss + syntax.ss, primdata.ss, + 7.ms, root-experr*, patch*, + system.stex, release_notes.stex +- added some argument-error checks for library-directories and + library-extensions, and fixed up the error messages a bit. + syntax.ss, + 7.ms, root-experr* +- compile-whole-program now inserts the program record into the + object file for the benefit of verify-loadability. + syntax.ss, + 7.ms, root-experr* +- changed 'loading' import-notify messages to the more precise + 'visiting' or 'revisiting' in a couple of places. + syntax.ss, + 7.ms, 8.ms +- added concatenate-object-files + compile.ss, primdata.ss + 7.ms, root-experr* + system.stex, use.stex, release_notes.stex +- added invoke-library + syntax.ss, primdata.ss, + 8.ms, root-experr*, + libraries.stex, release_notes.stex +- updated the date + release_notes.stex +- libraries contained within a whole program or library are now + marked pending before their invoke code is run so that invoke + cycles are reported as such rather than as attempts to invoke + while still loading. + compile.ss, syntax.ss, primdata.ss, + 7.ms, root-experr* +- the library manager now protects against unbound references + from separately compiled libraries or programs to identifiers + ostensibly but not actually exported by (invisible) libraries + that exist only locally within a whole program. this is done by + marking the invisibility of the library in the library-info and + propagating it to libdesc records; the latter is checked upon + library import, visit, and invoke as well as by verify-loadability. + the import and visit code of each invisible no longer complains + about invisibility since it shouldn't be reachable. + syntax.ss, compile.ss, expand-lang.ss, + 7.ms, 8.ms, root-experr*, patch* +- documented that compile-whole-xxx's linearization of the + library initialization code based on static dependencies might + not work for dynamic dependencies. + system.stex +- optimized bignum right shifts so the code (1) doesn't look at + shifted-off bigits if the bignum is positive, since it doesn't + need to know in that case if any bits are set; (2) doesn't look + at shifted-off bigits if the bignum is negative if it determines + that at least one bit is set in the bits shifted off the low-order + partially retained bigit; (3) quits looking, if it must look, for + one bits as soon as it finds one; (4) looks from both ends under + the assumption that set bits, if any, are most likely to be found + toward the high or low end of the bignum rather than just in the + middle; and (5) doesn't copy the retained bigits and then shift; + rather shifts as it copies. This leads to dramatic improvements + when the shift count is large and often significant improvements + otherwise. + number.c, + 5_3.ms, + release_notes.stex +- threaded tc argument through to all calls to S_bignum and + S_trunc_rem so they don't have to call get_thread_context() + when it might already have been called. + alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h +- added an expand-primitive handler to partially inline integer?. + cpnanopass.ss +- added some special cases for basic arithmetic operations (+, -, *, + /, quotient, remainder, and the div/div0/mod/mod0 operations) to + avoid doing unnecessary work for large bignums when the result + will be zero (e.g,. multiplying by 0), the same as one of the + inputs (e.g., adding 0 or multiplying by 1), or the additive + inverse of one of the inputs (e.g., subtracting from 0, dividing + by -1). This can have a major beneficial affect when operating + on large bignums in the cases handled. also converted some uses + of / into integer/ where going through the former would just add + overhead without the possibility of optimization. + 5_3.ss, + number.c, externs.h, prim5.c, + 5_3.ms, root-experr, patch*, + release_notes.stex +- added a queue to hold pending signals for which handlers have + been registered via register-signal-handler so up to 63 (configurable + in the source code) unhandled signals are buffered before the + handler has to start dropping them. + cmacros.ss, library.ss, prims.ss, primdata.ss, + schsig.c, externs.h, prim5.c, thread.c, gc.c, + unix.ms, + system.stex, release_notes.stex +- bytevector-compress now selects the level of compression based + on the compress-level parameter. Prior to this it always used a + default setting for compression. the compress-level parameter + can now take on the new minimum in addition to low, medium, high, + and maximum. minimum is presently treated the same as low + except in the case of lz4 bytevector compression, where it + results in the use of LZ4_compress_default rather than the + slower but more effective LZ4_compress_HC. + cmacros,ss, back.ss, + compress_io.c, new_io.c, externs.h, + bytevector.ms, mats/Mf-base, root-experr* + io.stex, objects.stex, release_notes.stex +- fix fasl-read signature + primdata.ss +- console I/O on Windows now supports Unicode characters in the BMP + expeditor.c, new-io.c, release_notes.stex +- the collector now releases bignum temporaries in the collector + rather than relocating them so we don't keep around huge bignum + temporaries forever. + gc.c +- removed the presumably useless vector-handling code from load() + which used to be required to handle fasl groups. + scheme.c +- object files are no longer compressed as a whole, and the parameter + compile-compressed is no longer defined. instead, the individual + fasl objects within an object file are compressed whenever the + new parameter fasl-compressed is set to its default value, #t. + this allows the fasl reader to seek past portions of an object + file that are not of interest, i.e., visit-only code and data + when "revisiting" an object file and revisit-only code and data + when "visiting" an object file. the compressed portions are + compressed using the format and level specified by the compress-format + and compress-level parameters. the C-coded fasl reader and + boot-file loader no longer handle compressed files; these are + handled, less efficiently, by the Scheme entry point (fasl-read). + a warning exception is raised the first time a program attempts + to create or read a compressed fasl file. + 7.ss, s/Mf-base, back.ss, bytevector.ss, cmacros.ss, compile.ss, + fasl-helpers.ss, fasl.ss, primdata.ss, strip.ss, syntax.ss, + externs.h, fasl.c, gc.c, scheme.c, thread.c, + mats/6.ms, mats/7.ms, mats/bytevector.ms, mats/misc.ms, patch*, + root-experr*, + intro.stex, use.stex, io.stex, system.stex, + release_notes.stex +- added begin wrappers around many of the Scheme source files that + contained multiple expressions to cut down the number of top-level + fasl objects and increase compressibility. also removed the + string filenames for debugging at the start of each file that had + one---these are best inserted universally by a modified compile-file + during a debugging session when desired. also removed unnecessary + top-level placeholder definitions for the assignments that follow. + 4.ss, 5_1.ss, 5_2.ss, 5_3.ss, 5_7.ss, 6.ss, 7.ss, bytevector.ss, + cafe.ss, cback.ss, compile.ss, cp0.ss, cpcommonize.ss, cpletrec.ss, + cpnanopass.ss, cprep.ss, cpvalid.ss, date.ss, engine.ss, enum.ss, + env.ss, event.ss, exceptions.ss, expeditor.ss, fasl.ss, foreign.ss, + format.ss, front.ss, ftype.ss, inspect.ss, interpret.ss, io.ss, + library.ss, mathprims.ss, newhash.ss, pdhtml.ss, pretty.ss, + prims.ss, primvars.ss, print.ss, read.ss, record.ss, reloc.ss, + strnum.ss, syntax.ss, trace.ss +- updated bullyx patches + patch* +- fixed csug copyright year substitutions and changed revisiondate + to not be generated, making the csug build reproducible + newrelease csug/csug.stex +- fixed Windows build using MSYS2 + c/Mf-a6nt, c/Mf-i3nt, c/Mf-ta6nt, c/Mf-ti3nt, mats/Mf-a6nt, + mats/Mf-i3nt, mats/Mf-ta6nt, mats/Mf-ti3nt +- fixed build on Linux with musl libc + expeditor.c +- extended primitive folding to primitives that return multiple + values. + cp0.ss, primdata.ss, + cp0.ms +- fix handling of calling code's address for locking around a callable + that has a u8*, u16*, or u32* argument, which could cause the + cp register copy in the thread context to be changed before + S_call_help gets it + cpnanopass.ss, schlib.c, foreign2.c, foreign.ms +- the collector now promotes objects one generation higher at a time + by default. previously, it promoted every live oldspace object to + the selected target generation, which could result in objects + prematurely skipping one or more generations and thus being + retained longer than their ages justify. the biggest cost in + terms of code complexity and performance is the recording of + pointers from older newspace objects to younger newspace objects + that could not previously occur. + gc.c, alloc.c, externs.h +- the collect procedure now takes an additional optional minimum + target generation argument to allow the new default behavior to + be overridden. + 7.ss, primdata.ss, + gcwrapper.c, + 7.ms, root-experr* +- added cn flag to control collect-notify + mats/Mf-base +- resweep_weak_pairs now sets sweep_loc to orig_next_loc rather than + first_loc since the latter could result in unnecessary sweeping of + existing target-generation weak pairs. + gc.c +- added set of S_child_processes[newg] to S_child_processes[oldg] + in S_do_gc code handling decreases in the maximum generation. + gcwrapper.c +- a specialized variant of the collector is used in the common case + where the max copied generation is 0, the min and max target + generations are 1, and there are no locked generation 0 objects + is now used. with the default collection parameters and no locking + of generation 0 objects, these collections account for 3/4 of all + collections. + gc.c, gc-011.c (new), gcwrapper.c, externs.h, c/Mf-base +- maybe-fire-collector no longer tries to be so precise and instead + just counts the number of generation-bytes allocated since the + last gc. surprisingly, rebuilding the s directory requires about + the same number of collections with this coarser (and less + expensive) measurement. this change also fixes a problem with + too-frequent collections when the maximum-generation is set to + zero. to make the determination even less expensive, a running + total of bytes in each generation is now maintained in a new + bytes_of_generation vector, and maybe-fire-collector is no longer + called when the collector is running. + alloc.c, gc.c, gcwrapper.c, globals.h +- copy now copies two pairs at once only if they are in the same + segment, which saves a few memory references and tests and turns + out not to reduce the number of opportunities significantly in + tested programs. + gc.c +- occupied_segments, first_loc, base_loc, next_loc, bytes_left, + bytes_of_space, sweep_loc, and orig_next_loc are now indexed + by [g][s] rather than [s][g] to improve locality in the default + (and common) case where there are only a handful of active + generations. + globals.h, types.h, segment.c, gc.c, gcwrapper.c, prim5.c +- documented change to collect procedure + smgmt.stex, release_notes.stex +- now maintaining 16-byte architectural stack alignment (if the + incoming stack is so aligned) on all x86 platforms except + i3nt/ti3nt. more recent versions of gcc sometimes generate sse + instructions that require 16-byte stack alignment. + x86.ss +- added missing #ifndef WIN32 + gcwrapper.c +- added initialization of __to_g to make gcc 7.5.0 happy + gc.c +- updated Windows makefiles + c/Makefile.*nt +- use lowercase for Windows include files + segment.c, windows.c +- proper unicode handling when retrieving error messages from the OS + on Windows + windows.c +- repair collector handling of an ephemerons that refers to a + younger object during incremental promotion + gc.c, 4.ms +- added textual-output-port checks for record-writer write argument + print.ss, + record.ms, root-experr* +- now using 64-bit arithmetic for seconds in S_condition_wait to + prevent a potential 2038 bug, at least on platforms where time_t + is 64 bits. also now rounding rather than truncating nanoseconds + in the conversion to milliseconds on Windows. + thread.c +- fixed a bug in arm32 that caused an error when generating + instructions with immediate operands where the immediate was larger + than 8 bits. + arm32.ss +- fixed formatting in arm32.ss + arm32.ss +- disabled unsupported mats for arm32le + foreign.ms, misc.ms +- fixed callee-save floating point registers for arm32 + arm32.ss, ftype.ss, np-languages.ss, primdata.ss +- added a mat for the add-with-immediate bug + misc.ms, + mats/arm-immediate-1.ss (new), mats/arm-immediate-2.ss (new) +- added a note about arm32 targets requiring a kernel module for the + time stamp counter + prims.ss + +9.5.4 changes: +- updated version to 9.5.4 + BUILDING NOTICE makefiles/Mf-install.in makefiles/Makefile-csug.in + scheme.1.in c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt + c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt + mats/Mf-ti3nt workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/copyright.stex csug/csug.stex + bintar/Makefile rpm/Makefile pkg/Makefile wininstall/Makefile + wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs + wininstall/ti3nt.wxs + +9.5.5 changes: +- updated version to 9.5.5 + BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt + c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt + mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc + s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex + csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile + wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs + wininstall/ta6nt.wxs wininstall/ti3nt.wxs +- newrelease no longer logs as updated files with no actual changes + newrelease +- repaired continuation for exception handler of error for returning + the wrong number of values to a multiple-value context + cpnanopass.ss, np-languages.ss, 3.ms +- adjust arm32 backend to not choose shorter instructions for larger + return-address offsets, which breaks label address assignment + arm32.ss +- repair remainder and modulo on flonums by using fmod + prim5.c, 5_3.ss, 5_3.ms +- add special case in cpnanopass.ss for (eq? (ftype-pointer-address x) 0) + cpnanopass.ss +- fix missing include in externs.h for struct timespec + c/expeditor.c, c/externs.h, c/prim5.c, c/scheme.c, c/stats.c +- fix signature of generate-temporaries + primdata.ss primvars.ss +- sleep of negative durations now returns immediately + 7.ss +- avoid hard-coded paths for utilities in build scripts + checkin csug/gifs/Makefile csug/math/Makefile examples/Makefile + makefiles/Makefile-csug.in makefiles/Makefile-release_notes.in + makefiles/Mf-install.in makefiles/installsh mats/6.ms mats/Mf-a6fb + mats/Mf-a6le mats/Mf-a6nb mats/Mf-a6ob mats/Mf-a6osx mats/Mf-arm32le + mats/Mf-i3fb mats/Mf-i3le mats/Mf-i3nb mats/Mf-i3ob mats/Mf-i3osx + mats/Mf-i3qnx mats/Mf-ppc32le mats/Mf-ta6fb mats/Mf-ta6le mats/Mf-ta6nb + mats/Mf-ta6ob mats/Mf-ta6osx mats/Mf-ti3fb mats/Mf-ti3le mats/Mf-ti3nb + mats/Mf-ti3ob mats/Mf-ti3osx mats/Mf-tppc32le mats/unix.ms newrelease + pkg/Makefile release_notes/gifs/Makefile release_notes/math/Makefile + s/Mf-base workarea +- fixed configure script for update of nanopass to v1.9.2 + configure +- fixed help description for configure options --installschemename, + --installpetitename, and --installscriptname + configure +- maybe-compile-program now returns void + compile.ss 7.ms +- fixed right shift of a negative bignum by a multiple of 32 + number.c 5_3.ms +- fixed the documentation of load-shared-object to mention an up-to-date + dll for Windows + foreign.stex +- New spellings #true and #false for #t and #f are recognized + read.ss 6.ms +- refactor mats to allow different configurations to run in parallel. + The {partial,all,bully}x targets in Mats/Mf-base now support running + in parallel if make chooses to do so (e.g., if instructed via -j). + Update travis-ci build scripts to use new partialx target and run + jobs in parallel (based on the number of cores available). Also + add the ability to "skip" (i.e., error before building) travis targets + by using a line (or lines) beginning with "travis:only:" and listing + the desired target machine type(s) in the commit message. + .travis.yml .travis/{build,test,maybe-skip-build}.sh + mats/{5_4,6,7,8,bytevector,examples,foreign}.ms + mats/{ftype,hash,io,misc,primvars,profile,record}.ms + mats/Mf-base mats/Mf-*nt mats/mat.ss mats/patch-interpret* +- fix x86_64 (& integer-8) and (& integer-16) foreign-call argument + passing + x86_64, s/Mf-[t]a6{le,osx} +- fixed misnamed pattern variables in bytevector-*-ref + bytevector.ss +- add workaround for Rosetta 2 bug in [t]a6osx builds. The overhead + during native (x86) execution is the addition of a single int compare + and branch in S_bytevector_read, plus a small amount of work at startup + to determine whether we are running under Rosetta translation. + new-io.c, scheme.c, version.h +- use a 7-byte NOP in the x86_64 fasl relocator instead of 7 1-byte NOPs + fasl.c +- Move unused terminals in L4.5 to later languages. + np-languages.ss +- vector literals can be made self-evaluating with the new parameter + self-evaluating-vectors + s/back.ss s/primdata.ss s/syntax.ss csug/objects.tex mats/misc.ms +- remove obsolete travis-ci.org configuration + README.md .travis.yml .travis/* +- add GitHub actions workflow for automated testing + .github/workflows/{build.sh,summary,test.sh,test.yml} +- corrected signature of compile-whole-program and compile-whole-library + s/primdata.ss +- clarify rd-bytevector error message for non-atomic token types, such + as vparen, where the token value is #f + mats/6.ms, mats/root-experr-compile-0-f-f-f, + mats/root-experr-compile-2-f-f-f, release_notes/release_notes.stex, + s/read.ss +- include an identifier name in the syntax error for missing ellipsis + mats/8.ms, mats/root-experr-compile-0-f-f-f, + mats/root-experr-compile-2-f-f-f, release_notes/release_notes.stex, + s/syntax.ss + +9.5.6 changes: +- added back.patch to patchobj + s/Mf-base +- updated version to 9.5.6 + makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt c/Makefile.i3nt + c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt + mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc s/7.ss + s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex + csug/csug.stex rpm/Makefile pkg/Makefile wininstall/Makefile + wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs + wininstall/ti3nt.wxs + +9.5.7 changes: +- updated version to 9.5.7 + BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt + c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt + mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc + s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex + csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile + wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs + wininstall/ta6nt.wxs wininstall/ti3nt.wxs +- fix bug in printf with certain control strings and argument counts + s/format.ss mats/format.ms mats/root-experr-compile-{0,2}-fff + release_notes/release_notes.stex +- updated ftypes to allow native ftypes to be used even if another + non-ftype syntactic binding for the type exists. for instance, if a + syntactic binding for integer-32 is introduced which is not bound to + an ftd, using integer-32 in the context of an ftype will still work. + this change also allows an ftype binding to be created for a native + type by using (define-ftype ), allowing + users to create standard ftype bindings for the native-types if that + is preferred. + s/ftype.ss, mats/ftype.ms +- fix occasional 0xC0000409 STATUS_STACK_BUFFER_OVERRUN crash on 64-bit + Windows from Microsoft's longjmp by implementing our own setjmp/longjmp + c/Makefile.{a6nt,ta6nt} c/Mf-{a6nt,ta6nt} c/a6nt-jump.asm c/externs.h + c/types.h c/version.h release_notes/release_notes.stex +- support Microsoft Visual Studio 2022 on Windows + BUILDING, c/vs.bat, wininstall/locate-vcredist.bat +- make threaded foreign mats more robust + mats/foreign.ms +- fix rational-valued? for numbers with an exceptional real part + s/5_3.ss mats/5_1.ms +- change behavior of mixed exact/inexact arithmetic comparisons in + the range where fixnums have greater precision than flonums. This + makes <=, =, and >= transitive as required by R6RS. (< and > were + already transitive, but the behavior is changed to match.) + s/5_3.ss mats/5_3.ms +- consolidate the $thread-check code in misc.ms and thread.ms, keeping + the thread.ms version of the code since it is more recent + mats/misc.ms mats/thread-check.ss mats/thread.ms +- Replace K&R style function declarations with ANSI style + c/alloc.c c/arm32le.c c/externs.h c/fasl.c c/flushcache.c c/foreign.c + c/gc.c c/gcwrapper.c c/i32le.c c/intern.c c/io.c c/itest.c c/new-io.c + c/number.c c/ppc32.c c/ppc32le.c c/prim.c c/prim5.c c/print.c c/scheme.c + c/schlib.c c/schsig.c c/segment.c c/statics.c c/stats.c c/symbol.c + c/thread.c c/windows.c mats/foreign1.c +- Eliminate PROTO macro from scheme.h + boot/*/scheme.h c/Makefile.* c/alloc.c c/externs.h c/fasl.c c/flushcache.c + c/foreign.c c/gc.c c/gcwrapper.c c/intern.c c/io.c c/new-io.c c/number.c + c/prim.c c/prim5.c c/print.c c/scheme.c c/schlib.c c/schsig.c c/segment.c + c/thread.c mats/foreign3.c s/mkheader.ss +- update lz4 to version 1.9.3 + configure +- update zlib to version 1.2.12 (which fixes CVE-2018-25032) + configure c/Mf-*le + +9.5.8 changes: +- updated version to 9.5.8 + BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt + c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt + mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc s/7.ss + s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex + csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile + wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs + wininstall/ta6nt.wxs wininstall/ti3nt.wxs newrelease + +9.5.9 changes: +- updated version to 9.5.9 + BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt + c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt + mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc + s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex + csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile + wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs + wininstall/ta6nt.wxs wininstall/ti3nt.wxs +- fix arm32le compilation systems using musl libc + c/arm32le.c +- added install-docs target for make and corresponding configuration + options: --installdoc, --installcsug, and --installreleasenotes + configure makefiles/Makefile.in +- fixed a bug in `char-` that led to returning a large positive integer + result when the second argument had a value greater than the first. + It now returns a negative number in this situation. + cpnanopass.ss + 5_4.ms root-experr-* patch-* +- fix ppc32 conditional-branch code generation when displacement is + exactly 32764 + s/ppc32.ss +- fix callable floating-point argument allocation on x86 + s/cpnanopass.ss +- corrected signature of multibyte->string and string->multibyte + s/primdata.ss +- fix typos found by Eric Lindblad + c/alloc.c c/compress-io.c c/gc.c c/gcwrapper.c c/new-io.c c/prim5.c + c/schsig.c csug/csug.stex csug/syntax.stex examples/template.ss + mats/4.ms mats/6.ms mats/7.ms mats/8.ms mats/bytevector.ms mats/foreign.ms + mats/io.ms mats/mat.ss mats/misc.ms mats/oop.ms mats/oop.ss mats/profile.ms + mats/record.ms mats/unix.ms s/5_3.ss s/7.ss s/arm32.ss s/base-lang.ss + s/cmacros.ss s/cp0.ss s/cpnanopass.ss s/date.ss s/format.ss s/io.ss + s/mkheader.ss s/np-languages.ss s/pdhtml.ss s/ppc32.ss s/print.ss + s/syntax.ss s/x86.ss s/x86_64.ss +- Unicode 14.0 support + unicode/* s/5_4.ss mats/5_4.ms mats/6.ms +- don't rely on signed integer overflow (UB) in symhash implementation + c/foreign.c +- Propagate immutable versions of "", #(), #vu8() and #vfx() in cp0. + s/cp0.ss s/cpnanopass.ss +- correct mislabeling of some functions as macros and vice versa in + docs + correct name of Slocked_objectp from Sunlocked_objectp + csug/foreign.stex diff --git a/NOTICE b/NOTICE new file mode 100644 index 0000000..3148992 --- /dev/null +++ b/NOTICE @@ -0,0 +1,33 @@ +Chez Scheme Version 9.5.9 +Copyright 1984-2022 Cisco Systems, Inc. + +This product includes code developed by Cisco Systems, Inc. + +This product also includes separately copyrighted: + +* Unicode data files from the Unicode Consortium + +* Unicode data-file processing code developed by Abdulaziz Ghuloum and + R. Kent Dybvig + +* sorting code developed by Olin Shivers + +* example programs, an html formatting module, and documentation + support files developed by R. Kent Dybvig + +* test code and other code used for testing developed by + William D Clinger, by Dirk Lutzebaeck, and by Oscar Waddell and + R. Kent Dybvig. + +* code derived from C. David Boyer's command-line editor + +Builds of this product incorporate separately copyrighted code from: + +* the Nanopass Infrastructure, developed by Dipanwita Sarkar, + Andrew W. Keep, R. Kent Dybvig, and Oscar Waddell + +* the Zlib compression library, developed by Jean-loup Gailly and + Mark Adler + +* the LZ4 compression library, developed by Yann Collet and + contributors. diff --git a/bintar/Makefile b/bintar/Makefile new file mode 100644 index 0000000..a928206 --- /dev/null +++ b/bintar/Makefile @@ -0,0 +1,86 @@ +# Makefile +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +version = 9.5.9 +m := $(shell find ../bin/* -type d | xargs basename) + +R = csv$(version) +TARBALL = $(R)-$(m).tar.gz + +CONTENTS=\ + $(R)/LICENSE\ + $(R)/NOTICE\ + $(R)/scheme.1.in\ + $(R)/installsh\ + $(R)/Makefile\ + $(R)/examples\ + $(R)/boot\ + $(R)/bin + +$(TARBALL): $(CONTENTS) + ( BROKEN=`find -L $R -type l` ; \ + if test -n "$$BROKEN" ; then \ + echo "Error: missing $(BROKEN)" ; \ + exit 1 ; \ + fi ) + tar -czhf $(TARBALL) $R + rm -rf $(R) + +$(R)/LICENSE: $(R) + ( cd $(R) ; ln -s ../../../LICENSE . ) + +$(R)/NOTICE: $(R) + ( cd $(R) ; ln -s ../../../NOTICE . ) + +$(R)/scheme.1.in: $(R) + ( cd $(R) ; ln -s ../../scheme.1.in . ) + +$(R)/installsh: $(R) + ( cd $(R) ; ln -s ../../installsh . ) + +$(R)/Makefile: $(R) + ( cd $(R) ; ln -s ../../Mf-install Makefile ) + +$(R)/examples: $(R) + ( cd $(R) ; ln -s ../../examples . ) + +$(R)/boot: $(R) + mkdir -p $(R)/boot/$(m) + ( cd $(R)/boot/$(m) ; ln -s ../../../../boot/$(m)/{scheme.h,petite.boot,scheme.boot,revision} . ) + case $(m) in \ + *nt) \ + ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{csv959md.lib,csv959mt.lib,mainmd.obj,mainmt.obj,scheme.res} . ) \ + ;; \ + *) \ + ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{main.o,kernel.o} . ) \ + ;; \ + esac + +$(R)/bin: $(R) + mkdir -p $(R)/bin/$(m) + case $(m) in \ + *nt) \ + ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/{scheme.exe,csv959.dll,csv959.lib,vcruntime140.lib} . ) \ + ;; \ + *) \ + ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/scheme . ) \ + ;; \ + esac + +$(R): + mkdir $(R) + +clean: + rm -rf $(R) $(TARBALL) diff --git a/boot/a6le/equates.h b/boot/a6le/equates.h new file mode 100644 index 0000000..bf56b88 --- /dev/null +++ b/boot/a6le/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long I64; +typedef unsigned long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x40 +#define long_long_bits 0x40 +#define machine_type 0xB +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name a6le +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long" +#define typedef_i8 "char" +#define typedef_iptr "long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/a6le/petite.boot b/boot/a6le/petite.boot new file mode 100644 index 0000000..13df887 Binary files /dev/null and b/boot/a6le/petite.boot differ diff --git a/boot/a6le/scheme.boot b/boot/a6le/scheme.boot new file mode 100644 index 0000000..4bcf339 Binary files /dev/null and b/boot/a6le/scheme.boot differ diff --git a/boot/a6le/scheme.h b/boot/a6le/scheme.h new file mode 100644 index 0000000..ebd134c --- /dev/null +++ b/boot/a6le/scheme.h @@ -0,0 +1,239 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (a6le) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "a6le" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long int iptr; +typedef unsigned long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long); +EXPORT ptr Sunsigned64(unsigned long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movq $1, %%rax\n\t"\ + "xchgq (%0), %%rax\n\t"\ + "cmpq $0, %%rax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpq $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "rax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + :"memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/a6nt/equates.h b/boot/a6nt/equates.h new file mode 100644 index 0000000..39f2677 --- /dev/null +++ b/boot/a6nt/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x1B +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name a6nt +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "long long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x10 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/a6nt/petite.boot b/boot/a6nt/petite.boot new file mode 100644 index 0000000..60ea820 Binary files /dev/null and b/boot/a6nt/petite.boot differ diff --git a/boot/a6nt/scheme.boot b/boot/a6nt/scheme.boot new file mode 100644 index 0000000..538b537 Binary files /dev/null and b/boot/a6nt/scheme.boot differ diff --git a/boot/a6nt/scheme.h b/boot/a6nt/scheme.h new file mode 100644 index 0000000..c366fb9 --- /dev/null +++ b/boot/a6nt/scheme.h @@ -0,0 +1,217 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (a6nt) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "a6nt" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long long int iptr; +typedef unsigned long long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Windows support. */ +#include +EXPORT char * Sgetenv(const char *); +EXPORT wchar_t * Sutf8_to_wide(const char *); +EXPORT char * Swide_to_utf8(const wchar_t *); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_WINDOWS + +/* Locking macros. */ +#define INITLOCK(addr) (*((long long *) addr) = 0) + +#define SPINLOCK(addr) \ +{ \ + while (_InterlockedExchange64(addr, 1) != 0) { \ + while(*((long long *) addr) != 0); \ + } \ +} while(0) + +#define UNLOCK(addr) (*((long long *) addr) = 0) + +#define LOCKED_INCR(addr, res) (res = (-1 == _InterlockedExchangeAdd64(addr, 1))) + +#define LOCKED_DECR(addr, res) (res = (1 == _InterlockedExchangeAdd64(addr, -1))) diff --git a/boot/a6ob/equates.h b/boot/a6ob/equates.h new file mode 100644 index 0000000..78b2f5e --- /dev/null +++ b/boot/a6ob/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long I64; +typedef unsigned long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x40 +#define long_long_bits 0x40 +#define machine_type 0xF +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name a6ob +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long" +#define typedef_i8 "char" +#define typedef_iptr "long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/a6ob/petite.boot b/boot/a6ob/petite.boot new file mode 100644 index 0000000..1295096 Binary files /dev/null and b/boot/a6ob/petite.boot differ diff --git a/boot/a6ob/scheme.boot b/boot/a6ob/scheme.boot new file mode 100644 index 0000000..75df81d Binary files /dev/null and b/boot/a6ob/scheme.boot differ diff --git a/boot/a6ob/scheme.h b/boot/a6ob/scheme.h new file mode 100644 index 0000000..fbf09d7 --- /dev/null +++ b/boot/a6ob/scheme.h @@ -0,0 +1,239 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (a6ob) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "a6ob" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long int iptr; +typedef unsigned long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long); +EXPORT ptr Sunsigned64(unsigned long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movq $1, %%rax\n\t"\ + "xchgq (%0), %%rax\n\t"\ + "cmpq $0, %%rax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpq $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "rax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + :"memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/a6osx/equates.h b/boot/a6osx/equates.h new file mode 100644 index 0000000..55b6d91 --- /dev/null +++ b/boot/a6osx/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long I64; +typedef unsigned long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x40 +#define long_long_bits 0x40 +#define machine_type 0xD +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name a6osx +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long" +#define typedef_i8 "char" +#define typedef_iptr "long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/a6osx/petite.boot b/boot/a6osx/petite.boot new file mode 100644 index 0000000..ede4e11 Binary files /dev/null and b/boot/a6osx/petite.boot differ diff --git a/boot/a6osx/scheme.boot b/boot/a6osx/scheme.boot new file mode 100644 index 0000000..f8c27e1 Binary files /dev/null and b/boot/a6osx/scheme.boot differ diff --git a/boot/a6osx/scheme.h b/boot/a6osx/scheme.h new file mode 100644 index 0000000..9aa421b --- /dev/null +++ b/boot/a6osx/scheme.h @@ -0,0 +1,239 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (a6osx) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "a6osx" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long int iptr; +typedef unsigned long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long); +EXPORT ptr Sunsigned64(unsigned long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movq $1, %%rax\n\t"\ + "xchgq (%0), %%rax\n\t"\ + "cmpq $0, %%rax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpq $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "rax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + :"memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/arm32le/equates.h b/boot/arm32le/equates.h new file mode 100644 index 0000000..4a7526e --- /dev/null +++ b/boot/arm32le/equates.h @@ -0,0 +1,991 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture arm32 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x1F +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name arm32le +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_arm32_abs 0x1 +#define reloc_arm32_call 0x2 +#define reloc_arm32_jump 0x3 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x170 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x164 +#define tc_SRCBV_disp 0x168 +#define tc_U_disp 0xB4 +#define tc_V_disp 0xB8 +#define tc_W_disp 0xBC +#define tc_X_disp 0xC0 +#define tc_Y_disp 0xC4 +#define tc_ac0_disp 0x14 +#define tc_ac1_disp 0x18 +#define tc_active_disp 0x9C +#define tc_alloc_counter_disp 0x158 +#define tc_ap_disp 0x28 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xF0 +#define tc_cchain_disp 0x90 +#define tc_code_ranges_to_flush_disp 0x94 +#define tc_compile_profile_disp 0x11C +#define tc_compress_format_disp 0x140 +#define tc_compress_level_disp 0x144 +#define tc_cp_disp 0x20 +#define tc_current_error_disp 0xEC +#define tc_current_input_disp 0xE4 +#define tc_current_mso_disp 0xF8 +#define tc_current_output_disp 0xE8 +#define tc_default_record_equal_procedure_disp 0x138 +#define tc_default_record_hash_procedure_disp 0x13C +#define tc_disable_count_disp 0xD0 +#define tc_eap_disp 0x2C +#define tc_esp_disp 0x24 +#define tc_fxfirst_bit_set_bv_disp 0x104 +#define tc_fxlength_bv_disp 0x100 +#define tc_generate_inspector_information_disp 0x120 +#define tc_generate_procedure_source_information_disp 0x124 +#define tc_generate_profile_forms_disp 0x128 +#define tc_guardian_entries_disp 0x8C +#define tc_instr_counter_disp 0x150 +#define tc_keyboard_interrupt_pending_disp 0xDC +#define tc_lz4_out_buffer_disp 0x148 +#define tc_meta_level_disp 0x118 +#define tc_null_immutable_bytevector_disp 0x110 +#define tc_null_immutable_fxvector_disp 0x10C +#define tc_null_immutable_string_disp 0x114 +#define tc_null_immutable_vector_disp 0x108 +#define tc_optimize_level_disp 0x12C +#define tc_parameters_disp 0x160 +#define tc_random_seed_disp 0x98 +#define tc_real_eap_disp 0x48 +#define tc_ret_disp 0x30 +#define tc_scheme_stack_disp 0xA0 +#define tc_scheme_stack_size_disp 0xAC +#define tc_sfd_disp 0xF4 +#define tc_sfp_disp 0x1C +#define tc_signal_interrupt_pending_disp 0xD4 +#define tc_signal_interrupt_queue_disp 0xD8 +#define tc_something_pending_disp 0xC8 +#define tc_stack_cache_disp 0xA4 +#define tc_stack_link_disp 0xA8 +#define tc_subset_mode_disp 0x130 +#define tc_suppress_primitive_inlining_disp 0x134 +#define tc_target_machine_disp 0xFC +#define tc_td_disp 0x44 +#define tc_threadno_disp 0xE0 +#define tc_timer_ticks_disp 0xCC +#define tc_trap_disp 0x34 +#define tc_ts_disp 0x40 +#define tc_virtual_registers_disp 0x4C +#define tc_winders_disp 0xB0 +#define tc_xp_disp 0x38 +#define tc_yp_disp 0x3C +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x20 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+356))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+360))) +#define U(x) (*((ptr *)((uptr)(x)+180))) +#define V(x) (*((ptr *)((uptr)(x)+184))) +#define W(x) (*((ptr *)((uptr)(x)+188))) +#define X(x) (*((ptr *)((uptr)(x)+192))) +#define Y(x) (*((ptr *)((uptr)(x)+196))) +#define AC0(x) (*((void* *)((uptr)(x)+20))) +#define AC1(x) (*((void* *)((uptr)(x)+24))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+156))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+344))) +#define AP(x) (*((void* *)((uptr)(x)+40))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+240))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+144))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+148))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+284))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+320))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+324))) +#define CP(x) (*((void* *)((uptr)(x)+32))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+236))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+228))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+248))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+232))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+312))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+316))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+208))) +#define EAP(x) (*((void* *)((uptr)(x)+44))) +#define ESP(x) (*((void* *)((uptr)(x)+36))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+260))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+256))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+288))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+292))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+296))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+140))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+336))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+220))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+328))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+280))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+272))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+268))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+276))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+264))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+300))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+352))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+152))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+72))) +#define RET(x) (*((void* *)((uptr)(x)+48))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+160))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+172))) +#define SFD(x) (*((ptr *)((uptr)(x)+244))) +#define SFP(x) (*((void* *)((uptr)(x)+28))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+212))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+216))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+200))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+164))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+168))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+304))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+308))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+252))) +#define TD(x) (*((void* *)((uptr)(x)+68))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+224))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+204))) +#define TRAP(x) (*((void* *)((uptr)(x)+52))) +#define TS(x) (*((void* *)((uptr)(x)+64))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+76))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+176))) +#define XP(x) (*((void* *)((uptr)(x)+56))) +#define YP(x) (*((void* *)((uptr)(x)+60))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+76))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/arm32le/petite.boot b/boot/arm32le/petite.boot new file mode 100644 index 0000000..83ad522 Binary files /dev/null and b/boot/arm32le/petite.boot differ diff --git a/boot/arm32le/scheme.boot b/boot/arm32le/scheme.boot new file mode 100644 index 0000000..5715b96 Binary files /dev/null and b/boot/arm32le/scheme.boot differ diff --git a/boot/arm32le/scheme.h b/boot/arm32le/scheme.h new file mode 100644 index 0000000..0827a34 --- /dev/null +++ b/boot/arm32le/scheme.h @@ -0,0 +1,256 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (arm32le) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "arm32le" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("mov r12, #0\n\t"\ + "str r12, [%0, #0]\n\t"\ + : \ + : "r" (addr)\ + :"memory", "r12") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "ldrex r12, [%0, #0]\n\t"\ + "cmp r12, #0\n\t"\ + "bne 1f\n\t"\ + "mov r12, #1\n\t"\ + "strex r11, r12, [%0]\n\t"\ + "cmp r11, #0\n\t"\ + "beq 2f\n\t"\ + "1:\n\t"\ + "ldr r12, [%0, #0]\n\t"\ + "cmp r12, #0\n\t"\ + "beq 0b\n\t"\ + "b 1b\n\t"\ + "2:\n\t"\ + : \ + : "r" (addr)\ + : "cc", "memory", "r12", "r11") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("mov r12, #0\n\t"\ + "str r12, [%0, #0]\n\t"\ + : \ + : "r" (addr)\ + :"memory", "r12") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("mov %0, #0\n\t"\ + "0:\n\t"\ + "ldrex r12, [%1, #0]\n\t"\ + "add r12, r12, #1\n\t"\ + "strex r11, r12, [%1]\n\t"\ + "cmp r11, #0\n\t"\ + "bne 0b\n\t"\ + "cmp r12, #0\n\t"\ + "moveq %0, #1\n\t"\ + : "=&r" (ret)\ + : "r" (addr)\ + : "cc", "memory", "r12", "r11") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("mov %0, #0\n\t"\ + "0:\n\t"\ + "ldrex r12, [%1, #0]\n\t"\ + "sub r12, r12, #1\n\t"\ + "strex r11, r12, [%1]\n\t"\ + "cmp r11, #0\n\t"\ + "bne 0b\n\t"\ + "cmp r12, #0\n\t"\ + "moveq %0, #1\n\t"\ + : "=&r" (ret)\ + : "r" (addr)\ + : "cc", "memory", "r12", "r11") diff --git a/boot/i3le/equates.h b/boot/i3le/equates.h new file mode 100644 index 0000000..73f6576 --- /dev/null +++ b/boot/i3le/equates.h @@ -0,0 +1,991 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86 +#define asm_arg_reg_cnt 0x1 +#define asm_arg_reg_max 0x1 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x1 +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name i3le +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x4 +#define max_integer_alignment 0x4 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_rel 0x1 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0xD +#define rtd_counts_timestamp_disp 0x5 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x158 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x150 +#define tc_SRCBV_disp 0x154 +#define tc_U_disp 0xA4 +#define tc_V_disp 0xA8 +#define tc_W_disp 0xAC +#define tc_X_disp 0xB0 +#define tc_Y_disp 0xB4 +#define tc_ac0_disp 0x4 +#define tc_ac1_disp 0x8 +#define tc_active_disp 0x8C +#define tc_alloc_counter_disp 0x144 +#define tc_ap_disp 0x18 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xE0 +#define tc_cchain_disp 0x80 +#define tc_code_ranges_to_flush_disp 0x84 +#define tc_compile_profile_disp 0x10C +#define tc_compress_format_disp 0x130 +#define tc_compress_level_disp 0x134 +#define tc_cp_disp 0x10 +#define tc_current_error_disp 0xDC +#define tc_current_input_disp 0xD4 +#define tc_current_mso_disp 0xE8 +#define tc_current_output_disp 0xD8 +#define tc_default_record_equal_procedure_disp 0x128 +#define tc_default_record_hash_procedure_disp 0x12C +#define tc_disable_count_disp 0xC0 +#define tc_eap_disp 0x1C +#define tc_esp_disp 0x14 +#define tc_fxfirst_bit_set_bv_disp 0xF4 +#define tc_fxlength_bv_disp 0xF0 +#define tc_generate_inspector_information_disp 0x110 +#define tc_generate_procedure_source_information_disp 0x114 +#define tc_generate_profile_forms_disp 0x118 +#define tc_guardian_entries_disp 0x7C +#define tc_instr_counter_disp 0x13C +#define tc_keyboard_interrupt_pending_disp 0xCC +#define tc_lz4_out_buffer_disp 0x138 +#define tc_meta_level_disp 0x108 +#define tc_null_immutable_bytevector_disp 0x100 +#define tc_null_immutable_fxvector_disp 0xFC +#define tc_null_immutable_string_disp 0x104 +#define tc_null_immutable_vector_disp 0xF8 +#define tc_optimize_level_disp 0x11C +#define tc_parameters_disp 0x14C +#define tc_random_seed_disp 0x88 +#define tc_real_eap_disp 0x38 +#define tc_ret_disp 0x20 +#define tc_scheme_stack_disp 0x90 +#define tc_scheme_stack_size_disp 0x9C +#define tc_sfd_disp 0xE4 +#define tc_sfp_disp 0xC +#define tc_signal_interrupt_pending_disp 0xC4 +#define tc_signal_interrupt_queue_disp 0xC8 +#define tc_something_pending_disp 0xB8 +#define tc_stack_cache_disp 0x94 +#define tc_stack_link_disp 0x98 +#define tc_subset_mode_disp 0x120 +#define tc_suppress_primitive_inlining_disp 0x124 +#define tc_target_machine_disp 0xEC +#define tc_td_disp 0x34 +#define tc_threadno_disp 0xD0 +#define tc_timer_ticks_disp 0xBC +#define tc_trap_disp 0x24 +#define tc_ts_disp 0x30 +#define tc_virtual_registers_disp 0x3C +#define tc_winders_disp 0xA0 +#define tc_xp_disp 0x28 +#define tc_yp_disp 0x2C +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x20 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+5))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+13))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+336))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+340))) +#define U(x) (*((ptr *)((uptr)(x)+164))) +#define V(x) (*((ptr *)((uptr)(x)+168))) +#define W(x) (*((ptr *)((uptr)(x)+172))) +#define X(x) (*((ptr *)((uptr)(x)+176))) +#define Y(x) (*((ptr *)((uptr)(x)+180))) +#define AC0(x) (*((void* *)((uptr)(x)+4))) +#define AC1(x) (*((void* *)((uptr)(x)+8))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+140))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+324))) +#define AP(x) (*((void* *)((uptr)(x)+24))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+224))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+128))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+132))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+268))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+304))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+308))) +#define CP(x) (*((void* *)((uptr)(x)+16))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+220))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+212))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+232))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+216))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+296))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+300))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+192))) +#define EAP(x) (*((void* *)((uptr)(x)+28))) +#define ESP(x) (*((void* *)((uptr)(x)+20))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+244))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+240))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+272))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+276))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+280))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+124))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+316))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+204))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+312))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+264))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+256))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+252))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+260))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+248))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+284))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+332))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+136))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+56))) +#define RET(x) (*((void* *)((uptr)(x)+32))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+144))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+156))) +#define SFD(x) (*((ptr *)((uptr)(x)+228))) +#define SFP(x) (*((void* *)((uptr)(x)+12))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+196))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+200))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+184))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+148))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+152))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+288))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+292))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+236))) +#define TD(x) (*((void* *)((uptr)(x)+52))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+208))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+188))) +#define TRAP(x) (*((void* *)((uptr)(x)+36))) +#define TS(x) (*((void* *)((uptr)(x)+48))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+60))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+160))) +#define XP(x) (*((void* *)((uptr)(x)+40))) +#define YP(x) (*((void* *)((uptr)(x)+44))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+60))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/i3le/petite.boot b/boot/i3le/petite.boot new file mode 100644 index 0000000..2d84a86 Binary files /dev/null and b/boot/i3le/petite.boot differ diff --git a/boot/i3le/scheme.boot b/boot/i3le/scheme.boot new file mode 100644 index 0000000..e7a864a Binary files /dev/null and b/boot/i3le/scheme.boot differ diff --git a/boot/i3le/scheme.h b/boot/i3le/scheme.h new file mode 100644 index 0000000..26c8b88 --- /dev/null +++ b/boot/i3le/scheme.h @@ -0,0 +1,239 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (i3le) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "i3le" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movl $1, %%eax\n\t"\ + "xchgl (%0), %%eax\n\t"\ + "cmpl $0, %%eax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpl $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "eax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/i3nt/equates.h b/boot/i3nt/equates.h new file mode 100644 index 0000000..6879b4a --- /dev/null +++ b/boot/i3nt/equates.h @@ -0,0 +1,992 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86 +#define asm_arg_reg_cnt 0x1 +#define asm_arg_reg_max 0x1 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x3 +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name i3nt +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_rel 0x1 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x160 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x154 +#define tc_SRCBV_disp 0x158 +#define tc_U_disp 0xA4 +#define tc_V_disp 0xA8 +#define tc_W_disp 0xAC +#define tc_X_disp 0xB0 +#define tc_Y_disp 0xB4 +#define tc_ac0_disp 0x4 +#define tc_ac1_disp 0x8 +#define tc_active_disp 0x8C +#define tc_alloc_counter_disp 0x148 +#define tc_ap_disp 0x18 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xE0 +#define tc_cchain_disp 0x80 +#define tc_code_ranges_to_flush_disp 0x84 +#define tc_compile_profile_disp 0x10C +#define tc_compress_format_disp 0x130 +#define tc_compress_level_disp 0x134 +#define tc_cp_disp 0x10 +#define tc_current_error_disp 0xDC +#define tc_current_input_disp 0xD4 +#define tc_current_mso_disp 0xE8 +#define tc_current_output_disp 0xD8 +#define tc_default_record_equal_procedure_disp 0x128 +#define tc_default_record_hash_procedure_disp 0x12C +#define tc_disable_count_disp 0xC0 +#define tc_eap_disp 0x1C +#define tc_esp_disp 0x14 +#define tc_fxfirst_bit_set_bv_disp 0xF4 +#define tc_fxlength_bv_disp 0xF0 +#define tc_generate_inspector_information_disp 0x110 +#define tc_generate_procedure_source_information_disp 0x114 +#define tc_generate_profile_forms_disp 0x118 +#define tc_guardian_entries_disp 0x7C +#define tc_instr_counter_disp 0x140 +#define tc_keyboard_interrupt_pending_disp 0xCC +#define tc_lz4_out_buffer_disp 0x138 +#define tc_meta_level_disp 0x108 +#define tc_null_immutable_bytevector_disp 0x100 +#define tc_null_immutable_fxvector_disp 0xFC +#define tc_null_immutable_string_disp 0x104 +#define tc_null_immutable_vector_disp 0xF8 +#define tc_optimize_level_disp 0x11C +#define tc_parameters_disp 0x150 +#define tc_random_seed_disp 0x88 +#define tc_real_eap_disp 0x38 +#define tc_ret_disp 0x20 +#define tc_scheme_stack_disp 0x90 +#define tc_scheme_stack_size_disp 0x9C +#define tc_sfd_disp 0xE4 +#define tc_sfp_disp 0xC +#define tc_signal_interrupt_pending_disp 0xC4 +#define tc_signal_interrupt_queue_disp 0xC8 +#define tc_something_pending_disp 0xB8 +#define tc_stack_cache_disp 0x94 +#define tc_stack_link_disp 0x98 +#define tc_subset_mode_disp 0x120 +#define tc_suppress_primitive_inlining_disp 0x124 +#define tc_target_machine_disp 0xEC +#define tc_td_disp 0x34 +#define tc_threadno_disp 0xD0 +#define tc_timer_ticks_disp 0xBC +#define tc_trap_disp 0x24 +#define tc_ts_disp 0x30 +#define tc_virtual_registers_disp 0x3C +#define tc_winders_disp 0xA0 +#define tc_xp_disp 0x28 +#define tc_yp_disp 0x2C +#define thread_handle_uptrs 0x1 +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x10 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+340))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+344))) +#define U(x) (*((ptr *)((uptr)(x)+164))) +#define V(x) (*((ptr *)((uptr)(x)+168))) +#define W(x) (*((ptr *)((uptr)(x)+172))) +#define X(x) (*((ptr *)((uptr)(x)+176))) +#define Y(x) (*((ptr *)((uptr)(x)+180))) +#define AC0(x) (*((void* *)((uptr)(x)+4))) +#define AC1(x) (*((void* *)((uptr)(x)+8))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+140))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+328))) +#define AP(x) (*((void* *)((uptr)(x)+24))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+224))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+128))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+132))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+268))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+304))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+308))) +#define CP(x) (*((void* *)((uptr)(x)+16))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+220))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+212))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+232))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+216))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+296))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+300))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+192))) +#define EAP(x) (*((void* *)((uptr)(x)+28))) +#define ESP(x) (*((void* *)((uptr)(x)+20))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+244))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+240))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+272))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+276))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+280))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+124))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+320))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+204))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+312))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+264))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+256))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+252))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+260))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+248))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+284))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+336))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+136))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+56))) +#define RET(x) (*((void* *)((uptr)(x)+32))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+144))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+156))) +#define SFD(x) (*((ptr *)((uptr)(x)+228))) +#define SFP(x) (*((void* *)((uptr)(x)+12))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+196))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+200))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+184))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+148))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+152))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+288))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+292))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+236))) +#define TD(x) (*((void* *)((uptr)(x)+52))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+208))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+188))) +#define TRAP(x) (*((void* *)((uptr)(x)+36))) +#define TS(x) (*((void* *)((uptr)(x)+48))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+60))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+160))) +#define XP(x) (*((void* *)((uptr)(x)+40))) +#define YP(x) (*((void* *)((uptr)(x)+44))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+60))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/i3nt/petite.boot b/boot/i3nt/petite.boot new file mode 100644 index 0000000..a0805d2 Binary files /dev/null and b/boot/i3nt/petite.boot differ diff --git a/boot/i3nt/scheme.boot b/boot/i3nt/scheme.boot new file mode 100644 index 0000000..36e3510 Binary files /dev/null and b/boot/i3nt/scheme.boot differ diff --git a/boot/i3nt/scheme.h b/boot/i3nt/scheme.h new file mode 100644 index 0000000..1fdc568 --- /dev/null +++ b/boot/i3nt/scheme.h @@ -0,0 +1,217 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (i3nt) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "i3nt" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Windows support. */ +#include +EXPORT char * Sgetenv(const char *); +EXPORT wchar_t * Sutf8_to_wide(const char *); +EXPORT char * Swide_to_utf8(const wchar_t *); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_WINDOWS + +/* Locking macros. */ +#define INITLOCK(addr) (*((long *) addr) = 0) + +#define SPINLOCK(addr) \ +{ \ + while (_InterlockedExchange(addr, 1) != 0) { \ + while(*((long *) addr) != 0); \ + } \ +} while(0) + +#define UNLOCK(addr) (*((long *) addr) = 0) + +#define LOCKED_INCR(addr, res) (res = (-1 == _InterlockedExchangeAdd(addr, 1))) + +#define LOCKED_DECR(addr, res) (res = (1 == _InterlockedExchangeAdd(addr, -1))) diff --git a/boot/i3osx/equates.h b/boot/i3osx/equates.h new file mode 100644 index 0000000..b70a4b0 --- /dev/null +++ b/boot/i3osx/equates.h @@ -0,0 +1,991 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86 +#define asm_arg_reg_cnt 0x1 +#define asm_arg_reg_max 0x1 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x9 +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name i3osx +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x4 +#define max_integer_alignment 0x4 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_rel 0x1 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0xD +#define rtd_counts_timestamp_disp 0x5 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x158 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x150 +#define tc_SRCBV_disp 0x154 +#define tc_U_disp 0xA4 +#define tc_V_disp 0xA8 +#define tc_W_disp 0xAC +#define tc_X_disp 0xB0 +#define tc_Y_disp 0xB4 +#define tc_ac0_disp 0x4 +#define tc_ac1_disp 0x8 +#define tc_active_disp 0x8C +#define tc_alloc_counter_disp 0x144 +#define tc_ap_disp 0x18 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xE0 +#define tc_cchain_disp 0x80 +#define tc_code_ranges_to_flush_disp 0x84 +#define tc_compile_profile_disp 0x10C +#define tc_compress_format_disp 0x130 +#define tc_compress_level_disp 0x134 +#define tc_cp_disp 0x10 +#define tc_current_error_disp 0xDC +#define tc_current_input_disp 0xD4 +#define tc_current_mso_disp 0xE8 +#define tc_current_output_disp 0xD8 +#define tc_default_record_equal_procedure_disp 0x128 +#define tc_default_record_hash_procedure_disp 0x12C +#define tc_disable_count_disp 0xC0 +#define tc_eap_disp 0x1C +#define tc_esp_disp 0x14 +#define tc_fxfirst_bit_set_bv_disp 0xF4 +#define tc_fxlength_bv_disp 0xF0 +#define tc_generate_inspector_information_disp 0x110 +#define tc_generate_procedure_source_information_disp 0x114 +#define tc_generate_profile_forms_disp 0x118 +#define tc_guardian_entries_disp 0x7C +#define tc_instr_counter_disp 0x13C +#define tc_keyboard_interrupt_pending_disp 0xCC +#define tc_lz4_out_buffer_disp 0x138 +#define tc_meta_level_disp 0x108 +#define tc_null_immutable_bytevector_disp 0x100 +#define tc_null_immutable_fxvector_disp 0xFC +#define tc_null_immutable_string_disp 0x104 +#define tc_null_immutable_vector_disp 0xF8 +#define tc_optimize_level_disp 0x11C +#define tc_parameters_disp 0x14C +#define tc_random_seed_disp 0x88 +#define tc_real_eap_disp 0x38 +#define tc_ret_disp 0x20 +#define tc_scheme_stack_disp 0x90 +#define tc_scheme_stack_size_disp 0x9C +#define tc_sfd_disp 0xE4 +#define tc_sfp_disp 0xC +#define tc_signal_interrupt_pending_disp 0xC4 +#define tc_signal_interrupt_queue_disp 0xC8 +#define tc_something_pending_disp 0xB8 +#define tc_stack_cache_disp 0x94 +#define tc_stack_link_disp 0x98 +#define tc_subset_mode_disp 0x120 +#define tc_suppress_primitive_inlining_disp 0x124 +#define tc_target_machine_disp 0xEC +#define tc_td_disp 0x34 +#define tc_threadno_disp 0xD0 +#define tc_timer_ticks_disp 0xBC +#define tc_trap_disp 0x24 +#define tc_ts_disp 0x30 +#define tc_virtual_registers_disp 0x3C +#define tc_winders_disp 0xA0 +#define tc_xp_disp 0x28 +#define tc_yp_disp 0x2C +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x20 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+5))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+13))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+336))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+340))) +#define U(x) (*((ptr *)((uptr)(x)+164))) +#define V(x) (*((ptr *)((uptr)(x)+168))) +#define W(x) (*((ptr *)((uptr)(x)+172))) +#define X(x) (*((ptr *)((uptr)(x)+176))) +#define Y(x) (*((ptr *)((uptr)(x)+180))) +#define AC0(x) (*((void* *)((uptr)(x)+4))) +#define AC1(x) (*((void* *)((uptr)(x)+8))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+140))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+324))) +#define AP(x) (*((void* *)((uptr)(x)+24))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+224))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+128))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+132))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+268))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+304))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+308))) +#define CP(x) (*((void* *)((uptr)(x)+16))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+220))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+212))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+232))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+216))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+296))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+300))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+192))) +#define EAP(x) (*((void* *)((uptr)(x)+28))) +#define ESP(x) (*((void* *)((uptr)(x)+20))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+244))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+240))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+272))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+276))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+280))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+124))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+316))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+204))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+312))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+264))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+256))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+252))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+260))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+248))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+284))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+332))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+136))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+56))) +#define RET(x) (*((void* *)((uptr)(x)+32))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+144))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+156))) +#define SFD(x) (*((ptr *)((uptr)(x)+228))) +#define SFP(x) (*((void* *)((uptr)(x)+12))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+196))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+200))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+184))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+148))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+152))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+288))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+292))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+236))) +#define TD(x) (*((void* *)((uptr)(x)+52))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+208))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+188))) +#define TRAP(x) (*((void* *)((uptr)(x)+36))) +#define TS(x) (*((void* *)((uptr)(x)+48))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+60))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+160))) +#define XP(x) (*((void* *)((uptr)(x)+40))) +#define YP(x) (*((void* *)((uptr)(x)+44))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+60))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/i3osx/petite.boot b/boot/i3osx/petite.boot new file mode 100644 index 0000000..8b7ce7d Binary files /dev/null and b/boot/i3osx/petite.boot differ diff --git a/boot/i3osx/scheme.boot b/boot/i3osx/scheme.boot new file mode 100644 index 0000000..f3e9c22 Binary files /dev/null and b/boot/i3osx/scheme.boot differ diff --git a/boot/i3osx/scheme.h b/boot/i3osx/scheme.h new file mode 100644 index 0000000..0db3a58 --- /dev/null +++ b/boot/i3osx/scheme.h @@ -0,0 +1,239 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (i3osx) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "i3osx" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movl $1, %%eax\n\t"\ + "xchgl (%0), %%eax\n\t"\ + "cmpl $0, %%eax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpl $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "eax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/ta6le/equates.h b/boot/ta6le/equates.h new file mode 100644 index 0000000..b0bbf51 --- /dev/null +++ b/boot/ta6le/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long I64; +typedef unsigned long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x40 +#define long_long_bits 0x40 +#define machine_type 0xC +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ta6le +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long" +#define typedef_i8 "char" +#define typedef_iptr "long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ta6le/petite.boot b/boot/ta6le/petite.boot new file mode 100644 index 0000000..f9f3560 Binary files /dev/null and b/boot/ta6le/petite.boot differ diff --git a/boot/ta6le/scheme.boot b/boot/ta6le/scheme.boot new file mode 100644 index 0000000..8614cdf Binary files /dev/null and b/boot/ta6le/scheme.boot differ diff --git a/boot/ta6le/scheme.h b/boot/ta6le/scheme.h new file mode 100644 index 0000000..a7cd243 --- /dev/null +++ b/boot/ta6le/scheme.h @@ -0,0 +1,245 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ta6le) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ta6le" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long int iptr; +typedef unsigned long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long); +EXPORT ptr Sunsigned64(unsigned long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movq $1, %%rax\n\t"\ + "xchgq (%0), %%rax\n\t"\ + "cmpq $0, %%rax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpq $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "rax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + :"memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/ta6nt/equates.h b/boot/ta6nt/equates.h new file mode 100644 index 0000000..2ede769 --- /dev/null +++ b/boot/ta6nt/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x1C +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ta6nt +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "long long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x10 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ta6nt/petite.boot b/boot/ta6nt/petite.boot new file mode 100644 index 0000000..7a32615 Binary files /dev/null and b/boot/ta6nt/petite.boot differ diff --git a/boot/ta6nt/scheme.boot b/boot/ta6nt/scheme.boot new file mode 100644 index 0000000..e40dd8f Binary files /dev/null and b/boot/ta6nt/scheme.boot differ diff --git a/boot/ta6nt/scheme.h b/boot/ta6nt/scheme.h new file mode 100644 index 0000000..d8f026b --- /dev/null +++ b/boot/ta6nt/scheme.h @@ -0,0 +1,223 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ta6nt) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ta6nt" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long long int iptr; +typedef unsigned long long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Windows support. */ +#include +EXPORT char * Sgetenv(const char *); +EXPORT wchar_t * Sutf8_to_wide(const char *); +EXPORT char * Swide_to_utf8(const wchar_t *); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS +#define FEATURE_WINDOWS + +/* Locking macros. */ +#define INITLOCK(addr) (*((long long *) addr) = 0) + +#define SPINLOCK(addr) \ +{ \ + while (_InterlockedExchange64(addr, 1) != 0) { \ + while(*((long long *) addr) != 0); \ + } \ +} while(0) + +#define UNLOCK(addr) (*((long long *) addr) = 0) + +#define LOCKED_INCR(addr, res) (res = (-1 == _InterlockedExchangeAdd64(addr, 1))) + +#define LOCKED_DECR(addr, res) (res = (1 == _InterlockedExchangeAdd64(addr, -1))) diff --git a/boot/ta6ob/equates.h b/boot/ta6ob/equates.h new file mode 100644 index 0000000..ba38a96 --- /dev/null +++ b/boot/ta6ob/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long I64; +typedef unsigned long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x40 +#define long_long_bits 0x40 +#define machine_type 0x10 +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ta6ob +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long" +#define typedef_i8 "char" +#define typedef_iptr "long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ta6ob/petite.boot b/boot/ta6ob/petite.boot new file mode 100644 index 0000000..a6e8df1 Binary files /dev/null and b/boot/ta6ob/petite.boot differ diff --git a/boot/ta6ob/scheme.boot b/boot/ta6ob/scheme.boot new file mode 100644 index 0000000..a804a46 Binary files /dev/null and b/boot/ta6ob/scheme.boot differ diff --git a/boot/ta6ob/scheme.h b/boot/ta6ob/scheme.h new file mode 100644 index 0000000..434b811 --- /dev/null +++ b/boot/ta6ob/scheme.h @@ -0,0 +1,245 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ta6ob) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ta6ob" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long int iptr; +typedef unsigned long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long); +EXPORT ptr Sunsigned64(unsigned long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movq $1, %%rax\n\t"\ + "xchgq (%0), %%rax\n\t"\ + "cmpq $0, %%rax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpq $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "rax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + :"memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/ta6osx/equates.h b/boot/ta6osx/equates.h new file mode 100644 index 0000000..406539d --- /dev/null +++ b/boot/ta6osx/equates.h @@ -0,0 +1,993 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long I64; +typedef unsigned long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x40 +#define alloc_waste_maximum 0x800 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86_64 +#define asm_arg_reg_cnt 0x3 +#define asm_arg_reg_max 0x5 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x9 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x9 +#define box_type_disp 0x1 +#define byte_alignment 0x10 +#define byte_constant_mask 0xFFFFFFFFFFFFFFFF +#define bytes_per_card 0x200 +#define bytes_per_segment 0x4000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x8 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x9 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0xB +#define code_arity_mask_disp 0x21 +#define code_closure_length_disp 0x29 +#define code_data_disp 0x41 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x31 +#define code_length_disp 0x9 +#define code_name_disp 0x19 +#define code_pinfos_disp 0x39 +#define code_reloc_disp 0x11 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x23 +#define continuation_return_address_disp 0x2B +#define continuation_stack_clength_disp 0x1B +#define continuation_stack_disp 0xB +#define continuation_stack_length_disp 0x13 +#define continuation_winders_disp 0x33 +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x800000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0xFFF0 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xF +#define ephemeron_next_disp 0x17 +#define ephemeron_trigger_next_disp 0x1F +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x11 +#define exactnum_real_disp 0x9 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x3D +#define fixnum_factor 0x8 +#define fixnum_offset 0x3 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x8 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x9 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0x18 +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x8 +#define guardian_entry_tconc_disp 0x10 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x8 +#define header_size_bytevector 0x8 +#define header_size_closure 0x8 +#define header_size_code 0x40 +#define header_size_fxvector 0x8 +#define header_size_record 0x8 +#define header_size_reloc_table 0x10 +#define header_size_string 0x8 +#define header_size_vector 0x8 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x19 +#define inexactnum_pad_disp 0x9 +#define inexactnum_real_disp 0x11 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x3 +#define long_bits 0x40 +#define long_long_bits 0x40 +#define machine_type 0xE +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ta6osx +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFFFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFFFFFFFFFF +#define mask_exactnum 0xFFFFFFFFFFFFFFFF +#define mask_false 0xFFFFFFFFFFFFFFFF +#define mask_fixnum 0x7 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFFFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFFFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0xF +#define mask_nil 0xFFFFFFFFFFFFFFFF +#define mask_octet -0x7F9 +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFFFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFFFFFFFFFF +#define mask_tlc 0xFFFFFFFFFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFFFFFFFFFF +#define mask_vector 0x7 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF +#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x1000000000000000 +#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF +#define native_endianness little +#define one_shot_headroom 0xC00 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xF +#define pair_shift 0x4 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x9 +#define port_ibuffer_disp 0x39 +#define port_icount_disp 0x19 +#define port_ilast_disp 0x31 +#define port_info_disp 0x41 +#define port_name_disp 0x49 +#define port_obuffer_disp 0x29 +#define port_ocount_disp 0x11 +#define port_olast_disp 0x21 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x40 +#define ptr_bytes 0x8 +#define ptrdiff_t_bits 0x40 +#define ratnum_denominator_disp 0x11 +#define ratnum_numerator_disp 0x9 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x9 +#define record_type_counts_disp 0x49 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x39 +#define record_type_flds_disp 0x31 +#define record_type_mpm_disp 0x21 +#define record_type_name_disp 0x29 +#define record_type_parent_disp 0x9 +#define record_type_pm_disp 0x19 +#define record_type_size_disp 0x11 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x41 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FFFFFF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFFFF +#define reloc_item_offset_offset 0x1E +#define reloc_longp_index 0x4 +#define reloc_table_code_disp 0x8 +#define reloc_table_data_disp 0x10 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define reloc_x86_64_call 0x1 +#define reloc_x86_64_jump 0x2 +#define return_address_frame_size_disp -0x10 +#define return_address_livemask_disp -0x20 +#define return_address_mv_return_address_disp -0x8 +#define return_address_toplink_disp -0x18 +#define rp_header_frame_size_disp 0x10 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0x18 +#define rp_header_toplink_disp 0x8 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x8 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xE +#define segment_t1_bits 0x10 +#define segment_t2_bits 0x11 +#define segment_t3_bits 0x11 +#define segment_table_levels 0x3 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x10 +#define size_cached_stack 0x10 +#define size_continuation 0x40 +#define size_ephemeron 0x20 +#define size_exactnum 0x20 +#define size_flonum 0x10 +#define size_forward 0x10 +#define size_guardian_entry 0x20 +#define size_inexactnum 0x20 +#define size_pair 0x10 +#define size_port 0x50 +#define size_ratnum 0x20 +#define size_record_type 0x50 +#define size_rp_header 0x20 +#define size_rtd_counts 0x810 +#define size_symbol 0x30 +#define size_tc 0x2C0 +#define size_thread 0x10 +#define size_tlc 0x20 +#define size_typed_object 0x10 +#define size_t_bits 0x40 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x200 +#define stack_slop 0x400 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x9 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x2D +#define symbol_name_disp 0x1D +#define symbol_plist_disp 0x15 +#define symbol_pvalue_disp 0xD +#define symbol_splist_disp 0x25 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 +#define tc_U_disp 0x160 +#define tc_V_disp 0x168 +#define tc_W_disp 0x170 +#define tc_X_disp 0x178 +#define tc_Y_disp 0x180 +#define tc_ac0_disp 0x28 +#define tc_ac1_disp 0x30 +#define tc_active_disp 0x134 +#define tc_alloc_counter_disp 0x298 +#define tc_ap_disp 0x50 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0x1D8 +#define tc_cchain_disp 0x120 +#define tc_code_ranges_to_flush_disp 0x128 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 +#define tc_cp_disp 0x40 +#define tc_current_error_disp 0x1D0 +#define tc_current_input_disp 0x1C0 +#define tc_current_mso_disp 0x1E8 +#define tc_current_output_disp 0x1C8 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 +#define tc_disable_count_disp 0x198 +#define tc_eap_disp 0x58 +#define tc_esp_disp 0x48 +#define tc_fxfirst_bit_set_bv_disp 0x200 +#define tc_fxlength_bv_disp 0x1F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 +#define tc_guardian_entries_disp 0x118 +#define tc_instr_counter_disp 0x290 +#define tc_keyboard_interrupt_pending_disp 0x1B0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_null_immutable_bytevector_disp 0x218 +#define tc_null_immutable_fxvector_disp 0x210 +#define tc_null_immutable_string_disp 0x220 +#define tc_null_immutable_vector_disp 0x208 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 +#define tc_random_seed_disp 0x130 +#define tc_real_eap_disp 0x90 +#define tc_ret_disp 0x60 +#define tc_scheme_stack_disp 0x138 +#define tc_scheme_stack_size_disp 0x150 +#define tc_sfd_disp 0x1E0 +#define tc_sfp_disp 0x38 +#define tc_signal_interrupt_pending_disp 0x1A0 +#define tc_signal_interrupt_queue_disp 0x1A8 +#define tc_something_pending_disp 0x188 +#define tc_stack_cache_disp 0x140 +#define tc_stack_link_disp 0x148 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 +#define tc_target_machine_disp 0x1F0 +#define tc_td_disp 0x88 +#define tc_threadno_disp 0x1B8 +#define tc_timer_ticks_disp 0x190 +#define tc_trap_disp 0x68 +#define tc_ts_disp 0x80 +#define tc_virtual_registers_disp 0x98 +#define tc_winders_disp 0x158 +#define tc_xp_disp 0x70 +#define tc_yp_disp 0x78 +#define thread_tc_disp 0x9 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x11 +#define tlc_keyval_disp 0x9 +#define tlc_next_disp 0x19 +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x8 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long" +#define typedef_i8 "char" +#define typedef_iptr "long int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned long int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x80 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x9 +#define vector_immutable_flag 0x8 +#define vector_length_factor 0x10 +#define vector_length_offset 0x4 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 9 +#define eq_hashtable_mutablep_disp 17 +#define eq_hashtable_vec_disp 25 +#define eq_hashtable_minlen_disp 33 +#define eq_hashtable_size_disp 41 +#define eq_hashtable_subtype_disp 49 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 9 +#define symbol_hashtable_mutablep_disp 17 +#define symbol_hashtable_vec_disp 25 +#define symbol_hashtable_minlen_disp 33 +#define symbol_hashtable_size_disp 41 +#define symbol_hashtable_equivp_disp 49 +#define code_info_rtd_disp 1 +#define code_info_src_disp 9 +#define code_info_sexpr_disp 17 +#define code_info_free_disp 25 +#define code_info_live_disp 33 +#define code_info_rpis_disp 41 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+15))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+9))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+17))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+73))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+65))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+25))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+49))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+9))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+17))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+25))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+41))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+49))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+35))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+43))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+9))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+688))) +#define U(x) (*((ptr *)((uptr)(x)+352))) +#define V(x) (*((ptr *)((uptr)(x)+360))) +#define W(x) (*((ptr *)((uptr)(x)+368))) +#define X(x) (*((ptr *)((uptr)(x)+376))) +#define Y(x) (*((ptr *)((uptr)(x)+384))) +#define AC0(x) (*((void* *)((uptr)(x)+40))) +#define AC1(x) (*((void* *)((uptr)(x)+48))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+308))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664))) +#define AP(x) (*((void* *)((uptr)(x)+80))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+288))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640))) +#define CP(x) (*((void* *)((uptr)(x)+64))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408))) +#define EAP(x) (*((void* *)((uptr)(x)+88))) +#define ESP(x) (*((void* *)((uptr)(x)+72))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+552))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+144))) +#define RET(x) (*((void* *)((uptr)(x)+96))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336))) +#define SFD(x) (*((ptr *)((uptr)(x)+480))) +#define SFP(x) (*((void* *)((uptr)(x)+56))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+328))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496))) +#define TD(x) (*((void* *)((uptr)(x)+136))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+440))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400))) +#define TRAP(x) (*((void* *)((uptr)(x)+104))) +#define TS(x) (*((void* *)((uptr)(x)+128))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+344))) +#define XP(x) (*((void* *)((uptr)(x)+112))) +#define YP(x) (*((void* *)((uptr)(x)+120))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ta6osx/petite.boot b/boot/ta6osx/petite.boot new file mode 100644 index 0000000..b200a59 Binary files /dev/null and b/boot/ta6osx/petite.boot differ diff --git a/boot/ta6osx/scheme.boot b/boot/ta6osx/scheme.boot new file mode 100644 index 0000000..d921618 Binary files /dev/null and b/boot/ta6osx/scheme.boot differ diff --git a/boot/ta6osx/scheme.h b/boot/ta6osx/scheme.h new file mode 100644 index 0000000..c41d9b8 --- /dev/null +++ b/boot/ta6osx/scheme.h @@ -0,0 +1,245 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ta6osx) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ta6osx" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef long int iptr; +typedef unsigned long int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x7)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/8) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+15))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+9))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*8)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long); +EXPORT ptr Sunsigned64(unsigned long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movq $1, %%rax\n\t"\ + "xchgq (%0), %%rax\n\t"\ + "cmpq $0, %%rax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpq $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "rax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movq $0, (%0)"\ + : \ + : "r" (addr) \ + :"memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decq (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/ti3le/equates.h b/boot/ti3le/equates.h new file mode 100644 index 0000000..755ee67 --- /dev/null +++ b/boot/ti3le/equates.h @@ -0,0 +1,991 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86 +#define asm_arg_reg_cnt 0x1 +#define asm_arg_reg_max 0x1 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x2 +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ti3le +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x4 +#define max_integer_alignment 0x4 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_rel 0x1 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0xD +#define rtd_counts_timestamp_disp 0x5 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x158 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x150 +#define tc_SRCBV_disp 0x154 +#define tc_U_disp 0xA4 +#define tc_V_disp 0xA8 +#define tc_W_disp 0xAC +#define tc_X_disp 0xB0 +#define tc_Y_disp 0xB4 +#define tc_ac0_disp 0x4 +#define tc_ac1_disp 0x8 +#define tc_active_disp 0x8C +#define tc_alloc_counter_disp 0x144 +#define tc_ap_disp 0x18 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xE0 +#define tc_cchain_disp 0x80 +#define tc_code_ranges_to_flush_disp 0x84 +#define tc_compile_profile_disp 0x10C +#define tc_compress_format_disp 0x130 +#define tc_compress_level_disp 0x134 +#define tc_cp_disp 0x10 +#define tc_current_error_disp 0xDC +#define tc_current_input_disp 0xD4 +#define tc_current_mso_disp 0xE8 +#define tc_current_output_disp 0xD8 +#define tc_default_record_equal_procedure_disp 0x128 +#define tc_default_record_hash_procedure_disp 0x12C +#define tc_disable_count_disp 0xC0 +#define tc_eap_disp 0x1C +#define tc_esp_disp 0x14 +#define tc_fxfirst_bit_set_bv_disp 0xF4 +#define tc_fxlength_bv_disp 0xF0 +#define tc_generate_inspector_information_disp 0x110 +#define tc_generate_procedure_source_information_disp 0x114 +#define tc_generate_profile_forms_disp 0x118 +#define tc_guardian_entries_disp 0x7C +#define tc_instr_counter_disp 0x13C +#define tc_keyboard_interrupt_pending_disp 0xCC +#define tc_lz4_out_buffer_disp 0x138 +#define tc_meta_level_disp 0x108 +#define tc_null_immutable_bytevector_disp 0x100 +#define tc_null_immutable_fxvector_disp 0xFC +#define tc_null_immutable_string_disp 0x104 +#define tc_null_immutable_vector_disp 0xF8 +#define tc_optimize_level_disp 0x11C +#define tc_parameters_disp 0x14C +#define tc_random_seed_disp 0x88 +#define tc_real_eap_disp 0x38 +#define tc_ret_disp 0x20 +#define tc_scheme_stack_disp 0x90 +#define tc_scheme_stack_size_disp 0x9C +#define tc_sfd_disp 0xE4 +#define tc_sfp_disp 0xC +#define tc_signal_interrupt_pending_disp 0xC4 +#define tc_signal_interrupt_queue_disp 0xC8 +#define tc_something_pending_disp 0xB8 +#define tc_stack_cache_disp 0x94 +#define tc_stack_link_disp 0x98 +#define tc_subset_mode_disp 0x120 +#define tc_suppress_primitive_inlining_disp 0x124 +#define tc_target_machine_disp 0xEC +#define tc_td_disp 0x34 +#define tc_threadno_disp 0xD0 +#define tc_timer_ticks_disp 0xBC +#define tc_trap_disp 0x24 +#define tc_ts_disp 0x30 +#define tc_virtual_registers_disp 0x3C +#define tc_winders_disp 0xA0 +#define tc_xp_disp 0x28 +#define tc_yp_disp 0x2C +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x20 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+5))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+13))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+336))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+340))) +#define U(x) (*((ptr *)((uptr)(x)+164))) +#define V(x) (*((ptr *)((uptr)(x)+168))) +#define W(x) (*((ptr *)((uptr)(x)+172))) +#define X(x) (*((ptr *)((uptr)(x)+176))) +#define Y(x) (*((ptr *)((uptr)(x)+180))) +#define AC0(x) (*((void* *)((uptr)(x)+4))) +#define AC1(x) (*((void* *)((uptr)(x)+8))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+140))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+324))) +#define AP(x) (*((void* *)((uptr)(x)+24))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+224))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+128))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+132))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+268))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+304))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+308))) +#define CP(x) (*((void* *)((uptr)(x)+16))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+220))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+212))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+232))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+216))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+296))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+300))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+192))) +#define EAP(x) (*((void* *)((uptr)(x)+28))) +#define ESP(x) (*((void* *)((uptr)(x)+20))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+244))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+240))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+272))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+276))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+280))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+124))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+316))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+204))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+312))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+264))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+256))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+252))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+260))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+248))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+284))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+332))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+136))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+56))) +#define RET(x) (*((void* *)((uptr)(x)+32))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+144))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+156))) +#define SFD(x) (*((ptr *)((uptr)(x)+228))) +#define SFP(x) (*((void* *)((uptr)(x)+12))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+196))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+200))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+184))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+148))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+152))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+288))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+292))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+236))) +#define TD(x) (*((void* *)((uptr)(x)+52))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+208))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+188))) +#define TRAP(x) (*((void* *)((uptr)(x)+36))) +#define TS(x) (*((void* *)((uptr)(x)+48))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+60))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+160))) +#define XP(x) (*((void* *)((uptr)(x)+40))) +#define YP(x) (*((void* *)((uptr)(x)+44))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+60))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ti3le/petite.boot b/boot/ti3le/petite.boot new file mode 100644 index 0000000..10875ff Binary files /dev/null and b/boot/ti3le/petite.boot differ diff --git a/boot/ti3le/scheme.boot b/boot/ti3le/scheme.boot new file mode 100644 index 0000000..6b49842 Binary files /dev/null and b/boot/ti3le/scheme.boot differ diff --git a/boot/ti3le/scheme.h b/boot/ti3le/scheme.h new file mode 100644 index 0000000..1367e11 --- /dev/null +++ b/boot/ti3le/scheme.h @@ -0,0 +1,245 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ti3le) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ti3le" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movl $1, %%eax\n\t"\ + "xchgl (%0), %%eax\n\t"\ + "cmpl $0, %%eax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpl $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "eax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/boot/ti3nt/equates.h b/boot/ti3nt/equates.h new file mode 100644 index 0000000..a1ad12b --- /dev/null +++ b/boot/ti3nt/equates.h @@ -0,0 +1,992 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86 +#define asm_arg_reg_cnt 0x1 +#define asm_arg_reg_max 0x1 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0x4 +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ti3nt +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x8 +#define max_integer_alignment 0x8 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_rel 0x1 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0x11 +#define rtd_counts_timestamp_disp 0x9 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x160 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x154 +#define tc_SRCBV_disp 0x158 +#define tc_U_disp 0xA4 +#define tc_V_disp 0xA8 +#define tc_W_disp 0xAC +#define tc_X_disp 0xB0 +#define tc_Y_disp 0xB4 +#define tc_ac0_disp 0x4 +#define tc_ac1_disp 0x8 +#define tc_active_disp 0x8C +#define tc_alloc_counter_disp 0x148 +#define tc_ap_disp 0x18 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xE0 +#define tc_cchain_disp 0x80 +#define tc_code_ranges_to_flush_disp 0x84 +#define tc_compile_profile_disp 0x10C +#define tc_compress_format_disp 0x130 +#define tc_compress_level_disp 0x134 +#define tc_cp_disp 0x10 +#define tc_current_error_disp 0xDC +#define tc_current_input_disp 0xD4 +#define tc_current_mso_disp 0xE8 +#define tc_current_output_disp 0xD8 +#define tc_default_record_equal_procedure_disp 0x128 +#define tc_default_record_hash_procedure_disp 0x12C +#define tc_disable_count_disp 0xC0 +#define tc_eap_disp 0x1C +#define tc_esp_disp 0x14 +#define tc_fxfirst_bit_set_bv_disp 0xF4 +#define tc_fxlength_bv_disp 0xF0 +#define tc_generate_inspector_information_disp 0x110 +#define tc_generate_procedure_source_information_disp 0x114 +#define tc_generate_profile_forms_disp 0x118 +#define tc_guardian_entries_disp 0x7C +#define tc_instr_counter_disp 0x140 +#define tc_keyboard_interrupt_pending_disp 0xCC +#define tc_lz4_out_buffer_disp 0x138 +#define tc_meta_level_disp 0x108 +#define tc_null_immutable_bytevector_disp 0x100 +#define tc_null_immutable_fxvector_disp 0xFC +#define tc_null_immutable_string_disp 0x104 +#define tc_null_immutable_vector_disp 0xF8 +#define tc_optimize_level_disp 0x11C +#define tc_parameters_disp 0x150 +#define tc_random_seed_disp 0x88 +#define tc_real_eap_disp 0x38 +#define tc_ret_disp 0x20 +#define tc_scheme_stack_disp 0x90 +#define tc_scheme_stack_size_disp 0x9C +#define tc_sfd_disp 0xE4 +#define tc_sfp_disp 0xC +#define tc_signal_interrupt_pending_disp 0xC4 +#define tc_signal_interrupt_queue_disp 0xC8 +#define tc_something_pending_disp 0xB8 +#define tc_stack_cache_disp 0x94 +#define tc_stack_link_disp 0x98 +#define tc_subset_mode_disp 0x120 +#define tc_suppress_primitive_inlining_disp 0x124 +#define tc_target_machine_disp 0xEC +#define tc_td_disp 0x34 +#define tc_threadno_disp 0xD0 +#define tc_timer_ticks_disp 0xBC +#define tc_trap_disp 0x24 +#define tc_ts_disp 0x30 +#define tc_virtual_registers_disp 0x3C +#define tc_winders_disp 0xA0 +#define tc_xp_disp 0x28 +#define tc_yp_disp 0x2C +#define thread_handle_uptrs 0x2 +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x40 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x10 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+340))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+344))) +#define U(x) (*((ptr *)((uptr)(x)+164))) +#define V(x) (*((ptr *)((uptr)(x)+168))) +#define W(x) (*((ptr *)((uptr)(x)+172))) +#define X(x) (*((ptr *)((uptr)(x)+176))) +#define Y(x) (*((ptr *)((uptr)(x)+180))) +#define AC0(x) (*((void* *)((uptr)(x)+4))) +#define AC1(x) (*((void* *)((uptr)(x)+8))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+140))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+328))) +#define AP(x) (*((void* *)((uptr)(x)+24))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+224))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+128))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+132))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+268))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+304))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+308))) +#define CP(x) (*((void* *)((uptr)(x)+16))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+220))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+212))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+232))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+216))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+296))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+300))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+192))) +#define EAP(x) (*((void* *)((uptr)(x)+28))) +#define ESP(x) (*((void* *)((uptr)(x)+20))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+244))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+240))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+272))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+276))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+280))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+124))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+320))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+204))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+312))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+264))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+256))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+252))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+260))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+248))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+284))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+336))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+136))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+56))) +#define RET(x) (*((void* *)((uptr)(x)+32))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+144))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+156))) +#define SFD(x) (*((ptr *)((uptr)(x)+228))) +#define SFP(x) (*((void* *)((uptr)(x)+12))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+196))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+200))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+184))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+148))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+152))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+288))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+292))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+236))) +#define TD(x) (*((void* *)((uptr)(x)+52))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+208))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+188))) +#define TRAP(x) (*((void* *)((uptr)(x)+36))) +#define TS(x) (*((void* *)((uptr)(x)+48))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+60))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+160))) +#define XP(x) (*((void* *)((uptr)(x)+40))) +#define YP(x) (*((void* *)((uptr)(x)+44))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+60))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ti3nt/petite.boot b/boot/ti3nt/petite.boot new file mode 100644 index 0000000..526cfe6 Binary files /dev/null and b/boot/ti3nt/petite.boot differ diff --git a/boot/ti3nt/scheme.boot b/boot/ti3nt/scheme.boot new file mode 100644 index 0000000..fbaa80f Binary files /dev/null and b/boot/ti3nt/scheme.boot differ diff --git a/boot/ti3nt/scheme.h b/boot/ti3nt/scheme.h new file mode 100644 index 0000000..774796f --- /dev/null +++ b/boot/ti3nt/scheme.h @@ -0,0 +1,223 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ti3nt) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ti3nt" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Windows support. */ +#include +EXPORT char * Sgetenv(const char *); +EXPORT wchar_t * Sutf8_to_wide(const char *); +EXPORT char * Swide_to_utf8(const wchar_t *); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS +#define FEATURE_WINDOWS + +/* Locking macros. */ +#define INITLOCK(addr) (*((long *) addr) = 0) + +#define SPINLOCK(addr) \ +{ \ + while (_InterlockedExchange(addr, 1) != 0) { \ + while(*((long *) addr) != 0); \ + } \ +} while(0) + +#define UNLOCK(addr) (*((long *) addr) = 0) + +#define LOCKED_INCR(addr, res) (res = (-1 == _InterlockedExchangeAdd(addr, 1))) + +#define LOCKED_DECR(addr, res) (res = (1 == _InterlockedExchangeAdd(addr, -1))) diff --git a/boot/ti3osx/equates.h b/boot/ti3osx/equates.h new file mode 100644 index 0000000..9024805 --- /dev/null +++ b/boot/ti3osx/equates.h @@ -0,0 +1,991 @@ +/* equates.h for Chez Scheme Version 9.5.9 */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct version */ +/* of this file for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Integer typedefs */ +typedef char I8; +typedef unsigned char U8; +typedef short I16; +typedef unsigned short U16; +typedef int I32; +typedef unsigned int U32; +typedef long long I64; +typedef unsigned long long U64; + +/* constants from cmacros.ss */ +#define $c_func_closure_index 0x4 +#define $c_func_closure_record_index 0x3 +#define $c_func_code_object_index 0x2 +#define $c_func_code_record_index 0x1 +#define COMPRESS_FORMAT_BITS 0x3 +#define COMPRESS_GZIP 0x0 +#define COMPRESS_HIGH 0x3 +#define COMPRESS_LOW 0x1 +#define COMPRESS_LZ4 0x1 +#define COMPRESS_MAX 0x4 +#define COMPRESS_MEDIUM 0x2 +#define COMPRESS_MIN 0x0 +#define ERROR_CALL_ARGUMENT_COUNT 0x4 +#define ERROR_CALL_NONPROCEDURE 0x3 +#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2 +#define ERROR_CALL_UNBOUND 0x1 +#define ERROR_MVLET 0x8 +#define ERROR_NONCONTINUABLE_INTERRUPT 0x6 +#define ERROR_OTHER 0x0 +#define ERROR_RESET 0x5 +#define ERROR_VALUES 0x7 +#define OPEN_ERROR_EXISTS 0x2 +#define OPEN_ERROR_EXISTSNOT 0x3 +#define OPEN_ERROR_OTHER 0x0 +#define OPEN_ERROR_PROTECTION 0x1 +#define PORT_FLAG_BINARY 0x400 +#define PORT_FLAG_BLOCK_BUFFERED 0x20000 +#define PORT_FLAG_BOL 0x8000 +#define PORT_FLAG_CHAR_POSITIONS 0x100000 +#define PORT_FLAG_CLOSED 0x800 +#define PORT_FLAG_COMPRESSED 0x2000 +#define PORT_FLAG_EOF 0x10000 +#define PORT_FLAG_EXCLUSIVE 0x4000 +#define PORT_FLAG_FILE 0x1000 +#define PORT_FLAG_FOLD_CASE 0x400000 +#define PORT_FLAG_INPUT 0x100 +#define PORT_FLAG_INPUT_MODE 0x80000 +#define PORT_FLAG_LINE_BUFFERED 0x40000 +#define PORT_FLAG_NO_FOLD_CASE 0x800000 +#define PORT_FLAG_OUTPUT 0x200 +#define PORT_FLAG_R6RS 0x200000 +#define SAPPEND 0x3 +#define SDEFAULT 0x4 +#define SEOF -0x1 +#define SERROR 0x0 +#define SICONV_DUNNO 0x0 +#define SICONV_INCOMPLETE 0x2 +#define SICONV_INVALID 0x1 +#define SICONV_NOROOM 0x3 +#define SREPLACE 0x2 +#define STRVNCATE 0x1 +#define address_bits 0x20 +#define alloc_waste_maximum 0x400 +#define annotation_all 0x3 +#define annotation_debug 0x1 +#define annotation_profile 0x2 +#define architecture x86 +#define asm_arg_reg_cnt 0x1 +#define asm_arg_reg_max 0x1 +#define bigit_bits 0x20 +#define bigit_bytes 0x4 +#define bignum_data_disp 0x5 +#define bignum_length_factor 0x40 +#define bignum_length_offset 0x6 +#define bignum_sign_offset 0x5 +#define bignum_type_disp 0x1 +#define black_hole (ptr)0x46 +#define box_ref_disp 0x5 +#define box_type_disp 0x1 +#define byte_alignment 0x8 +#define byte_constant_mask 0xFFFFFFFF +#define bytes_per_card 0x100 +#define bytes_per_segment 0x2000 +#define bytevector_data_disp 0x9 +#define bytevector_immutable_flag 0x4 +#define bytevector_length_factor 0x8 +#define bytevector_length_offset 0x3 +#define bytevector_pad_disp 0x5 +#define bytevector_type_disp 0x1 +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results) +#define c_entry_vector_size 0x19 +#define cached_stack_link_disp 0x4 +#define cached_stack_size_disp 0x0 +#define card_offset_bits 0x8 +#define cards_per_segment 0x20 +#define char_data_offset 0x8 +#define char_factor 0x100 +#define closure_code_disp 0x3 +#define closure_data_disp 0x7 +#define code_arity_mask_disp 0x11 +#define code_closure_length_disp 0x15 +#define code_data_disp 0x21 +#define code_flag_continuation 0x2 +#define code_flag_guardian 0x8 +#define code_flag_system 0x1 +#define code_flag_template 0x4 +#define code_flags_offset 0x8 +#define code_info_disp 0x19 +#define code_length_disp 0x5 +#define code_name_disp 0xD +#define code_pinfos_disp 0x1D +#define code_reloc_disp 0x9 +#define code_type_disp 0x1 +#define collect_interrupt_index 0x1 +#define continuation_code_disp 0x3 +#define continuation_link_disp 0x13 +#define continuation_return_address_disp 0x17 +#define continuation_stack_clength_disp 0xF +#define continuation_stack_disp 0x7 +#define continuation_stack_length_disp 0xB +#define continuation_winders_disp 0x1B +#define countof_bignum 0x5 +#define countof_box 0x9 +#define countof_bytevector 0x15 +#define countof_closure 0x3 +#define countof_code 0xB +#define countof_continuation 0x4 +#define countof_ephemeron 0x19 +#define countof_exactnum 0x8 +#define countof_flonum 0x2 +#define countof_fxvector 0x14 +#define countof_guardian 0x17 +#define countof_inexactnum 0x7 +#define countof_locked 0x16 +#define countof_oblist 0x18 +#define countof_pair 0x0 +#define countof_port 0xA +#define countof_ratnum 0x6 +#define countof_relocation_table 0x10 +#define countof_rtd_counts 0xE +#define countof_stack 0xF +#define countof_string 0x13 +#define countof_symbol 0x1 +#define countof_thread 0xC +#define countof_tlc 0xD +#define countof_types 0x1A +#define countof_vector 0x12 +#define countof_weakpair 0x11 +#define default_collect_trip_bytes 0x400000 +#define default_heap_reserve_ratio 1.0 +#define default_max_nonstatic_generation 0x4 +#define default_stack_size 0x7FF8 +#define default_timer_ticks 0x3E8 +#define dtvec_hour 0x3 +#define dtvec_isdst 0x9 +#define dtvec_mday 0x4 +#define dtvec_min 0x2 +#define dtvec_mon 0x5 +#define dtvec_nsec 0x0 +#define dtvec_sec 0x1 +#define dtvec_size 0xC +#define dtvec_tzname 0xB +#define dtvec_tzoff 0xA +#define dtvec_wday 0x7 +#define dtvec_yday 0x8 +#define dtvec_year 0x6 +#define ephemeron_car_disp 0x7 +#define ephemeron_cdr_disp 0xB +#define ephemeron_next_disp 0xF +#define ephemeron_trigger_next_disp 0x13 +#define eq_hashtable_subtype_ephemeron 0x2 +#define eq_hashtable_subtype_normal 0x0 +#define eq_hashtable_subtype_weak 0x1 +#define exactnum_imag_disp 0x9 +#define exactnum_real_disp 0x5 +#define exactnum_type_disp 0x1 +#define fasl_fld_double 0xA +#define fasl_fld_i16 0x2 +#define fasl_fld_i24 0x3 +#define fasl_fld_i32 0x4 +#define fasl_fld_i40 0x5 +#define fasl_fld_i48 0x6 +#define fasl_fld_i56 0x7 +#define fasl_fld_i64 0x8 +#define fasl_fld_ptr 0x0 +#define fasl_fld_single 0x9 +#define fasl_fld_u8 0x1 +#define fasl_header #vu8(0 0 0 0 99 104 101 122) +#define fasl_type_base_rtd 0x1A +#define fasl_type_box 0x1 +#define fasl_type_bytevector 0x1D +#define fasl_type_closure 0x6 +#define fasl_type_code 0xB +#define fasl_type_entry 0xD +#define fasl_type_ephemeron 0x1C +#define fasl_type_eq_hashtable 0x1F +#define fasl_type_exactnum 0x14 +#define fasl_type_flonum 0x8 +#define fasl_type_fxvector 0x1B +#define fasl_type_gensym 0x13 +#define fasl_type_graph 0x10 +#define fasl_type_graph_def 0x11 +#define fasl_type_graph_ref 0x12 +#define fasl_type_gzip 0x2B +#define fasl_type_header 0x0 +#define fasl_type_immediate 0xC +#define fasl_type_immutable_box 0x29 +#define fasl_type_immutable_bytevector 0x28 +#define fasl_type_immutable_fxvector 0x27 +#define fasl_type_immutable_string 0x26 +#define fasl_type_immutable_vector 0x25 +#define fasl_type_inexactnum 0x5 +#define fasl_type_large_integer 0xA +#define fasl_type_library 0xE +#define fasl_type_library_code 0xF +#define fasl_type_lz4 0x2C +#define fasl_type_pair 0x7 +#define fasl_type_ratnum 0x3 +#define fasl_type_record 0x17 +#define fasl_type_revisit 0x23 +#define fasl_type_rtd 0x18 +#define fasl_type_small_integer 0x19 +#define fasl_type_string 0x9 +#define fasl_type_symbol 0x2 +#define fasl_type_symbol_hashtable 0x20 +#define fasl_type_uncompressed 0x2A +#define fasl_type_vector 0x4 +#define fasl_type_visit 0x22 +#define fasl_type_visit_revisit 0x24 +#define fasl_type_weak_pair 0x1E +#define fixnum_bits 0x1E +#define fixnum_factor 0x4 +#define fixnum_offset 0x2 +#define fld_byte_index 0x4 +#define fld_mutablep_index 0x2 +#define fld_name_index 0x1 +#define fld_type_index 0x3 +#define flonum_data_disp 0x6 +#define forward_address_disp 0x4 +#define forward_marker (ptr)0x2E +#define forward_marker_disp 0x0 +#define ftype_guardian_rep (ptr)0x56 +#define fxvector_data_disp 0x5 +#define fxvector_immutable_flag 0x8 +#define fxvector_length_factor 0x10 +#define fxvector_length_offset 0x4 +#define fxvector_type_disp 0x1 +#define guardian_entry_next_disp 0xC +#define guardian_entry_obj_disp 0x0 +#define guardian_entry_rep_disp 0x4 +#define guardian_entry_tconc_disp 0x8 +#define hashtable_default_size 0x8 +#define header_size_bignum 0x4 +#define header_size_bytevector 0x8 +#define header_size_closure 0x4 +#define header_size_code 0x20 +#define header_size_fxvector 0x4 +#define header_size_record 0x4 +#define header_size_reloc_table 0x8 +#define header_size_string 0x4 +#define header_size_vector 0x4 +#define ignore_event_flag 0x0 +#define inexactnum_imag_disp 0x11 +#define inexactnum_pad_disp 0x5 +#define inexactnum_real_disp 0x9 +#define inexactnum_type_disp 0x1 +#define int_bits 0x20 +#define integer_divide_instruction 1 +#define keyboard_interrupt_index 0x3 +#define library_entry_vector_size 0x210 +#define libspec_closure_index 0xD +#define libspec_does_not_expect_headroom_index 0x0 +#define libspec_error_index 0xE +#define libspec_fake_index 0x10 +#define libspec_flags_index 0x2 +#define libspec_has_does_not_expect_headroom_version_index 0xF +#define libspec_index_base_offset 0x1 +#define libspec_index_base_size 0x9 +#define libspec_index_offset 0x0 +#define libspec_index_size 0xA +#define libspec_interface_offset 0xA +#define libspec_interface_size 0x3 +#define libspec_name_index 0x1 +#define log2_ptr_bytes 0x2 +#define long_bits 0x20 +#define long_long_bits 0x40 +#define machine_type 0xA +#define machine_type_a6fb 0x15 +#define machine_type_a6le 0xB +#define machine_type_a6nb 0x19 +#define machine_type_a6nt 0x1B +#define machine_type_a6ob 0xF +#define machine_type_a6osx 0xD +#define machine_type_a6s2 0x11 +#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le)) +#define machine_type_any 0x0 +#define machine_type_arm32le 0x1F +#define machine_type_i3fb 0x5 +#define machine_type_i3le 0x1 +#define machine_type_i3nb 0x17 +#define machine_type_i3nt 0x3 +#define machine_type_i3ob 0x7 +#define machine_type_i3osx 0x9 +#define machine_type_i3qnx 0x1D +#define machine_type_i3s2 0x13 +#define machine_type_limit 0x23 +#define machine_type_name ti3osx +#define machine_type_ppc32le 0x21 +#define machine_type_ta6fb 0x16 +#define machine_type_ta6le 0xC +#define machine_type_ta6nb 0x1A +#define machine_type_ta6nt 0x1C +#define machine_type_ta6ob 0x10 +#define machine_type_ta6osx 0xE +#define machine_type_ta6s2 0x12 +#define machine_type_tarm32le 0x20 +#define machine_type_ti3fb 0x6 +#define machine_type_ti3le 0x2 +#define machine_type_ti3nb 0x18 +#define machine_type_ti3nt 0x4 +#define machine_type_ti3ob 0x8 +#define machine_type_ti3osx 0xA +#define machine_type_ti3qnx 0x1E +#define machine_type_ti3s2 0x14 +#define machine_type_tppc32le 0x22 +#define mask_bignum 0x1F +#define mask_bignum_sign 0x20 +#define mask_binary_input_port 0x5FF +#define mask_binary_output_port 0x6FF +#define mask_binary_port 0x4FF +#define mask_boolean 0xF7 +#define mask_box 0x7F +#define mask_bwp 0xFFFFFFFF +#define mask_bytevector 0x3 +#define mask_char 0xFF +#define mask_closure 0x7 +#define mask_code 0xFF +#define mask_continuation_code 0x2FF +#define mask_eof 0xFFFFFFFF +#define mask_exactnum 0xFFFFFFFF +#define mask_false 0xFFFFFFFF +#define mask_fixnum 0x3 +#define mask_flonum 0x7 +#define mask_fxvector 0x7 +#define mask_guardian_code 0x8FF +#define mask_immediate 0x7 +#define mask_inexactnum 0xFFFFFFFF +#define mask_input_port 0x1FF +#define mask_mutable_box 0xFFFFFFFF +#define mask_mutable_bytevector 0x7 +#define mask_mutable_fxvector 0xF +#define mask_mutable_string 0xF +#define mask_mutable_vector 0x7 +#define mask_nil 0xFFFFFFFF +#define mask_octet -0x3FD +#define mask_other_number 0xF +#define mask_output_port 0x2FF +#define mask_pair 0x7 +#define mask_port 0xFF +#define mask_ratnum 0xFFFFFFFF +#define mask_record 0x7 +#define mask_rtd_counts 0xFFFFFFFF +#define mask_signed_bignum 0x3F +#define mask_string 0x7 +#define mask_symbol 0x7 +#define mask_system_code 0x1FF +#define mask_textual_input_port 0x5FF +#define mask_textual_output_port 0x6FF +#define mask_textual_port 0x4FF +#define mask_thread 0xFFFFFFFF +#define mask_tlc 0xFFFFFFFF +#define mask_typed_object 0x7 +#define mask_unbound 0xFFFFFFFF +#define mask_vector 0x3 +#define max_float_alignment 0x4 +#define max_integer_alignment 0x4 +#define max_real_space 0xB +#define max_space 0xC +#define max_sweep_space 0xA +#define maximum_bignum_length (iptr)0x3FFFFFF +#define maximum_bytevector_length (iptr)0x1FFFFFFF +#define maximum_fxvector_length (iptr)0xFFFFFFF +#define maximum_interrupt_index 0x4 +#define maximum_string_length (iptr)0xFFFFFFF +#define maximum_vector_length (iptr)0x1FFFFFFF +#define minimum_segment_request 0x80 +#define most_negative_fixnum (iptr)-0x20000000 +#define most_positive_fixnum (iptr)0x1FFFFFFF +#define native_endianness little +#define one_shot_headroom 0x600 +#define ordinary_type_bits 0x8 +#define pair_car_disp 0x7 +#define pair_cdr_disp 0xB +#define pair_shift 0x3 +#define port_flag_binary 0x4 +#define port_flag_block_buffered 0x200 +#define port_flag_bol 0x80 +#define port_flag_char_positions 0x1000 +#define port_flag_closed 0x8 +#define port_flag_compressed 0x20 +#define port_flag_eof 0x100 +#define port_flag_exclusive 0x40 +#define port_flag_file 0x10 +#define port_flag_fold_case 0x4000 +#define port_flag_input 0x1 +#define port_flag_input_mode 0x800 +#define port_flag_line_buffered 0x400 +#define port_flag_no_fold_case 0x8000 +#define port_flag_output 0x2 +#define port_flag_r6rs 0x2000 +#define port_flags_offset 0x8 +#define port_handler_disp 0x5 +#define port_ibuffer_disp 0x1D +#define port_icount_disp 0xD +#define port_ilast_disp 0x19 +#define port_info_disp 0x21 +#define port_name_disp 0x25 +#define port_obuffer_disp 0x15 +#define port_ocount_disp 0x9 +#define port_olast_disp 0x11 +#define port_type_disp 0x1 +#define prelex_is_flags_offset 0x8 +#define prelex_is_mask 0xFF00 +#define prelex_sticky_mask 0xFF +#define prelex_was_flags_offset 0x10 +#define primary_type_bits 0x3 +#define ptr_bits 0x20 +#define ptr_bytes 0x4 +#define ptrdiff_t_bits 0x20 +#define ratnum_denominator_disp 0x9 +#define ratnum_numerator_disp 0x5 +#define ratnum_type_disp 0x1 +#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11)) +#define record_data_disp 0x5 +#define record_type_counts_disp 0x25 +#define record_type_disp 0x1 +#define record_type_flags_disp 0x1D +#define record_type_flds_disp 0x19 +#define record_type_mpm_disp 0x11 +#define record_type_name_disp 0x15 +#define record_type_parent_disp 0x5 +#define record_type_pm_disp 0xD +#define record_type_size_disp 0x9 +#define record_type_type_disp 0x1 +#define record_type_uid_disp 0x21 +#define reloc_abs 0x0 +#define reloc_code_offset_index 0x3 +#define reloc_code_offset_mask 0x3FF +#define reloc_code_offset_offset 0x4 +#define reloc_extended_format 0x1 +#define reloc_item_offset_index 0x2 +#define reloc_item_offset_mask 0x3FFFF +#define reloc_item_offset_offset 0xE +#define reloc_longp_index 0x4 +#define reloc_rel 0x1 +#define reloc_table_code_disp 0x4 +#define reloc_table_data_disp 0x8 +#define reloc_table_size_disp 0x0 +#define reloc_type_index 0x1 +#define reloc_type_mask 0x7 +#define reloc_type_offset 0x1 +#define return_address_frame_size_disp -0x8 +#define return_address_livemask_disp -0x10 +#define return_address_mv_return_address_disp -0x4 +#define return_address_toplink_disp -0xC +#define rp_header_frame_size_disp 0x8 +#define rp_header_livemask_disp 0x0 +#define rp_header_mv_return_address_disp 0xC +#define rp_header_toplink_disp 0x4 +#define rtd_counts_data_disp 0xD +#define rtd_counts_timestamp_disp 0x5 +#define rtd_counts_type_disp 0x1 +#define rtd_generative 0x1 +#define rtd_opaque 0x2 +#define rtd_sealed 0x4 +#define sbwp (ptr)0x4E +#define scaled_shot_1_shot_flag -0x4 +#define scheme_version 0x90509 +#define segment_card_offset_bits 0x5 +#define segment_offset_bits 0xD +#define segment_t1_bits 0x13 +#define segment_table_levels 0x1 +#define seof (ptr)0x36 +#define sfalse (ptr)0x6 +#define short_bits 0x10 +#define signal_interrupt_index 0x4 +#define size_box 0x8 +#define size_cached_stack 0x8 +#define size_continuation 0x20 +#define size_ephemeron 0x10 +#define size_exactnum 0x10 +#define size_flonum 0x8 +#define size_forward 0x8 +#define size_guardian_entry 0x10 +#define size_inexactnum 0x18 +#define size_pair 0x8 +#define size_port 0x28 +#define size_ratnum 0x10 +#define size_record_type 0x28 +#define size_rp_header 0x10 +#define size_rtd_counts 0x410 +#define size_symbol 0x18 +#define size_tc 0x158 +#define size_thread 0x8 +#define size_tlc 0x10 +#define size_typed_object 0x8 +#define size_t_bits 0x20 +#define snil (ptr)0x26 +#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e) +#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty") +#define space_code 0x8 +#define space_continuation 0x7 +#define space_data 0xB +#define space_empty 0xC +#define space_ephemeron 0x5 +#define space_impure 0x1 +#define space_impure_record 0xA +#define space_locked 0x20 +#define space_new 0x0 +#define space_old 0x40 +#define space_port 0x3 +#define space_pure 0x6 +#define space_pure_typed_object 0x9 +#define space_symbol 0x2 +#define space_weakpair 0x4 +#define stack_frame_limit 0x100 +#define stack_slop 0x200 +#define static_generation 0xFF +#define string_char_bits 0x20 +#define string_char_bytes 0x4 +#define string_char_offset 0x2 +#define string_data_disp 0x5 +#define string_immutable_flag 0x8 +#define string_length_factor 0x10 +#define string_length_offset 0x4 +#define string_type_disp 0x1 +#define strue (ptr)0xE +#define sunbound (ptr)0x1E +#define svoid (ptr)0x3E +#define symbol_hash_disp 0x19 +#define symbol_name_disp 0x11 +#define symbol_plist_disp 0xD +#define symbol_pvalue_disp 0x9 +#define symbol_splist_disp 0x15 +#define symbol_value_disp 0x5 +#define tc_DSTBV_disp 0x150 +#define tc_SRCBV_disp 0x154 +#define tc_U_disp 0xA4 +#define tc_V_disp 0xA8 +#define tc_W_disp 0xAC +#define tc_X_disp 0xB0 +#define tc_Y_disp 0xB4 +#define tc_ac0_disp 0x4 +#define tc_ac1_disp 0x8 +#define tc_active_disp 0x8C +#define tc_alloc_counter_disp 0x144 +#define tc_ap_disp 0x18 +#define tc_arg_regs_disp 0x0 +#define tc_block_counter_disp 0xE0 +#define tc_cchain_disp 0x80 +#define tc_code_ranges_to_flush_disp 0x84 +#define tc_compile_profile_disp 0x10C +#define tc_compress_format_disp 0x130 +#define tc_compress_level_disp 0x134 +#define tc_cp_disp 0x10 +#define tc_current_error_disp 0xDC +#define tc_current_input_disp 0xD4 +#define tc_current_mso_disp 0xE8 +#define tc_current_output_disp 0xD8 +#define tc_default_record_equal_procedure_disp 0x128 +#define tc_default_record_hash_procedure_disp 0x12C +#define tc_disable_count_disp 0xC0 +#define tc_eap_disp 0x1C +#define tc_esp_disp 0x14 +#define tc_fxfirst_bit_set_bv_disp 0xF4 +#define tc_fxlength_bv_disp 0xF0 +#define tc_generate_inspector_information_disp 0x110 +#define tc_generate_procedure_source_information_disp 0x114 +#define tc_generate_profile_forms_disp 0x118 +#define tc_guardian_entries_disp 0x7C +#define tc_instr_counter_disp 0x13C +#define tc_keyboard_interrupt_pending_disp 0xCC +#define tc_lz4_out_buffer_disp 0x138 +#define tc_meta_level_disp 0x108 +#define tc_null_immutable_bytevector_disp 0x100 +#define tc_null_immutable_fxvector_disp 0xFC +#define tc_null_immutable_string_disp 0x104 +#define tc_null_immutable_vector_disp 0xF8 +#define tc_optimize_level_disp 0x11C +#define tc_parameters_disp 0x14C +#define tc_random_seed_disp 0x88 +#define tc_real_eap_disp 0x38 +#define tc_ret_disp 0x20 +#define tc_scheme_stack_disp 0x90 +#define tc_scheme_stack_size_disp 0x9C +#define tc_sfd_disp 0xE4 +#define tc_sfp_disp 0xC +#define tc_signal_interrupt_pending_disp 0xC4 +#define tc_signal_interrupt_queue_disp 0xC8 +#define tc_something_pending_disp 0xB8 +#define tc_stack_cache_disp 0x94 +#define tc_stack_link_disp 0x98 +#define tc_subset_mode_disp 0x120 +#define tc_suppress_primitive_inlining_disp 0x124 +#define tc_target_machine_disp 0xEC +#define tc_td_disp 0x34 +#define tc_threadno_disp 0xD0 +#define tc_timer_ticks_disp 0xBC +#define tc_trap_disp 0x24 +#define tc_ts_disp 0x30 +#define tc_virtual_registers_disp 0x3C +#define tc_winders_disp 0xA0 +#define tc_xp_disp 0x28 +#define tc_yp_disp 0x2C +#define thread_tc_disp 0x5 +#define thread_type_disp 0x1 +#define time_collector_cpu 0x5 +#define time_collector_real 0x6 +#define time_duration 0x2 +#define time_monotonic 0x3 +#define time_process 0x0 +#define time_t_bits 0x20 +#define time_thread 0x1 +#define time_utc 0x4 +#define timer_interrupt_index 0x2 +#define tlc_ht_disp 0x9 +#define tlc_keyval_disp 0x5 +#define tlc_next_disp 0xD +#define tlc_type_disp 0x1 +#define type_bignum 0x6 +#define type_binary_input_port 0x51E +#define type_binary_output_port 0x61E +#define type_binary_port 0x41E +#define type_boolean 0x6 +#define type_box 0xE +#define type_bytevector 0x1 +#define type_char 0x16 +#define type_closure 0x5 +#define type_code 0x3E +#define type_continuation_code 0x23E +#define type_exactnum 0x56 +#define type_fixnum 0x0 +#define type_flonum 0x2 +#define type_fxvector 0x3 +#define type_guardian_code 0x83E +#define type_immediate 0x6 +#define type_immutable_box 0x8E +#define type_immutable_bytevector 0x5 +#define type_immutable_fxvector 0xB +#define type_immutable_string 0xA +#define type_immutable_vector 0x4 +#define type_inexactnum 0x36 +#define type_input_port 0x11E +#define type_io_port 0x31E +#define type_mutable_box 0xE +#define type_mutable_bytevector 0x1 +#define type_mutable_fxvector 0x3 +#define type_mutable_string 0x2 +#define type_mutable_vector 0x0 +#define type_negative_bignum 0x26 +#define type_octet 0x0 +#define type_other_number 0x6 +#define type_output_port 0x21E +#define type_pair 0x1 +#define type_port 0x1E +#define type_positive_bignum 0x6 +#define type_ratnum 0x16 +#define type_record 0x7 +#define type_rtd_counts 0x6E +#define type_string 0x2 +#define type_symbol 0x3 +#define type_system_code 0x13E +#define type_textual_input_port 0x11E +#define type_textual_output_port 0x21E +#define type_textual_port 0x1E +#define type_thread 0x4E +#define type_tlc 0x5E +#define type_typed_object 0x7 +#define type_vector 0x0 +#define typed_object_type_disp 0x1 +#define typedef_i16 "short" +#define typedef_i32 "int" +#define typedef_i64 "long long" +#define typedef_i8 "char" +#define typedef_iptr "int" +#define typedef_ptr "void *" +#define typedef_string_char "unsigned int" +#define typedef_u16 "unsigned short" +#define typedef_u32 "unsigned int" +#define typedef_u64 "unsigned long long" +#define typedef_u8 "unsigned char" +#define typedef_uptr "unsigned int" +#define typemod 0x8 +#define unactivate_mode_deactivate 0x1 +#define unactivate_mode_destroy 0x2 +#define unactivate_mode_noop 0x0 +#define unaligned_floats 1 +#define unaligned_integers 1 +#define underflow_limit 0x40 +#define unscaled_shot_1_shot_flag -0x1 +#define vector_data_disp 0x5 +#define vector_immutable_flag 0x4 +#define vector_length_factor 0x8 +#define vector_length_offset 0x3 +#define vector_type_disp 0x1 +#define virtual_register_count 0x10 +#define wchar_bits 0x20 + +/* constants from declare-c-entries */ +#define CENTRY_Scall_any_results 24 +#define CENTRY_Scall_one_result 23 +#define CENTRY_Sreturn 22 +#define CENTRY_activate_thread 11 +#define CENTRY_deactivate_thread 12 +#define CENTRY_foreign_entry 17 +#define CENTRY_get_more_room 19 +#define CENTRY_get_thread_context 1 +#define CENTRY_handle_apply_overflood 2 +#define CENTRY_handle_arg_error 16 +#define CENTRY_handle_docall_error 3 +#define CENTRY_handle_mvlet_error 15 +#define CENTRY_handle_nonprocedure_symbol 6 +#define CENTRY_handle_overflood 5 +#define CENTRY_handle_overflow 4 +#define CENTRY_handle_values_error 14 +#define CENTRY_install_library_entry 18 +#define CENTRY_instantiate_code_object 21 +#define CENTRY_raw_collect_cond 9 +#define CENTRY_raw_tc_mutex 10 +#define CENTRY_scan_remembered_set 20 +#define CENTRY_split_and_resize 8 +#define CENTRY_thread_context 0 +#define CENTRY_thread_list 7 +#define CENTRY_unactivate_thread 13 + +/* displacements for records */ +#define eq_hashtable_rtd_disp 1 +#define eq_hashtable_type_disp 5 +#define eq_hashtable_mutablep_disp 9 +#define eq_hashtable_vec_disp 13 +#define eq_hashtable_minlen_disp 17 +#define eq_hashtable_size_disp 21 +#define eq_hashtable_subtype_disp 25 +#define symbol_hashtable_rtd_disp 1 +#define symbol_hashtable_type_disp 5 +#define symbol_hashtable_mutablep_disp 9 +#define symbol_hashtable_vec_disp 13 +#define symbol_hashtable_minlen_disp 17 +#define symbol_hashtable_size_disp 21 +#define symbol_hashtable_equivp_disp 25 +#define code_info_rtd_disp 1 +#define code_info_src_disp 5 +#define code_info_sexpr_disp 9 +#define code_info_free_disp 13 +#define code_info_live_disp 17 +#define code_info_rpis_disp 21 + +/* predicates */ +#define Simmediatep(x) (((uptr)(x)&0x7)==0x6) +#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E)) +#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E)) + +/* structure accessors */ +#define INITCAR(x) (*((ptr *)((uptr)(x)+7))) +#define INITCDR(x) (*((ptr *)((uptr)(x)+11))) +#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y)) +#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+11)),(y)) +#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITBOXREF(x) (*((ptr *)((uptr)(x)+5))) +#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+15))) +#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+19))) +#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define TLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define TLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITTLCHT(x) (*((ptr *)((uptr)(x)+9))) +#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+13))) +#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define SYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define SYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define SYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define SYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5))) +#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+9))) +#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+13))) +#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+17))) +#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+21))) +#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+25))) +#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y)) +#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y)) +#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y)) +#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+17)),(y)) +#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y)) +#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y)) +#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+5))+i),(y)) +#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i]) +#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+9))) +#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+17))) +#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1))) +#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+5))) +#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+9))) +#define RATTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RATNUM(x) (*((ptr *)((uptr)(x)+5))) +#define RATDEN(x) (*((ptr *)((uptr)(x)+9))) +#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3))) +#define CLOSIT(x,i) (((ptr *)((uptr)(x)+7))[i]) +#define FLODAT(x) (*((double *)((uptr)(x)+6))) +#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define PORTNAME(x) (*((ptr *)((uptr)(x)+37))) +#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+5))) +#define PORTINFO(x) (*((ptr *)((uptr)(x)+33))) +#define PORTOCNT(x) (*((iptr *)((uptr)(x)+9))) +#define PORTOLAST(x) (*((ptr *)((uptr)(x)+17))) +#define PORTOBUF(x) (*((ptr *)((uptr)(x)+21))) +#define PORTICNT(x) (*((iptr *)((uptr)(x)+13))) +#define PORTILAST(x) (*((ptr *)((uptr)(x)+25))) +#define PORTIBUF(x) (*((ptr *)((uptr)(x)+29))) +#define STRTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define STRIT(x,i) (((string_char *)((uptr)(x)+5))[i]) +#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define BIGIT(x,i) (((bigit *)((uptr)(x)+5))[i]) +#define CODETYPE(x) (*((iptr *)((uptr)(x)+1))) +#define CODELEN(x) (*((iptr *)((uptr)(x)+5))) +#define CODERELOC(x) (*((ptr *)((uptr)(x)+9))) +#define CODENAME(x) (*((ptr *)((uptr)(x)+13))) +#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+17))) +#define CODEFREE(x) (*((iptr *)((uptr)(x)+21))) +#define CODEINFO(x) (*((ptr *)((uptr)(x)+25))) +#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+29))) +#define CODEIT(x,i) (((octet *)((uptr)(x)+33))[i]) +#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define RELOCCODE(x) (*((ptr *)((uptr)(x)+4))) +#define RELOCIT(x,i) (((uptr *)((uptr)(x)+8))[i]) +#define CONTSTACK(x) (*((ptr *)((uptr)(x)+7))) +#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+11))) +#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+15))) +#define CONTLINK(x) (*((ptr *)((uptr)(x)+19))) +#define CONTRET(x) (*((ptr *)((uptr)(x)+23))) +#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+27))) +#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1))) +#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+5))) +#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+13))[i]) +#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+5))) +#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+9))) +#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+13))) +#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+17))) +#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+21))) +#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+25))) +#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+29))) +#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+33))) +#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+37))) +#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1))) +#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp)) +#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp)) +#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x)) +#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp)) +#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x)) +#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x)) +#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset)) +#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset) +#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum +#define CLOSLEN(p) CODEFREE(CLOSCODE(p)) +#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0))) +#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+4))) +#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+8))) +#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+12))) +#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0))) +#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+4))) +#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0))) +#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+4))) +#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+8))) +#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0))) +#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+4))) + +/* machine types */ +#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"} + +/* allocation-space names */ +#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty" + +/* allocation-space characters */ +#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e' + +/* threads */ +#define THREADTC(x) (*((uptr *)((uptr)(x)+5))) + +/* thread-context data */ +#define DSTBV(x) (*((ptr *)((uptr)(x)+336))) +#define SRCBV(x) (*((ptr *)((uptr)(x)+340))) +#define U(x) (*((ptr *)((uptr)(x)+164))) +#define V(x) (*((ptr *)((uptr)(x)+168))) +#define W(x) (*((ptr *)((uptr)(x)+172))) +#define X(x) (*((ptr *)((uptr)(x)+176))) +#define Y(x) (*((ptr *)((uptr)(x)+180))) +#define AC0(x) (*((void* *)((uptr)(x)+4))) +#define AC1(x) (*((void* *)((uptr)(x)+8))) +#define ACTIVE(x) (*((I32 *)((uptr)(x)+140))) +#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+324))) +#define AP(x) (*((void* *)((uptr)(x)+24))) +#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i]) +#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+224))) +#define CCHAIN(x) (*((ptr *)((uptr)(x)+128))) +#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+132))) +#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+268))) +#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+304))) +#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+308))) +#define CP(x) (*((void* *)((uptr)(x)+16))) +#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+220))) +#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+212))) +#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+232))) +#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+216))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+296))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+300))) +#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+192))) +#define EAP(x) (*((void* *)((uptr)(x)+28))) +#define ESP(x) (*((void* *)((uptr)(x)+20))) +#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+244))) +#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+240))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+272))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+276))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+280))) +#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+124))) +#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+316))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+204))) +#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+312))) +#define METALEVEL(x) (*((ptr *)((uptr)(x)+264))) +#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+256))) +#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+252))) +#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+260))) +#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+248))) +#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+284))) +#define PARAMETERS(x) (*((ptr *)((uptr)(x)+332))) +#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+136))) +#define REAL_EAP(x) (*((void* *)((uptr)(x)+56))) +#define RET(x) (*((void* *)((uptr)(x)+32))) +#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+144))) +#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+156))) +#define SFD(x) (*((ptr *)((uptr)(x)+228))) +#define SFP(x) (*((void* *)((uptr)(x)+12))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+196))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+200))) +#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+184))) +#define STACKCACHE(x) (*((ptr *)((uptr)(x)+148))) +#define STACKLINK(x) (*((ptr *)((uptr)(x)+152))) +#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+288))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+292))) +#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+236))) +#define TD(x) (*((void* *)((uptr)(x)+52))) +#define THREADNO(x) (*((ptr *)((uptr)(x)+208))) +#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+188))) +#define TRAP(x) (*((void* *)((uptr)(x)+36))) +#define TS(x) (*((void* *)((uptr)(x)+48))) +#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+60))[i]) +#define WINDERS(x) (*((ptr *)((uptr)(x)+160))) +#define XP(x) (*((void* *)((uptr)(x)+40))) +#define YP(x) (*((void* *)((uptr)(x)+44))) +#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i]) +#define VIRTREG(x,i) (((ptr *)((uptr)(x)+60))[i]) + +/* library entries we access from C code */ +#define library_nonprocedure_code 152 +#define library_dounderflow 154 diff --git a/boot/ti3osx/petite.boot b/boot/ti3osx/petite.boot new file mode 100644 index 0000000..ae22fa8 Binary files /dev/null and b/boot/ti3osx/petite.boot differ diff --git a/boot/ti3osx/scheme.boot b/boot/ti3osx/scheme.boot new file mode 100644 index 0000000..c0695c0 Binary files /dev/null and b/boot/ti3osx/scheme.boot differ diff --git a/boot/ti3osx/scheme.h b/boot/ti3osx/scheme.h new file mode 100644 index 0000000..8d9d820 --- /dev/null +++ b/boot/ti3osx/scheme.h @@ -0,0 +1,245 @@ +/* scheme.h for Chez Scheme Version 9.5.9 (ti3osx) */ + +/* Do not edit this file. It is automatically generated and */ +/* specifically tailored to the version of Chez Scheme named */ +/* above. Always be certain that you have the correct scheme.h */ +/* for the version of Chez Scheme you are using. */ + +/* Warning: Some macros may evaluate arguments more than once. */ + +/* Specify declaration of exports. */ +#ifdef _WIN32 +# if __cplusplus +# ifdef SCHEME_IMPORT +# define EXPORT extern "C" __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern "C" +# else +# define EXPORT extern "C" __declspec (dllexport) +# endif +# else +# ifdef SCHEME_IMPORT +# define EXPORT extern __declspec (dllimport) +# elif SCHEME_STATIC +# define EXPORT extern +# else +# define EXPORT extern __declspec (dllexport) +# endif +# endif +#else +# if __cplusplus +# define EXPORT extern "C" +# else +# define EXPORT extern +# endif +#endif + +/* Chez Scheme Version and machine type */ +#define VERSION "9.5.9" +#define MACHINE_TYPE "ti3osx" + +/* All Scheme objects are of type ptr. Type iptr and */ +/* uptr are signed and unsigned ints of the same size */ +/* as a ptr */ +typedef void * ptr; +typedef int iptr; +typedef unsigned int uptr; + +/* String elements are 32-bit tagged char objects */ +typedef unsigned int string_char; + +/* Bytevector elements are 8-bit unsigned "octets" */ +typedef unsigned char octet; + +/* Type predicates */ +#define Sfixnump(x) (((uptr)(x)&0x3)==0x0) +#define Scharp(x) (((uptr)(x)&0xFF)==0x16) +#define Snullp(x) ((uptr)(x)==0x26) +#define Seof_objectp(x) ((uptr)(x)==0x36) +#define Sbwp_objectp(x) ((uptr)(x)==0x4E) +#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6) +#define Spairp(x) (((uptr)(x)&0x7)==0x1) +#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3) +#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5) +#define Sflonump(x) (((uptr)(x)&0x7)==0x2) +#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x0)) +#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3)) +#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1)) +#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2)) +#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6)) +#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE)) +#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36)) +#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56)) +#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\ + ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16)) +#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E)) +#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E)) +#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7)) + +/* Accessors */ +#define Sfixnum_value(x) ((iptr)(x)/4) +#define Schar_value(x) ((string_char)((uptr)(x)>>8)) +#define Sboolean_value(x) ((x) != Sfalse) +#define Scar(x) (*((ptr *)((uptr)(x)+7))) +#define Scdr(x) (*((ptr *)((uptr)(x)+11))) +#define Sflonum_value(x) (*((double *)((uptr)(x)+6))) +#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Svector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+5))[i]) +#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3)) +#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i]) +/* Warning: Sbytevector_data(x) returns a pointer into x. */ +#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0) +#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4)) +#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+5))[i]) +#define Sunbox(x) (*((ptr *)((uptr)(x)+5))) +EXPORT iptr Sinteger_value(ptr); +#define Sunsigned_value(x) (uptr)Sinteger_value(x) +EXPORT int Sinteger32_value(ptr); +#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) +EXPORT long long Sinteger64_value(ptr); +#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) + +/* Mutators */ +EXPORT void Sset_box(ptr, ptr); +EXPORT void Sset_car(ptr, ptr); +EXPORT void Sset_cdr(ptr, ptr); +#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+5))[i]) = (string_char)(uptr)Schar(c))) +#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) +EXPORT void Svector_set(ptr, iptr, ptr); + +/* Constructors */ +#define Sfixnum(x) ((ptr)(uptr)((x)*4)) +#define Schar(x) ((ptr)(uptr)((x)<<8|0x16)) +#define Snil ((ptr)0x26) +#define Strue ((ptr)0xE) +#define Sfalse ((ptr)0x6) +#define Sboolean(x) ((x)?Strue:Sfalse) +#define Sbwp_object ((ptr)0x4E) +#define Seof_object ((ptr)0x36) +#define Svoid ((ptr)0x3E) +EXPORT ptr Scons(ptr, ptr); +EXPORT ptr Sstring_to_symbol(const char *); +EXPORT ptr Ssymbol_to_string(ptr); +EXPORT ptr Sflonum(double); +EXPORT ptr Smake_vector(iptr, ptr); +EXPORT ptr Smake_fxvector(iptr, ptr); +EXPORT ptr Smake_bytevector(iptr, int); +EXPORT ptr Smake_string(iptr, int); +EXPORT ptr Smake_uninitialized_string(iptr); +EXPORT ptr Sstring(const char *); +EXPORT ptr Sstring_of_length(const char *, iptr); +EXPORT ptr Sstring_utf8(const char*, iptr); +EXPORT ptr Sbox(ptr); +EXPORT ptr Sinteger(iptr); +EXPORT ptr Sunsigned(uptr); +EXPORT ptr Sinteger32(int); +EXPORT ptr Sunsigned32(unsigned int); +EXPORT ptr Sinteger64(long long); +EXPORT ptr Sunsigned64(unsigned long long); + +/* Miscellaneous */ +EXPORT ptr Stop_level_value(ptr); +EXPORT void Sset_top_level_value(ptr, ptr); +EXPORT void Slock_object(ptr); +EXPORT void Sunlock_object(ptr); +EXPORT int Slocked_objectp(ptr); +EXPORT void Sforeign_symbol(const char *, void *); +EXPORT void Sregister_symbol(const char *, void *); + +/* Support for calls into Scheme */ +EXPORT ptr Scall0(ptr); +EXPORT ptr Scall1(ptr, ptr); +EXPORT ptr Scall2(ptr, ptr, ptr); +EXPORT ptr Scall3(ptr, ptr, ptr, ptr); +EXPORT void Sinitframe(iptr); +EXPORT void Sput_arg(iptr, ptr); +EXPORT ptr Scall(ptr, iptr); +/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */ +#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+33)) +#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-33)) + +/* Customization support. */ +EXPORT const char * Skernel_version(void); +EXPORT void Sretain_static_relocation(void); +EXPORT void Sset_verbose(int); +EXPORT void Sscheme_init(void (*)(void)); +EXPORT void Sregister_boot_file(const char *); +EXPORT void Sregister_boot_file_fd(const char *, int fd); +EXPORT void Sregister_heap_file(const char *); +EXPORT void Scompact_heap(void); +EXPORT void Ssave_heap(const char *, int); +EXPORT void Sbuild_heap(const char *, void (*)(void)); +EXPORT void Senable_expeditor(const char *); +EXPORT int Sscheme_start(int, const char *[]); +EXPORT int Sscheme_script(const char *, int, const char *[]); +EXPORT int Sscheme_program(const char *, int, const char *[]); +EXPORT void Sscheme_deinit(void); + +/* Thread support. */ +EXPORT int Sactivate_thread(void); +EXPORT void Sdeactivate_thread(void); +EXPORT int Sdestroy_thread(void); + +/* Features. */ +#define FEATURE_ICONV +#define FEATURE_EXPEDITOR +#define FEATURE_PTHREADS + +/* Locking macros. */ +#define INITLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define SPINLOCK(addr) \ + __asm__ __volatile__ ("0:\n\t"\ + "movl $1, %%eax\n\t"\ + "xchgl (%0), %%eax\n\t"\ + "cmpl $0, %%eax\n\t"\ + "je 2f\n\t"\ + "1:\n\t"\ + "pause\n\t"\ + "cmpl $0, (%0)\n\t"\ + "je 0b\n\t"\ + "jmp 1b\n\t"\ + "2:"\ + : \ + : "r" (addr) \ + : "eax", "flags", "memory") + +#define UNLOCK(addr) \ + __asm__ __volatile__ ("movl $0, (%0)"\ + : \ + : "r" (addr) \ + : "memory") + +#define LOCKED_INCR(addr, ret) \ + __asm__ __volatile__ ("lock; incl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") + +#define LOCKED_DECR(addr, ret) \ + __asm__ __volatile__ ("lock; decl (%1)\n\t"\ + "sete %b0\n\t"\ + "movzx %b0, %0\n\t"\ + : "=q" (ret) \ + : "r" (addr) \ + : "flags", "memory") diff --git a/c/Makefile.a6nt b/c/Makefile.a6nt new file mode 100644 index 0000000..ab8bf8f --- /dev/null +++ b/c/Makefile.a6nt @@ -0,0 +1,154 @@ +# Makefile.a6nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6nt + +# following have to use \ for directory separator +SchemeInclude = ..\boot\$m +KernelDll = ..\bin\$m\csv959.dll +KernelLib = ..\bin\$m\csv959.lib +MTKernelLib = ..\boot\$m\csv959mt.lib +MDKernelLib = ..\boot\$m\csv959md.lib +KernelExp = ..\bin\$m\csv959.exp +Exec = ..\bin\$m\scheme.exe +MTMain = ..\boot\$m\mainmt.obj +MDMain = ..\boot\$m\mainmd.obj +ResFile = ..\boot\$m\scheme.res + +# We use MD so that we can link with and load DLLs built against msvcrxxx.dll +CFLAGS=/nologo /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +MDCFLAGS=$(CFLAGS) /MD +MTCFLAGS=$(CFLAGS) /MT +DLLLDFLAGS=/debug:full /machine:X64 /nologo +# stack limit is 1MB by default. this is not enough for one of the mats in foreign.ms, which +# builds up nested C & Scheme stack frames. 2MB seems to be enough, but we set to 16MB. +EXELDFLAGS=/debug:full /machine:X64 /incremental:no /nologo /STACK:0x1000000 + +# use following flags for debugging +# CFLAGS=/nologo /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd + +SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib +MDZlibLib=..\zlib\zlib.lib +MTZlibLib=..\zlib\zlibmt.lib +MDLZ4Lib=..\lz4\lib\liblz4.lib +MTLZ4Lib=..\lz4\lib\liblz4mt.lib + +csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\ + number.c schsig.c io.c new-io.c print.c fasl.c stats.c\ + foreign.c prim.c prim5.c flushcache.c\ + windows.c\ + schlib.c thread.c expeditor.c scheme.c compress-io.c + +cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\ + number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\ + foreign.obj prim.obj prim5.obj flushcache.obj\ + windows.obj\ + schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj + +hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c + +.SUFFIXES: + +all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain) + +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc) +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h + +$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj + -del /f $(MTKernelLib) + cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc) + link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj + +$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj + -del /f $(MDKernelLib) + cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc) + link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj + +# nmake builds Dll twice if we list it with $(KernelLib) below +$(KernelDll): $(KernelLib) + +# base chosen to be consistent with "microsoft conventions" +# http://www.windevnet.com/documents/s=7482/win1078945937961/ +# but set at a basically odd address to reduce likelihood of +# conflicts with other dlls. use 'depends ' to check. +# we no longer attempt to rebase other the CRT dll since it +# has already been signed. +$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj + -del /f $(KernelLib) + -del /f $(KernelDll) + cl /c $(MDCFLAGS) $(csrc) + link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib) a6nt-jump.obj + editbin /nologo /rebase:base=0x67480000 $(KernelDll) + +$(MTMain): main.c + -del /f $(MTMain) + cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c + copy main.obj $(MTMain) + +$(MDMain): main.c + -del /f $(MDMain) + cl /c $(MDCFLAGS) main.c + copy main.obj $(MDMain) + +$(Exec): $(ResFile) $(MDMain) $(KernelLib) + -del /f $(Exec) + link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib) + mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1 + +$(ResFile): scheme.rc + -del /f $(ResFile) + rc -r /fo $(ResFile) -DWIN32 scheme.rc + +# for testing mt kernel and mainmt.obj: +mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib) + -del /f mtscheme.exe + link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib) + +# for testing md kernel and mainmd.obj: +mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib) + -del /f mdscheme.exe + link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib) + +..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib): + cd ../zlib + nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)" + ren zlib.lib zlibmt.lib + nmake /nologo -f win32/Makefile.msc clean + nmake /nologo -f win32/Makefile.msc AR="link /lib" + cd ../c + +$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj + cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj + +a6nt-jump.obj: a6nt-jump.asm + ml64 /nologo /W3 /Zi /c a6nt-jump.asm + +clean: + -del /f $(cobj) main.obj $(KernelExp) a6nt-jump.obj + -del /f mtscheme.exe + -del /f mdscheme.exe diff --git a/c/Makefile.i3nt b/c/Makefile.i3nt new file mode 100644 index 0000000..92bbbe5 --- /dev/null +++ b/c/Makefile.i3nt @@ -0,0 +1,150 @@ +# Makefile.i3nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3nt + +# following have to use \ for directory separator +SchemeInclude = ..\boot\$m +KernelDll = ..\bin\$m\csv959.dll +KernelLib = ..\bin\$m\csv959.lib +MTKernelLib = ..\boot\$m\csv959mt.lib +MDKernelLib = ..\boot\$m\csv959md.lib +KernelExp = ..\bin\$m\csv959.exp +Exec = ..\bin\$m\scheme.exe +MTMain = ..\boot\$m\mainmt.obj +MDMain = ..\boot\$m\mainmd.obj +ResFile = ..\boot\$m\scheme.res + +# We use MD so that we can link with and load DLLs built against msvcrxxx.dll +CFLAGS=/nologo /fp:precise /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +MDCFLAGS=$(CFLAGS) /MD +MTCFLAGS=$(CFLAGS) /MT +DLLLDFLAGS=/debug:full /machine:ix86 /nologo +# see note in Makefile.a6nt regarding stack size. we use 8MB here to be consistent. +EXELDFLAGS=/debug:full /machine:ix86 /incremental:no /nologo /STACK:0x800000 + +# use following flags for debugging +# CFLAGS=/nologo /fp:precise /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd + +SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib +MDZlibLib=..\zlib\zlib.lib +MTZlibLib=..\zlib\zlibmt.lib +MDLZ4Lib=..\lz4\lib\liblz4.lib +MTLZ4Lib=..\lz4\lib\liblz4mt.lib + +csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\ + number.c schsig.c io.c new-io.c print.c fasl.c stats.c\ + foreign.c prim.c prim5.c flushcache.c\ + windows.c\ + schlib.c thread.c expeditor.c scheme.c compress-io.c + +cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\ + number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\ + foreign.obj prim.obj prim5.obj flushcache.obj\ + windows.obj\ + schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj + +hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c + +.SUFFIXES: + +all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain) + +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc) +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h + +$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib) + -del /f $(MTKernelLib) + cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc) + link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib) + +$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib) + -del /f $(MDKernelLib) + cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc) + link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib) + +# nmake builds Dll twice if we list it with $(KernelLib) below +$(KernelDll): $(KernelLib) + +# base chosen to be consistent with "microsoft conventions" +# http://www.windevnet.com/documents/s=7482/win1078945937961/ +# but set at a basically odd address to reduce likelihood of +# conflicts with other dlls. use 'depends ' to check. +# we no longer attempt to rebase other the CRT dll since it +# has already been signed. +$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib) + -del /f $(KernelLib) + -del /f $(KernelDll) + cl /c $(MDCFLAGS) $(csrc) + link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib) + editbin /nologo /rebase:base=0x67480000 $(KernelDll) + +$(MTMain): main.c + -del /f $(MTMain) + cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c + copy main.obj $(MTMain) + +$(MDMain): main.c + -del /f $(MDMain) + cl /c $(MDCFLAGS) main.c + copy main.obj $(MDMain) + +$(Exec): $(ResFile) $(MDMain) $(KernelLib) + -del /f $(Exec) + link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib) + mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1 + +$(ResFile): scheme.rc + -del /f $(ResFile) + rc -r /fo $(ResFile) -DWIN32 scheme.rc + +# for testing mt kernel and mainmt.obj: +mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib) + -del /f mtscheme.exe + link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib) + +# for testing md kernel and mainmd.obj: +mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib) + -del /f mdscheme.exe + link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib) + +..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib): + cd ../zlib + nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)" + ren zlib.lib zlibmt.lib + nmake /nologo -f win32/Makefile.msc clean + nmake /nologo -f win32/Makefile.msc AR="link /lib" + cd ../c + +$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj + cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj + +clean: + -del /f $(cobj) main.obj $(KernelExp) + -del /f mtscheme.exe + -del /f mdscheme.exe diff --git a/c/Makefile.ta6nt b/c/Makefile.ta6nt new file mode 100644 index 0000000..dce7905 --- /dev/null +++ b/c/Makefile.ta6nt @@ -0,0 +1,154 @@ +# Makefile.ta6nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6nt + +# following have to use \ for directory separator +SchemeInclude = ..\boot\$m +KernelDll = ..\bin\$m\csv959.dll +KernelLib = ..\bin\$m\csv959.lib +MTKernelLib = ..\boot\$m\csv959mt.lib +MDKernelLib = ..\boot\$m\csv959md.lib +KernelExp = ..\bin\$m\csv959.exp +Exec = ..\bin\$m\scheme.exe +MTMain = ..\boot\$m\mainmt.obj +MDMain = ..\boot\$m\mainmd.obj +ResFile = ..\boot\$m\scheme.res + +# We use MD so that we can link with and load DLLs built against msvcrxxx.dll +CFLAGS=/nologo /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +MDCFLAGS=$(CFLAGS) /MD +MTCFLAGS=$(CFLAGS) /MT +DLLLDFLAGS=/debug:full /machine:X64 /nologo +# stack limit is 1MB by default. this is not enough for one of the mats in foreign.ms, which +# builds up nested C & Scheme stack frames. 2MB seems to be enough, but we set to 16MB. +EXELDFLAGS=/debug:full /machine:X64 /incremental:no /nologo /STACK:0x1000000 + +# use following flags for debugging +# CFLAGS=/nologo /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd + +SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib +MDZlibLib=..\zlib\zlib.lib +MTZlibLib=..\zlib\zlibmt.lib +MDLZ4Lib=..\lz4\lib\liblz4.lib +MTLZ4Lib=..\lz4\lib\liblz4mt.lib + +csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\ + number.c schsig.c io.c new-io.c print.c fasl.c stats.c\ + foreign.c prim.c prim5.c flushcache.c\ + windows.c\ + schlib.c thread.c expeditor.c scheme.c compress-io.c + +cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\ + number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\ + foreign.obj prim.obj prim5.obj flushcache.obj\ + windows.obj\ + schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj + +hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c + +.SUFFIXES: + +all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain) + +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc) +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h + +$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj + -del /f $(MTKernelLib) + cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc) + link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj + +$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj + -del /f $(MDKernelLib) + cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc) + link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj + +# nmake builds Dll twice if we list it with $(KernelLib) below +$(KernelDll): $(KernelLib) + +# base chosen to be consistent with "microsoft conventions" +# http://www.windevnet.com/documents/s=7482/win1078945937961/ +# but set at a basically odd address to reduce likelihood of +# conflicts with other dlls. use 'depends ' to check. +# we no longer attempt to rebase other the CRT dll since it +# has already been signed. +$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj + -del /f $(KernelLib) + -del /f $(KernelDll) + cl /c $(MDCFLAGS) $(csrc) + link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib) a6nt-jump.obj + editbin /nologo /rebase:base=0x67480000 $(KernelDll) + +$(MTMain): main.c + -del /f $(MTMain) + cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c + copy main.obj $(MTMain) + +$(MDMain): main.c + -del /f $(MDMain) + cl /c $(MDCFLAGS) main.c + copy main.obj $(MDMain) + +$(Exec): $(ResFile) $(MDMain) $(KernelLib) + -del /f $(Exec) + link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib) + mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1 + +$(ResFile): scheme.rc + -del /f $(ResFile) + rc -r /fo $(ResFile) -DWIN32 scheme.rc + +# for testing mt kernel and mainmt.obj: +mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib) + -del /f mtscheme.exe + link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib) + +# for testing md kernel and mainmd.obj: +mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib) + -del /f mdscheme.exe + link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib) + +..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib): + cd ../zlib + nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)" + ren zlib.lib zlibmt.lib + nmake /nologo -f win32/Makefile.msc clean + nmake /nologo -f win32/Makefile.msc AR="link /lib" + cd ../c + +$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj + cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj + +a6nt-jump.obj: a6nt-jump.asm + ml64 /nologo /W3 /Zi /c a6nt-jump.asm + +clean: + -del /f $(cobj) main.obj $(KernelExp) a6nt-jump.obj + -del /f mtscheme.exe + -del /f mdscheme.exe diff --git a/c/Makefile.ti3nt b/c/Makefile.ti3nt new file mode 100644 index 0000000..32a53d7 --- /dev/null +++ b/c/Makefile.ti3nt @@ -0,0 +1,150 @@ +# Makefile.ti3nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3nt + +# following have to use \ for directory separator +SchemeInclude = ..\boot\$m +KernelDll = ..\bin\$m\csv959.dll +KernelLib = ..\bin\$m\csv959.lib +MTKernelLib = ..\boot\$m\csv959mt.lib +MDKernelLib = ..\boot\$m\csv959md.lib +KernelExp = ..\bin\$m\csv959.exp +Exec = ..\bin\$m\scheme.exe +MTMain = ..\boot\$m\mainmt.obj +MDMain = ..\boot\$m\mainmd.obj +ResFile = ..\boot\$m\scheme.res + +# We use MD so that we can link with and load DLLs built against msvcrxxx.dll +CFLAGS=/nologo /fp:precise /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +MDCFLAGS=$(CFLAGS) /MD +MTCFLAGS=$(CFLAGS) /MT +DLLLDFLAGS=/debug:full /machine:ix86 /nologo +# see note in Makefile.a6nt regarding stack size. we use 8MB here to be consistent. +EXELDFLAGS=/debug:full /machine:ix86 /incremental:no /nologo /STACK:0x800000 + +# use following flags for debugging +# CFLAGS=/nologo /fp:precise /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd + +SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib +MDZlibLib=..\zlib\zlib.lib +MTZlibLib=..\zlib\zlibmt.lib +MDLZ4Lib=..\lz4\lib\liblz4.lib +MTLZ4Lib=..\lz4\lib\liblz4mt.lib + +csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\ + number.c schsig.c io.c new-io.c print.c fasl.c stats.c\ + foreign.c prim.c prim5.c flushcache.c\ + windows.c\ + schlib.c thread.c expeditor.c scheme.c compress-io.c + +cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\ + number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\ + foreign.obj prim.obj prim5.obj flushcache.obj\ + windows.obj\ + schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj + +hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c + +.SUFFIXES: + +all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain) + +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc) +$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h +$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h + +$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib) + -del /f $(MTKernelLib) + cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc) + link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib) + +$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib) + -del /f $(MDKernelLib) + cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc) + link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib) + +# nmake builds Dll twice if we list it with $(KernelLib) below +$(KernelDll): $(KernelLib) + +# base chosen to be consistent with "microsoft conventions" +# http://www.windevnet.com/documents/s=7482/win1078945937961/ +# but set at a basically odd address to reduce likelihood of +# conflicts with other dlls. use 'depends ' to check. +# we no longer attempt to rebase other the CRT dll since it +# has already been signed. +$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib) + -del /f $(KernelLib) + -del /f $(KernelDll) + cl /c $(MDCFLAGS) $(csrc) + link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib) + editbin /nologo /rebase:base=0x67480000 $(KernelDll) + +$(MTMain): main.c + -del /f $(MTMain) + cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c + copy main.obj $(MTMain) + +$(MDMain): main.c + -del /f $(MDMain) + cl /c $(MDCFLAGS) main.c + copy main.obj $(MDMain) + +$(Exec): $(ResFile) $(MDMain) $(KernelLib) + -del /f $(Exec) + link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib) + mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1 + +$(ResFile): scheme.rc + -del /f $(ResFile) + rc -r /fo $(ResFile) -DWIN32 scheme.rc + +# for testing mt kernel and mainmt.obj: +mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib) + -del /f mtscheme.exe + link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib) + +# for testing md kernel and mainmd.obj: +mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib) + -del /f mdscheme.exe + link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib) + +..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib): + cd ../zlib + nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)" + ren zlib.lib zlibmt.lib + nmake /nologo -f win32/Makefile.msc clean + nmake /nologo -f win32/Makefile.msc AR="link /lib" + cd ../c + +$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj + cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c + cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c + cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c + cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c + lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj + +clean: + -del /f $(cobj) main.obj $(KernelExp) + -del /f mtscheme.exe + -del /f mdscheme.exe diff --git a/c/Mf-a6fb b/c/Mf-a6fb new file mode 100644 index 0000000..43bf590 --- /dev/null +++ b/c/Mf-a6fb @@ -0,0 +1,47 @@ +# Mf-a6fb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6fb +Cpu = X86_64 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6le b/c/Mf-a6le new file mode 100644 index 0000000..9931a92 --- /dev/null +++ b/c/Mf-a6le @@ -0,0 +1,46 @@ +# Mf-a6le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6le +Cpu = X86_64 + +mdclib = -lm -ldl ${ncursesLib} -lrt -luuid +C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64 -fPIC" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6nb b/c/Mf-a6nb new file mode 100644 index 0000000..42b5483 --- /dev/null +++ b/c/Mf-a6nb @@ -0,0 +1,48 @@ +# Mf-a6nb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6nb +Cpu = X86_64 + +mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/local/include -I/usr/X11R6/include +mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + paxctl +m ${Scheme} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6nt b/c/Mf-a6nt new file mode 100644 index 0000000..7ae4a52 --- /dev/null +++ b/c/Mf-a6nt @@ -0,0 +1,65 @@ +# Mf-a6nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6nt +Cpu = X86_64 + +clib= +o = obj +mdobj=windows.$o +mdsrc=a6nt-jump.asm windows.c Makefile.$m cs.ico scheme.rc make.bat +mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* +cross=f + +include Mf-base + +export MSYS_NO_PATHCONV=1 +export MSYS2_ARG_CONV_EXCL=* + +${Scheme}${cross:f=}: make.bat + cmd.exe /c make.bat + cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb + +make.bat: vs.bat + echo '@echo off' > $@ + echo 'set MAKEFLAGS=' >> $@ + echo 'vs.bat amd64 && nmake /f Makefile.$m /nologo %*' >> $@ + chmod +x $@ + +# ------------------------------------------------------- +# For cross-compilation, triggered by setting cross=t o=o + +C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} + +${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid + +.c.$o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +../zlib/configure.log: + echo "all:" >> ../zlib/Makefile + echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile + touch ../zlib/configure.log + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a) diff --git a/c/Mf-a6ob b/c/Mf-a6ob new file mode 100644 index 0000000..fe117c6 --- /dev/null +++ b/c/Mf-a6ob @@ -0,0 +1,47 @@ +# Mf-a6ob +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6ob +Cpu = X86_64 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6osx b/c/Mf-a6osx new file mode 100644 index 0000000..1977f3c --- /dev/null +++ b/c/Mf-a6osx @@ -0,0 +1,46 @@ +# Mf-a6osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6osx +Cpu = X86_64 + +mdclib = -liconv -lm ${ncursesLib} +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6s2 b/c/Mf-a6s2 new file mode 100644 index 0000000..6a8e403 --- /dev/null +++ b/c/Mf-a6s2 @@ -0,0 +1,46 @@ +# Mf-a6s2 +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = a6s2 +Cpu = X86_64 + +mdclib = -lnsl -ldl -lm ${cursesLib} -lrt +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-arm32le b/c/Mf-arm32le new file mode 100644 index 0000000..14016fa --- /dev/null +++ b/c/Mf-arm32le @@ -0,0 +1,46 @@ +# Mf-arm32le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = arm32le +Cpu = ARMV6 + +mdclib = -lm -ldl ${ncursesLib} -lrt -luuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +o = o +mdsrc = arm32le.c +mdobj = arm32le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -fPIC" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; ${MAKE} liblz4.a) diff --git a/c/Mf-base b/c/Mf-base new file mode 100644 index 0000000..d97cf91 --- /dev/null +++ b/c/Mf-base @@ -0,0 +1,82 @@ +# Mf-base +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +include Mf-config +export CC CFLAGS LD LDFLAGS + +Include=../boot/$m +PetiteBoot=../boot/$m/petite.boot +SchemeBoot=../boot/$m/scheme.boot +Main=../boot/$m/main.$o +Scheme=../bin/$m/scheme + +# One of these sets is referenced in Mf-config to select between +# linking with kernel.o or libkernel.a + +KernelO=../boot/$m/kernel.$o +KernelOLinkDeps= +KernelOLinkLibs= + +KernelLib=../boot/$m/libkernel.a +KernelLibLinkDeps=${zlibDep} ${LZ4Dep} +KernelLibLinkLibs=${zlibLib} ${LZ4Lib} + +kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-ocd.c gc-oce.c\ + number.c schsig.c io.c new-io.c print.c fasl.c stats.c foreign.c prim.c prim5.c flushcache.c\ + schlib.c thread.c expeditor.c scheme.c compress-io.c + +kernelobj=${kernelsrc:%.c=%.$o} ${mdobj} + +kernelhdr=system.h types.h version.h globals.h externs.h segment.h gc.c sort.h thread.h config.h compress-io.h itest.c nocurses.h + +mainsrc=main.c + +mainobj:=${mainsrc:%.c=%.$o} + +doit: ${Scheme} + +source: ${kernelsrc} ${kernelhdr} ${mdsrc} ${mainsrc} + +${Main}: ${mainobj} + cp -p ${mainobj} ${Main} + +rootsrc=$(shell cd ../../c; echo *) +${rootsrc}: +ifeq ($(OS),Windows_NT) + cp -p ../../c/$@ $@ +else + ln -s ../../c/$@ $@ +endif + +scheme.o: itest.c +scheme.o main.o: config.h +${kernelobj}: system.h types.h version.h externs.h globals.h segment.h thread.h sort.h compress-io.h nocurses.h +${kernelobj}: ${Include}/equates.h ${Include}/scheme.h +${mainobj}: ${Include}/scheme.h +${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep} +gc-011.o gc-ocd.o gc-oce.o: gc.c + +../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log + +../zlib/libz.a: ../zlib/configure.log + (cd ../zlib; ${MAKE}) + +LZ4Sources=../lz4/lib/lz4.h ../lz4/lib/lz4frame.h \ + ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c \ + ../lz4/lib/lz4hc.c ../lz4/lib/xxhash.c + +clean: + rm -f *.$o ${mdclean} + rm -f Make.out diff --git a/c/Mf-i3fb b/c/Mf-i3fb new file mode 100644 index 0000000..187e036 --- /dev/null +++ b/c/Mf-i3fb @@ -0,0 +1,47 @@ +# Mf-i3fb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3fb +Cpu = I386 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3le b/c/Mf-i3le new file mode 100644 index 0000000..995809e --- /dev/null +++ b/c/Mf-i3le @@ -0,0 +1,46 @@ +# Mf-i3le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3le +Cpu = I386 + +mdclib = -lm -ldl ${ncursesLib} -lrt -luuid +C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -fno-stack-protector ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3nb b/c/Mf-i3nb new file mode 100644 index 0000000..05592cf --- /dev/null +++ b/c/Mf-i3nb @@ -0,0 +1,48 @@ +# Mf-i3nb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3nb +Cpu = I386 + +mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include +mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + paxctl +m ${Scheme} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3nt b/c/Mf-i3nt new file mode 100644 index 0000000..9a02747 --- /dev/null +++ b/c/Mf-i3nt @@ -0,0 +1,65 @@ +# Mf-i3nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3nt +Cpu = I386 + +clib= +o = obj +mdobj=windows.$o +mdsrc=windows.c Makefile.$m cs.ico scheme.rc make.bat +mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* +cross=f + +include Mf-base + +export MSYS_NO_PATHCONV=1 +export MSYS2_ARG_CONV_EXCL=* + +${Scheme}${cross:f=}: make.bat + cmd.exe /c make.bat + cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb + +make.bat: vs.bat + echo '@echo off' > $@ + echo 'set MAKEFLAGS=' >> $@ + echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@ + chmod +x $@ + +# ------------------------------------------------------- +# For cross-compilation, triggered by setting cross=t o=o + +C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} + +${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid + +.c.$o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +../zlib/configure.log: + echo "all:" >> ../zlib/Makefile + echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile + touch ../zlib/configure.log + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a) diff --git a/c/Mf-i3ob b/c/Mf-i3ob new file mode 100644 index 0000000..a1a6d39 --- /dev/null +++ b/c/Mf-i3ob @@ -0,0 +1,47 @@ +# Mf-i3ob +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3ob +Cpu = I386 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3osx b/c/Mf-i3osx new file mode 100644 index 0000000..1a4b181 --- /dev/null +++ b/c/Mf-i3osx @@ -0,0 +1,46 @@ +# Mf-i3osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3osx +Cpu = I386 + +mdclib = -liconv -lm ${ncursesLib} +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3qnx b/c/Mf-i3qnx new file mode 100644 index 0000000..7d03738 --- /dev/null +++ b/c/Mf-i3qnx @@ -0,0 +1,47 @@ +# Mf-i3qnx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3qnx +Cpu = I386 + +mdclib = -lm /usr/local/lib/libiconv.so -lsocket ${ncursesLib} +C = qcc ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -N2048K ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o +LocalInclude = /usr/local/include + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} -I${LocalInclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -mi386nto -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -Wl,--export-dynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3s2 b/c/Mf-i3s2 new file mode 100644 index 0000000..c0dabc3 --- /dev/null +++ b/c/Mf-i3s2 @@ -0,0 +1,46 @@ +# Mf-i3s2 +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = i3s2 +Cpu = I386 + +mdclib = -lnsl -ldl -lm ${cursesLib} -lrt +C = ${CC} ${CFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O ${CPPFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ppc32le b/c/Mf-ppc32le new file mode 100644 index 0000000..6b84b54 --- /dev/null +++ b/c/Mf-ppc32le @@ -0,0 +1,46 @@ +# Mf-ppc32le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ppc32le +Cpu = PPC32 + +mdclib = -lm -ldl ${ncursesLib} -lrt -luuid +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +o = o +mdsrc = ppc32.c +mdobj = ppc32.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6fb b/c/Mf-ta6fb new file mode 100644 index 0000000..6b362e9 --- /dev/null +++ b/c/Mf-ta6fb @@ -0,0 +1,47 @@ +# Mf-ta6fb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6fb +Cpu = X86_64 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6le b/c/Mf-ta6le new file mode 100644 index 0000000..d8d549d --- /dev/null +++ b/c/Mf-ta6le @@ -0,0 +1,46 @@ +# Mf-ta6le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6le +Cpu = X86_64 + +mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid +C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64 -fPIC" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6nb b/c/Mf-ta6nb new file mode 100644 index 0000000..6133398 --- /dev/null +++ b/c/Mf-ta6nb @@ -0,0 +1,48 @@ +# Mf-ta6nb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6nb +Cpu = X86_64 + +mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include +mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -lpthread +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + paxctl +m ${Scheme} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6nt b/c/Mf-ta6nt new file mode 100644 index 0000000..5d2f47f --- /dev/null +++ b/c/Mf-ta6nt @@ -0,0 +1,65 @@ +# Mf-ta6nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6nt +Cpu = X86_64 + +clib= +o = obj +mdobj=windows.$o +mdsrc=a6nt-jump.asm windows.c Makefile.$m cs.ico scheme.rc make.bat +mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* +cross=f + +include Mf-base + +export MSYS_NO_PATHCONV=1 +export MSYS2_ARG_CONV_EXCL=* + +${Scheme}${cross:f=}: make.bat + cmd.exe /c make.bat + cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb + +make.bat: vs.bat + echo '@echo off' > $@ + echo 'set MAKEFLAGS=' >> $@ + echo 'vs.bat amd64 && nmake /f Makefile.$m /nologo %*' >> $@ + chmod +x $@ + +# ------------------------------------------------------- +# For cross-compilation, triggered by setting cross=t o=o + +C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} + +${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid + +.c.$o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +../zlib/configure.log: + echo "all:" >> ../zlib/Makefile + echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile + touch ../zlib/configure.log + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6ob b/c/Mf-ta6ob new file mode 100644 index 0000000..74857da --- /dev/null +++ b/c/Mf-ta6ob @@ -0,0 +1,47 @@ +# Mf-ta6ob +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6ob +Cpu = X86_64 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6osx b/c/Mf-ta6osx new file mode 100644 index 0000000..10335a8 --- /dev/null +++ b/c/Mf-ta6osx @@ -0,0 +1,46 @@ +# Mf-ta6osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6osx +Cpu = X86_64 + +mdclib = -liconv -lm ${ncursesLib} +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6s2 b/c/Mf-ta6s2 new file mode 100644 index 0000000..dbe035f --- /dev/null +++ b/c/Mf-ta6s2 @@ -0,0 +1,46 @@ +# Mf-ta6s2 +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ta6s2 +Cpu = X86_64 + +mdclib = -lnsl -ldl -lm -lpthread ${cursesLib} -lrt +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3fb b/c/Mf-ti3fb new file mode 100644 index 0000000..bb4d812 --- /dev/null +++ b/c/Mf-ti3fb @@ -0,0 +1,47 @@ +# Mf-ti3fb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3fb +Cpu = I386 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3le b/c/Mf-ti3le new file mode 100644 index 0000000..dbba3af --- /dev/null +++ b/c/Mf-ti3le @@ -0,0 +1,46 @@ +# Mf-ti3le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3le +Cpu = I386 + +mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid +C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3nb b/c/Mf-ti3nb new file mode 100644 index 0000000..db753ac --- /dev/null +++ b/c/Mf-ti3nb @@ -0,0 +1,48 @@ +# Mf-ti3nb +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3nb +Cpu = I386 + +mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include +mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -lpthread +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -m elf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + paxctl +m ${Scheme} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3nt b/c/Mf-ti3nt new file mode 100644 index 0000000..6cf258d --- /dev/null +++ b/c/Mf-ti3nt @@ -0,0 +1,65 @@ +# Mf-ti3nt +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3nt +Cpu = I386 + +clib= +o = obj +mdobj=windows.$o +mdsrc=windows.c Makefile.$m cs.ico scheme.rc make.bat +mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* +cross=f + +include Mf-base + +export MSYS_NO_PATHCONV=1 +export MSYS2_ARG_CONV_EXCL=* + +${Scheme}${cross:f=}: make.bat + cmd.exe /c make.bat + cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb + +make.bat: vs.bat + echo '@echo off' > $@ + echo 'set MAKEFLAGS=' >> $@ + echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@ + chmod +x $@ + +# ------------------------------------------------------- +# For cross-compilation, triggered by setting cross=t o=o + +C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} -D__MINGW_USE_VC2005_COMPAT + +${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid + +.c.$o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +../zlib/configure.log: + echo "all:" >> ../zlib/Makefile + echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile + touch ../zlib/configure.log + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3ob b/c/Mf-ti3ob new file mode 100644 index 0000000..381ebca --- /dev/null +++ b/c/Mf-ti3ob @@ -0,0 +1,47 @@ +# Mf-ti3ob +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3ob +Cpu = I386 + +mdinclude = -I/usr/local/include -I/usr/X11R6/include +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3osx b/c/Mf-ti3osx new file mode 100644 index 0000000..1421c07 --- /dev/null +++ b/c/Mf-ti3osx @@ -0,0 +1,46 @@ +# Mf-ti3osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3osx +Cpu = I386 + +mdclib = -liconv -lm ${ncursesLib} +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ti3s2 b/c/Mf-ti3s2 new file mode 100644 index 0000000..a8fd5da --- /dev/null +++ b/c/Mf-ti3s2 @@ -0,0 +1,46 @@ +# Mf-ti3s2 +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = ti3s2 +Cpu = I386 + +mdclib = -lnsl -ldl -lm -lpthread ${cursesLib} -lrt +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT ${CFLAGS} +o = o +mdsrc = i3le.c +mdobj = i3le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-tppc32le b/c/Mf-tppc32le new file mode 100644 index 0000000..301bd76 --- /dev/null +++ b/c/Mf-tppc32le @@ -0,0 +1,46 @@ +# Mf-tppc32le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = tppc32le +Cpu = PPC32 + +mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} +o = o +mdsrc = ppc32le.c +mdobj = ppc32le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) diff --git a/c/a6nt-jump.asm b/c/a6nt-jump.asm new file mode 100755 index 0000000..9de699a --- /dev/null +++ b/c/a6nt-jump.asm @@ -0,0 +1,69 @@ +; We do not use Microsoft's implementation because its longjmp unwinds +; the stack to support C++ destructors, and the stack frames generated +; by Chez Scheme do not have the required information for this to work +; properly. +; See https://docs.microsoft.com/en-us/cpp/build/x64-calling-convention + +.code + +S_setjmp proc + ; store nonvolatile registers & control words + mov [rcx], rbx + mov [rcx+08h], rbp + mov [rcx+10h], rdi + mov [rcx+18h], rsi + mov [rcx+20h], rsp + mov [rcx+28h], r12 + mov [rcx+30h], r13 + mov [rcx+38h], r14 + mov [rcx+40h], r15 + stmxcsr [rcx+48h] + fnstcw [rcx+4ch] + movdqu [rcx+50h], xmm6 + movdqu [rcx+60h], xmm7 + movdqu [rcx+70h], xmm8 + movdqu [rcx+80h], xmm9 + movdqu [rcx+90h], xmm10 + movdqu [rcx+0a0h], xmm11 + movdqu [rcx+0b0h], xmm12 + movdqu [rcx+0c0h], xmm13 + movdqu [rcx+0d0h], xmm14 + movdqu [rcx+0e0h], xmm15 + ; store return address + mov rax, [rsp] + mov [rcx+0f0h], rax + xor eax, eax + ret +S_setjmp endp + +S_longjmp proc + ; restore nonvolatile registers & control words + mov rbx, [rcx] + mov rbp, [rcx+08h] + mov rdi, [rcx+10h] + mov rsi, [rcx+18h] + mov rsp, [rcx+20h] + mov r12, [rcx+28h] + mov r13, [rcx+30h] + mov r14, [rcx+38h] + mov r15, [rcx+40h] + ldmxcsr [rcx+48h] + fldcw [rcx+4ch] + movdqu xmm6, [rcx+50h] + movdqu xmm7, [rcx+60h] + movdqu xmm8, [rcx+70h] + movdqu xmm9, [rcx+80h] + movdqu xmm10, [rcx+90h] + movdqu xmm11, [rcx+0a0h] + movdqu xmm12, [rcx+0b0h] + movdqu xmm13, [rcx+0c0h] + movdqu xmm14, [rcx+0d0h] + movdqu xmm15, [rcx+0e0h] + ; restore return address + mov rax, [rcx+0f0h] + mov [rsp], rax + mov rax, rdx + ret +S_longjmp endp + +end diff --git a/c/alloc.c b/c/alloc.c new file mode 100644 index 0000000..cb7c967 --- /dev/null +++ b/c/alloc.c @@ -0,0 +1,862 @@ +/* alloc.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +static void maybe_fire_collector(void); + +void S_alloc_init(void) { + ISPC s; IGEN g; UINT i; + + if (S_boot_time) { + /* reset the allocation tables */ + for (g = 0; g <= static_generation; g++) { + S_G.bytes_of_generation[g] = 0; + for (s = 0; s <= max_real_space; s++) { + S_G.base_loc[g][s] = FIX(0); + S_G.first_loc[g][s] = FIX(0); + S_G.next_loc[g][s] = FIX(0); + S_G.bytes_left[g][s] = 0; + S_G.bytes_of_space[g][s] = 0; + } + } + + /* initialize the dirty-segment lists. */ + for (i = 0; i < DIRTY_SEGMENT_LISTS; i += 1) { + S_G.dirty_segments[i] = NULL; + } + + S_G.collect_trip_bytes = default_collect_trip_bytes; + S_G.g0_bytes_after_last_gc = 0; + + /* set to final value in prim.c when known */ + S_protect(&S_G.nonprocedure_code); + S_G.nonprocedure_code = FIX(0); + + S_protect(&S_G.null_vector); + find_room(space_new, 0, type_typed_object, size_vector(0), S_G.null_vector); + VECTTYPE(S_G.null_vector) = (0 << vector_length_offset) | type_vector; + + S_protect(&S_G.null_fxvector); + find_room(space_new, 0, type_typed_object, size_fxvector(0), S_G.null_fxvector); + FXVECTOR_TYPE(S_G.null_fxvector) = (0 << fxvector_length_offset) | type_fxvector; + + S_protect(&S_G.null_bytevector); + find_room(space_new, 0, type_typed_object, size_bytevector(0), S_G.null_bytevector); + BYTEVECTOR_TYPE(S_G.null_bytevector) = (0 << bytevector_length_offset) | type_bytevector; + + S_protect(&S_G.null_string); + find_room(space_new, 0, type_typed_object, size_string(0), S_G.null_string); + STRTYPE(S_G.null_string) = (0 << string_length_offset) | type_string; + } +} + +void S_protect(ptr *p) { + if (S_G.protect_next > max_protected) + S_error_abort("max_protected constant too small"); + *p = snil; + S_G.protected[S_G.protect_next++] = p; +} + +/* S_reset_scheme_stack is always called with mutex */ +void S_reset_scheme_stack(ptr tc, iptr n) { + ptr *x; iptr m; + + /* we allow less than one_shot_headroom here for no truly justifiable + reason */ + n = ptr_align(n + (one_shot_headroom >> 1)); + + x = &STACKCACHE(tc); + for (;;) { + if (*x == snil) { + if (n < default_stack_size) n = default_stack_size; + /* stacks are untyped objects */ + find_room(space_new, 0, typemod, n, SCHEMESTACK(tc)); + break; + } + if ((m = CACHEDSTACKSIZE(*x)) >= n) { + n = m; + SCHEMESTACK(tc) = *x; +/* if we decide to leave KEEPSMALLPUPPIES undefined permanently, we should + rewrite this code to remove the indirect on x */ +/* #define KEEPSMALLPUPPIES */ +#ifdef KEEPSMALLPUPPIES + *x = CACHEDSTACKLINK(*x); +#else + STACKCACHE(tc) = CACHEDSTACKLINK(*x); +#endif + break; + } + x = &CACHEDSTACKLINK(*x); + } + SCHEMESTACKSIZE(tc) = n; + ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + n - stack_slop); + SFP(tc) = (ptr)SCHEMESTACK(tc); +} + +ptr S_compute_bytes_allocated(ptr xg, ptr xs) { + ptr tc = get_thread_context(); + ISPC s, smax, smin; IGEN g, gmax, gmin; + uptr n; + + gmin = (IGEN)UNFIX(xg); + if (gmin < 0) { + gmin = 0; + gmax = static_generation; + } else if (gmin == S_G.new_max_nonstatic_generation) { + /* include virtual inhabitents too */ + gmax = S_G.max_nonstatic_generation; + } else { + gmax = gmin; + } + + smin = (ISPC)(UNFIX(xs)); + smax = smin < 0 ? max_real_space : smin; + smin = smin < 0 ? 0 : smin; + + n = 0; + + g = gmin; + while (g <= gmax) { + for (s = smin; s <= smax; s++) { + ptr next_loc = S_G.next_loc[g][s]; + /* add in bytes previously recorded */ + n += S_G.bytes_of_space[g][s]; + /* add in bytes in active segments */ + if (next_loc != FIX(0)) + n += (char *)next_loc - (char *)S_G.base_loc[g][s]; + } + if (g == S_G.max_nonstatic_generation) + g = static_generation; + else + g += 1; + } + + /* subtract off bytes not allocated */ + if (gmin == 0 && smin <= space_new && space_new <= smax) + n -= (uptr)REAL_EAP(tc) - (uptr)AP(tc); + + return Sunsigned(n); +} + +static void maybe_fire_collector(void) { + if (S_G.bytes_of_generation[0] - S_G.g0_bytes_after_last_gc >= S_G.collect_trip_bytes) + S_fire_collector(); +} + +/* find_more_room + * S_find_more_room is called from the macro find_room when + * the current segment is too full to fit the allocation. + * + * A forward_marker followed by a pointer to + * the newly obtained segment is placed at next_loc to show + * gc where the end of this segment is and where the next + * segment of this type resides. Allocation occurs from the + * beginning of the newly obtained segment. The need for the + * eos marker explains the (2 * ptr_bytes) byte factor in + * S_find_more_room. + */ +/* S_find_more_room is always called with mutex */ +ptr S_find_more_room(ISPC s, IGEN g, iptr n, ptr old) { + iptr nsegs, seg; + ptr new; + + S_pants_down += 1; + + nsegs = (uptr)(n + 2 * ptr_bytes + bytes_per_segment - 1) >> segment_offset_bits; + + /* block requests to minimize fragmentation and improve cache locality */ + if (s == space_code && nsegs < 16) nsegs = 16; + + seg = S_find_segments(s, g, nsegs); + new = build_ptr(seg, 0); + + if (old == FIX(0)) { + /* first object of this space */ + S_G.first_loc[g][s] = new; + } else { + uptr bytes = (char *)old - (char *)S_G.base_loc[g][s]; + /* increment bytes_allocated by the closed-off partial segment */ + S_G.bytes_of_space[g][s] += bytes; + S_G.bytes_of_generation[g] += bytes; + /* lay down an end-of-segment marker */ + *(ptr*)old = forward_marker; + *((ptr*)old + 1) = new; + } + + /* base address of current block of segments to track amount of allocation */ + S_G.base_loc[g][s] = new; + + S_G.next_loc[g][s] = (ptr)((uptr)new + n); + S_G.bytes_left[g][s] = (nsegs * bytes_per_segment - n) - 2 * ptr_bytes; + + if (g == 0 && S_pants_down == 1) maybe_fire_collector(); + + S_pants_down -= 1; + return new; +} + +/* S_reset_allocation_pointer is always called with mutex */ +/* We always allocate exactly one segment for the allocation area, since + we can get into hot water with formerly locked objects, specifically + symbols and impure records, that cross segment boundaries. This allows + us to maintain the invariant that no object crosses a segment boundary + unless it starts on a segment boundary (and is thus at least one + segment long). NB. This invariant does not apply to code objects + since we grab large blocks of segments for them. +*/ + +void S_reset_allocation_pointer(ptr tc) { + iptr seg; + + S_pants_down += 1; + + seg = S_find_segments(space_new, 0, 1); + + /* NB: if allocate_segments didn't already ensure we don't use the last segment + of memory, we'd have to reject it here so cp2-alloc can avoid a carry check for + small allocation requests, using something like this: + + if (seg == (((uptr)1 << (ptr_bits - segment_offset_bits)) - 1)) + seg = S_find_segments(space_new, 0, 1); + */ + + S_G.bytes_of_space[0][space_new] += bytes_per_segment; + S_G.bytes_of_generation[0] += bytes_per_segment; + + if (S_pants_down == 1) maybe_fire_collector(); + + AP(tc) = build_ptr(seg, 0); + REAL_EAP(tc) = EAP(tc) = (ptr)((uptr)AP(tc) + bytes_per_segment); + + S_pants_down -= 1; +} + + +FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g, IGEN to_g) { + IGEN old_to_g = si->min_dirty_byte; + if (to_g < old_to_g) { + seginfo **pointer_to_first, *oldfirst; + if (old_to_g != 0xff) { + seginfo *next = si->dirty_next, **prev = si->dirty_prev; + /* presently on some other list, so remove */ + *prev = next; + if (next != NULL) next->dirty_prev = prev; + } + oldfirst = *(pointer_to_first = &DirtySegments(from_g, to_g)); + *pointer_to_first = si; + si->dirty_prev = pointer_to_first; + si->dirty_next = oldfirst; + if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next; + si->min_dirty_byte = to_g; + } +} + +void S_dirty_set(ptr *loc, ptr x) { + *loc = x; + if (!Sfixnump(x)) { + seginfo *si = SegInfo(addr_get_segment(loc)); + IGEN from_g = si->generation; + if (from_g != 0) { + si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0; + mark_segment_dirty(si, from_g, 0); + } + } +} + +void S_mark_card_dirty(uptr card, IGEN to_g) { + uptr loc = card << card_offset_bits; + uptr seg = addr_get_segment(loc); + seginfo *si = SegInfo(seg); + uptr cardno = card & ((1 << segment_card_offset_bits) - 1); + if (to_g < si->dirty_bytes[cardno]) { + si->dirty_bytes[cardno] = to_g; + mark_segment_dirty(si, si->generation, to_g); + } +} + +/* scan remembered set from P to ENDP, transferring to dirty vector */ +void S_scan_dirty(ptr **p, ptr **endp) { + uptr this, last; + + last = 0; + + while (p < endp) { + ptr *loc = *p; + /* whether building s directory or running UXLB code, the most + common situations are that *loc is a fixnum, this == last, or loc + is in generation 0. the generated code no longer adds elements + to the remembered set if the RHS val is a fixnum. the other + checks we do here. we don't bother looking for *loc being an + immediate or outside the heap, nor for the generation of *loc + being the same or older than the generation of loc, since these + don't seem to weed out many dirty writes, and we don't want to + waste time here on fruitless memory reads and comparisions */ + if ((this = (uptr)loc >> card_offset_bits) != last) { + seginfo *si = SegInfo(addr_get_segment(loc)); + IGEN from_g = si->generation; + if (from_g != 0) { + si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0; + if (this >> segment_card_offset_bits != last >> segment_card_offset_bits) mark_segment_dirty(si, from_g, 0); + } + last = this; + } + p += 1; + } +} + +/* S_scan_remembered_set is called from generated machine code when there + * is insufficient room for a remembered set addition. + */ + +void S_scan_remembered_set(void) { + ptr tc = get_thread_context(); + uptr ap, eap, real_eap; + + tc_mutex_acquire() + + ap = (uptr)AP(tc); + eap = (uptr)EAP(tc); + real_eap = (uptr)REAL_EAP(tc); + + S_scan_dirty((ptr **)eap, (ptr **)real_eap); + eap = real_eap; + + if (eap - ap > alloc_waste_maximum) { + AP(tc) = (ptr)ap; + EAP(tc) = (ptr)eap; + } else { + uptr bytes = eap - ap; + S_G.bytes_of_space[0][space_new] -= bytes; + S_G.bytes_of_generation[0] -= bytes; + S_reset_allocation_pointer(tc); + } + + tc_mutex_release() +} + +/* S_get_more_room is called from generated machine code when there is + * insufficient room for an allocation. ap has already been incremented + * by the size of the object and xp is a (typed) pointer to the value of + * ap before the allocation attempt. xp must be set to a new object of + * the appropriate type and size. + */ + +void S_get_more_room(void) { + ptr tc = get_thread_context(); + ptr xp; uptr ap, type, size; + + xp = XP(tc); + if ((type = TYPEBITS(xp)) == 0) type = typemod; + ap = (uptr)UNTYPE(xp, type); + size = (uptr)((iptr)AP(tc) - (iptr)ap); + + XP(tc) = S_get_more_room_help(tc, ap, type, size); +} + +ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) { + ptr x; uptr eap, real_eap; + + eap = (uptr)EAP(tc); + real_eap = (uptr)REAL_EAP(tc); + + tc_mutex_acquire() + + S_scan_dirty((ptr **)eap, (ptr **)real_eap); + eap = real_eap; + + if (eap - ap >= size) { + x = TYPE(ap, type); + ap += size; + if (eap - ap > alloc_waste_maximum) { + AP(tc) = (ptr)ap; + EAP(tc) = (ptr)eap; + } else { + uptr bytes = eap - ap; + S_G.bytes_of_space[0][space_new] -= bytes; + S_G.bytes_of_generation[0] -= bytes; + S_reset_allocation_pointer(tc); + } + } else if (eap - ap > alloc_waste_maximum) { + AP(tc) = (ptr)ap; + EAP(tc) = (ptr)eap; + find_room(space_new, 0, type, size, x); + } else { + uptr bytes = eap - ap; + S_G.bytes_of_space[0][space_new] -= bytes; + S_G.bytes_of_generation[0] -= bytes; + S_reset_allocation_pointer(tc); + ap = (uptr)AP(tc); + if (size + alloc_waste_maximum <= (uptr)EAP(tc) - ap) { + x = TYPE(ap, type); + AP(tc) = (ptr)(ap + size); + } else { + find_room(space_new, 0, type, size, x); + } + } + + tc_mutex_release() + + return x; +} + +/* S_cons_in is always called with mutex */ +ptr S_cons_in(ISPC s, IGEN g, ptr car, ptr cdr) { + ptr p; + + find_room(s, g, type_pair, size_pair, p); + INITCAR(p) = car; + INITCDR(p) = cdr; + return p; +} + +ptr Scons(ptr car, ptr cdr) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_pair, size_pair, p); + INITCAR(p) = car; + INITCDR(p) = cdr; + return p; +} + +ptr Sbox(ptr ref) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_typed_object, size_box, p); + BOXTYPE(p) = type_box; + INITBOXREF(p) = ref; + return p; +} + +ptr S_symbol(ptr name) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_symbol, size_symbol, p); + /* changes here should be reflected in the oblist collection code in gc.c */ + INITSYMVAL(p) = sunbound; + INITSYMCODE(p,S_G.nonprocedure_code); + INITSYMPLIST(p) = snil; + INITSYMSPLIST(p) = snil; + INITSYMNAME(p) = name; + INITSYMHASH(p) = Sfalse; + return p; +} + +ptr S_rational(ptr n, ptr d) { + if (d == FIX(1)) return n; + else { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_typed_object, size_ratnum, p); + RATTYPE(p) = type_ratnum; + RATNUM(p) = n; + RATDEN(p) = d; + return p; + } +} + +ptr S_tlc(ptr keyval, ptr ht, ptr next) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_typed_object, size_tlc, p); + TLCTYPE(p) = type_tlc; + INITTLCKEYVAL(p) = keyval; + INITTLCHT(p) = ht; + INITTLCNEXT(p) = next; + return p; +} + +/* S_vector_in is always called with mutex */ +ptr S_vector_in(ISPC s, IGEN g, iptr n) { + ptr p; iptr d; + + if (n == 0) return S_G.null_vector; + + if ((uptr)n >= maximum_vector_length) + S_error("", "invalid vector size request"); + + d = size_vector(n); + /* S_vector_in always called with mutex */ + find_room(s, g, type_typed_object, d, p); + VECTTYPE(p) = (n << vector_length_offset) | type_vector; + return p; +} + +ptr S_vector(iptr n) { + ptr tc; + ptr p; iptr d; + + if (n == 0) return S_G.null_vector; + + if ((uptr)n >= maximum_vector_length) + S_error("", "invalid vector size request"); + + tc = get_thread_context(); + + d = size_vector(n); + thread_find_room(tc, type_typed_object, d, p); + VECTTYPE(p) = (n << vector_length_offset) | type_vector; + return p; +} + +ptr S_fxvector(iptr n) { + ptr tc; + ptr p; iptr d; + + if (n == 0) return S_G.null_fxvector; + + if ((uptr)n > (uptr)maximum_fxvector_length) + S_error("", "invalid fxvector size request"); + + tc = get_thread_context(); + + d = size_fxvector(n); + thread_find_room(tc, type_typed_object, d, p); + FXVECTOR_TYPE(p) = (n << fxvector_length_offset) | type_fxvector; + return p; +} + +ptr S_bytevector(iptr n) { + ptr tc; + ptr p; iptr d; + + if (n == 0) return S_G.null_bytevector; + + if ((uptr)n > (uptr)maximum_bytevector_length) + S_error("", "invalid bytevector size request"); + + tc = get_thread_context(); + + d = size_bytevector(n); + thread_find_room(tc, type_typed_object, d, p); + BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector; + return p; +} + +ptr S_null_immutable_vector(void) { + ptr v; + find_room(space_new, 0, type_typed_object, size_vector(0), v); + VECTTYPE(v) = (0 << vector_length_offset) | type_vector | vector_immutable_flag; + return v; +} + +ptr S_null_immutable_fxvector(void) { + ptr v; + find_room(space_new, 0, type_typed_object, size_fxvector(0), v); + VECTTYPE(v) = (0 << fxvector_length_offset) | type_fxvector | fxvector_immutable_flag; + return v; +} + +ptr S_null_immutable_bytevector(void) { + ptr v; + find_room(space_new, 0, type_typed_object, size_bytevector(0), v); + VECTTYPE(v) = (0 << bytevector_length_offset) | type_bytevector | bytevector_immutable_flag; + return v; +} + +ptr S_null_immutable_string(void) { + ptr v; + find_room(space_new, 0, type_typed_object, size_string(0), v); + VECTTYPE(v) = (0 << string_length_offset) | type_string | string_immutable_flag; + return v; +} + +ptr S_record(iptr n) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_typed_object, n, p); + return p; +} + +ptr S_closure(ptr cod, iptr n) { + ptr tc = get_thread_context(); + ptr p; iptr d; + + d = size_closure(n); + thread_find_room(tc, type_closure, d, p); + CLOSENTRY(p) = cod; + return p; +} + +/* S_mkcontinuation is always called with mutex */ +ptr S_mkcontinuation(ISPC s, IGEN g, ptr nuate, ptr stack, iptr length, iptr clength, + ptr link, ptr ret, ptr winders) { + ptr p; + + find_room(s, g, type_closure, size_continuation, p); + CLOSENTRY(p) = nuate; + CONTSTACK(p) = stack; + CONTLENGTH(p) = length; + CONTCLENGTH(p) = clength; + CONTLINK(p) = link; + CONTRET(p) = ret; + CONTWINDERS(p) = winders; + return p; +} + +ptr Sflonum(double x) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_flonum, size_flonum, p); + FLODAT(p) = x; + return p; +} + +ptr S_inexactnum(double rp, double ip) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_typed_object, size_inexactnum, p); + INEXACTNUM_TYPE(p) = type_inexactnum; + INEXACTNUM_REAL_PART(p) = rp; + INEXACTNUM_IMAG_PART(p) = ip; + return p; +} + +/* S_thread is always called with mutex */ +ptr S_thread(ptr xtc) { + ptr p; + + /* don't use thread_find_room since we may be building the current thread */ + find_room(space_new, 0, type_typed_object, size_thread, p); + TYPEFIELD(p) = (ptr)type_thread; + THREADTC(p) = (uptr)xtc; + return p; +} + +ptr S_exactnum(ptr a, ptr b) { + ptr tc = get_thread_context(); + ptr p; + + thread_find_room(tc, type_typed_object, size_exactnum, p); + EXACTNUM_TYPE(p) = type_exactnum; + EXACTNUM_REAL_PART(p) = a; + EXACTNUM_IMAG_PART(p) = b; + return p; +} + +/* S_string returns a new string of length n. If s is not NULL, it is + * copied into the new string. If n < 0, then s must be non-NULL, + * and the length of s (by strlen) determines the length of the string */ +ptr S_string(const char *s, iptr n) { + ptr tc; + ptr p; iptr d; + iptr i; + + if (n < 0) n = strlen(s); + + if (n == 0) return S_G.null_string; + + if ((uptr)n > (uptr)maximum_string_length) + S_error("", "invalid string size request"); + + tc = get_thread_context(); + + d = size_string(n); + thread_find_room(tc, type_typed_object, d, p); + STRTYPE(p) = (n << string_length_offset) | type_string; + + /* fill the string with valid characters */ + i = 0; + + /* first copy input string, if any */ + if (s != (char *)NULL) { + while (i != n && *s != 0) { + Sstring_set(p, i, *s++); + i += 1; + } + } + + /* fill remaining slots with nul */ + while (i != n) { + Sstring_set(p, i, 0); + i += 1; + } + + return p; +} + +ptr Sstring_utf8(const char *s, iptr n) { + const char* u8; + iptr cc, d, i, n8; + ptr p, tc; + + if (n < 0) n = strlen(s); + + if (n == 0) return S_G.null_string; + + /* determine code point count cc */ + u8 = s; + n8 = n; + cc = 0; + while (n8 > 0) { + unsigned char b1 = *(const unsigned char*)u8++; + n8--; + cc++; + if ((b1 & 0x80) == 0) + ; + else if ((b1 & 0x40) == 0) + ; + else if ((b1 & 0x20) == 0) { + if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) { + u8++; + n8--; + } + } else if ((b1 & 0x10) == 0) { + if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) { + u8++; + n8--; + if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) { + u8++; + n8--; + } + } + } else if ((b1 & 0x08) == 0) { + if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) { + u8++; + n8--; + if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) { + u8++; + n8--; + if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) { + u8++; + n8--; + } + } + } + } + } + + if ((uptr)cc > (uptr)maximum_string_length) + S_error("", "invalid string size request"); + + tc = get_thread_context(); + d = size_string(cc); + thread_find_room(tc, type_typed_object, d, p); + STRTYPE(p) = (cc << string_length_offset) | type_string; + + /* fill the string */ + u8 = s; + n8 = n; + i = 0; + while (n8 > 0) { + unsigned char b1 = *u8++; + int c = 0xfffd; + n8--; + if ((b1 & 0x80) == 0) + c = b1; + else if ((b1 & 0x40) == 0) + ; + else if ((b1 & 0x20) == 0) { + unsigned char b2; + if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) { + int x = ((b1 & 0x1f) << 6) | (b2 & 0x3f); + u8++; + n8--; + if (x >= 0x80) + c = x; + } + } else if ((b1 & 0x10) == 0) { + unsigned char b2; + if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) { + unsigned char b3; + u8++; + n8--; + if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) { + int x = ((b1 & 0x0f) << 12) | ((b2 & 0x3f) << 6) | (b3 & 0x3f); + u8++; + n8--; + if ((x >= 0x800) && ((x < 0xd800) || (x > 0xdfff))) + c = x; + } + } + } else if ((b1 & 0x08) == 0) { + unsigned char b2; + if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) { + unsigned char b3; + u8++; + n8--; + if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) { + unsigned char b4; + u8++; + n8--; + if ((n8 >= 1) && (((b4 = *u8) & 0xc0) == 0x80)) { + int x = ((b1 & 0x07) << 18) | ((b2 & 0x3f) << 12) | ((b3 & 0x3f) << 6) | (b4 & 0x3f); + u8++; + n8--; + if ((x >= 0x10000) && (x <= 0x10ffff)) + c = x; + } + } + } + } + Sstring_set(p, i++, c); + } + return p; +} + +ptr S_bignum(ptr tc, iptr n, IBOOL sign) { + ptr p; iptr d; + + if ((uptr)n > (uptr)maximum_bignum_length) + S_error("", "invalid bignum size request"); + + d = size_bignum(n); + thread_find_room(tc, type_typed_object, d, p); + BIGTYPE(p) = (uptr)n << bignum_length_offset | sign << bignum_sign_offset | type_bignum; + return p; +} + +/* S_code is always called with mutex */ +ptr S_code(ptr tc, iptr type, iptr n) { + ptr p; iptr d; + + d = size_code(n); + find_room(space_code, 0, type_typed_object, d, p); + CODETYPE(p) = type; + CODELEN(p) = n; + /* we record the code modification here, even though we haven't + even started modifying the code yet, since we always create + and fill the code object within a critical section. */ + S_record_code_mod(tc, (uptr)&CODEIT(p,0), (uptr)n); + return p; +} + +ptr S_relocation_table(iptr n) { + ptr tc = get_thread_context(); + ptr p; iptr d; + + d = size_reloc_table(n); + thread_find_room(tc, typemod, d, p); + RELOCSIZE(p) = n; + return p; +} + +ptr S_weak_cons(ptr car, ptr cdr) { + ptr p; + tc_mutex_acquire(); + p = S_cons_in(space_weakpair, 0, car, cdr); + tc_mutex_release(); + return p; +} diff --git a/c/arm32le.c b/c/arm32le.c new file mode 100644 index 0000000..bf09cfa --- /dev/null +++ b/c/arm32le.c @@ -0,0 +1,53 @@ +/* arm32le.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +#include +#include + +/* we don't count on having the right value for correctness, + * but the right value will give maximum efficiency */ +#define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 + +static int l1_max_cache_line_size; + +/* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */ +INT S_flushcache_max_gap(void) { + return l1_max_cache_line_size; +} + +void S_doflush(uptr start, uptr end) { +#ifdef DEBUG + printf(" doflush(%x, %x)\n", start, end); fflush(stdout); +#endif + + __clear_cache((char *)start, (char *)end); +} + +void S_machine_init(void) { + int l1_dcache_line_size, l1_icache_line_size; + +#ifdef _SC_LEVEL1_DCACHE_LINESIZE + if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) +#endif + l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; +#ifdef _SC_LEVEL1_ICACHE_LINESIZE + if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) +#endif + l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; +} diff --git a/c/build.bat b/c/build.bat new file mode 100644 index 0000000..bc4481f --- /dev/null +++ b/c/build.bat @@ -0,0 +1,30 @@ +@echo off +setlocal + +set M=%1 +set WORKAREA=%M% + +if "%WORKAREA%"=="" goto needargument + +xcopy /s /i /y c %WORKAREA%\c +xcopy /s /i /y s %WORKAREA%\s +xcopy /s /i /y boot %WORKAREA%\boot +xcopy /s /i /y zlib %WORKAREA%\zlib +xcopy /s /i /y lz4 %WORKAREA%\lz4 + +mkdir %WORKAREA%\bin\%M% + +echo #define SCHEME_SCRIPT "scheme-script" > %WORKAREA%\c\config.h + +cd %WORKAREA%\c +nmake Makefile.%M% +cd ..\.. + +goto donebuilding + +:needargument + +echo Please supply the machine name as an argument +exit /B 1 + +:donebuilding diff --git a/c/compress-io.c b/c/compress-io.c new file mode 100644 index 0000000..6333648 --- /dev/null +++ b/c/compress-io.c @@ -0,0 +1,672 @@ +/* compress-io.c + * Copyright 1984-2019 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* Dispatch to zlib or LZ4 */ + +#include "system.h" +#include "zlib.h" +#include "lz4.h" +#include "lz4frame.h" +#include "lz4hc.h" +#include +#include + +#ifdef WIN32 +#include +# define WIN32_IZE(id) _ ## id +# define GLZ_O_BINARY O_BINARY +#else +# define WIN32_IZE(id) id +# define GLZ_O_BINARY 0 +#endif + +/* the value of LZ4_OUTPUT_PORT_IN_BUFFER_SIZE was determined + through experimentation on an intel linux server and an intel + osx laptop. smaller sizes result in significantly worse compression + of object files, and larger sizes don't have much beneficial effect. + don't increase the output-port in-buffer size unless you're sure + it reduces object-file size or reduces compression time + significantly. don't decrease it unless you're sure it doesn't + increase object-file size significantly. one buffer of size + LZ4_OUTPUT_PORT_IN_BUFFER_SIZE is allocated per lz4-compressed + output port. another buffer of a closely related size is allocated + per thread. */ +#define LZ4_OUTPUT_PORT_IN_BUFFER_SIZE (1 << 18) + +/* the values we choose for LZ4_INPUT_PORT_IN_BUFFER_SIZE and + LZ4_INPUT_PORT_OUT_BUFFER_SIZE don't seem to make much difference + in decompression speed, so we keep them fairly small. one buffer + of size LZ4_INPUT_PORT_IN_BUFFER_SIZE and one buffer of size + LZ4_INPUT_PORT_OUT_BUFFER_SIZE are allocated per lz4-compressed + input port. */ +#define LZ4_INPUT_PORT_IN_BUFFER_SIZE (1 << 12) +#define LZ4_INPUT_PORT_OUT_BUFFER_SIZE (1 << 14) + +typedef struct lz4File_out_r { + LZ4F_preferences_t preferences; + INT fd; + INT out_buffer_size; + INT in_pos; + INT err; + size_t stream_pos; + char in_buffer[LZ4_OUTPUT_PORT_IN_BUFFER_SIZE]; +} lz4File_out; + +typedef struct lz4File_in_r { + INT fd; + LZ4F_dctx *dctx; + INT in_pos, in_len, out_pos, out_len; + INT frame_ended; + INT err; + size_t stream_pos; + off_t init_pos; + char in_buffer[LZ4_INPUT_PORT_IN_BUFFER_SIZE]; + char out_buffer[LZ4_INPUT_PORT_OUT_BUFFER_SIZE]; +} lz4File_in; + +typedef struct sized_buffer_r { + INT size; + char buffer[0]; +} sized_buffer; + +/* local functions */ +static glzFile glzdopen_output_gz(INT fd, INT compress_level); +static glzFile glzdopen_output_lz4(INT fd, INT compress_level); +static glzFile glzdopen_input_gz(INT fd); +static glzFile glzdopen_input_lz4(INT fd, off_t init_pos); +static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count); +static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count); +static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count); + +INT S_zlib_compress_level(INT compress_level) { + switch (compress_level) { + case COMPRESS_MIN: + case COMPRESS_LOW: + return Z_BEST_SPEED; + case COMPRESS_MEDIUM: + return (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2; + case COMPRESS_HIGH: + return (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4; + case COMPRESS_MAX: + return Z_BEST_COMPRESSION; + default: + S_error1("S_zlib_compress_level", "unexpected compress level ~s", Sinteger(compress_level)); + return 0; + } +} + +static glzFile glzdopen_output_gz(INT fd, INT compress_level) { + gzFile gz; + glzFile glz; + INT as_append; + INT level; + +#ifdef WIN32 + as_append = 0; +#else + as_append = fcntl(fd, F_GETFL) & O_APPEND; +#endif + + if ((gz = gzdopen(fd, as_append ? "ab" : "wb")) == Z_NULL) return Z_NULL; + + level = S_zlib_compress_level(compress_level); + + gzsetparams(gz, level, Z_DEFAULT_STRATEGY); + + if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) { + (void)gzclose(gz); + return Z_NULL; + } + glz->fd = fd; + glz->inputp = 0; + glz->format = COMPRESS_GZIP; + glz->gz = gz; + return glz; +} + +INT S_lz4_compress_level(INT compress_level) { + switch (compress_level) { + case COMPRESS_MIN: + case COMPRESS_LOW: + return 1; + case COMPRESS_MEDIUM: + return LZ4HC_CLEVEL_MIN; + case COMPRESS_HIGH: + return (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2; + case COMPRESS_MAX: + return LZ4HC_CLEVEL_MAX; + default: + S_error1("S_lz4_compress_level", "unexpected compress level ~s", Sinteger(compress_level)); + return 0; + } +} + +static glzFile glzdopen_output_lz4(INT fd, INT compress_level) { + glzFile glz; + lz4File_out *lz4; + INT level; + + level = S_lz4_compress_level(compress_level); + + if ((lz4 = malloc(sizeof(lz4File_out))) == NULL) return Z_NULL; + memset(&lz4->preferences, 0, sizeof(LZ4F_preferences_t)); + lz4->preferences.compressionLevel = level; + lz4->fd = fd; + lz4->out_buffer_size = (INT)LZ4F_compressFrameBound(LZ4_OUTPUT_PORT_IN_BUFFER_SIZE, &lz4->preferences); + lz4->in_pos = 0; + lz4->err = 0; + lz4->stream_pos = 0; + + if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) { + free(lz4); + return Z_NULL; + } + glz->fd = fd; + glz->inputp = 0; + glz->format = COMPRESS_LZ4; + glz->lz4_out = lz4; + return glz; +} + +glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level) { + switch (compress_format) { + case COMPRESS_GZIP: + return glzdopen_output_gz(fd, compress_level); + case COMPRESS_LZ4: + return glzdopen_output_lz4(fd, compress_level); + default: + S_error1("glzdopen_output", "unexpected compress format ~s", Sinteger(compress_format)); + return Z_NULL; + } +} + +static glzFile glzdopen_input_gz(INT fd) { + gzFile gz; + glzFile glz; + + if ((gz = gzdopen(fd, "rb")) == Z_NULL) return Z_NULL; + + if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) { + (void)gzclose(gz); + return Z_NULL; + } + glz->fd = fd; + glz->inputp = 1; + glz->format = COMPRESS_GZIP; + glz->gz = gz; + return glz; +} + +static glzFile glzdopen_input_lz4(INT fd, off_t init_pos) { + glzFile glz; + LZ4F_dctx *dctx; + LZ4F_errorCode_t r; + lz4File_in *lz4; + + r = LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION); + if (LZ4F_isError(r)) + return Z_NULL; + + if ((lz4 = malloc(sizeof(lz4File_in))) == NULL) { + (void)LZ4F_freeDecompressionContext(dctx); + return Z_NULL; + } + lz4->fd = fd; + lz4->dctx = dctx; + lz4->in_pos = 0; + lz4->in_len = 0; + lz4->out_len = 0; + lz4->out_pos = 0; + lz4->frame_ended = 0; + lz4->err = 0; + lz4->stream_pos = 0; + lz4->init_pos = init_pos; + + if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) { + (void)LZ4F_freeDecompressionContext(lz4->dctx); + free(lz4); + return Z_NULL; + } + glz->fd = fd; + glz->inputp = 1; + glz->format = COMPRESS_LZ4; + glz->lz4_in = lz4; + return glz; +} + +glzFile S_glzdopen_input(INT fd) { + INT r, pos = 0; + unsigned char buffer[4]; + off_t init_pos; + + /* check for LZ4 magic number, otherwise defer to gzdopen */ + + if ((init_pos = WIN32_IZE(lseek)(fd, 0, SEEK_CUR)) == -1) return Z_NULL; + + while (pos < 4) { + r = WIN32_IZE(read)(fd, (char*)buffer + pos, 4 - pos); + if (r == 0) + break; + else if (r > 0) + pos += r; +#ifdef EINTR + else if (errno == EINTR) + continue; +#endif + else + break; /* error reading */ + } + + if (pos > 0) { + if (WIN32_IZE(lseek)(fd, init_pos, SEEK_SET) == -1) return Z_NULL; + } + + if ((pos == 4) + && (buffer[0] == 0x04) + && (buffer[1] == 0x22) + && (buffer[2] == 0x4d) + && (buffer[3] == 0x18)) + return glzdopen_input_lz4(fd, init_pos); + + return glzdopen_input_gz(fd); +} + +glzFile S_glzopen_input(const char *path) { + INT fd; + + fd = WIN32_IZE(open)(path, O_RDONLY | GLZ_O_BINARY); + + if (fd == -1) + return Z_NULL; + else + return S_glzdopen_input(fd); +} + +#ifdef WIN32 +glzFile S_glzopen_input_w(const wchar_t *path) { + INT fd; + + fd = _wopen(path, O_RDONLY | GLZ_O_BINARY); + + if (fd == -1) + return Z_NULL; + else + return S_glzdopen_input(fd); +} +#endif + +IBOOL S_glzdirect(glzFile glz) { + if (glz->format == COMPRESS_GZIP) + return gzdirect(glz->gz); + else + return 0; +} + +INT S_glzclose(glzFile glz) { + INT r = Z_OK, saved_errno = 0; + switch (glz->format) { + case COMPRESS_GZIP: + r = gzclose(glz->gz); + break; + case COMPRESS_LZ4: + if (glz->inputp) { + lz4File_in *lz4 = glz->lz4_in; + while (1) { + INT r = WIN32_IZE(close)(lz4->fd); +#ifdef EINTR + if (r < 0 && errno == EINTR) continue; +#endif + if (r == 0) { saved_errno = errno; } + break; + } + (void)LZ4F_freeDecompressionContext(lz4->dctx); + free(lz4); + } else { + lz4File_out *lz4 = glz->lz4_out; + if (lz4->in_pos != 0) { + r = glzemit_lz4(lz4, lz4->in_buffer, lz4->in_pos); + if (r >= 0) r = Z_OK; else { r = Z_ERRNO; saved_errno = errno; } + } + while (1) { + int r1 = WIN32_IZE(close)(lz4->fd); +#ifdef EINTR + if (r1 < 0 && errno == EINTR) continue; +#endif + if (r == Z_OK && r1 < 0) { r = Z_ERRNO; saved_errno = errno; } + break; + } + free(lz4); + } + break; + default: + S_error1("S_glzclose", "unexpected compress format ~s", Sinteger(glz->format)); + } + free(glz); + if (saved_errno) errno = saved_errno; + return r; +} + +static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count) { + while (lz4->out_pos == lz4->out_len) { + INT in_avail; + + in_avail = lz4->in_len - lz4->in_pos; + if (!in_avail) { + while (1) { + in_avail = WIN32_IZE(read)(lz4->fd, lz4->in_buffer, LZ4_INPUT_PORT_IN_BUFFER_SIZE); + if (in_avail >= 0) { + lz4->in_len = in_avail; + lz4->in_pos = 0; + break; +#ifdef EINTR + } else if (errno == EINTR) { + /* try again */ +#endif + } else { + lz4->err = Z_ERRNO; + return -1; + } + } + } + + if (in_avail > 0) { + size_t amt, out_len = LZ4_INPUT_PORT_OUT_BUFFER_SIZE, in_len = in_avail; + + /* For a large enough result buffer, try to decompress directly + to that buffer: */ + if (count >= (out_len >> 1)) { + size_t direct_out_len = count; + + if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0) + return 0; /* count 0 after frame as stream terminator */ + + amt = LZ4F_decompress(lz4->dctx, + buffer, &direct_out_len, + lz4->in_buffer + lz4->in_pos, &in_len, + NULL); + lz4->frame_ended = (amt == 0); + + if (LZ4F_isError(amt)) { + lz4->err = Z_STREAM_ERROR; + return -1; + } + + lz4->in_pos += (INT)in_len; + + if (direct_out_len) { + lz4->stream_pos += direct_out_len; + return (INT)direct_out_len; + } + + in_len = in_avail - in_len; + } + + if (in_len > 0) { + if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0) + return 0; /* count 0 after frame as stream terminator */ + + amt = LZ4F_decompress(lz4->dctx, + lz4->out_buffer, &out_len, + lz4->in_buffer + lz4->in_pos, &in_len, + NULL); + lz4->frame_ended = (amt == 0); + + if (LZ4F_isError(amt)) { + lz4->err = Z_STREAM_ERROR; + return -1; + } + + lz4->in_pos += (INT)in_len; + lz4->out_len = (INT)out_len; + lz4->out_pos = 0; + } + } else { + /* EOF on read */ + break; + } + } + + if (lz4->out_pos < lz4->out_len) { + UINT amt = lz4->out_len - lz4->out_pos; + if (amt > count) amt = count; + memcpy(buffer, lz4->out_buffer + lz4->out_pos, amt); + lz4->out_pos += amt; + lz4->stream_pos += amt; + return amt; + } + + return 0; +} + +INT S_glzread(glzFile glz, void *buffer, UINT count) { + switch (glz->format) { + case COMPRESS_GZIP: + return gzread(glz->gz, buffer, count); + case COMPRESS_LZ4: + return glzread_lz4(glz->lz4_in, buffer, count); + default: + S_error1("S_glzread", "unexpected compress format ~s", Sinteger(glz->format)); + return -1; + } +} + +static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count) { + ptr tc = get_thread_context(); + sized_buffer *cached_out_buffer; + char *out_buffer; + INT out_len, out_pos; + INT r = 0; + + /* allocate one out_buffer (per thread) since we don't need one for each file. + the buffer is freed by destroy_thread. */ + if ((cached_out_buffer = LZ4OUTBUFFER(tc)) == NULL || cached_out_buffer->size < lz4->out_buffer_size) { + if (cached_out_buffer != NULL) free(cached_out_buffer); + if ((LZ4OUTBUFFER(tc) = cached_out_buffer = malloc(sizeof(sized_buffer) + lz4->out_buffer_size)) == NULL) return -1; + cached_out_buffer->size = lz4->out_buffer_size; + } + out_buffer = cached_out_buffer->buffer; + + out_len = (INT)LZ4F_compressFrame(out_buffer, lz4->out_buffer_size, + buffer, count, + &lz4->preferences); + if (LZ4F_isError(out_len)) { + lz4->err = Z_STREAM_ERROR; + return -1; + } + + out_pos = 0; + while (out_pos < out_len) { + r = WIN32_IZE(write)(lz4->fd, out_buffer + out_pos, out_len - out_pos); + if (r >= 0) + out_pos += r; +#ifdef EINTR + else if (errno == EINTR) + continue; +#endif + else + break; + } + + return r; +} + +static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count) { + UINT amt; INT r; + + if ((amt = LZ4_OUTPUT_PORT_IN_BUFFER_SIZE - lz4->in_pos) > count) amt = count; + + if (amt == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) { + /* full buffer coming from input...skip the memcpy */ + if ((r = glzemit_lz4(lz4, buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0; + } else { + memcpy(lz4->in_buffer + lz4->in_pos, buffer, amt); + if ((lz4->in_pos += amt) == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) { + lz4->in_pos = 0; + if ((r = glzemit_lz4(lz4, lz4->in_buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0; + } + } + + lz4->stream_pos += amt; + return amt; +} + +INT S_glzwrite(glzFile glz, void *buffer, UINT count) { + switch (glz->format) { + case COMPRESS_GZIP: + return gzwrite(glz->gz, buffer, count); + case COMPRESS_LZ4: + return glzwrite_lz4(glz->lz4_out, buffer, count); + default: + S_error1("S_glzwrite", "unexpected compress format ~s", Sinteger(glz->format)); + return -1; + } +} + +long S_glzseek(glzFile glz, long offset, INT whence) { + switch (glz->format) { + case COMPRESS_GZIP: + return gzseek(glz->gz, offset, whence); + case COMPRESS_LZ4: + if (glz->inputp) { + lz4File_in *lz4 = glz->lz4_in; + if (whence == SEEK_CUR) + offset += (long)lz4->stream_pos; + if (offset < 0) + offset = 0; + if ((size_t)offset < lz4->stream_pos) { + /* rewind and read from start */ + if (WIN32_IZE(lseek)(lz4->fd, lz4->init_pos, SEEK_SET) < 0) { + lz4->err = Z_ERRNO; + return -1; + } + LZ4F_resetDecompressionContext(lz4->dctx); + lz4->in_pos = 0; + lz4->in_len = 0; + lz4->out_len = 0; + lz4->out_pos = 0; + lz4->err = 0; + lz4->stream_pos = 0; + } + while ((size_t)offset > lz4->stream_pos) { + static char buffer[1024]; + size_t amt = (size_t)offset - lz4->stream_pos; + if (amt > sizeof(buffer)) amt = sizeof(buffer); + if (glzread_lz4(lz4, buffer, (UINT)amt) < 0) + return -1; + } + return (long)lz4->stream_pos; + } else { + lz4File_out *lz4 = glz->lz4_out; + if (whence == SEEK_CUR) + offset += (long)lz4->stream_pos; + if (offset >= 0) { + while ((size_t)offset > lz4->stream_pos) { + size_t amt = (size_t)offset - lz4->stream_pos; + if (amt > 8) amt = 8; + if (glzwrite_lz4(lz4, "\0\0\0\0\0\0\0\0", (UINT)amt) < 0) + return -1; + } + } + return (long)lz4->stream_pos; + } + default: + S_error1("S_glzseek", "unexpected compress format ~s", Sinteger(glz->format)); + return -1; + } +} + +INT S_glzgetc(glzFile glz) { + switch (glz->format) { + case COMPRESS_GZIP: + return gzgetc(glz->gz); + case COMPRESS_LZ4: + { + unsigned char buffer[1]; + INT r; + r = S_glzread(glz, buffer, 1); + if (r == 1) + return buffer[0]; + else + return -1; + } + default: + S_error1("S_glzgetc", "unexpected compress format ~s", Sinteger(glz->format)); + return -1; + } +} + +INT S_glzungetc(INT c, glzFile glz) { + switch (glz->format) { + case COMPRESS_GZIP: + return gzungetc(c, glz->gz); + case COMPRESS_LZ4: + { + lz4File_in *lz4 = glz->lz4_in; + if (lz4->out_len == 0) + lz4->out_len = lz4->out_pos = 1; + if (lz4->out_pos) { + lz4->out_pos--; + lz4->out_buffer[lz4->out_pos] = c; + lz4->stream_pos--; + return c; + } else { + /* support ungetc only just after a getc, in which case there + should have been room */ + return -1; + } + } + default: + S_error1("S_glzungetc", "unexpected compress format ~s", Sinteger(glz->format)); + return -1; + } +} + +INT S_glzrewind(glzFile glz) { + return S_glzseek(glz, 0, SEEK_SET); +} + +void S_glzerror(glzFile glz, INT *errnum) { + switch (glz->format) { + case COMPRESS_GZIP: + (void)gzerror(glz->gz, errnum); + break; + case COMPRESS_LZ4: + if (glz->inputp) + *errnum = glz->lz4_in->err; + else + *errnum = glz->lz4_out->err; + break; + default: + S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format)); + *errnum = 0; + } +} + +void S_glzclearerr(glzFile glz) { + switch (glz->format) { + case COMPRESS_GZIP: + gzclearerr(glz->gz); + break; + case COMPRESS_LZ4: + if (glz->inputp) + glz->lz4_in->err = 0; + else + glz->lz4_out->err = 0; + break; + default: + S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format)); + } +} diff --git a/c/compress-io.h b/c/compress-io.h new file mode 100644 index 0000000..a5f988b --- /dev/null +++ b/c/compress-io.h @@ -0,0 +1,26 @@ +/* compress-io.h + * Copyright 1984-2019 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +typedef struct glzFile_r { + INT fd; + IBOOL inputp; + INT format; + union { + struct gzFile_s *gz; + struct lz4File_in_r *lz4_in; + struct lz4File_out_r *lz4_out; + }; +} *glzFile; diff --git a/c/cs.ico b/c/cs.ico new file mode 100644 index 0000000..58faf11 Binary files /dev/null and b/c/cs.ico differ diff --git a/c/expeditor.c b/c/expeditor.c new file mode 100644 index 0000000..c148e96 --- /dev/null +++ b/c/expeditor.c @@ -0,0 +1,1087 @@ +/* expeditor.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +#ifdef FEATURE_EXPEDITOR + +/* locally defined functions */ +static IBOOL s_ee_init_term(void); +static ptr s_ee_read_char(IBOOL blockp); +static void s_ee_write_char(wchar_t c); +static void s_ee_flush(void); +static ptr s_ee_get_screen_size(void); +static void s_ee_raw(void); +static void s_ee_noraw(void); +static void s_ee_enter_am_mode(void); +static void s_ee_exit_am_mode(void); +static void s_ee_pause(void); +static void s_ee_nanosleep(U32 secs, U32 nanosecs); +static ptr s_ee_get_clipboard(void); +static void s_ee_up(I32); +static void s_ee_down(I32); +static void s_ee_left(I32); +static void s_ee_right(I32); +static void s_ee_clear_eol(void); +static void s_ee_clear_eos(void); +static void s_ee_clear_screen(void); +static void s_ee_scroll_reverse(I32); +static void s_ee_bell(void); +static void s_ee_carriage_return(void); +static void s_ee_line_feed(void); + +static INT init_status = -1; + +#ifdef WIN32 + +#include +#include + +static HANDLE hStdout, hStdin; +static DWORD InMode, OutMode; + +static IBOOL s_ee_init_term(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + + if (init_status != -1) return init_status; + + init_status = + (hStdin = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE + && (hStdout = GetStdHandle(STD_OUTPUT_HANDLE)) != INVALID_HANDLE_VALUE + && GetConsoleScreenBufferInfo(hStdout, &csbiInfo) + && GetConsoleMode(hStdin, &InMode) + && GetConsoleMode(hStdout, &OutMode); + + return init_status; +} + +/* returns char, eof, #t (winched), or #f (nothing ready), the latter + only if blockp is false */ +static ptr s_ee_read_char(IBOOL blockp) { + DWORD cNumRead; + INPUT_RECORD irInBuf[1]; +#ifdef PTHREADS + ptr tc; +#endif /* PTHREADS */ + BOOL succ; + static wchar_t buf[10]; + static int bufidx = 0; + static int buflen = 0; + static int rptcnt = 0; + + for (;;) { + if (buflen != 0) { + int i = bufidx++; + if (bufidx == buflen) { + bufidx = 0; + if (--rptcnt == 0) buflen = 0; + } + return Schar(buf[i]); + } + + if (!blockp) { + DWORD NumberOfEvents; + if (!GetNumberOfConsoleInputEvents(hStdin, &NumberOfEvents)) + S_error1("expeditor", "error getting console input: ~a", + S_LastErrorString()); + if (NumberOfEvents == 0) return Sfalse; + } + +#ifdef PTHREADS + tc = get_thread_context(); + if (DISABLECOUNT(tc) == FIX(0)) { + deactivate_thread(tc); + succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead); + reactivate_thread(tc); + } else { + succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead); + } +#else /* PTHREADS */ + succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead); +#endif /* PTHREADS */ + + + if (!succ) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + if (cNumRead == 0) return Seof_object; + + switch(irInBuf[0].EventType) { + case KEY_EVENT: { + KEY_EVENT_RECORD ker = irInBuf[0].Event.KeyEvent; + rptcnt = ker.wRepeatCount; + if (ker.bKeyDown) { + wchar_t c; + + if (c = ker.uChar.UnicodeChar) { + /* translate ^ to nul */ + if (c == 0x20 && (ker.dwControlKeyState & (LEFT_CTRL_PRESSED|RIGHT_CTRL_PRESSED))) + buf[0] = 0; + else + buf[0] = c; + buflen = 1; + } else { + switch (ker.wVirtualKeyCode) { + case VK_DELETE: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = '3'; + buf[3] = '~'; + buflen = 4; + break; + case VK_NEXT: /* page-down */ + buf[0] = '\033'; + buf[1] = '['; + buf[2] = '6'; + buf[3] = '~'; + buflen = 4; + break; + case VK_PRIOR: /* page-up */ + buf[0] = '\033'; + buf[1] = '['; + buf[2] = '5'; + buf[3] = '~'; + buflen = 4; + break; + case VK_END: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = 'F'; + buflen = 3; + break; + case VK_HOME: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = 'H'; + buflen = 3; + break; + case VK_LEFT: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = 'D'; + buflen = 3; + break; + case VK_UP: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = 'A'; + buflen = 3; + break; + case VK_RIGHT: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = 'C'; + buflen = 3; + break; + case VK_DOWN: + buf[0] = '\033'; + buf[1] = '['; + buf[2] = 'B'; + buflen = 3; + break; + /* translate ^@ to nul */ + case 0x32: + if (ker.dwControlKeyState & (LEFT_CTRL_PRESSED|RIGHT_CTRL_PRESSED)) { + buf[0] = 0; + buflen = 1; + } + break; + default: + break; + } + } + } + break; + } + + /* this tells us when the buffer size changes, but nothing comes through + when the window size changes. */ + case WINDOW_BUFFER_SIZE_EVENT: // scrn buf. resizing + return Strue; + + default: + break; + } + } +} + +/* probably need write-char too */ + +static ptr s_ee_get_screen_size(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + return Scons(Sinteger(csbiInfo.srWindow.Bottom - csbiInfo.srWindow.Top + 1), + Sinteger(csbiInfo.srWindow.Right - csbiInfo.srWindow.Left + 1)); +} + +static void s_ee_raw(void) { + /* see http://msdn2.microsoft.com/en-us/library/ms686033.aspx */ + if (!SetConsoleMode(hStdin, ENABLE_WINDOW_INPUT) + || !SetConsoleMode(hStdout, 0)) + S_error1("expeditor", "error setting console mode: ~a", + S_LastErrorString()); +} + +static void s_ee_noraw(void) { + if (!SetConsoleMode(hStdin, InMode) || !SetConsoleMode(hStdout, OutMode)) + S_error1("expeditor", "error setting console mode: ~a", + S_LastErrorString()); +} + +static void s_ee_enter_am_mode(void) { return; } + +static void s_ee_exit_am_mode(void) { return; } + +static void s_ee_pause(void) { return; } + +static void s_ee_nanosleep(U32 secs, U32 nanosecs) { + Sleep((secs * 1000) + (nanosecs / 1000000)); +} + +static void s_ee_up(I32 n) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + COORD cursor_pos; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + cursor_pos.X = csbiInfo.dwCursorPosition.X; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y - n; + + /* ignore error, which can occur only if someone else screwed with screen */ + SetConsoleCursorPosition(hStdout, cursor_pos); +} + +static void s_ee_down(I32 n) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + COORD cursor_pos; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + cursor_pos.X = csbiInfo.dwCursorPosition.X; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y + n; + + /* ignore error, which can occur only if someone else screwed with screen */ + SetConsoleCursorPosition(hStdout, cursor_pos); +} + +static void s_ee_left(I32 n) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + COORD cursor_pos; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + cursor_pos.X = csbiInfo.dwCursorPosition.X - n; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y; + + /* ignore error, which can occur only if someone else screwed with screen */ + SetConsoleCursorPosition(hStdout, cursor_pos); +} + +static void s_ee_right(I32 n) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + COORD cursor_pos; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + cursor_pos.X = csbiInfo.dwCursorPosition.X + n; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y; + + /* ignore error, which can occur only if someone else screwed with screen */ + SetConsoleCursorPosition(hStdout, cursor_pos); +} + +static void s_ee_clear_eol(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + DWORD ntowrite, numwritten; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + ntowrite = csbiInfo.dwSize.X - csbiInfo.dwCursorPosition.X; + + if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ', + ntowrite, csbiInfo.dwCursorPosition, &numwritten)) + S_error1("expeditor", "error clearing section of screen buffer: ~a", + S_LastErrorString()); + + if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes, + ntowrite, csbiInfo.dwCursorPosition, &numwritten)) + S_error1("expeditor", "error setting attributes in section of screen buffer: ~a", + S_LastErrorString()); +} + +static void s_ee_clear_eos(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + DWORD ntowrite, numwritten; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + ntowrite = (csbiInfo.dwSize.X - csbiInfo.dwCursorPosition.X) + + (csbiInfo.dwSize.X * + (csbiInfo.dwSize.Y - csbiInfo.dwCursorPosition.Y - 1)); + + if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ', + ntowrite, csbiInfo.dwCursorPosition, &numwritten)) + S_error1("expeditor", "error clearing section of screen buffer: ~a", + S_LastErrorString()); + + if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes, + ntowrite, csbiInfo.dwCursorPosition, &numwritten)) + S_error1("expeditor", "error setting attributes in section of screen buffer: ~a", + S_LastErrorString()); +} + +static void s_ee_clear_screen(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + COORD cursor_pos; + DWORD ntowrite, numwritten; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + cursor_pos.X = 0; + cursor_pos.Y = csbiInfo.srWindow.Top; + SetConsoleCursorPosition(hStdout, cursor_pos); + + ntowrite = csbiInfo.dwSize.X * (csbiInfo.dwSize.Y - cursor_pos.Y); + + if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ', + ntowrite, cursor_pos, &numwritten)) + S_error1("expeditor", "error clearing section of screen buffer: ~a", + S_LastErrorString()); + + if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes, + ntowrite, cursor_pos, &numwritten)) + S_error1("expeditor", "error setting attributes in section of screen buffer: ~a", + S_LastErrorString()); +} + +static void s_ee_scroll_reverse(I32 n) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + if (csbiInfo.dwCursorPosition.Y - n < 0) { + SMALL_RECT rect; + COORD dest; + CHAR_INFO fill; + + /* set fill to blank so new top lines will be cleared */ + fill.Attributes = csbiInfo.wAttributes; + fill.Char.AsciiChar = (char)' '; + + /* move lines 0 through N-n-1 down to lines n through N-1 */ + rect.Top = 0; + rect.Bottom = csbiInfo.dwSize.Y - n - 1; + rect.Left = 0; + rect.Right = csbiInfo.dwSize.X - 1; + dest.X = 0; + dest.Y = n; + if (!ScrollConsoleScreenBuffer(hStdout, &rect, (SMALL_RECT *)0, dest, &fill)) + S_error1("expeditor", "error scrolling screen buffer: ~a", + S_LastErrorString()); + } else { + COORD cursor_pos; DWORD numwritten; + + cursor_pos.X = csbiInfo.dwCursorPosition.X; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y - n; + SetConsoleCursorPosition(hStdout, cursor_pos); + + if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ', + csbiInfo.dwSize.X * n, cursor_pos, &numwritten)) + S_error1("expeditor", "error clearing section of screen buffer: ~a", + S_LastErrorString()); + + if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes, + csbiInfo.dwSize.X * n, cursor_pos, &numwritten)) + S_error1("expeditor", "error setting attributes in section of screen buffer: ~a", + S_LastErrorString()); + } +} + +static void s_ee_bell(void) { + MessageBeep(MB_OK); +} + +static void s_ee_carriage_return(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + COORD cursor_pos; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + cursor_pos.X = 0; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y; + + SetConsoleCursorPosition(hStdout, cursor_pos); +} + +static void s_ee_line_feed(void) { + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + + fflush(stdout); + + if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo)) + S_error1("expeditor", "error getting console info: ~a", + S_LastErrorString()); + + if (csbiInfo.dwCursorPosition.Y == (csbiInfo.dwSize.Y - 1)) { + SMALL_RECT rect; + COORD dest; + CHAR_INFO fill; + + /* set fill to blank so new bottom line will be cleared */ + fill.Attributes = csbiInfo.wAttributes; + fill.Char.AsciiChar = (char)' '; + + /* move lines 1 through N-1 up to lines 0 through N-2 */ + rect.Top = 1; + rect.Bottom = csbiInfo.dwSize.Y - 1; + rect.Left = 0; + rect.Right = csbiInfo.dwSize.X - 1; + dest.X = 0; + dest.Y = 0; + if (!ScrollConsoleScreenBuffer(hStdout, &rect, (SMALL_RECT *)0, dest, &fill)) + S_error1("expeditor", "error scrolling screen buffer: ~a", + S_LastErrorString()); + } else { + COORD cursor_pos; + + cursor_pos.X = csbiInfo.dwCursorPosition.X; + cursor_pos.Y = csbiInfo.dwCursorPosition.Y + 1; + SetConsoleCursorPosition(hStdout, cursor_pos); + } +} + +static ptr s_ee_get_clipboard(void) { + ptr x = S_G.null_string; + + if (OpenClipboard((HWND)0)) { + HANDLE h = GetClipboardData(CF_UNICODETEXT); + if (h != NULL) { + wchar_t *w = (wchar_t*)GlobalLock(h); + if (w != NULL) { + char *s = Swide_to_utf8(w); + x = Sstring_utf8(s, -1); + free(s); + GlobalUnlock(h); + } + } + CloseClipboard(); + } + + return x; +} + +static void s_ee_write_char(wchar_t c) { + DWORD n; + WriteConsoleW(hStdout, &c, 1, &n, NULL); +} + +#else /* WIN32 */ +#include +#ifdef DISABLE_CURSES +#include "nocurses.h" +#elif defined(SOLARIS) +#define NCURSES_CONST +#define CHTYPE int +#include +#include +#elif defined(NETBSD) +#include +#include +#else /* NETBSD */ +#include +#include +#endif /* SOLARIS */ +#include +#include +#include +#include +#include +#include +#if !defined(__linux__) && !defined(__OpenBSD__) && !defined(__NetBSD__) +#include +#endif + +#if defined(TIOCGWINSZ) && defined(SIGWINCH) && defined(EINTR) +#define HANDLE_SIGWINCH +#endif + +#ifdef USE_MBRTOWC_L +static locale_t the_locale; +static locale_t uselocale_alt(locale_t l) { + locale_t old = the_locale; + the_locale = l; + return old; +} +# define uselocale(v) uselocale_alt(v) +# define mbrtowc(pwc, s, n, ps) mbrtowc_l(pwc, s, n, ps, the_locale) +#endif + +/* locally defined functions */ +static int eeputc(tputsputcchar c); +#ifdef HANDLE_SIGWINCH +static void handle_sigwinch(int sig); +#endif + +#ifdef HANDLE_SIGWINCH +static IBOOL winched = 0; +static void handle_sigwinch(UNUSED int sig) { + winched = 1; +} +#endif + +#define STDIN_FD 0 +#define STDOUT_FD 1 + +static IBOOL disable_auto_margin = 0, avoid_last_column = 0; +static locale_t term_locale; +static mbstate_t term_in_mbs; +static mbstate_t term_out_mbs; + +static IBOOL s_ee_init_term(void) { + int errret; + + if (init_status != -1) return init_status; + + if (isatty(STDIN_FD) + && isatty(STDOUT_FD) + && setupterm(NULL, STDOUT_FD, &errret) != ERR +/* assuming here and in our optproc definitions later that the names of + missing capabilities are set to NULL, although this does not appear + to be documented */ + && cursor_up + && cursor_down + && cursor_left + && cursor_right + && clr_eol + && clr_eos + && clear_screen + && scroll_reverse + && carriage_return) { + if (auto_right_margin) { + /* terminal automatically wraps. safest to disable if possible */ + if (exit_am_mode && enter_am_mode) { + disable_auto_margin = 1; + avoid_last_column = 0; + /* can't disable automatic margins, but eat_newline_glitch is set. + may still be okay, since we never write past the last column, + and the automatic newline should be emitted only if we do. but + see hack in s_ee_enter_am_mode */ + } else if (eat_newline_glitch) { + disable_auto_margin = 0; + avoid_last_column = 0; + } else { + disable_auto_margin = 0; + avoid_last_column = 1; + } + } else { + disable_auto_margin = 0; + avoid_last_column = 0; + } + +#ifdef HANDLE_SIGWINCH + struct sigaction act; + + sigemptyset(&act.sa_mask); + + act.sa_flags = 0; + act.sa_handler = handle_sigwinch; + sigaction(SIGWINCH, &act, (struct sigaction *)0); +#endif + + term_locale = newlocale(LC_ALL_MASK, "", NULL); + memset(&term_out_mbs, 0, sizeof(term_out_mbs)); + memset(&term_in_mbs, 0, sizeof(term_in_mbs)); + + init_status = 1; + } else { + init_status = 0; + } + + return init_status; +} + +/* returns char, eof, #t (winched), or #f (nothing ready), the latter + only if blockp is false */ +static ptr s_ee_read_char(IBOOL blockp) { + ptr msg; int fd = STDIN_FD; int n; char buf[1]; wchar_t wch; size_t sz; + locale_t old_locale; +#ifdef PTHREADS + ptr tc = get_thread_context(); +#endif + + do { +#ifdef HANDLE_SIGWINCH + if (winched) { winched = 0; return Strue; } +#endif +#ifdef PTHREADS + if (!blockp || DISABLECOUNT(tc) == FIX(0)) { + fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | NOBLOCK); + n = READ(fd, buf, 1); + fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) & ~NOBLOCK); + if (n < 0 && errno == EWOULDBLOCK) { + if (!blockp) return Sfalse; + deactivate_thread(tc); + n = READ(fd, buf, 1); + reactivate_thread(tc); + } + } else { + n = READ(fd, buf, 1); + } +#else /* PTHREADS */ + if (!blockp) { + fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | NOBLOCK); + n = READ(fd, buf, 1); + fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) & ~NOBLOCK); + if (n < 0 && errno == EWOULDBLOCK) return Sfalse; + } else { + n = READ(fd, buf, 1); + } +#endif /* PTHREADS */ + + if (n == 1) { + if (buf[0] == '\0') { + return Schar('\0'); + } else { + old_locale = uselocale(term_locale); + sz = mbrtowc(&wch, buf, 1, &term_out_mbs); + uselocale(old_locale); + if (sz == 1) { + return Schar(wch); + } + } + } + + } while ((n < 0 && errno == EINTR) || (n == 1 && sz == (size_t)-2)); + + if (n == 0) return Seof_object; + + msg = S_strerror(errno); + S_error1("expeditor", "error reading from console: ~a", msg); + + memset(&term_out_mbs, 0, sizeof(term_out_mbs)); + return Svoid; +} + +/* returns a pair of positive integers */ +static ptr s_ee_get_screen_size(void) { + static INT ee_rows = 0; + static INT ee_cols = 0; + +#ifdef TIOCGWINSZ + struct winsize ws; + if (ioctl(STDOUT_FD, TIOCGWINSZ, &ws) == 0) { + if (ws.ws_row > 0) ee_rows = ws.ws_row; + if (ws.ws_col > 0) ee_cols = ws.ws_col; + } +#ifdef MACOSX + static IBOOL tried_resize = 0; + /* attempt to work around 10.6 tty driver / xterm bug */ + if (ee_rows == 0 && ee_cols == 0 && !tried_resize) { + system("exec /usr/X11/bin/resize >& /dev/null"); + tried_resize = 1; + return s_ee_get_screen_size(); + } +#endif /* MACOSX */ +#endif /* TIOCGWINSZ */ + + if (ee_rows == 0) { + char *s, *endp; + if ((s = getenv("LINES")) != NULL) { + INT n = (int)strtol(s, &endp, 10); + if (n > 0 && *endp == '\0') ee_rows = n; + } + if (ee_rows == 0) ee_rows = lines > 0 ? lines : 24; + } + + if (ee_cols == 0) { + char *s, *endp; + if ((s = getenv("COLUMNS")) != NULL) { + INT n = (int)strtol(s, &endp, 10); + if (n > 0 && *endp == '\0') ee_cols = n; + } + if (ee_cols == 0) ee_cols = columns > 0 ? columns : 80; + } + + return Scons(Sinteger(ee_rows), Sinteger(ee_cols > 1 && avoid_last_column ? ee_cols - 1 : ee_cols)); +} + +static int eeputc(tputsputcchar c) { + return putchar(c); +} + +static struct termios orig_termios; + +static void s_ee_raw(void) { + struct termios new_termios; + while (tcgetattr(STDIN_FD, &orig_termios) != 0) { + if (errno != EINTR) { + ptr msg = S_strerror(errno); + if (msg != Sfalse) + S_error1("expeditor", "error entering raw mode: ~a", msg); + else + S_error("expeditor", "error entering raw mode"); + } + } + new_termios = orig_termios; + + /* essentially want "stty raw -echo". the appropriate flags to accomplish + this were determined by studying the gnu/linux stty and termios man + pages, with particular attention to the cfmakeraw function. */ + new_termios.c_iflag &= ~(IGNBRK|BRKINT|PARMRK|INPCK|ISTRIP + |INLCR|IGNCR|ICRNL|IXON); + new_termios.c_oflag &= ~(OPOST); + new_termios.c_lflag &= ~(ISIG|ICANON|ECHO|IEXTEN); + new_termios.c_cflag &= ~(CSIZE|PARENB); + new_termios.c_cflag |= CS8; + new_termios.c_cc[VMIN] = 1; + new_termios.c_cc[VTIME] = 0; + + while (tcsetattr(STDIN_FD, TCSADRAIN, &new_termios) != 0) { + if (errno != EINTR) { + ptr msg = S_strerror(errno); + if (msg != Sfalse) + S_error1("expeditor", "error entering raw mode: ~a", msg); + else + S_error("expeditor", "error entering raw mode"); + } + } +} + +static void s_ee_noraw(void) { + while (tcsetattr(STDIN_FD, TCSADRAIN, &orig_termios) != 0) { + if (errno != EINTR) { + ptr msg = S_strerror(errno); + if (msg != Sfalse) + S_error1("expeditor", "error leaving raw mode: ~a", msg); + else + S_error("expeditor", "error leaving raw mode"); + } + } +} + +static void s_ee_enter_am_mode(void) { + if (disable_auto_margin) { + tputs(enter_am_mode, 1, eeputc); + /* flush to minimize time span when automatic margins are disabled */ + fflush(stdout); + } else if (eat_newline_glitch) { + /* hack: try to prevent terminal from eating subsequent cr or lf. + assumes we've just written to last column. probably works only + for vt100 interpretation of eat_newline_glitch/xn/xenl flag. */ + tputs(cursor_left, 1, eeputc); + tputs(cursor_right, 1, eeputc); + } +} + +static void s_ee_exit_am_mode(void) { + if (disable_auto_margin) { + tputs(exit_am_mode, 1, eeputc); + } +} + +static void s_ee_pause(void) { /* used to handle ^Z */ + fflush(stdout); + kill(0, SIGTSTP); +} + +static void s_ee_nanosleep(U32 secs, U32 nanosecs) { + struct timespec ts; + ts.tv_sec = secs; + ts.tv_nsec = nanosecs; + nanosleep(&ts, (struct timespec *)0); +} + +static void s_ee_up(I32 n) { + while (n--) tputs(cursor_up, 1, eeputc); +} + +static void s_ee_down(I32 n) { + while (n--) tputs(cursor_down, 1, eeputc); +} + +static void s_ee_left(I32 n) { + while (n--) tputs(cursor_left, 1, eeputc); +} + +static void s_ee_right(I32 n) { + while (n--) tputs(cursor_right, 1, eeputc); +} + +static void s_ee_clear_eol(void) { + tputs(clr_eol, 1, eeputc); +} + +static void s_ee_clear_eos(void) { + tputs(clr_eos, 1, eeputc); +} + +static void s_ee_clear_screen(void) { + tputs(clear_screen, 1, eeputc); +} + +static void s_ee_scroll_reverse(I32 n) { + /* moving up from an entry that was only partially displayed, + scroll-reverse may be called when cursor isn't at the top line of + the screen, in which case we hope it will move up by one line. + in this case, which we have no way of distinguishing from the normal + case, scroll-reverse needs to clear the line explicitly */ + while (n--) { + tputs(scroll_reverse, 1, eeputc); + tputs(clr_eol, 1, eeputc); + } +} + +static void s_ee_bell(void) { + tputs(bell, 1, eeputc); +} + +static void s_ee_carriage_return(void) { + tputs(carriage_return, 1, eeputc); +} + +/* move-line-down doesn't scroll the screen when performed on the last + line on the freebsd and openbsd consoles. the official way to scroll + the screen is to use scroll-forward (ind), but ind is defined only + at the bottom left corner of the screen, and we don't always know + where the bottom of the screen actually is. so we write a line-feed + (newline) character and hope that will do the job. */ +static void s_ee_line_feed(void) { + putchar(0x0a); +} + +#ifdef LIBX11 +#include +#include +#include +#include +#endif /* LIBX11 */ + +static ptr s_ee_get_clipboard(void) { +#ifdef LIBX11 + static enum {UNINITIALIZED, INITIALIZED, FAILED} status = UNINITIALIZED; + static int (*pXConvertSelection)(Display *, Atom, Atom, Atom, Window, Time); + static int (*pXPending)(Display *display); + static int (*pXNextEvent)(Display *, XEvent *); + static int (*pXGetWindowProperty)(Display *, Window, Atom, long, long, Bool, Atom, Atom *, int *, unsigned long *, unsigned long *, unsigned char **); + static int (*pXFree)(void *); + + static Display *D; + static Window R, W; +#endif /* LIBX11 */ + + ptr p = S_G.null_string; + +#ifdef LIBX11 + if (status == UNINITIALIZED) { + char *display_name; + void *handle; + Display *(*pXOpenDisplay)(char *); + Window (*pXDefaultRootWindow)(Display *); + Window (*pXCreateSimpleWindow)(Display *, Window, int, int, unsigned int, unsigned int, unsigned int, unsigned long, unsigned long); + + status = (display_name = getenv("DISPLAY")) + && (handle = dlopen(LIBX11, RTLD_NOW)) + && (pXOpenDisplay = (Display *(*)(char *display_name))dlsym(handle, "XOpenDisplay")) + && (pXDefaultRootWindow = (Window (*)(Display *))dlsym(handle, "XDefaultRootWindow")) + && (pXCreateSimpleWindow = (Window (*)(Display *, Window, int, int, unsigned int, unsigned int, unsigned int, unsigned long, unsigned long))dlsym(handle, "XCreateSimpleWindow")) + && (pXConvertSelection = (int (*)(Display *, Atom, Atom, Atom, Window, Time))dlsym(handle, "XConvertSelection")) + && (pXPending = (int (*)(Display *display))dlsym(handle, "XPending")) + && (pXNextEvent = (int (*)(Display *, XEvent *))dlsym(handle, "XNextEvent")) + && (pXGetWindowProperty = (int (*)(Display *, Window, Atom, long, long, Bool, Atom, Atom *, int *, unsigned long *, unsigned long *, unsigned char **))dlsym(handle, "XGetWindowProperty")) + && (pXFree = (int (*)(void *))dlsym(handle, "XFree")) + && (D = pXOpenDisplay(display_name)) + && (R = pXDefaultRootWindow(D)) + && (W = pXCreateSimpleWindow(D, R, 0, 0, 1, 1, 0, 0, 0)) + ? INITIALIZED : FAILED; + } + + if (status == INITIALIZED) { + XEvent XE; + Window W2; Atom P; + Atom type; + int format; + unsigned long items, bytes, ignore_bytes; + unsigned char *buf; + int timeout; + + /* flush late arrivals from previous requests, if any */ + while (pXPending(D)) pXNextEvent(D, &XE); + + pXConvertSelection(D, XA_PRIMARY, XA_STRING, XA_STRING, W, CurrentTime); + + /* mini event loop to catch response, if any */ + timeout = 20; /* wait two seconds, 100ms at a time */ + for (;;) { + if (pXPending(D)) { + pXNextEvent(D, &XE); + if (XE.type == SelectionNotify) { + if (XE.xselection.property == None) { + W2 = R; + P = XA_CUT_BUFFER0; + } else { + W2 = XE.xselection.requestor; + P = XE.xselection.property; + } + + if (pXGetWindowProperty(D, W2, P, 0, 0, 0, AnyPropertyType, + &type, &format, &items, &bytes, &buf) == Success + && type == XA_STRING + && format == 8) { + pXFree(buf); + if (pXGetWindowProperty(D, W2, P, 0, bytes, 0, AnyPropertyType, + &type, &format, &items, &ignore_bytes, &buf) == Success + && type == XA_STRING + && format == 8) { + p = S_string((char *)buf, (iptr)bytes); + } + } + + pXFree(buf); + + break; + } + } else { + int xfd; + fd_set rfds; + struct timeval tv; + + if (timeout == 0) break; + xfd = ConnectionNumber(D); + FD_ZERO(&rfds); + FD_SET(xfd, &rfds); + tv.tv_sec = 0; + tv.tv_usec = 100*1000; + select(xfd+1, &rfds, NULL, NULL, &tv); + timeout -= 1; + } + } + } +#endif /* LIBX11 */ + +#ifdef MACOSX +#define PBPASTEBUFSIZE 1024 + if (p == S_G.null_string) { + char buf[PBPASTEBUFSIZE]; + FILE *f = popen("/usr/bin/pbpaste", "r"); + iptr i, n, m; + char *s; + + for (;;) { + ptr newp; + n = fread(buf, 1, PBPASTEBUFSIZE, f); + if (n == 0) break; + n += (m = Sstring_length(p)); + newp = S_string(NULL, n); + for (i = 0; i != m; i += 1) Sstring_set(newp, i, Sstring_ref(p, i)); + for (s = buf; i != n; i += 1, s += 1) + Sstring_set(newp, i, *s); + p = newp; + } + + fclose(f); + } +#endif /* MACOSX */ + + return p; +} + +static void s_ee_write_char(wchar_t wch) { + locale_t old; char buf[MB_LEN_MAX]; size_t n; + + old = uselocale(term_locale); + n = wcrtomb(buf, wch, &term_in_mbs); + if (n == (size_t)-1) { + putchar('?'); + } else { + fwrite(buf, 1, n, stdout); + } + uselocale(old); +} + +#endif /* WIN32 */ + +static void s_ee_flush(void) { + fflush(stdout); +} + +void S_expeditor_init(void) { + Sforeign_symbol("(cs)ee_init_term", (void *)s_ee_init_term); + Sforeign_symbol("(cs)ee_read_char", (void *)s_ee_read_char); + Sforeign_symbol("(cs)ee_write_char", (void *)s_ee_write_char); + Sforeign_symbol("(cs)ee_flush", (void *)s_ee_flush); + Sforeign_symbol("(cs)ee_get_screen_size", (void *)s_ee_get_screen_size); + Sforeign_symbol("(cs)ee_raw", (void *)s_ee_raw); + Sforeign_symbol("(cs)ee_noraw", (void *)s_ee_noraw); + Sforeign_symbol("(cs)ee_enter_am_mode", (void *)s_ee_enter_am_mode); + Sforeign_symbol("(cs)ee_exit_am_mode", (void *)s_ee_exit_am_mode); + Sforeign_symbol("(cs)ee_pause", (void *)s_ee_pause); + Sforeign_symbol("(cs)ee_nanosleep", (void *)s_ee_nanosleep); + Sforeign_symbol("(cs)ee_get_clipboard", (void *)s_ee_get_clipboard); + Sforeign_symbol("(cs)ee_up", (void *)s_ee_up); + Sforeign_symbol("(cs)ee_down", (void *)s_ee_down); + Sforeign_symbol("(cs)ee_left", (void *)s_ee_left); + Sforeign_symbol("(cs)ee_right", (void *)s_ee_right); + Sforeign_symbol("(cs)ee_clr_eol", (void *)s_ee_clear_eol); + Sforeign_symbol("(cs)ee_clr_eos", (void *)s_ee_clear_eos); + Sforeign_symbol("(cs)ee_clear_screen", (void *)s_ee_clear_screen); + Sforeign_symbol("(cs)ee_scroll_reverse", (void *)s_ee_scroll_reverse); + Sforeign_symbol("(cs)ee_bell", (void *)s_ee_bell); + Sforeign_symbol("(cs)ee_carriage_return", (void *)s_ee_carriage_return); + Sforeign_symbol("(cs)ee_line_feed", (void *)s_ee_line_feed); +} + +#endif /* FEATURE_EXPEDITOR */ diff --git a/c/externs.h b/c/externs.h new file mode 100644 index 0000000..773f030 --- /dev/null +++ b/c/externs.h @@ -0,0 +1,415 @@ +/* externs.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* This file sets up platform-dependent includes and extern declarations + * for Scheme globals not intended for use outside of the system (prefixed + * with S_). Scheme globals intended for use outside of the system + * (prefixed with S) are declared in scheme.h + */ + +#include +#include +#include +#include + +#ifndef WIN32 +#include + +#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx) +off64_t lseek64(int,off64_t,int); +#endif + +#endif + +#ifdef SOLARIS +#include +#include +#include +#endif + +#ifdef WIN32 +#include +#include /* for _getcwd */ +#include +#endif + +#if !defined(NORETURN) +# if defined(__GNUC__) || defined(__clang__) +# define NORETURN __attribute__((noreturn)) +# elif defined(_MSC_VER) +# define NORETURN __declspec(noreturn) +# else +# define NORETURN +# endif /* defined(__GNUC__) || defined(__clang__) */ +#endif /* !defined(NORETURN) */ + +/* external procedure declarations */ +/* prototypes gen. by ProtoGen Version 0.31 (Haydn Huntley) 1/18/93 */ + +/* alloc.c */ +extern void S_alloc_init(void); +extern void S_protect(ptr *p); +extern void S_reset_scheme_stack(ptr tc, iptr n); +extern void S_reset_allocation_pointer(ptr tc); +extern ptr S_compute_bytes_allocated(ptr xg, ptr xs); +extern ptr S_find_more_room(ISPC s, IGEN g, iptr n, ptr old); +extern void S_dirty_set(ptr *loc, ptr x); +extern void S_mark_card_dirty(uptr card, IGEN to_g); +extern void S_scan_dirty(ptr **p, ptr **endp); +extern void S_scan_remembered_set(void); +extern void S_get_more_room(void); +extern ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size); +extern ptr S_cons_in(ISPC s, IGEN g, ptr car, ptr cdr); +extern ptr S_symbol(ptr name); +extern ptr S_rational(ptr n, ptr d); +extern ptr S_tlc(ptr keyval, ptr tconc, ptr next); +extern ptr S_vector_in(ISPC s, IGEN g, iptr n); +extern ptr S_vector(iptr n); +extern ptr S_fxvector(iptr n); +extern ptr S_bytevector(iptr n); +extern ptr S_null_immutable_vector(void); +extern ptr S_null_immutable_fxvector(void); +extern ptr S_null_immutable_bytevector(void); +extern ptr S_null_immutable_string(void); +extern ptr S_record(iptr n); +extern ptr S_closure(ptr cod, iptr n); +extern ptr S_mkcontinuation(ISPC s, IGEN g, ptr nuate, ptr stack, + iptr length, iptr clength, ptr link, ptr ret, ptr winders); +extern ptr S_inexactnum(double rp, double ip); +extern ptr S_exactnum(ptr a, ptr b); +extern ptr S_thread(ptr tc); +extern ptr S_string(const char *s, iptr n); +extern ptr S_bignum(ptr tc, iptr n, IBOOL sign); +extern ptr S_code(ptr tc, iptr type, iptr n); +extern ptr S_relocation_table(iptr n); +extern ptr S_weak_cons(ptr car, ptr cdr); + +/* fasl.c */ +extern void S_fasl_init(void); +ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path); +ptr S_bv_fasl_read(ptr bv, ptr path); +ptr S_boot_read(INT fd, const char *path); +char *S_format_scheme_version(uptr n); +char *S_lookup_machine_type(uptr n); +extern void S_set_code_obj(char *who, IFASLCODE typ, ptr p, iptr n, + ptr x, iptr o); +extern ptr S_get_code_obj(IFASLCODE typ, ptr p, iptr n, iptr o); + +/* flushcache.c */ +extern void S_record_code_mod(ptr tc, uptr addr, uptr bytes); +extern void S_flush_instruction_cache(ptr tc); +extern void S_flushcache_init(void); + +/* foreign.c */ +extern void S_foreign_init(void); +extern void S_foreign_entry(void); + +/* gcwrapper.c */ +extern void S_ptr_tell(ptr p); +extern void S_addr_tell(ptr p); +extern void S_gc_init(void); +#ifndef WIN32 +extern void S_register_child_process(INT child); +#endif /* WIN32 */ +extern void S_fixup_counts(ptr counts); +extern void S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg); +extern void S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg); +extern void S_gc_init(void); +extern void S_set_maxgen(IGEN g); +extern IGEN S_maxgen(void); +extern void S_set_minfreegen(IGEN g); +extern IGEN S_minfreegen(void); +#ifndef WIN32 +extern void S_register_child_process(INT child); +#endif /* WIN32 */ +extern IBOOL S_enable_object_counts(void); +extern void S_set_enable_object_counts(IBOOL eoc); +extern ptr S_object_counts(void); +extern ptr S_locked_objects(void); +extern ptr S_unregister_guardian(ptr tconc); +extern void S_compact_heap(void); +extern void S_check_heap(IBOOL aftergc); + +/* gc-011.c */ +extern void S_gc_011(ptr tc); + +/* gc-ocd.c */ +extern void S_gc_ocd(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg); + +/* gc-oce.c */ +extern void S_gc_oce(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg); + +/* intern.c */ +extern void S_intern_init(void); +extern void S_resize_oblist(void); +extern ptr S_intern(const unsigned char *s); +extern ptr S_intern_sc(const string_char *s, iptr n, ptr name_str); +extern ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uame_str); +extern void S_intern_gensym(ptr g); +extern void S_retrofit_nonprocedure_code(void); + +/* io.c */ +extern IBOOL S_file_existsp(const char *inpath, IBOOL followp); +extern IBOOL S_file_regularp(const char *inpath, IBOOL followp); +extern IBOOL S_file_directoryp(const char *inpath, IBOOL followp); +extern IBOOL S_file_symbolic_linkp(const char *inpath); +#ifdef WIN32 +extern ptr S_find_files(const char *wildpath); +#else +extern ptr S_directory_list(const char *inpath); +#endif +extern char *S_malloc_pathname(const char *inpath); +#ifdef WIN32 +extern wchar_t *S_malloc_wide_pathname(const char *inpath); +#endif +extern IBOOL S_fixedpathp(const char *inpath); + +/* compress-io.c */ +extern INT S_zlib_compress_level(INT compress_level); +extern INT S_lz4_compress_level(INT compress_level); +extern glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level); +extern glzFile S_glzdopen_input(INT fd); +extern glzFile S_glzopen_input(const char *path); +#ifdef WIN32 +extern glzFile S_glzopen_input_w(const wchar_t *path); +#endif +extern IBOOL S_glzdirect(glzFile file); +extern INT S_glzclose(glzFile file); + +extern INT S_glzread(glzFile file, void *buffer, UINT count); +extern INT S_glzwrite(glzFile file, void *buffer, UINT count); +extern long S_glzseek(glzFile file, long offset, INT whence); +extern INT S_glzgetc(glzFile file); +extern INT S_glzungetc(INT c, glzFile file); +extern INT S_glzrewind(glzFile file); + +extern void S_glzerror(glzFile file, INT *errnum); +extern void S_glzclearerr(glzFile fdfile); + + +/* new-io.c */ +extern INT S_gzxfile_fd(ptr x); +extern glzFile S_gzxfile_gzfile(ptr x); +extern ptr S_new_open_input_fd(const char *filename, IBOOL compressed); +extern ptr S_new_open_output_fd( + const char *filename, INT mode, + IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, + IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed); +extern ptr S_new_open_input_output_fd( + const char *filename, INT mode, + IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, + IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed); +extern ptr S_close_fd(ptr file, IBOOL gzflag); +extern ptr S_compress_input_fd(INT fd, I64 fp); +extern ptr S_compress_output_fd(INT fd); + +extern ptr S_bytevector_read(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag); +extern ptr S_bytevector_read_nb(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag); +extern ptr S_bytevector_write(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag); +extern ptr S_put_byte(ptr file, INT byte, IBOOL gzflag); + +extern ptr S_get_fd_pos(ptr file, IBOOL gzflag); +extern ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag); +extern ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag); +extern ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag); +extern ptr S_get_fd_length(ptr file, IBOOL gzflag); +extern ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag); +extern void S_new_io_init(void); + +extern uptr S_bytevector_compress_size(iptr s_count, INT compress_format); +extern ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count, + ptr src_bv, iptr s_start, iptr s_count, + INT compress_format); +extern ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count, + ptr src_bv, iptr s_start, iptr s_count, + INT compress_format); + +/* thread.c */ +extern void S_thread_init(void); +extern ptr S_create_thread_object(const char *who, ptr p_tc); +#ifdef PTHREADS +extern ptr S_fork_thread(ptr thunk); +extern scheme_mutex_t *S_make_mutex(void); +extern void S_mutex_free(scheme_mutex_t *m); +extern void S_mutex_acquire(scheme_mutex_t *m); +extern INT S_mutex_tryacquire(scheme_mutex_t *m); +extern void S_mutex_release(scheme_mutex_t *m); +extern s_thread_cond_t *S_make_condition(void); +extern void S_condition_free(s_thread_cond_t *c); +extern IBOOL S_condition_wait(s_thread_cond_t *c, scheme_mutex_t *m, ptr t); +extern INT S_activate_thread(void); +extern void S_unactivate_thread(int mode); +#endif + +/* scheme.c */ +extern void S_generic_invoke(ptr tc, ptr code); + +/* number.c */ +extern void S_number_init(void); +extern ptr S_normalize_bignum(ptr x); +extern IBOOL S_integer_valuep(ptr x); +extern iptr S_integer_value(const char *who, ptr x); +extern I64 S_int64_value(char *who, ptr x); +extern IBOOL S_big_eq(ptr x, ptr y); +extern IBOOL S_big_lt(ptr x, ptr y); +extern ptr S_big_negate(ptr x); +extern ptr S_add(ptr x, ptr y); +extern ptr S_sub(ptr x, ptr y); +extern ptr S_mul(ptr x, ptr y); +extern ptr S_div(ptr x, ptr y); +extern ptr S_rem(ptr x, ptr y); +extern ptr S_trunc(ptr x, ptr y); +extern void S_trunc_rem(ptr tc, ptr x, ptr y, ptr *q, ptr *r); +extern ptr S_gcd(ptr x, ptr y); +extern ptr S_ash(ptr x, ptr n); +extern ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend); +extern ptr S_integer_length(ptr x); +extern ptr S_big_first_bit_set(ptr x); +extern double S_random_double(U32 m1, U32 m2, + U32 m3, U32 m4, double scale); +extern double S_floatify(ptr x); +extern ptr S_decode_float(double d); +extern ptr S_logand(ptr x, ptr y); +extern ptr S_logbitp(ptr k, ptr x); +extern ptr S_logbit0(ptr k, ptr x); +extern ptr S_logbit1(ptr k, ptr x); +extern ptr S_logtest(ptr x, ptr y); +extern ptr S_logor(ptr x, ptr y); +extern ptr S_logxor(ptr x, ptr y); +extern ptr S_lognot(ptr x); + +/* prim.c */ +extern ptr S_lookup_library_entry(iptr n, IBOOL errorp); +extern ptr S_lookup_c_entry(iptr i); +extern void S_prim_init(void); + +/* prim5.c */ +extern ptr S_strerror(INT errnum); +extern void S_prim5_init(void); +extern void S_dump_tc(ptr tc); + +/* print.c */ +extern void S_print_init(void); +extern void S_prin1(ptr x); + +/* schsig.c */ +extern ptr S_get_scheme_arg(ptr tc, iptr n); +extern void S_put_scheme_arg(ptr tc, iptr n, ptr x); +extern iptr S_continuation_depth(ptr k); +extern ptr S_single_continuation(ptr k, iptr n); +extern void S_split_and_resize(void); +extern void S_handle_overflow(void); +extern void S_handle_overflood(void); +extern void S_handle_apply_overflood(void); +extern void S_overflow(ptr tc, iptr frame_request); +extern NORETURN void S_error_reset(const char *s); +extern NORETURN void S_error_abort(const char *s); +extern NORETURN void S_abnormal_exit(void); +extern NORETURN void S_error(const char *who, const char *s); +extern NORETURN void S_error1(const char *who, const char *s, ptr x); +extern NORETURN void S_error2(const char *who, const char *s, ptr x, ptr y); +extern NORETURN void S_error3(const char *who, const char *s, ptr x, ptr y, ptr z); +extern NORETURN void S_boot_error(const ptr who, ptr s, ptr args); +extern void S_handle_docall_error(void); +extern void S_handle_arg_error(void); +extern void S_handle_nonprocedure_symbol(void); +extern void S_handle_values_error(void); +extern void S_handle_mvlet_error(void); +extern ptr S_allocate_scheme_signal_queue(void); +extern ptr S_dequeue_scheme_signals(ptr tc); +extern void S_register_scheme_signal(iptr sig); +extern void S_fire_collector(void); +extern NORETURN void S_noncontinuable_interrupt(void); +extern void S_schsig_init(void); +#ifdef DEFINE_MATHERR +#include +extern INT matherr(struct exception *x); +#endif /* DEFINE_MATHERR */ + +/* segment.c */ +extern void S_segment_init(void); +extern void *S_getmem(iptr bytes, IBOOL zerofill); +extern void S_freemem(void *addr, iptr bytes); +extern iptr S_find_segments(ISPC s, IGEN g, iptr n); +extern void S_free_chunk(chunkinfo *chunk); +extern void S_free_chunks(void); +extern uptr S_curmembytes(void); +extern uptr S_maxmembytes(void); +extern void S_resetmaxmembytes(void); +extern void S_move_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list); + +/* stats.c */ +extern void S_stats_init(void); +extern ptr S_cputime(void); +extern ptr S_realtime(void); +extern ptr S_clock_gettime(I32 typeno); +extern ptr S_gmtime(ptr tzoff, ptr tspair); +extern ptr S_asctime(ptr dtvec); +extern ptr S_mktime(ptr dtvec); +extern ptr S_unique_id(void); +extern void S_gettime(INT typeno, struct timespec *tp); + +/* symbol.c */ +extern ptr S_symbol_value(ptr sym); +extern void S_set_symbol_value(ptr sym, ptr val); + +/* machine-dependent .c files, e.g., x88k.c */ +#ifdef FLUSHCACHE +extern INT S_flushcache_max_gap(void); +extern void S_doflush(uptr start, uptr end); +#endif +extern void S_machine_init(void); + +/* schlib.c */ +extern void S_initframe(ptr tc, iptr n); +extern void S_put_arg(ptr tc, iptr i, ptr x); +extern void S_return(void); +extern void S_call_help(ptr tc, IBOOL singlep, IBOOL lock_ts); +extern void S_call_one_result(void); +extern void S_call_any_results(void); + +#ifdef WIN32 +/* windows.c */ +extern INT S_getpagesize(void); +extern ptr S_LastErrorString(void); +extern void *S_ntdlopen(const char *path); +extern void *S_ntdlsym(void *h, const char *s); +extern ptr S_ntdlerror(void); +extern int S_windows_flock(int fd, int operation); +extern int S_windows_chdir(const char *pathname); +extern int S_windows_chmod(const char *pathname, int mode); +extern int S_windows_mkdir(const char *pathname); +extern int S_windows_open(const char *pathname, int flags, int mode); +extern int S_windows_rename(const char *oldpathname, const char *newpathname); +extern int S_windows_rmdir(const char *pathname); +extern int S_windows_stat64(const char *pathname, struct STATBUF *buffer); +extern int S_windows_system(const char *command); +extern int S_windows_unlink(const char *pathname); +extern char *S_windows_getcwd(char *buffer, int maxlen); +#endif /* WIN32 */ + +#ifdef _WIN64 +extern int S_setjmp(void* jb); +extern void S_longjmp(void* jb, int value); +#endif /* _WIN64 */ + +#ifdef FEATURE_EXPEDITOR +/* expeditor.c */ +extern void S_expeditor_init(void); +#endif /* FEATURE_EXPEDITOR */ + +/* statics.c */ +extern void scheme_statics(void); diff --git a/c/fasl.c b/c/fasl.c new file mode 100644 index 0000000..b0f51fa --- /dev/null +++ b/c/fasl.c @@ -0,0 +1,1662 @@ +/* fasl.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* fasl representation: + * + * -> * + * + * -> * + * + * -> {header}\0\0\0chez( ...) + * + * -> * + * + * -> # size is the size in bytes of + * + * -> {visit} | {revisit} | {visit-revisit} + * + * -> | {uncompressed} + * + * -> {gzip} | {lz4} + * + * -> {pair}... + * + * -> {weak-pair} + * + * -> {box} + * + * -> {symbol} + * + * -> {gensym} + * + * -> {string} + * + * -> {vector}... + * + * -> {fxvector}... + * + * -> {bytevector}... + * + * -> {immediate} + * + * -> {small-integer} + * + * -> {large-integer}... + * + * -> {ratum} + * + * -> {inexactnum} + * + * -> {exactnum} + * + * -> {flonum} + * + * -> {entry} + * + * -> {library} + * + * -> {library-code} + * + * -> {graph} + * + * -> {graph-def} + * + * -> {graph-ref} + * + * -> {base-rtd} + * + * -> {rtd} + * + * -> {record} + * + * -> {eq-hashtable} + * + * + * + * + * ... + * -> + * + * -> {symbol-hashtable} + * + * ; 0: eq?, 1: eqv?, 2: equal?, 3: symbol=? + * + * + * ... + * -> + * + * -> {closure} + * + * -> {code} + * # number of free variables + * # length in bytes of code + * + * # two's complement encoding of accepted argument counts + * # inspector info + * # profiling info + * ... + * # length in uptrs of relocation table + * # first relocation entry + * ... + * # last relocation entry + * + * -> # bit 0: extended entry, bit 1: expect item offset, bit 2+: type + * + * # omitted if bit 1 of type-etc is 0 + * + * + * -> ... + * + * -> # size in bytes, not necessarily ptr-aligned + * # number of flds + * + * + * ... + * + * -> + * + * + * + * + * # 32-bit target + * # 64-bit target + * # 32-bit target + * # 64-bit target + * # 32-bit target + * # 64-bit target + * # 32-bit target + * # 64-bit target + * + * + * -> + * + * -> * + * -> k << 1 | 1, 0 <= k <= 127 + * -> k << 1 | 0, 0 <= k <= 127 + * each ubyte represents 7 bits of the uptr, least-significant first + * low-order bit is continuation bit: 1 iff more bytes are present + * + * -> | * + * -> sign << 7 | k << 1 | 1, 0 <= k <= 63 + * -> sign << 7 | k << 1 | 0, 0 <= k <= 63 + * leading ibyte represents least-significant 6 bits and sign + * each ubyte represents 7 of the remaining bits of the iptr, + * least-significant first + * + * Notes: + * * a list of length n will appear to be shorter in the fasl + * representation when the tail of the list is shared, since the + * shared tail will be a {graph-def} or {graph-ref}. + * + * * the length of a relocation table is the number of uptrs in the + * table, not the number of relocation entries. + * + * * closure offset is the amount added to the code object before + * storing it in the code field of the closure. + * + * * {graph} defines the size of the graph used to commonize shared + * structure, including cycles. It must appear before {graph-def} + * or {graph-ref}. A {graph-def} at index i must appear before + * a {graph-ref} at index i. + * + * * after an rtd is read: if its uname is unbound, the rtd is placed + * into the symbol value slot of the uname; otherwise, the rtd is + * discarded and the existing symbol value of uname is returned + * instead. Note that when many records appear within the same + * aggregrate structure, the full rtd will appear only in the + * first occurrence; the remainder will simply be graph references. + * + * * at present, the fasl representation supports only records + * containing only scheme-object fields. + */ + +#include "system.h" +#include "zlib.h" + +#ifdef WIN32 +#include +#endif /* WIN32 */ + +#ifdef NAN_INCLUDE +#include NAN_INCLUDE +#endif + +#define UFFO_TYPE_FD 2 +#define UFFO_TYPE_BV 3 + +#define PREPARE_BYTEVECTOR(bv,n) {if (bv == Sfalse || Sbytevector_length(bv) < (n)) bv = S_bytevector(n);} + +typedef struct unbufFaslFileObj { + ptr path; + INT type; + INT fd; +} *unbufFaslFile; + +typedef struct faslFileObj { + unbufFaslFile uf; + iptr size; + octet *next; + octet *end; + octet *buf; +} *faslFile; + +/* locally defined functions */ +static INT uf_read(unbufFaslFile uf, octet *s, iptr n); +static octet uf_bytein(unbufFaslFile uf); +static uptr uf_uptrin(unbufFaslFile uf, INT *bytes_consumed); +static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf); +static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf); +static void fillFaslFile(faslFile f); +static void bytesin(octet *s, iptr n, faslFile f); +static void toolarge(ptr path); +static iptr iptrin(faslFile f); +static uptr uptrin(faslFile f); +static float singlein(faslFile f); +static double doublein(faslFile f); +static iptr stringin(ptr *pstrbuf, iptr start, faslFile f); +static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f); +static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f); +static IBOOL rtd_equiv(ptr x, ptr y); +static IBOOL equalp(ptr x, ptr y); +#ifdef ARMV6 +static void arm32_set_abs(void *address, uptr item); +static uptr arm32_get_abs(void *address); +static void arm32_set_jump(void *address, uptr item, IBOOL callp); +static uptr arm32_get_jump(void *address); +#endif /* ARMV6 */ +#ifdef PPC32 +static void ppc32_set_abs(void *address, uptr item); +static uptr ppc32_get_abs(void *address); +static void ppc32_set_jump(void *address, uptr item, IBOOL callp); +static uptr ppc32_get_jump(void *address); +#endif /* PPC32 */ +#ifdef X86_64 +static void x86_64_set_jump(void *address, uptr item, IBOOL callp); +static uptr x86_64_get_jump(void *address); +#endif /* X86_64 */ +#ifdef SPARC64 +static INT extract_reg_from_sethi(void *address); +static void emit_sethi_lo(U32 item, INT destreg, void *address); +static uptr sparc64_get_literal(void *address); +static void sparc64_set_call(void *address, U32 *call_addr, uptr item); +static U32 adjust_delay_inst(U32 delay_inst, U32 *old_call_addr, U32 *new_call_addr); +static INT sparc64_set_lit_only(void *address, uptr item, I32 destreg); +static void sparc64_set_literal(void *address, uptr item); +#endif /* SPARC64 */ + +static double s_nan; + +void S_fasl_init(void) { + if (S_boot_time) { + S_protect(&S_G.base_rtd); + S_G.base_rtd = Sfalse; + S_protect(&S_G.rtd_key); + S_G.rtd_key = S_intern((const unsigned char *)"*rtd*"); + S_protect(&S_G.eq_symbol); + S_G.eq_symbol = S_intern((const unsigned char *)"eq"); + S_protect(&S_G.eq_ht_rtd); + S_G.eq_ht_rtd = Sfalse; + S_protect(&S_G.symbol_symbol); + S_G.symbol_symbol = S_intern((const unsigned char *)"symbol"); + S_protect(&S_G.symbol_ht_rtd); + S_G.symbol_ht_rtd = Sfalse; + S_protect(&S_G.eqp); + S_G.eqp = Sfalse; + S_protect(&S_G.eqvp); + S_G.eqvp = Sfalse; + S_protect(&S_G.equalp); + S_G.equalp = Sfalse; + S_protect(&S_G.symboleqp); + S_G.symboleqp = Sfalse; + } + + MAKE_NAN(s_nan) +#ifndef WIN32 /* msvc returns true for s_nan==s_nan! */ + if (s_nan == s_nan) { + fprintf(stderr, "s_nan == s_nan\n"); + S_abnormal_exit(); + } +#endif +} + +ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path) { + ptr tc = get_thread_context(); + ptr x; struct unbufFaslFileObj uffo; + + /* acquire mutex in case we modify code pages */ + tc_mutex_acquire() + uffo.path = path; + uffo.type = UFFO_TYPE_FD; + uffo.fd = fd; + x = fasl_entry(tc, situation, &uffo); + tc_mutex_release() + return x; +} + +ptr S_bv_fasl_read(ptr bv, ptr path) { + ptr tc = get_thread_context(); + ptr x; struct unbufFaslFileObj uffo; + + /* acquire mutex in case we modify code pages */ + tc_mutex_acquire() + uffo.path = path; + uffo.type = UFFO_TYPE_BV; + x = bv_fasl_entry(tc, bv, &uffo); + tc_mutex_release() + return x; +} + +ptr S_boot_read(INT fd, const char *path) { + ptr tc = get_thread_context(); + struct unbufFaslFileObj uffo; + + uffo.path = Sstring_utf8(path, -1); + uffo.type = UFFO_TYPE_FD; + uffo.fd = fd; + return fasl_entry(tc, fasl_type_visit_revisit, &uffo); +} + +#ifdef WIN32 +#define IO_SIZE_T unsigned int +#else /* WIN32 */ +#define IO_SIZE_T size_t +#endif /* WIN32 */ + +static INT uf_read(unbufFaslFile uf, octet *s, iptr n) { + iptr k; + while (n > 0) { + uptr nx = n; + +#if (iptr_bits > 32) + if (WIN32 && (unsigned int)nx != nx) nx = 0xffffffff; +#endif + + switch (uf->type) { + case UFFO_TYPE_FD: + k = READ(uf->fd, s, (IO_SIZE_T)nx); + if (k > 0) + n -= k; + else if (k == 0) + return -1; + else if (errno != EINTR) + S_error1("", "error reading from ~a", uf->path); + break; + default: + return -1; + } + + s += k; + } + return 0; +} + +static void uf_skipbytes(unbufFaslFile uf, iptr n) { + switch (uf->type) { + case UFFO_TYPE_FD: + if (LSEEK(uf->fd, n, SEEK_CUR) == -1) { + S_error1("", "error seeking ~a", uf->path); + } + break; + } +} + +static octet uf_bytein(unbufFaslFile uf) { + octet buf[1]; + if (uf_read(uf, buf, 1) < 0) + S_error1("", "unexpected eof in fasl file ~a", uf->path); + return buf[0]; +} + +static uptr uf_uptrin(unbufFaslFile uf, INT *bytes_consumed) { + uptr n, m; octet k; + + if (bytes_consumed) *bytes_consumed = 1; + k = uf_bytein(uf); + n = k >> 1; + while (k & 1) { + if (bytes_consumed) *bytes_consumed += 1; + k = uf_bytein(uf); + m = n << 7; + if (m >> 7 != n) toolarge(uf->path); + n = m | (k >> 1); + } + + return n; +} + +char *S_format_scheme_version(uptr n) { + static char buf[16]; INT len; + if ((n >> 16) != ((n >> 16) & 0xffff)) return "unknown"; + if ((n & 0xff) == 0) + len = snprintf(buf, 16, "%d.%d", (int) n >> 16, (int) (n >> 8) & 0xff); + else + len = snprintf(buf, 16, "%d.%d.%d", (int) n >> 16, (int) (n >> 8) & 0xff, + (int) n & 0xff); + return len > 0 ? buf : "unknown"; +} + +char *S_lookup_machine_type(uptr n) { + static char *machine_type_table[] = machine_type_names; + if (n < machine_type_limit) + return machine_type_table[n]; + else + return "unknown"; +} + +static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) { + ptr x; ptr strbuf = S_G.null_string; + octet tybuf[1]; IFASLCODE ty; iptr size; + /* gcc (GCC) 4.8.5 20150623 (Red Hat 4.8.5-28) co-locates buf and x if we put the declaration of buf down where we use it */ + octet buf[SBUFSIZ]; + + for (;;) { + if (uf_read(uf, tybuf, 1) < 0) return Seof_object; + ty = tybuf[0]; + + while (ty == fasl_type_header) { + uptr n; ICHAR c; + + /* check for remainder of magic number */ + if (uf_bytein(uf) != 0 || + uf_bytein(uf) != 0 || + uf_bytein(uf) != 0 || + uf_bytein(uf) != 'c' || + uf_bytein(uf) != 'h' || + uf_bytein(uf) != 'e' || + uf_bytein(uf) != 'z') + S_error1("", "malformed fasl-object header (missing magic word) found in ~a", uf->path); + + if ((n = uf_uptrin(uf, (INT *)0)) != scheme_version) + S_error2("", "incompatible fasl-object version ~a found in ~a", S_string(S_format_scheme_version(n), -1), uf->path); + + if ((n = uf_uptrin(uf, (INT *)0)) != machine_type_any && n != machine_type) + S_error2("", "incompatible fasl-object machine-type ~a found in ~a", S_string(S_lookup_machine_type(n), -1), uf->path); + + if (uf_bytein(uf) != '(') + S_error1("", "malformed fasl-object header (missing open paren) found in ~a", uf->path); + + while ((c = uf_bytein(uf)) != ')') + if (c < 0) S_error1("", "malformed fasl-object header (missing close paren) found in ~a", uf->path); + + ty = uf_bytein(uf); + } + + switch (ty) { + case fasl_type_visit: + case fasl_type_revisit: + case fasl_type_visit_revisit: + break; + default: + S_error2("", "malformed fasl-object header (missing situation, got ~s) found in ~a", FIX(ty), uf->path); + return (ptr)0; + } + + size = uf_uptrin(uf, (INT *)0); + + if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) { + struct faslFileObj ffo; + + ty = uf_bytein(uf); + switch (ty) { + case fasl_type_gzip: + case fasl_type_lz4: { + ptr result; INT bytes_consumed; + iptr dest_size = uf_uptrin(uf, &bytes_consumed); + iptr src_size = size - (1 + bytes_consumed); /* adjust for u8 compression type and uptr dest_size */ + + PREPARE_BYTEVECTOR(SRCBV(tc), src_size); + PREPARE_BYTEVECTOR(DSTBV(tc), dest_size); + if (uf_read(uf, &BVIT(SRCBV(tc),0), src_size) < 0) + S_error1("", "unexpected eof in fasl file ~a", uf->path); + result = S_bytevector_uncompress(DSTBV(tc), 0, dest_size, SRCBV(tc), 0, src_size, + (ty == fasl_type_gzip ? COMPRESS_GZIP : COMPRESS_LZ4)); + if (result != FIX(dest_size)) { + if (Sstringp(result)) S_error2("fasl-read", "~@?", result, SRCBV(tc)); + S_error3("fasl-read", "uncompressed size ~s for ~s is smaller than expected size ~s", result, SRCBV(tc), FIX(dest_size)); + } + ffo.size = dest_size; + ffo.next = ffo.buf = &BVIT(DSTBV(tc),0); + ffo.end = &BVIT(DSTBV(tc),dest_size); + ffo.uf = uf; + break; + } + case fasl_type_uncompressed: { + ffo.size = size - 1; /* adjust for u8 compression type */ + ffo.next = ffo.end = ffo.buf = buf; + ffo.uf = uf; + break; + } + default: + S_error2("", "malformed fasl-object header (missing possibly-compressed, got ~s) found in ~a", FIX(ty), uf->path); + return (ptr)0; + } + faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + S_flush_instruction_cache(tc); + return x; + } else { + uf_skipbytes(uf, size); + } + } +} + +static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) { + ptr x; ptr strbuf = S_G.null_string; + struct faslFileObj ffo; + + ffo.size = Sbytevector_length(bv); + ffo.next = ffo.buf = &BVIT(bv, 0); + ffo.end = &BVIT(bv, ffo.size); + ffo.uf = uf; + + faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + S_flush_instruction_cache(tc); + return x; +} + +static void fillFaslFile(faslFile f) { + iptr n = f->size < SBUFSIZ ? f->size : SBUFSIZ; + if (uf_read(f->uf, f->buf, n) < 0) + S_error1("", "unexpected eof in fasl file ~a", f->uf->path); + f->end = (f->next = f->buf) + n; + f->size -= n; +} + +#define bytein(f) ((((f)->next == (f)->end) ? fillFaslFile(f) : (void)0), *((f)->next++)) + +static void bytesin(octet *s, iptr n, faslFile f) { + iptr avail = f->end - f->next; + if (avail < n) { + if (avail != 0) { + memcpy(s, f->next, avail); + f->next = f->end; + n -= avail; + s += avail; + } + if (uf_read(f->uf, s, n) < 0) + S_error1("", "unexpected eof in fasl file ~a", f->uf->path); + f->size -= n; + } else { + memcpy(s, f->next, n); + f->next += n; + } +} + +static void toolarge(ptr path) { + S_error1("", "fasl value too large for this machine type in ~a", path); +} + +static iptr iptrin(faslFile f) { + uptr n, m; octet k, k0; + + k0 = k = bytein(f); + n = (k & 0x7f) >> 1; + while (k & 1) { + k = bytein(f); + m = n << 7; + if (m >> 7 != n) toolarge(f->uf->path); + n = m | (k >> 1); + } + + if (k0 & 0x80) { + if (n < ((uptr)1 << (ptr_bits - 1))) { + return -(iptr)n; + } else if (n > ((uptr)1 << (ptr_bits - 1))) { + toolarge(f->uf->path); + } +#if (fixnum_bits > 32) + return (iptr)0x8000000000000000; +#else + return (iptr)0x80000000; +#endif + } else { + if (n >= ((uptr)1 << (ptr_bits - 1))) toolarge(f->uf->path); + return (iptr)n; + } +} + +static uptr uptrin(faslFile f) { + uptr n, m; octet k; + + k = bytein(f); + n = k >> 1; + while (k & 1) { + k = bytein(f); + m = n << 7; + if (m >> 7 != n) toolarge(f->uf->path); + n = m | (k >> 1); + } + + return n; +} + +static float singlein(faslFile f) { + union { float f; U32 u; } val; + + val.u = (U32)uptrin(f); + + return val.f; +} + +static double doublein(faslFile f) { +#ifdef LITTLE_ENDIAN_IEEE_DOUBLE + union { double d; struct { U32 l; U32 h; } u; } val; +#else + union { double d; struct { U32 h; U32 l; } u; } val; +#endif + + val.u.h = (U32)uptrin(f); + val.u.l = (U32)uptrin(f); + + return val.d; +} + +static iptr stringin(ptr *pstrbuf, iptr start, faslFile f) { + iptr end, n, i; ptr p = *pstrbuf; + + end = start + (n = uptrin(f)); + if (Sstring_length(*pstrbuf) < end) { + ptr newp = S_string((char *)0, end); + for (i = 0; i != start; i += 1) Sstring_set(newp, i, Sstring_ref(p, i)); + *pstrbuf = p = newp; + } + for (i = start; i != end; i += 1) Sstring_set(p, i, uptrin(f)); + return n; +} + +static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { + IFASLCODE ty = bytein(f); + switch (ty) { + case fasl_type_pair: { + iptr n; ptr p; + n = uptrin(f); + *x = p = Scons(FIX(0), FIX(0)); + faslin(tc, &INITCAR(p), t, pstrbuf, f); + while (--n) { + INITCDR(p) = Scons(FIX(0), FIX(0)); + p = INITCDR(p); + faslin(tc, &INITCAR(p), t, pstrbuf, f); + } + faslin(tc, &INITCDR(p), t, pstrbuf, f); + return; + } + case fasl_type_box: + case fasl_type_immutable_box: + *x = Sbox(FIX(0)); + faslin(tc, &INITBOXREF(*x), t, pstrbuf, f); + if (ty == fasl_type_immutable_box) + BOXTYPE(*x) = type_immutable_box; + return; + case fasl_type_symbol: { + iptr n; + n = stringin(pstrbuf, 0, f); + *x = S_intern_sc(&STRIT(*pstrbuf, 0), n, Sfalse); + return; + } + case fasl_type_gensym: { + iptr pn, un; + pn = stringin(pstrbuf, 0, f); + un = stringin(pstrbuf, pn, f); + *x = S_intern3(&STRIT(*pstrbuf, 0), pn, &STRIT(*pstrbuf, pn), un, Sfalse, Sfalse); + return; + } + case fasl_type_ratnum: + *x = S_rational(FIX(0), FIX(0)); + faslin(tc, &RATNUM(*x), t, pstrbuf, f); + faslin(tc, &RATDEN(*x), t, pstrbuf, f); + return; + case fasl_type_exactnum: + *x = S_exactnum(FIX(0), FIX(0)); + faslin(tc, &EXACTNUM_REAL_PART(*x), t, pstrbuf, f); + faslin(tc, &EXACTNUM_IMAG_PART(*x), t, pstrbuf, f); + return; + case fasl_type_vector: + case fasl_type_immutable_vector: { + iptr n; ptr *p; + n = uptrin(f); + *x = S_vector(n); + p = &INITVECTIT(*x, 0); + while (n--) faslin(tc, p++, t, pstrbuf, f); + if (ty == fasl_type_immutable_vector) { + if (Svector_length(*x) == 0) + *x = NULLIMMUTABLEVECTOR(tc); + else + VECTTYPE(*x) |= vector_immutable_flag; + } + return; + } + case fasl_type_fxvector: + case fasl_type_immutable_fxvector: { + iptr n; ptr *p; + n = uptrin(f); + *x = S_fxvector(n); + p = &FXVECTIT(*x, 0); + while (n--) { + iptr t = iptrin(f); + if (!FIXRANGE(t)) toolarge(f->uf->path); + *p++ = FIX(t); + } + if (ty == fasl_type_immutable_fxvector) { + if (Sfxvector_length(*x) == 0) + *x = NULLIMMUTABLEFXVECTOR(tc); + else + FXVECTOR_TYPE(*x) |= fxvector_immutable_flag; + } + return; + } + case fasl_type_bytevector: + case fasl_type_immutable_bytevector: { + iptr n; + n = uptrin(f); + *x = S_bytevector(n); + bytesin(&BVIT(*x,0), n, f); + if (ty == fasl_type_immutable_bytevector) { + if (Sbytevector_length(*x) == 0) + *x = NULLIMMUTABLEBYTEVECTOR(tc); + else + BYTEVECTOR_TYPE(*x) |= bytevector_immutable_flag; + } + return; + } + case fasl_type_base_rtd: { + ptr rtd; + if ((rtd = S_G.base_rtd) == Sfalse) { + if (!Srecordp(rtd)) S_error_abort("S_G.base-rtd has not been set"); + } + *x = rtd; + return; + } case fasl_type_rtd: { + ptr rtd, rtd_uid, plist, ls; + + faslin(tc, &rtd_uid, t, pstrbuf, f); + + /* look for rtd on uid's property list */ + plist = SYMSPLIST(rtd_uid); + for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) { + if (Scar(ls) == S_G.rtd_key) { + ptr tmp; + *x = rtd = Scar(Scdr(ls)); + fasl_record(tc, &tmp, t, pstrbuf, f); + if (!rtd_equiv(tmp, rtd)) + S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(tmp), f->uf->path); + return; + } + } + + fasl_record(tc, x, t, pstrbuf, f); + rtd = *x; + + /* register rtd on uid's property list */ + SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist))); + return; + } + case fasl_type_record: { + fasl_record(tc, x, t, pstrbuf, f); + return; + } + case fasl_type_eq_hashtable: { + ptr rtd, ht, v; uptr subtype; uptr veclen, i, n; + if ((rtd = S_G.eq_ht_rtd) == Sfalse) { + S_G.eq_ht_rtd = rtd = SYMVAL(S_intern((const unsigned char *)"$eq-ht-rtd")); + if (!Srecordp(rtd)) S_error_abort("$eq-ht-rtd has not been set"); + } + *x = ht = S_record(size_record_inst(UNFIX(RECORDDESCSIZE(rtd)))); + RECORDINSTTYPE(ht) = rtd; + INITPTRFIELD(ht,eq_hashtable_type_disp) = S_G.eq_symbol; + INITPTRFIELD(ht,eq_hashtable_mutablep_disp) = bytein(f) ? Strue : Sfalse; + switch ((subtype = bytein(f))) { + case eq_hashtable_subtype_normal: + case eq_hashtable_subtype_weak: + case eq_hashtable_subtype_ephemeron: + INITPTRFIELD(ht,eq_hashtable_subtype_disp) = FIX(subtype); + break; + default: + S_error2("", "invalid eq-hashtable subtype code", FIX(subtype), f->uf->path); + } + INITPTRFIELD(ht,eq_hashtable_minlen_disp) = FIX(uptrin(f)); + veclen = uptrin(f); + INITPTRFIELD(ht,eq_hashtable_vec_disp) = v = S_vector(veclen); + n = uptrin(f); + INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(n); + for (i = 0; i < veclen ; i += 1) { INITVECTIT(v, i) = FIX(i); } + while (n > 0) { + ptr keyval; + switch (subtype) { + case eq_hashtable_subtype_normal: + keyval = Scons(FIX(0), FIX(0)); + break; + case eq_hashtable_subtype_weak: + keyval = S_cons_in(space_weakpair, 0, FIX(0), FIX(0)); + break; + case eq_hashtable_subtype_ephemeron: + default: + keyval = S_cons_in(space_ephemeron, 0, FIX(0), FIX(0)); + break; + } + faslin(tc, &INITCAR(keyval), t, pstrbuf, f); + faslin(tc, &INITCDR(keyval), t, pstrbuf, f); + i = ((uptr)Scar(keyval) >> primary_type_bits) & (veclen - 1); + INITVECTIT(v, i) = S_tlc(keyval, ht, Svector_ref(v, i)); + n -= 1; + } + return; + } + case fasl_type_symbol_hashtable: { + ptr rtd, ht, equiv, v; uptr equiv_code, veclen, i, n; + if ((rtd = S_G.symbol_ht_rtd) == Sfalse) { + S_G.symbol_ht_rtd = rtd = SYMVAL(S_intern((const unsigned char *)"$symbol-ht-rtd")); + if (!Srecordp(rtd)) S_error_abort("$symbol-ht-rtd has not been set"); + } + *x = ht = S_record(size_record_inst(UNFIX(RECORDDESCSIZE(rtd)))); + RECORDINSTTYPE(ht) = rtd; + INITPTRFIELD(ht,symbol_hashtable_type_disp) = S_G.symbol_symbol; + INITPTRFIELD(ht,symbol_hashtable_mutablep_disp) = bytein(f) ? Strue : Sfalse; + INITPTRFIELD(ht,symbol_hashtable_minlen_disp) = FIX(uptrin(f)); + equiv_code = bytein(f); + switch (equiv_code) { + case 0: + if ((equiv = S_G.eqp) == Sfalse) { + S_G.eqp = equiv = SYMVAL(S_intern((const unsigned char *)"eq?")); + if (!Sprocedurep(equiv)) S_error_abort("fasl: eq? has not been set"); + } + break; + case 1: + if ((equiv = S_G.eqvp) == Sfalse) { + S_G.eqvp = equiv = SYMVAL(S_intern((const unsigned char *)"eqv?")); + if (!Sprocedurep(equiv)) S_error_abort("fasl: eqv? has not been set"); + } + break; + case 2: + if ((equiv = S_G.equalp) == Sfalse) { + S_G.equalp = equiv = SYMVAL(S_intern((const unsigned char *)"equal?")); + if (!Sprocedurep(equiv)) S_error_abort("fasl: equal? has not been set"); + } + break; + case 3: + if ((equiv = S_G.symboleqp) == Sfalse) { + S_G.symboleqp = equiv = SYMVAL(S_intern((const unsigned char *)"symbol=?")); + if (!Sprocedurep(equiv)) S_error_abort("fasl: symbol=? has not been set"); + } + break; + default: + S_error2("", "invalid symbol-hashtable equiv code", FIX(equiv_code), f->uf->path); + /* make compiler happy */ + equiv = Sfalse; + } + INITPTRFIELD(ht,symbol_hashtable_equivp_disp) = equiv; + veclen = uptrin(f); + INITPTRFIELD(ht,symbol_hashtable_vec_disp) = v = S_vector(veclen); + n = uptrin(f); + INITPTRFIELD(ht,symbol_hashtable_size_disp) = FIX(n); + for (i = 0; i < veclen ; i += 1) { INITVECTIT(v, i) = Snil; } + while (n > 0) { + ptr keyval; + keyval = Scons(FIX(0), FIX(0)); + faslin(tc, &INITCAR(keyval), t, pstrbuf, f); + faslin(tc, &INITCDR(keyval), t, pstrbuf, f); + i = UNFIX(SYMHASH(Scar(keyval))) & (veclen - 1); + INITVECTIT(v, i) = Scons(keyval, Svector_ref(v, i)); + n -= 1; + } + return; + } + case fasl_type_closure: { + ptr cod; iptr offset; + offset = uptrin(f); + *x = S_closure((ptr)0, 0); + faslin(tc, &cod, t, pstrbuf, f); + CLOSENTRY(*x) = (ptr)((uptr)cod + offset); + return; + } + case fasl_type_flonum: { + *x = Sflonum(doublein(f)); + return; + } + case fasl_type_inexactnum: { + ptr rp, ip; + faslin(tc, &rp, t, pstrbuf, f); + faslin(tc, &ip, t, pstrbuf, f); + *x = S_inexactnum(FLODAT(rp), FLODAT(ip)); + return; + } + case fasl_type_string: + case fasl_type_immutable_string: { + iptr i, n; ptr str; + n = uptrin(f); + str = S_string((char *)0, n); + for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f)); + if (ty == fasl_type_immutable_string) { + if (n == 0) + str = NULLIMMUTABLESTRING(tc); + else + STRTYPE(str) |= string_immutable_flag; + } + *x = str; + return; + } + case fasl_type_small_integer: + *x = Sinteger(iptrin(f)); + return; + case fasl_type_large_integer: { + IBOOL sign; iptr n; ptr t; bigit *p; + sign = bytein(f); + n = uptrin(f); + t = S_bignum(tc, n, sign); + p = &BIGIT(t, 0); + while (n--) *p++ = (bigit)uptrin(f); + *x = S_normalize_bignum(t); + return; + } + case fasl_type_weak_pair: + *x = S_cons_in(space_weakpair, 0, FIX(0), FIX(0)); + faslin(tc, &INITCAR(*x), t, pstrbuf, f); + faslin(tc, &INITCDR(*x), t, pstrbuf, f); + return; + case fasl_type_ephemeron: + *x = S_cons_in(space_ephemeron, 0, FIX(0), FIX(0)); + faslin(tc, &INITCAR(*x), t, pstrbuf, f); + faslin(tc, &INITCDR(*x), t, pstrbuf, f); + return; + case fasl_type_code: { + iptr n, m, a; INT flags; iptr free; + ptr co, reloc, name, pinfos; + flags = bytein(f); + free = uptrin(f); + n = uptrin(f) /* length in bytes of code */; + *x = co = S_code(tc, type_code | (flags << code_flags_offset), n); + CODEFREE(co) = free; + faslin(tc, &name, t, pstrbuf, f); + if (Sstringp(name)) name = SYMNAME(S_intern_sc(&STRIT(name, 0), Sstring_length(name), name)); + CODENAME(co) = name; + faslin(tc, &CODEARITYMASK(co), t, pstrbuf, f); + faslin(tc, &CODEINFO(co), t, pstrbuf, f); + faslin(tc, &pinfos, t, pstrbuf, f); + CODEPINFOS(co) = pinfos; + if (pinfos != Snil) { + S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); + } + bytesin((octet *)&CODEIT(co, 0), n, f); + m = uptrin(f); + CODERELOC(co) = reloc = S_relocation_table(m); + RELOCCODE(reloc) = co; + a = 0; + n = 0; + while (n < m) { + INT type_etc, type; uptr item_off, code_off; + ptr obj; + type_etc = bytein(f); + type = type_etc >> 2; + code_off = uptrin(f); + item_off = (type_etc & 2) ? uptrin(f) : 0; + if (type_etc & 1) { + RELOCIT(reloc,n) = (type << reloc_type_offset)|reloc_extended_format ; n += 1; + RELOCIT(reloc,n) = item_off; n += 1; + RELOCIT(reloc,n) = code_off; n += 1; + } else { + RELOCIT(reloc,n) = MAKE_SHORT_RELOC(type,code_off,item_off); n += 1; + } + a += code_off; + faslin(tc, &obj, t, pstrbuf, f); + S_set_code_obj("read", type, co, a, obj, item_off); + } + return; + } + case fasl_type_immediate: + *x = (ptr)uptrin(f); + return; + case fasl_type_entry: + *x = (ptr)S_lookup_c_entry(uptrin(f)); + return; + case fasl_type_library: + *x = S_lookup_library_entry(uptrin(f), 1); + return; + case fasl_type_library_code: + *x = CLOSCODE(S_lookup_library_entry(uptrin(f), 1)); + return; + case fasl_type_graph: + faslin(tc, x, S_vector(uptrin(f)), pstrbuf, f); + return; + case fasl_type_graph_def: { + ptr *p; + p = &INITVECTIT(t, uptrin(f)); + faslin(tc, p, t, pstrbuf, f); + *x = *p; + return; + } + case fasl_type_graph_ref: + *x = Svector_ref(t, uptrin(f)); + return; + default: + S_error2("", "invalid object type ~d in fasl file ~a", FIX(ty), f->uf->path); + } +} + +#define big 0 +#define little 1 +static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { + uptr size, n, addr; ptr p; UINT padty; + + size = uptrin(f); + n = uptrin(f); + *x = p = S_record(size_record_inst(size)); + faslin(tc, &RECORDINSTTYPE(p), t, pstrbuf, f); + addr = (uptr)&RECORDINSTIT(p, 0); + for (; n != 0; n -= 1) { + padty = bytein(f); + addr += padty >> 4; + switch (padty & 0xf) { + case fasl_fld_ptr: + faslin(tc, (ptr *)addr, t, pstrbuf, f); + addr += sizeof(ptr); + break; + case fasl_fld_u8: + *(U8 *)addr = (U8)bytein(f); + addr += 1; + break; + case fasl_fld_i16: + *(I16 *)addr = (I16)iptrin(f); + addr += 2; + break; + case fasl_fld_i24: { + iptr q = iptrin(f); +#if (native_endianness == little) + *(U16 *)addr = (U16)q; + *(U8 *)(addr + 2) = (U8)(q >> 16); +#elif (native_endianness == big) + *(U16 *)addr = (U16)(q >> 8); + *(U8 *)(addr + 2) = (U8)q; +#else + unexpected_endianness(); +#endif + addr += 3; + break; + } + case fasl_fld_i32: + *(I32 *)addr = (I32)iptrin(f); + addr += 4; + break; + case fasl_fld_i40: { + I64 q; +#if (ptr_bits == 32) + q = (I64)iptrin(f) << 32; + q |= (U32)uptrin(f); +#elif (ptr_bits == 64) + q = (I64)iptrin(f); +#else + unexpected_ptr_bits(); +#endif +#if (native_endianness == little) + *(U32 *)addr = (U32)q; + *(U8 *)(addr + 4) = (U8)(q >> 32); +#elif (native_endianness == big) + *(U32 *)addr = (U32)(q >> 8); + *(U8 *)(addr + 4) = (U8)q; +#else + unexpected_endianness(); +#endif + addr += 5; + break; + } + case fasl_fld_i48: { + I64 q; +#if (ptr_bits == 32) + q = (I64)iptrin(f) << 32; + q |= (U32)uptrin(f); +#elif (ptr_bits == 64) + q = (I64)iptrin(f); +#else + unexpected_ptr_bits(); +#endif +#if (native_endianness == little) + *(U32 *)addr = (U32)q; + *(U16 *)(addr + 4) = (U16)(q >> 32); +#elif (native_endianness == big) + *(U32 *)addr = (U32)(q >> 16); + *(U16 *)(addr + 4) = (U16)q; +#else + unexpected_endianness(); +#endif + addr += 6; + break; + } + case fasl_fld_i56: { + I64 q; +#if (ptr_bits == 32) + q = (I64)iptrin(f) << 32; + q |= (U32)uptrin(f); +#elif (ptr_bits == 64) + q = (I64)iptrin(f); +#else + unexpected_ptr_bits(); +#endif +#if (native_endianness == little) + *(U32 *)addr = (U32)q; + *(U16 *)(addr + 4) = (U16)(q >> 32); + *(U8 *)(addr + 6) = (U8)(q >> 48); +#elif (native_endianness == big) + *(U32 *)addr = (U32)(q >> 24); + *(U32 *)(addr + 3) = (U32)q; +#else + unexpected_endianness(); +#endif + addr += 7; + break; + } + case fasl_fld_i64: { + I64 q; +#if (ptr_bits == 32) + q = (I64)iptrin(f) << 32; + q |= (U32)uptrin(f); +#elif (ptr_bits == 64) + q = (I64)iptrin(f); +#else + unexpected_ptr_bits(); +#endif + *(I64 *)addr = q; + addr += 8; + break; + } + case fasl_fld_single: + *(float *)addr = (float)singlein(f); + addr += sizeof(float); + break; + case fasl_fld_double: + *(double *)addr = (double)doublein(f); + addr += sizeof(double); + break; + default: + S_error1("", "unrecognized record fld type ~d", FIX(padty & 0xf)); + break; + } + } +} + +/* limited version for checking rtd fields */ +static IBOOL equalp(ptr x, ptr y) { + if (x == y) return 1; + if (Spairp(x)) return Spairp(y) && equalp(Scar(x), Scar(y)) && equalp(Scdr(x), Scdr(y)); + if (Svectorp(x)) { + iptr n; + if (!Svectorp(y)) return 0; + if ((n = Svector_length(x)) != Svector_length(y)) return 0; + while (--n >= 0) if (!equalp(Svector_ref(x, n), Svector_ref(y, n))) return 0; + return 1; + } + return Sbignump(x) && Sbignump(y) && S_big_eq(x, y); +} + +static IBOOL rtd_equiv(ptr x, ptr y) { + return RECORDINSTTYPE(x) == RECORDINSTTYPE(y) && + RECORDDESCPARENT(x) == RECORDDESCPARENT(y) && + equalp(RECORDDESCPM(x), RECORDDESCPM(y)) && + equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) && + equalp(RECORDDESCFLDS(x), RECORDDESCFLDS(y)) && + RECORDDESCSIZE(x) == RECORDDESCSIZE(y) && + RECORDDESCFLAGS(x) == RECORDDESCFLAGS(y); +} + +#ifdef HPUX +INT pax_decode21(INT x) +{ + INT x0_4, x5_6, x7_8, x9_19, x20; + + x20 = x & 0x1; x >>= 1; + x9_19 = x & 0x7ff; x >>= 11; + x7_8 = x & 0x3; x >>= 2; + x5_6 = x & 0x3; + x0_4 = x >> 2; + + return (((x20<<11 | x9_19)<<2 | x5_6)<<5 | x0_4)<<2 | x7_8; +} + +INT pax_encode21(INT n) +{ + INT x0_4, x5_6, x7_8, x9_19, x20; + + x7_8 = n & 0x3; n >>= 2; + x0_4 = n & 0x1f; n >>= 5; + x5_6 = n & 0x3; n >>= 2; + x9_19 = n & 0x7ff; + x20 = n >> 11; + + return (((x0_4<<2 | x5_6)<<2 | x7_8)<<11 | x9_19)<<1 | x20; +} +#endif /* HPUX */ + +/* used here, in S_gc(), and in compile.ss */ +void S_set_code_obj(char *who, IFASLCODE typ, ptr p, iptr n, ptr x, iptr o) { + void *address; uptr item; + + address = (void *)((uptr)p + n); + item = (uptr)x + o; + switch (typ) { + case reloc_abs: + *(uptr *)address = item; + break; +#ifdef ARMV6 + case reloc_arm32_abs: + arm32_set_abs(address, item); + break; + case reloc_arm32_jump: + arm32_set_jump(address, item, 0); + break; + case reloc_arm32_call: + arm32_set_jump(address, item, 1); + break; +#endif /* ARMV6 */ +#ifdef PPC32 + case reloc_ppc32_abs: + ppc32_set_abs(address, item); + break; + case reloc_ppc32_jump: + ppc32_set_jump(address, item, 0); + break; + case reloc_ppc32_call: + ppc32_set_jump(address, item, 1); + break; +#endif /* PPC32 */ +#ifdef I386 + case reloc_rel: + item = item - ((uptr)address + sizeof(uptr)); + *(uptr *)address = item; + break; +#endif /* I386 */ +#ifdef X86_64 + case reloc_x86_64_jump: + x86_64_set_jump(address, item, 0); + break; + case reloc_x86_64_call: + x86_64_set_jump(address, item, 1); + break; +#endif /* X86_64 */ +#ifdef SPARC64 + case reloc_sparc64abs: + sparc64_set_literal(address, item); + break; + /* we don't use this presently since it can't handle out-of-range + relocations */ + case reloc_sparc64rel: + /* later: make the damn thing local by copying it an + every other code object we can reach into a single + close area of memory */ + item = item - (uptr)address; + if ((iptr)item < -0x20000000 || (iptr)item > 0x1FFFFFFF) + S_error1("", "sparc64rel address out of range ~x", + Sunsigned((uptr)address)); + *(U32 *)address = *(U32 *)address & ~0x3fffffff | item >> 2 & 0x3fffffff; + break; +#endif /* SPARC64 */ +#ifdef SPARC + case reloc_sparcabs: + *(U32 *)address = *(U32 *)address & ~0x3fffff | item >> 10 & 0x3fffff; + *((U32 *)address + 1) = *((U32 *)address + 1) & ~0x3ff | item & 0x3ff; + break; + case reloc_sparcrel: + item = item - (uptr)address; + *(U32 *)address = *(U32 *)address & ~0x3fffffff | item >> 2 & 0x3fffffff; + break; +#endif /* SPARC */ + default: + S_error1(who, "invalid relocation type ~s", FIX(typ)); + } +} + +/* used in S_gc() */ +ptr S_get_code_obj(IFASLCODE typ, ptr p, iptr n, iptr o) { + void *address; uptr item; + + address = (void *)((uptr)p + n); + switch (typ) { + case reloc_abs: + item = *(uptr *)address; + break; +#ifdef ARMV6 + case reloc_arm32_abs: + item = arm32_get_abs(address); + break; + case reloc_arm32_jump: + case reloc_arm32_call: + item = arm32_get_jump(address); + break; +#endif /* ARMV6 */ +#ifdef PPC32 + case reloc_ppc32_abs: + item = ppc32_get_abs(address); + break; + case reloc_ppc32_jump: + case reloc_ppc32_call: + item = ppc32_get_jump(address); + break; +#endif /* PPC32 */ +#ifdef I386 + case reloc_rel: + item = *(uptr *)address; + item = item + ((uptr)address + sizeof(uptr)); + break; +#endif /* I386 */ +#ifdef X86_64 + case reloc_x86_64_jump: + case reloc_x86_64_call: + item = x86_64_get_jump(address); + break; +#endif /* X86_64 */ +#ifdef SPARC64 + case reloc_sparc64abs: + item = sparc64_get_literal(address); + break; + case reloc_sparc64rel: + item = (*(U32 *)address & 0x3fffffff) << 2; + if (item & 0x80000000) /* sign bit set */ + item = item | 0xffffffff00000000; + item = (uptr)address + (iptr)item; + break; +#endif /* SPARC64 */ +#ifdef SPARC + case reloc_sparcabs: + item = (*(U32 *)address & 0x3fffff) << 10 | *((U32 *)address + 1) & 0x3ff; + break; + case reloc_sparcrel: + item = (*(U32 *)address & 0x3fffffff) << 2; + item += (uptr)address; + break; +#endif /* SPARC */ + default: + S_error1("", "invalid relocation type ~s", FIX(typ)); + return (ptr)0 /* not reached */; + } + return (ptr)(item - o); +} + + +#ifdef ARMV6 +static void arm32_set_abs(void *address, uptr item) { + /* code generator produces ldrlit destreg, 0; brai 0; long 0 */ + /* we change long 0 => long item */ + *((U32 *)address + 2) = item; +} + +static uptr arm32_get_abs(void *address) { + return *((U32 *)address + 2); +} + +#define MAKE_B(n) (0xEA000000 | (n)) +#define MAKE_BL(n) (0xEB000000 | (n)) +#define B_OR_BL_DISP(x) ((x) & 0xFFFFFF) +#define MAKE_BX(reg) (0xE12FFF10 | (reg)) +#define MAKE_BLX(reg) (0xE12FFF30 | (reg)) +#define MAKE_LDRLIT(dst,n) (0xE59F0000 | ((dst) << 12) | (n)) +#define LDRLITP(x) (((x) & 0xFFFF0000) == 0xE59F0000) +#define LDRLIT_DST(x) (((x) >> 12) & 0xf) +#define MAKE_MOV(dst,src) (0xE1A00000 | ((dst) << 12) | (src)) +#define MOV_SRC(x) ((x) & 0xf) +/* nop instruction is not supported by all ARMv6 chips, so use recommended mov r0, r0 */ +#define NOP MAKE_MOV(0,0) + +static void arm32_set_jump(void *address, uptr item, IBOOL callp) { + /* code generator produces ldrlit %ip, 0; brai 0; long 0; bx or blx %ip */ + U32 inst = *((U32 *)address + 0); + INT reg = LDRLITP(inst) ? LDRLIT_DST(inst) : MOV_SRC(*((U32 *)address + 1)); + I32 worddisp = (U32 *)item - ((U32 *)address + 2); + if (worddisp >= -0x800000 && worddisp <= 0x7FFFFF) { + worddisp &= 0xFFFFFF; + *((U32 *)address + 0) = (callp ? MAKE_BL(worddisp) : MAKE_B(worddisp)); + *((U32 *)address + 1) = MAKE_MOV(reg,reg); /* effective NOP recording tmp reg for later use */ + *((U32 *)address + 2) = NOP; + *((U32 *)address + 3) = NOP; + } else { + *((U32 *)address + 0) = MAKE_LDRLIT(reg,0); + *((U32 *)address + 1) = MAKE_B(0); + *((U32 *)address + 2) = item; + *((U32 *)address + 3) = (callp ? MAKE_BLX(reg) : MAKE_BX(reg)); + } +} + +static uptr arm32_get_jump(void *address) { + U32 inst = *((U32 *)address + 0); + if (LDRLITP(inst)) { + return *((U32 *)address + 2); + } else { + I32 worddisp = B_OR_BL_DISP(inst); + if (worddisp >= 0x800000) worddisp -= 0x1000000; + return (uptr)(((U32 *)address + 2) + worddisp); + } +} +#endif /* ARMV6 */ + +#ifdef PPC32 + +#define UPDATE_ADDIS(item, instr) (((instr) & ~0xFFFF) | (((item) >> 16) & 0xFFFF)) +#define UPDATE_ADDI(item, instr) (((instr) & ~0xFFFF) | ((item) & 0xFFFF)) + +#define MAKE_B(disp, callp) ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp)) +#define MAKE_ADDIS(item) ((15 << 26) | (((item) >> 16) & 0xFFFF)) +#define MAKE_ORI(item) ((24 << 26) | ((item) & 0xFFFF)) +#define MAKE_NOP ((24 << 26)) +#define MAKE_MTCTR ((31 << 26) | (9 << 16) | (467 << 1)) +#define MAKE_BCTR(callp) ((19 << 26) | (20 << 21) | (528 << 1) | (callp)) + +static void ppc32_set_abs(void *address, uptr item) { + /* code generator produces addis destreg, %r0, 0 (hi) ; addi destreg, destreg, 0 (lo) */ + /* we change 0 (hi) => upper 16 bits of address */ + /* we change 0 (lo) => lower 16 bits of address */ + /* low part is signed: if negative, increment high part */ + item = item + (item << 1 & 0x10000); + *((U32 *)address + 0) = UPDATE_ADDIS(item, *((U32 *)address + 0)); + *((U32 *)address + 1) = UPDATE_ADDI(item, *((U32 *)address + 1)); +} + +static uptr ppc32_get_abs(void *address) { + uptr item = ((*((U32 *)address + 0) & 0xFFFF) << 16) | (*((U32 *)address + 1) & 0xFFFF); + return item - (item << 1 & 0x10000); +} + +static void ppc32_set_jump(void *address, uptr item, IBOOL callp) { + iptr disp = (iptr *)item - (iptr *)address; + if (-0x800000 <= disp && disp <= 0x7FFFFF) { + *((U32 *)address + 0) = MAKE_B(disp, callp); + *((U32 *)address + 1) = MAKE_NOP; + *((U32 *)address + 2) = MAKE_NOP; + *((U32 *)address + 3) = MAKE_NOP; + } else { + *((U32 *)address + 0) = MAKE_ADDIS(item); + *((U32 *)address + 1) = MAKE_ORI(item); + *((U32 *)address + 2) = MAKE_MTCTR; + *((U32 *)address + 3) = MAKE_BCTR(callp); + } +} + +static uptr ppc32_get_jump(void *address) { + uptr item, instr = *(U32 *)address; + + if ((instr >> 26) == 18) { + /* bl disp */ + iptr disp = (instr >> 2) & 0xFFFFFF; + if (disp & 0x800000) disp -= 0x1000000; + item = (uptr)address + (disp << 2); + } else { + /* lis r0, high + ori r0, r0, low */ + item = ((instr & 0xFFFF) << 16) | (*((U32 *)address + 1) & 0xFFFF); + } + + return item; +} +#endif /* PPC32 */ + +#ifdef X86_64 +static void x86_64_set_jump(void *address, uptr item, IBOOL callp) { + I64 disp = (I64)item - ((I64)address + 5); /* 5 = size of call instruction */ + if ((I32)disp == disp) { + *(octet *)address = callp ? 0xE8 : 0xE9; /* call or jmp disp32 opcode */ + *(I32 *)((uptr)address + 1) = (I32)disp; + /* 7-byte long NOP */ + *((octet *)address + 5) = 0x0f; + *((octet *)address + 6) = 0x1f; + *((octet *)address + 7) = 0x80; + *((octet *)address + 8) = 0x00; + *((octet *)address + 9) = 0x00; + *((octet *)address + 10) = 0x00; + *((octet *)address + 11) = 0x00; + } else { + *(octet *)address = 0x48; /* REX w/REX.w set */ + *((octet *)address + 1)= 0xB8; /* MOV imm64 to RAX */ + *(uptr *)((uptr)address + 2) = item; + *((octet *)address + 10) = 0xFF; /* call/jmp reg/mem opcode */ + *((octet *)address + 11) = callp ? 0xD0 : 0xE0; /* mod=11, ttt=010 (call) or 100 (jmp), r/m = 0 (RAX) */ + } +} + +static uptr x86_64_get_jump(void *address) { + if (*(octet *)address == 0x48) /* REX w/REX.w set */ + /* must be long form: move followed by call/jmp */ + return *(uptr *)((uptr)address + 2); + else + /* must be short form: call/jmp */ + return ((uptr)address + 5) + *(I32 *)((uptr)address + 1); +} +#endif /* X86_64 */ + +#ifdef SPARC64 +#define ASMREG0 1 +/* TMPREG is asm-literal-tmp in sparc64macros.ss */ +#define TMPREG 5 +/* CRETREG is retreg in sparc64macros.ss */ +#define CRETREG 15 +/* SRETREG is ret in sparc64macros.ss */ +#define SRETREG 26 + +#define OP_ADDI 0x80002000 +#define OP_CALL 0x40000000 +#define OP_JSR 0x81C00000 +#define OP_OR 0x80100000 +#define OP_ORI 0x80102000 +#define OP_SETHI 0x1000000 +/* SLLXI is the 64-bit version */ +#define OP_SLLXI 0x81283000 +#define OP_XORI 0x80182000 +/* NOP is sethi %g0,0 */ +#define NOP 0x1000000 +#define IMMMASK (U32)0x1fff +#define IMMRANGE(x) ((U32)(x) + (U32)0x1000 <= IMMMASK) +#define ADDI(src,imm,dst) (OP_ADDI | (dst) << 25 | (src) << 14 | (imm) & IMMMASK) +#define JSR(src) (OP_JSR | CRETREG << 25 | (src) << 14) +#define ORI(src,imm,dst) (OP_ORI | (dst) << 25 | (src) << 14 | (imm) & IMMMASK) +#define SETHI(dst,high) (OP_SETHI | (dst) << 25 | (high) & 0x3fffff) +#define CALL(disp) (OP_CALL | (disp) >> 2 & 0x3fffffff) + + +static INT extract_reg_from_sethi(void* address) { + return *(U32 *)address >> 25; +} + +static void emit_sethi_lo(U32 item, INT destreg, void *address) { + U32 high = item >> 10; + U32 low = item & 0x3ff; + + /* sethi destreg, high */ + *(U32 *)address = SETHI(destreg,high); + /* setlo destreg, low */ + *((U32 *)address + 1) = ORI(destreg,low,destreg); +} + +static uptr sparc64_get_literal(void *address) { + uptr item; + + /* we may have "call disp" followed by delay instruction */ + item = *(U32 *)address; + if (item >> 30 == OP_CALL >> 30) { + item = (item & 0x3fffffff) << 2; + if (item & 0x80000000) /* sign bit set */ + item = item | 0xffffffff00000000; + item = (uptr)address + (iptr)item; + return item; + } + + item = (item & 0x3fffff) << 10 | *((U32 *)address + 1) & 0x3ff; + if (*((U32 *)address + 2) != NOP) { + item = item << 32 | + (*((U32 *)address + 3) & 0x3fffff) << 10 | + *((U32 *)address + 4) & 0x3ff; + } + return item; +} + +static U32 adjust_delay_inst(delay_inst, old_call_addr, new_call_addr) + U32 delay_inst; U32 *old_call_addr, *new_call_addr; { + INT offset; + + offset = sizeof(U32) * (old_call_addr - new_call_addr); + if (offset == 0) return delay_inst; + + if ((delay_inst & ~IMMMASK) == ADDI(CRETREG,0,SRETREG)) { + INT k = delay_inst & IMMMASK; + k = k - ((k << 1) & (IMMMASK+1)); + offset = k + offset; + if (IMMRANGE(offset)) return ADDI(CRETREG,offset,SRETREG); + } else if ((delay_inst & ~IMMMASK) == ADDI(CRETREG,0,CRETREG)) { + INT k = delay_inst & IMMMASK; + k = k - ((k << 1) & (IMMMASK+1)); + offset = k + offset; + if (offset == 0) return NOP; + if (IMMRANGE(offset)) return ADDI(CRETREG,offset,CRETREG); + } else if (IMMRANGE(offset)) + return ADDI(CRETREG,offset,CRETREG); + + return 0; /* fortunately, not a valid instruction here */ +} + +static void sparc64_set_call(void *address, U32 *call_addr, uptr item) { + U32 delay_inst = *(call_addr + 1), new_delay_inst; iptr disp; + + /* later: make item local if it refers to Scheme code, i.e., is in the + Scheme heap, by copying it and every other code object we can reach + into a single close area of memory. Or generate a close stub. */ + disp = item - (uptr)address; + if (disp >= -0x20000000 && disp <= 0x1FFFFFFF && + (new_delay_inst = adjust_delay_inst(delay_inst, call_addr, + (U32 *)address))) { + *(U32 *)address = CALL(disp); + *((U32 *)address + 1) = new_delay_inst; + } else { + INT n = sparc64_set_lit_only(address, item, ASMREG0); + new_delay_inst = adjust_delay_inst(delay_inst, call_addr, (U32 *)address + n); + *((U32 *)address + n) = JSR(ASMREG0); + *((U32 *)address + n + 1) = new_delay_inst; + } +} + +static INT sparc64_set_lit_only(void *address, uptr item, I32 destreg) { + + if ((iptr)item >= -0xffffffff && item <= 0xffffffff) { + uptr x, high, low; + + if ((iptr)item < 0) { + x = 0x100000000 - item; + high = x >> 10; + low = x - (high << 10); + /* sethi destreg, ~high */ + *(U32 *)address = OP_SETHI | destreg << 25 | ~high & 0x3fffff; + /* xor.i destreg, low|0x1c00, destreg */ + *((U32 *)address + 1) = OP_XORI | destreg << 25 | destreg << 14 | + low | 0x1c00; + } else { + emit_sethi_lo(item, destreg, address); + } + *((U32 *)address + 2) = NOP; + *((U32 *)address + 3) = NOP; + *((U32 *)address + 4) = NOP; + *((U32 *)address + 5) = NOP; + return 2; + } else { + emit_sethi_lo(item >> 32, destreg, address); + /* sll destreg, 32, destreg */ + *((U32 *)address + 2) = OP_SLLXI | destreg << 25 | destreg << 14 | 32; + emit_sethi_lo(item & 0xffffffff, TMPREG, (void *)((U32 *)address+3)); + /* or destreg, tmpreg, destreg */ + *((U32 *)address + 5) = OP_OR | destreg << 25 | destreg << 14 | TMPREG; + return 6; + } +} + +static void sparc64_set_literal(void* address, uptr item) { + I32 destreg; + + /* case 1: we have call followed by delay inst */ + if (*(U32 *)address >> 30 == OP_CALL >> 30) { + sparc64_set_call(address, (U32 *)address, item); + return; + } + + destreg = extract_reg_from_sethi(address); + + /* case 2: we have two-instr load-literal followed by jsr and delay inst */ + if (*((U32 *)address + 2) == JSR(destreg)) { + sparc64_set_call(address, (U32 *)address + 2, item); + return; + } + + /* case 3: we have six-instr load-literal followed by jsr and a delay + instruction we're willing to try to deal with */ + if (*((U32 *)address + 6) == JSR(destreg) && + (*((U32 *)address + 7) & ~IMMMASK == ADDI(CRETREG,0,SRETREG) || + *((U32 *)address + 7) == NOP)) { + sparc64_set_call(address, (U32 *)address + 6, item); + return; + } + + /* case 4: we have a plain load-literal */ + sparc64_set_lit_only(address, item, destreg); +} +#endif /* SPARC64 */ diff --git a/c/flushcache.c b/c/flushcache.c new file mode 100644 index 0000000..e2520f9 --- /dev/null +++ b/c/flushcache.c @@ -0,0 +1,87 @@ +/* flushcache.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +#ifdef FLUSHCACHE +typedef struct { + uptr start; + uptr end; +} mod_range; + +#define mod_range_start(x) (((mod_range *)&BVIT(x,0))->start) +#define mod_range_end(x) (((mod_range *)&BVIT(x,0))->end) + +static uptr max_gap; + +static ptr make_mod_range(uptr start, uptr end) { + ptr bv = S_bytevector(sizeof(mod_range)); + mod_range_start(bv) = start; + mod_range_end(bv) = end; + return bv; +} + +/* we record info per thread so flush in one prematurely for another doesn't prevent + the other from doing its own flush...and also since it's not clear that flushing in one + actually syncs caches across cores & processors */ + +void S_record_code_mod(ptr tc, uptr addr, uptr bytes) { + uptr end = addr + bytes; + ptr ls = CODERANGESTOFLUSH(tc); + + if (ls != Snil) { + ptr last_mod = Scar(ls); + uptr last_end = mod_range_end(last_mod); + if (addr > last_end && addr - last_end < max_gap) { +#ifdef DEBUG + printf(" record_code_mod merging %x %x and %x %x\n", mod_range_start(last_mod), last_end, addr, end); fflush(stdout); +#endif + mod_range_end(last_mod) = end; + return; + } + } + +#ifdef DEBUG + printf(" record_code_mod new range %x to %x\n", addr, end); fflush(stdout); +#endif + CODERANGESTOFLUSH(tc) = S_cons_in(space_new, 0, make_mod_range(addr, end), ls); + return; +} + +extern void S_flush_instruction_cache(ptr tc) { + ptr ls; + + for (ls = CODERANGESTOFLUSH(tc); ls != Snil; ls = Scdr(ls)) { + S_doflush(mod_range_start(Scar(ls)), mod_range_end(Scar(ls))); + } + CODERANGESTOFLUSH(tc) = Snil; +} + +extern void S_flushcache_init(void) { + if (S_boot_time) { + max_gap = S_flushcache_max_gap(); + if (max_gap < (uptr)(code_data_disp + byte_alignment)) { + max_gap = (uptr)(code_data_disp + byte_alignment); + } + } +} +#else /* FLUSHCACHE */ + +extern void S_record_code_mod(UNUSED ptr tc, UNUSED uptr addr, UNUSED uptr bytes) {} +extern void S_flush_instruction_cache(UNUSED ptr tc) {} +extern void S_flushcache_init(void) { return; } + +#endif /* FLUSHCACHE */ diff --git a/c/foreign.c b/c/foreign.c new file mode 100644 index 0000000..fbe9a12 --- /dev/null +++ b/c/foreign.c @@ -0,0 +1,334 @@ +/* foreign.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define debug(y) /* (void)printf(y) *//* uncomment printf for debug */ +/* #define UNLINK(x) 0 *//* uncomment #define to preserve temp files */ + + +#include "system.h" + +/* we can now return arbitrary values (aligned or not) + * since the garbage collector ignores addresses outside of the heap + * or within foreign segments */ +#define ptr_to_addr(p) ((void *)p) +#define addr_to_ptr(a) ((ptr)a) + +/* buckets should be prime */ +#define buckets 457 +#define multiplier 3 + +#define ptrhash(x) ((uptr)x % buckets) + +#ifdef LOAD_SHARED_OBJECT +#if defined(HPUX) +#include +#define dlopen(path,flags) (void *)shl_load(path, BIND_IMMEDIATE, 0L) +#define s_dlerror() Sstring_utf8(strerror(errno), -1) +#elif defined(WIN32) +#define dlopen(path,flags) S_ntdlopen(path) +#define dlsym(h,s) S_ntdlsym(h,s) +#define s_dlerror() S_ntdlerror() +#else +#include +#define s_dlerror() Sstring_utf8(dlerror(), -1) +#ifndef RTLD_NOW +#define RTLD_NOW 2 +#endif /* RTLD_NOW */ +#endif /* machine types */ +#endif /* LOAD_SHARED_OBJECT */ + +/* locally defined functions */ +static uptr symhash(const char *s); +static ptr lookup_static(const char *s); +static ptr lookup_dynamic(const char *s, ptr tbl); +static ptr lookup(const char *s); +static ptr remove_foreign_entry(const char *s); +static void *lookup_foreign_entry(const char *s); +static ptr foreign_entries(void); +static ptr foreign_static_table(void); +static ptr foreign_dynamic_table(void); +static ptr bvstring(const char *s); + +#ifdef LOAD_SHARED_OBJECT +static void load_shared_object(const char *path); +#endif /* LOAD_SHARED_OBJECT */ + +#ifdef HPUX +void *proc2entry(void *f, ptr name) { + if (((uptr)f & 2) == 0) + if (name == NULL) + S_error("Sforeign_symbol", "invalid entry"); + else + S_error1("Sforeign_symbol", "invalid entry for ~s", name); + return (void *)((uptr)f & ~0x3); +} +#endif /* HPUX */ + +static ptr bvstring(const char *s) { + iptr n = strlen(s) + 1; + ptr x = S_bytevector(n); + memcpy(&BVIT(x, 0), s, n); + return x; +} + +/* multiplier weights each character, h = n factors in the length */ +static uptr symhash(const char *s) { + uptr n, h; + + h = n = strlen(s); + while (n--) h = h * multiplier + (unsigned char)*s++; + return h % buckets; +} + +static ptr lookup_static(const char *s) { + uptr b; ptr p; + + b = symhash(s); + for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p)) + if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0) + return Scdr(Scar(p)); + + return addr_to_ptr(0); +} + +#ifdef LOAD_SHARED_OBJECT +#define LOOKUP_DYNAMIC +static ptr lookup_dynamic(const char *s, ptr tbl) { + ptr p; + + for (p = tbl; p != Snil; p = Scdr(p)) { +#ifdef HPUX + (void *)value = (void *)0; /* assignment to prevent compiler warning */ + shl_t handle = (shl_t)ptr_to_addr(Scar(p)); + + if (shl_findsym(&handle, s, TYPE_PROCEDURE, (void *)&value) == 0) + return addr_to_ptr(proc2entry(value, NULL)); +#else /* HPUX */ + void *value; + + value = dlsym(ptr_to_addr(Scar(p)), s); + if (value != (void *)0) return addr_to_ptr(value); +#endif /* HPUX */ + } + + return addr_to_ptr(0); +} +#endif /* LOAD_SHARED_OBJECT */ + +static ptr lookup(const char *s) { + iptr b; ptr p; + +#ifdef LOOKUP_DYNAMIC + ptr x; + + x = lookup_dynamic(s, S_foreign_dynamic); + if (x == addr_to_ptr(0)) +#endif /* LOOKUP_DYNAMIC */ + + x = lookup_static(s); + if (x == addr_to_ptr(0)) return x; + + tc_mutex_acquire() + + b = ptrhash(x); + for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p)) { + if (Scar(Scar(p)) == x) { + SETCDR(Scar(p),bvstring(s)); + goto quit; + } + } + SETVECTIT(S_G.foreign_names, b, Scons(Scons(addr_to_ptr(x),bvstring(s)), + Svector_ref(S_G.foreign_names, b))); + +quit: + tc_mutex_release() + return x; +} + +void Sforeign_symbol(const char *s, void *v) { + iptr b; ptr x; + + tc_mutex_acquire() + +#ifdef HPUX + v = proc2entry(v,name); +#endif + + if ((x = lookup(s)) == addr_to_ptr(0)) { + b = symhash(s); + SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)), + Svector_ref(S_G.foreign_static, b))); + } else if (ptr_to_addr(x) != v) + S_error1("Sforeign_symbol", "duplicate symbol entry for ~s", Sstring_utf8(s, -1)); + + tc_mutex_release() +} + +/* like Sforeign_symbol except it silently redefines the symbol + if it's already in S_G.foreign_static */ +void Sregister_symbol(const char *s, void *v) { + uptr b; ptr p; + + tc_mutex_acquire() + + b = symhash(s); + for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p)) + if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0) { + INITCDR(Scar(p)) = addr_to_ptr(v); + goto quit; + } + SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)), + Svector_ref(S_G.foreign_static, b))); + + quit: + tc_mutex_release() +} + +static ptr remove_foreign_entry(const char *s) { + uptr b; + ptr tbl, p1, p2; + + tc_mutex_acquire() + + b = symhash(s); + tbl = S_G.foreign_static; + p1 = Snil; + p2 = Svector_ref(tbl, b); + for (; p2 != Snil; p1 = p2, p2 = Scdr(p2)) { + if (strcmp(s, (char *)&BVIT(Scar(Scar(p2)), 0)) == 0) { + if (p1 == Snil) { + SETVECTIT(tbl, b, Scdr(p2)) + } else { + SETCDR(p1, Scdr(p2)) + } + tc_mutex_release() + return Strue; + } + } + tc_mutex_release() + return Sfalse; +} + +#ifdef LOAD_SHARED_OBJECT +static void load_shared_object(const char *path) { + void *handle; + + tc_mutex_acquire() + + handle = dlopen(path, RTLD_NOW); + if (handle == (void *)NULL) + S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror()); + S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic); + + tc_mutex_release() + + return; +} +#endif /* LOAD_SHARED_OBJECT */ + +void S_foreign_entry(void) { + ptr tc = get_thread_context(); + ptr name, x, bvname; + iptr i, n; + + name = AC0(tc); + if (Sfixnump(name) || Sbignump(name)) { + AC0(tc) = (ptr)Sinteger_value(name); + return; + } + + if (!(Sstringp(name))) { + S_error1("foreign-procedure", "invalid foreign procedure handle ~s", name); + } + + n = Sstring_length(name); + bvname = S_bytevector(n + 1); + for (i = 0; i != n; i += 1) { + int k = Sstring_ref(name, i); + if (k >= 256) k = '?'; + BVIT(bvname, i) = k; + } + BVIT(bvname, n) = 0; + + if ((x = lookup((char *)&BVIT(bvname, 0))) == addr_to_ptr(0)) { + S_error1("foreign-procedure", "no entry for ~s", name); + } + + AC0(tc) = x; +} + +static void *lookup_foreign_entry(s) const char *s; { + return ptr_to_addr(lookup(s)); +} + +static ptr foreign_entries(void) { + iptr b; ptr p, entries; + + entries = Snil; + + for (b = 0; b < buckets; b++) + for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p)) + entries = Scons(Sstring_utf8((char *)&BVIT(Scar(Scar(p)), 0), -1), entries); + + return entries; +} + +static ptr foreign_static_table(void) { return S_G.foreign_static; } +#ifdef LOAD_SHARED_OBJECT +static ptr foreign_dynamic_table(void) { return S_foreign_dynamic; } +#else +static ptr foreign_dynamic_table(void) { return Sfalse; } +#endif /* LOAD_SHARED_OBJECT */ + +static octet *foreign_address_name(ptr addr) { + iptr b; ptr p; + + b = ptrhash(addr); + for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p)) + if (Scar(Scar(p)) == (ptr)addr) + return &BVIT(Scdr(Scar(p)),0); + + return NULL; +} + +void S_foreign_init(void) { + if (S_boot_time) { + S_protect(&S_G.foreign_static); + S_G.foreign_static = S_vector(buckets); + {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_static,i) = Snil;} + + S_protect(&S_G.foreign_names); + S_G.foreign_names = S_vector(buckets); + {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_names,i) = Snil;} + +#ifdef LOAD_SHARED_OBJECT + S_protect(&S_foreign_dynamic); + S_foreign_dynamic = Snil; + Sforeign_symbol("(cs)load_shared_object", (void *)load_shared_object); +#endif /* LOAD_SHARED_OBJECT */ + + Sforeign_symbol("(cs)lookup_foreign_entry", (void *)lookup_foreign_entry); + Sforeign_symbol("(cs)remove_foreign_entry", (void *)remove_foreign_entry); + Sforeign_symbol("(cs)foreign_entries", (void *)foreign_entries); + Sforeign_symbol("(cs)foreign_static_table", (void *)foreign_static_table); + Sforeign_symbol("(cs)foreign_dynamic_table", (void *)foreign_dynamic_table); + Sforeign_symbol("(cs)foreign_address_name", (void *)foreign_address_name); + } + +#ifdef LOAD_SHARED_OBJECT + S_foreign_dynamic = Snil; +#endif /* LOAD_SHARED_OBJECT */ +} diff --git a/c/gc-011.c b/c/gc-011.c new file mode 100644 index 0000000..5fbbbef --- /dev/null +++ b/c/gc-011.c @@ -0,0 +1,23 @@ +/* gc-011.c + * Copyright 1984-2020 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define GCENTRY S_gc_011 +#define MAX_CG 0 +#define MIN_TG 1 +#define MAX_TG 1 +#define compute_target_generation(g) 1 +#define NO_LOCKED_OLDSPACE_OBJECTS +#include "gc.c" diff --git a/c/gc-ocd.c b/c/gc-ocd.c new file mode 100644 index 0000000..614d4fa --- /dev/null +++ b/c/gc-ocd.c @@ -0,0 +1,18 @@ +/* gc-ocd.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define GCENTRY S_gc_ocd +#include "gc.c" diff --git a/c/gc-oce.c b/c/gc-oce.c new file mode 100644 index 0000000..ab910e7 --- /dev/null +++ b/c/gc-oce.c @@ -0,0 +1,19 @@ +/* gc-oce.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define GCENTRY S_gc_oce +#define ENABLE_OBJECT_COUNTS +#include "gc.c" diff --git a/c/gc.c b/c/gc.c new file mode 100644 index 0000000..425d92f --- /dev/null +++ b/c/gc.c @@ -0,0 +1,2324 @@ +/* gc.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" +#include "sort.h" +#ifndef WIN32 +#include +#endif /* WIN32 */ + +#define enable_object_counts do_not_use_enable_object_counts_in_this_file_use_ifdef_ENABLE_OBJECT_COUNTS_instead + +#if defined(MIN_TG) && defined(MAX_TG) +#if MIN_TG == MAX_TG +#define NO_DIRTY_NEWSPACE_POINTERS +#endif +#endif + +#if defined(MAX_CG) && defined(MIN_TG) && defined(MAX_TG) +#define FORMAL_CTGS +#define ONLY_FORMAL_CTGS void +#define ACTUAL_CTGS +#define ONLY_ACTUAL_CTGS +#define DECLARE_CTGS(max_cg, min_tg, max_tg) IGEN max_cg = MAX_CG, min_tg = MIN_TG, max_tg = MAX_TG +#define GCENTRY_PROTO(tcdecl, max_cgdecl, min_tgdecl, max_tgdecl) (tcdecl) +#else +#define FORMAL_CTGS , UINT _ctgs +#define ONLY_FORMAL_CTGS UINT _ctgs +#define ACTUAL_CTGS , _ctgs +#define ONLY_ACTUAL_CTGS _ctgs +#define DECLARE_CTGS(max_cg, min_tg, max_tg) UINT _ctgs = (((UINT)min_tg << 16) | ((UINT)max_cg << 8) | (UINT)max_tg) +#define MAX_CG ((INT)((_ctgs >> 8) & 0xff)) +#define MIN_TG ((INT)(_ctgs >> 16)) +#define MAX_TG ((INT)(_ctgs & 0xff)) +#define GCENTRY_PROTO(tcdecl, max_cgdecl, min_tgdecl, max_tgdecl) (tcdecl, max_cgdecl, min_tgdecl, max_tgdecl) +#endif + +/* locally defined functions */ +#ifndef NO_DIRTY_NEWSPACE_POINTERS +static void record_new_dirty_card(ptr *ppp, IGEN to_g); +#endif /* !NO_DIRTY_NEWSPACE_POINTERS */ +#ifndef NO_LOCKED_OLDSPACE_OBJECTS +static ptr append_bang(ptr ls1, ptr ls2); +static uptr count_unique(ptr ls); +static uptr list_length(ptr ls); +static ptr dosort(ptr ls, uptr n); +static ptr domerge(ptr l1, ptr l2); +static IBOOL search_locked(ptr p); +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ +static IGEN copy(ptr pp, seginfo *si, ptr *ppp FORMAL_CTGS); +static void sweep_locked_ptrs(ptr *p, iptr n FORMAL_CTGS); +static void sweep_locked(ptr tc, ptr p, IBOOL sweep_pure FORMAL_CTGS); +static ptr copy_stack(ptr old, iptr *length, iptr clength FORMAL_CTGS); +static void resweep_weak_pairs(ONLY_FORMAL_CTGS); +static void forward_or_bwp(ptr *pp, ptr p); +static void sweep_generation(ptr tc FORMAL_CTGS); +#ifndef NO_LOCKED_OLDSPACE_OBJECTS +static iptr size_object(ptr p); +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ +static iptr sweep_typed_object(ptr p, IGEN from_g FORMAL_CTGS); +static void sweep_symbol(ptr p, IGEN from_g FORMAL_CTGS); +static void sweep_port(ptr p, IGEN from_g FORMAL_CTGS); +static void sweep_thread(ptr p FORMAL_CTGS); +static void sweep_continuation(ptr p FORMAL_CTGS); +static void sweep_stack(uptr base, uptr size, uptr ret FORMAL_CTGS); +static void sweep_record(ptr x, IGEN from_g FORMAL_CTGS); +static IGEN sweep_dirty_record(ptr x, IGEN youngest FORMAL_CTGS); +static void sweep_code_object(ptr tc, ptr co FORMAL_CTGS); +static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si); +static void sweep_dirty(ONLY_FORMAL_CTGS); +static void resweep_dirty_weak_pairs(ONLY_FORMAL_CTGS); +static void add_ephemeron_to_pending(ptr p); +static void add_trigger_ephemerons_to_repending(ptr p); +static void check_trigger_ephemerons(seginfo *si); +static void check_ephemeron(ptr pe, IBOOL add_to_trigger FORMAL_CTGS); +static void check_pending_ephemerons(ONLY_FORMAL_CTGS); +static IGEN check_dirty_ephemeron(ptr pe, IGEN youngest FORMAL_CTGS); +static void clear_trigger_ephemerons(); + +#define OLDSPACE(x) (SPACE(x) & space_old) + +/* #define DEBUG */ + +/* initialized and used each gc cycle. any others should be defined in globals.h */ +static IBOOL change; +static ptr sweep_loc[static_generation+1][max_real_space+1]; +static ptr orig_next_loc[static_generation+1][max_real_space+1]; +#ifndef NO_LOCKED_OLDSPACE_OBJECTS +static ptr sorted_locked_objects; +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ +static ptr tlcs_to_rehash; + +#ifndef compute_target_generation +FORCEINLINE IGEN compute_target_generation(IGEN g FORMAL_CTGS) { + return g == MAX_TG ? g : g < MIN_TG ? MIN_TG : g + 1; +} +#endif /* !compute_target_generation */ + +/* rkd 2020/06/16: had the relocate routines more nicely coded with FORCEINLINE. + unfortunately, the llvm-compiled gc ran much (10-20%) slower on my mac. */ +#define relocate_return_addr(PCP) do {\ + ptr *_pcp = PCP;\ + seginfo *_si;\ + ptr _cp = *_pcp;\ + if ((_si = SegInfo(ptr_get_segment(_cp)))->space & space_old) {\ + iptr _co = ENTRYOFFSET(_cp) + ((uptr)_cp - (uptr)&ENTRYOFFSET(_cp));\ + ptr _pp = (ptr)((uptr)_cp - _co);\ + if (FWDMARKER(_pp) == forward_marker)\ + _pp = FWDADDRESS(_pp);\ + else\ + (void) copy(_pp, _si, &_pp ACTUAL_CTGS);\ + *_pcp = (ptr)((uptr)_pp + _co);\ + }\ +} while (0) + +/* use relocate_dirty for oldspace fields that might hold pointers to younger objects */ +#define relocate_dirty(PPP, YOUNGEST) do {\ + seginfo *_si; ptr *_ppp = PPP, _pp = *_ppp; IGEN _pg;\ + if (!IMMEDIATE(_pp) && (_si = MaybeSegInfo(ptr_get_segment(_pp))) != NULL) {\ + if (!(_si->space & space_old)) {\ + _pg = _si->generation;\ + } else if (FWDMARKER(_pp) == forward_marker && TYPEBITS(_pp) != type_flonum) {\ + *_ppp = FWDADDRESS(_pp);\ + _pg = compute_target_generation(_si->generation ACTUAL_CTGS);\ + } else {\ + _pg = copy(_pp, _si, _ppp ACTUAL_CTGS);\ + }\ + if (_pg < YOUNGEST) YOUNGEST = _pg;\ + }\ +} while (0) + +/* use relocate_pure for newspace fields that can't point to younger objects */ +#define relocate_pure_help(PPP, PP) do {\ + ptr *__ppp = PPP, __pp = PP; seginfo *__si;\ + if (!IMMEDIATE(__pp) && (__si = MaybeSegInfo(ptr_get_segment(__pp))) != NULL && (__si->space & space_old)) {\ + if (FWDMARKER(__pp) == forward_marker && TYPEBITS(__pp) != type_flonum) {\ + *__ppp = FWDADDRESS(__pp);\ + } else {\ + (void) copy(__pp, __si, __ppp ACTUAL_CTGS);\ + }\ + }\ +} while (0) + +#define relocate_pure(PPP) do {\ + ptr *_ppp = PPP; relocate_pure_help(_ppp, *_ppp);\ +} while (0) + +/* use relocate_impure for newspace fields that can point to younger objects */ +#ifdef NO_DIRTY_NEWSPACE_POINTERS +#define relocate_impure_help(PPP, PP, FROM_G) do {(void)FROM_G; relocate_pure_help(PPP, PP);} while (0) +#define relocate_impure(PPP, FROM_G) do {(void)FROM_G; relocate_pure(PPP);} while (0) +#else /* !NO_DIRTY_NEWSPACE_POINTERS */ +/* the initialization of __to_g to 0 below shouldn't be necessary, but gcc 7.5.0 complains without it */ +#define relocate_impure_help(PPP, PP, FROM_G) do {\ + ptr *__ppp = PPP, __pp = PP; IGEN __from_g = FROM_G;\ + seginfo *__si; IGEN __to_g = 0;\ + if (!IMMEDIATE(__pp) && (__si = MaybeSegInfo(ptr_get_segment(__pp))) != NULL && (__si->space & space_old)) {\ + if (FWDMARKER(__pp) == forward_marker && TYPEBITS(__pp) != type_flonum ?\ + (*__ppp = FWDADDRESS(__pp), (__from_g > 1 && (__to_g = compute_target_generation(__si->generation ACTUAL_CTGS)) < __from_g)) :\ + ((__to_g = copy(__pp, __si, __ppp ACTUAL_CTGS)) < __from_g)) {\ + record_new_dirty_card(__ppp, __to_g);\ + }\ + }\ +} while (0) + +#define relocate_impure(PPP, FROM_G) do {\ + ptr *_ppp = PPP; relocate_impure_help(_ppp, *_ppp, FROM_G);\ +} while (0) +#endif /* !NO_DIRTY_NEWSPACE_POINTERS */ + +#ifndef NO_DIRTY_NEWSPACE_POINTERS +typedef struct _dirtycardinfo { + uptr card; + IGEN youngest; + struct _dirtycardinfo *next; +} dirtycardinfo; + +static dirtycardinfo *new_dirty_cards; + +static void record_new_dirty_card(ptr *ppp, IGEN to_g) { + uptr card = (uptr)ppp >> card_offset_bits; + + dirtycardinfo *ndc = new_dirty_cards; + if (ndc != NULL && ndc->card == card) { + if (to_g < ndc->youngest) ndc->youngest = to_g; + } else { + dirtycardinfo *next = ndc; + find_room(space_new, 0, typemod, ptr_align(sizeof(dirtycardinfo)), ndc); + ndc->card = card; + ndc->youngest = to_g; + ndc->next = next; + new_dirty_cards = ndc; + } +} +#endif + +/* rkd 2015/06/05: tried to use sse instructions. abandoned the code + because the collector ran slower */ +#define copy_ptrs(ty, p1, p2, n) {\ + ptr *Q1, *Q2, *Q1END;\ + Q1 = (ptr *)UNTYPE((p1),ty);\ + Q2 = (ptr *)UNTYPE((p2),ty);\ + Q1END = (ptr *)((uptr)Q1 + n);\ + while (Q1 != Q1END) *Q1++ = *Q2++;} + +#ifdef NO_LOCKED_OLDSPACE_OBJECTS +#define locked(p) 0 +#else /* !NO_LOCKED_OLDSPACE_OBJECTS */ +/* MAXPTR is used to pad the sorted_locked_object vector. The pad value must be greater than any heap address */ +#define MAXPTR ((ptr)-1) + +static ptr append_bang(ptr ls1, ptr ls2) { /* assumes ls2 pairs are older than ls1 pairs, or that we don't care */ + if (ls2 == Snil) { + return ls1; + } else if (ls1 == Snil) { + return ls2; + } else { + ptr this = ls1, next; + while ((next = Scdr(this)) != Snil) this = next; + INITCDR(this) = ls2; + return ls1; + } +} + +static uptr count_unique(ptr ls) { /* assumes ls is sorted and nonempty */ + uptr i = 1; ptr x = Scar(ls), y; + while ((ls = Scdr(ls)) != Snil) { + if ((y = Scar(ls)) != x) { + i += 1; + x = y; + } + } + return i; +} + +#define CARLT(x, y) (Scar(x) < Scar(y)) +mkmergesort(dosort, domerge, ptr, Snil, CARLT, INITCDR) + +uptr list_length(ptr ls) { + uptr i = 0; + while (ls != Snil) { ls = Scdr(ls); i += 1; } + return i; +} + +static IBOOL search_locked(ptr p) { + uptr k; ptr v, *vp, x; + v = sorted_locked_objects; + k = Svector_length(v); + vp = &INITVECTIT(v, 0); + for (;;) { + k >>= 1; + if ((x = vp[k]) == p) return 1; + if (k == 0) return 0; + if (x < p) vp += k + 1; + } +} + +#define locked(p) (sorted_locked_objects != FIX(0) && search_locked(p)) +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + +FORCEINLINE void check_trigger_ephemerons(seginfo *si) { + /* Registering ephemerons to recheck at the granularity of a segment + means that the worst-case complexity of GC is quadratic in the + number of objects that fit into a segment (but that only happens + if the objects are ephemeron keys that are reachable just through + a chain via the value field of the same ephemerons). */ + if (si->trigger_ephemerons) { + add_trigger_ephemerons_to_repending(si->trigger_ephemerons); + si->trigger_ephemerons = NULL; + } +} + +static IGEN copy(ptr pp, seginfo *si, ptr *ppp FORMAL_CTGS) { + ptr p, tf; ITYPE t; + IGEN newg = compute_target_generation(si->generation ACTUAL_CTGS); + +#ifndef NO_LOCKED_OLDSPACE_OBJECTS + if (locked(pp)) { *ppp = pp; return newg; } +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + + change = 1; + + check_trigger_ephemerons(si); + + if ((t = TYPEBITS(pp)) == type_typed_object) { + tf = TYPEFIELD(pp); + if (TYPEP(tf, mask_record, type_record)) { + ptr rtd; iptr n; ISPC s; + + /* relocate to make sure we aren't using an oldspace descriptor + that has been overwritten by a forwarding marker, but don't loop + on tag-reflexive base descriptor */ + if ((rtd = tf) != pp) relocate_pure(&rtd); + + n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + +#ifdef ENABLE_OBJECT_COUNTS + { ptr counts; IGEN g; + counts = RECORDDESCCOUNTS(rtd); + if (counts == Sfalse) { + IGEN grtd = rtd == pp ? newg : GENERATION(rtd); + S_G.countof[grtd][countof_rtd_counts] += 1; + /* allocate counts struct in same generation as rtd. initialize timestamp & counts */ + find_room(space_data, grtd, type_typed_object, size_rtd_counts, counts); + RTDCOUNTSTYPE(counts) = type_rtd_counts; + RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0]; + for (g = 0; g <= static_generation; g += 1) RTDCOUNTSIT(counts, g) = 0; + RECORDDESCCOUNTS(rtd) = counts; + S_G.rtds_with_counts[grtd] = S_cons_in((grtd == 0 ? space_new : space_impure), grtd, rtd, S_G.rtds_with_counts[grtd]); + S_G.countof[grtd][countof_pair] += 1; + } else { + relocate_pure(&counts); + RECORDDESCCOUNTS(rtd) = counts; + if (RTDCOUNTSTIMESTAMP(counts) != S_G.gctimestamp[0]) S_fixup_counts(counts); + } + RTDCOUNTSIT(counts, newg) += 1; + } +#endif /* ENABLE_OBJECT_COUNTS */ + + /* if the rtd is the only pointer and is immutable, put the record + into space data. if the record contains only pointers, put it + into space_pure or space_impure. otherwise put it into + space_pure_typed_object or space_impure_record. we could put all + records into space_{pure,impure}_record or even into + space_impure_record, but by picking the target space more + carefully we may reduce fragmentation and sweeping cost */ + s = RECORDDESCPM(rtd) == FIX(1) && RECORDDESCMPM(rtd) == FIX(0) ? + space_data : + RECORDDESCPM(rtd) == FIX(-1) ? + RECORDDESCMPM(rtd) == FIX(0) ? + space_pure : + space_impure : + RECORDDESCMPM(rtd) == FIX(0) ? + space_pure_typed_object : + space_impure_record; + + find_room(s, newg, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + + /* overwrite type field with forwarded descriptor */ + RECORDINSTTYPE(p) = rtd == pp ? p : rtd; + + /* pad if necessary */ + if (s == space_pure || s == space_impure) { + iptr m = unaligned_size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + if (m != n) + *((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0); + } + } else if (TYPEP(tf, mask_vector, type_vector)) { + iptr len, n; + len = Svector_length(pp); + n = size_vector(len); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_vector] += 1; + S_G.bytesof[newg][countof_vector] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + /* assumes vector lengths look like fixnums; if not, vectors will need their own space */ + if ((uptr)tf & vector_immutable_flag) { + find_room(space_pure, newg, type_typed_object, n, p); + } else { + find_room(space_impure, newg, type_typed_object, n, p); + } + copy_ptrs(type_typed_object, p, pp, n); + /* pad if necessary */ + if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0); + } else if (TYPEP(tf, mask_string, type_string)) { + iptr n; + n = size_string(Sstring_length(pp)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_string] += 1; + S_G.bytesof[newg][countof_string] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + iptr n; + n = size_bytevector(Sbytevector_length(pp)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_bytevector] += 1; + S_G.bytesof[newg][countof_bytevector] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if ((iptr)tf == type_tlc) { + ptr keyval, next; + +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_tlc] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_impure, newg, type_typed_object, size_tlc, p); + TLCTYPE(p) = type_tlc; + INITTLCKEYVAL(p) = keyval = TLCKEYVAL(pp); + INITTLCHT(p) = TLCHT(pp); + INITTLCNEXT(p) = next = TLCNEXT(pp); + + /* if next isn't false and keyval is old, add tlc to a list of tlcs + * to process later. determining if keyval is old is a (conservative) + * approximation to determining if key is old. we can't easily + * determine if key is old, since keyval might or might not have been + * swept already. NB: assuming keyvals are always pairs. */ + if (next != Sfalse && SPACE(keyval) & space_old) + tlcs_to_rehash = S_cons_in(space_new, 0, p, tlcs_to_rehash); + } else if (TYPEP(tf, mask_box, type_box)) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_box] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + if ((uptr)tf == type_immutable_box) { + find_room(space_pure, newg, type_typed_object, size_box, p); + } else { + find_room(space_impure, newg, type_typed_object, size_box, p); + } + BOXTYPE(p) = (iptr)tf; + INITBOXREF(p) = Sunbox(pp); + } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { + iptr n; + n = size_fxvector(Sfxvector_length(pp)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_fxvector] += 1; + S_G.bytesof[newg][countof_fxvector] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if ((iptr)tf == type_ratnum) { + /* not recursive: place in space_data and relocate fields immediately */ +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_ratnum] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, + type_typed_object, size_ratnum, p); + RATTYPE(p) = type_ratnum; + RATNUM(p) = RATNUM(pp); + RATDEN(p) = RATDEN(pp); + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); + } else if ((iptr)tf == type_exactnum) { + /* not recursive: place in space_data and relocate fields immediately */ +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_exactnum] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, + type_typed_object, size_exactnum, p); + EXACTNUM_TYPE(p) = type_exactnum; + EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp); + EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp); + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); + } else if ((iptr)tf == type_inexactnum) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_inexactnum] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, + type_typed_object, size_inexactnum, p); + INEXACTNUM_TYPE(p) = type_inexactnum; + INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp); + INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp); + } else if (TYPEP(tf, mask_bignum, type_bignum)) { + iptr n; + n = size_bignum(BIGLEN(pp)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_bignum] += 1; + S_G.bytesof[newg][countof_bignum] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_port, type_port)) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_port] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_port, newg, type_typed_object, size_port, p); + PORTTYPE(p) = PORTTYPE(pp); + PORTHANDLER(p) = PORTHANDLER(pp); + PORTNAME(p) = PORTNAME(pp); + PORTINFO(p) = PORTINFO(pp); + PORTOCNT(p) = PORTOCNT(pp); + PORTICNT(p) = PORTICNT(pp); + PORTOBUF(p) = PORTOBUF(pp); + PORTOLAST(p) = PORTOLAST(pp); + PORTIBUF(p) = PORTIBUF(pp); + PORTILAST(p) = PORTILAST(pp); + } else if (TYPEP(tf, mask_code, type_code)) { + iptr n; + n = size_code(CODELEN(pp)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_code] += 1; + S_G.bytesof[newg][countof_code] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_code, newg, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if ((iptr)tf == type_thread) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_thread] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_pure_typed_object, newg, + type_typed_object, size_thread, p); + TYPEFIELD(p) = (ptr)type_thread; + THREADTC(p) = THREADTC(pp); /* static */ + } else if ((iptr)tf == type_rtd_counts) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_rtd_counts] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, type_typed_object, size_rtd_counts, p); + copy_ptrs(type_typed_object, p, pp, size_rtd_counts); + } else { + S_error_abort("copy(gc): illegal type"); + return newg /* not reached */; + } + } else if (t == type_pair) { + if (si->space == (space_ephemeron | space_old)) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_ephemeron] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_ephemeron, newg, type_pair, size_ephemeron, p); + INITCAR(p) = Scar(pp); + INITCDR(p) = Scdr(pp); + } else { + ptr qq = Scdr(pp); ptr q; + if (qq != pp && TYPEBITS(qq) == type_pair && ptr_get_segment(qq) == ptr_get_segment(pp) && FWDMARKER(qq) != forward_marker && !locked(qq)) { + if (si->space == (space_weakpair | space_old)) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_weakpair] += 2; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_weakpair, newg, type_pair, 2 * size_pair, p); + } else { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_pair] += 2; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_impure, newg, type_pair, 2 * size_pair, p); + } + q = (ptr)((uptr)p + size_pair); + INITCAR(p) = Scar(pp); + INITCDR(p) = q; + INITCAR(q) = Scar(qq); + INITCDR(q) = Scdr(qq); + FWDMARKER(qq) = forward_marker; + FWDADDRESS(qq) = q; + } else { + if (si->space == (space_weakpair | space_old)) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_weakpair] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_weakpair, newg, type_pair, size_pair, p); + } else { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_pair] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_impure, newg, type_pair, size_pair, p); + } + INITCAR(p) = Scar(pp); + INITCDR(p) = qq; + } + } + } else if (t == type_closure) { + ptr code; + + /* relocate before accessing code type field, which otherwise might + be a forwarding marker */ + code = CLOSCODE(pp); + relocate_pure(&code); + if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_continuation] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_continuation, newg, + type_closure, size_continuation, p); + SETCLOSCODE(p,code); + /* don't promote one-shots */ + CONTLENGTH(p) = CONTLENGTH(pp); + CONTCLENGTH(p) = CONTCLENGTH(pp); + CONTWINDERS(p) = CONTWINDERS(pp); + if (CONTLENGTH(p) != scaled_shot_1_shot_flag) { + CONTLINK(p) = CONTLINK(pp); + CONTRET(p) = CONTRET(pp); + CONTSTACK(p) = CONTSTACK(pp); + } + } else { + iptr len, n; + len = CLOSLEN(pp); + n = size_closure(len); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_closure] += 1; + S_G.bytesof[newg][countof_closure] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_pure, newg, type_closure, n, p); + copy_ptrs(type_closure, p, pp, n); + SETCLOSCODE(p,code); + /* pad if necessary */ + if ((len & 1) == 0) CLOSIT(p, len) = FIX(0); + } + } else if (t == type_symbol) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_symbol] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_symbol, newg, type_symbol, size_symbol, p); + INITSYMVAL(p) = SYMVAL(pp); + INITSYMPVAL(p) = SYMPVAL(pp); + INITSYMPLIST(p) = SYMPLIST(pp); + INITSYMSPLIST(p) = SYMSPLIST(pp); + INITSYMNAME(p) = SYMNAME(pp); + INITSYMHASH(p) = SYMHASH(pp); + } else if (t == type_flonum) { +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_flonum] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, type_flonum, size_flonum, p); + FLODAT(p) = FLODAT(pp); + /* no room for forwarding address, so let 'em be duplicated */ + *ppp = p; + return newg; + } else { + S_error_abort("copy(gc): illegal type"); + return newg /* not reached */; + } + + FWDMARKER(pp) = forward_marker; + FWDADDRESS(pp) = p; + + *ppp = p; + return newg; +} + +static void sweep_locked_ptrs(ptr *pp, iptr n FORMAL_CTGS) { + ptr *end = pp + n; + + while (pp != end) { + relocate_pure(pp); + pp += 1; + } +} + +static void sweep_locked(ptr tc, ptr p, IBOOL sweep_pure FORMAL_CTGS) { + ptr tf; ITYPE t; + + if ((t = TYPEBITS(p)) == type_pair) { + ISPC s = SPACE(p) & ~(space_locked | space_old); + if (s == space_ephemeron) + add_ephemeron_to_pending(p); + else { + if (s != space_weakpair) { + relocate_pure(&INITCAR(p)); + } + relocate_pure(&INITCDR(p)); + } + } else if (t == type_closure) { + if (sweep_pure) { + ptr code; + + code = CLOSCODE(p); + relocate_pure(&code); + SETCLOSCODE(p,code); + if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) + sweep_continuation(p ACTUAL_CTGS); + else + sweep_locked_ptrs(&CLOSIT(p, 0), CLOSLEN(p) ACTUAL_CTGS); + } + } else if (t == type_symbol) { + sweep_symbol(p, 0 ACTUAL_CTGS); + } else if (t == type_flonum) { + /* nothing to sweep */; + /* typed objects */ + } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { + sweep_locked_ptrs(&INITVECTIT(p, 0), Svector_length(p) ACTUAL_CTGS); + } else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) { + /* nothing to sweep */; + } else if (TYPEP(tf, mask_record, type_record)) { + relocate_pure(&RECORDINSTTYPE(p)); + if (sweep_pure || RECORDDESCMPM(RECORDINSTTYPE(p)) != FIX(0)) { + sweep_record(p, 0 ACTUAL_CTGS); + } + } else if (TYPEP(tf, mask_box, type_box)) { + relocate_pure(&INITBOXREF(p)); + } else if ((iptr)tf == type_ratnum) { + if (sweep_pure) { + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); + } + } else if ((iptr)tf == type_exactnum) { + if (sweep_pure) { + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); + } + } else if ((iptr)tf == type_inexactnum) { + /* nothing to sweep */; + } else if (TYPEP(tf, mask_bignum, type_bignum)) { + /* nothing to sweep */; + } else if (TYPEP(tf, mask_port, type_port)) { + sweep_port(p, 0 ACTUAL_CTGS); + } else if (TYPEP(tf, mask_code, type_code)) { + if (sweep_pure) { + sweep_code_object(tc, p ACTUAL_CTGS); + } + } else if ((iptr)tf == type_thread) { + sweep_thread(p ACTUAL_CTGS); + } else if ((iptr)tf == type_rtd_counts) { + /* nothing to sweep */; + } else { + S_error_abort("sweep_locked(gc): illegal type"); + } +} + +static ptr copy_stack(ptr old, iptr *length, iptr clength FORMAL_CTGS) { + iptr n, m; ptr new; IGEN newg; + + /* Don't copy non-oldspace stacks, since we may be sweeping a locked + continuation. Doing so would be a waste of work anyway. */ + if (!OLDSPACE(old)) return old; + + newg = compute_target_generation(GENERATION(old) ACTUAL_CTGS); + + /* reduce headroom created for excessively large frames (typically resulting from apply with long lists) */ + if ((n = *length) != clength && n > default_stack_size && n > (m = clength + one_shot_headroom)) { + *length = n = m; + } + + n = ptr_align(n); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_stack] += 1; + S_G.bytesof[newg][countof_stack] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, typemod, n, new); + n = ptr_align(clength); + /* warning: stack may have been left non-double-aligned by split_and_resize */ + copy_ptrs(typemod, new, old, n); + + /* also returning possibly updated value in *length */ + return new; +} + +#define NONSTATICINHEAP(si, x) (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation) +#define ALWAYSTRUE(si, x) (si = SegInfo(ptr_get_segment(x)), 1) +#define partition_guardians(LS, FILTER) { \ + ptr ls; seginfo *si;\ + for (ls = LS; ls != Snil; ls = next) { \ + obj = GUARDIANOBJ(ls); \ + next = GUARDIANNEXT(ls); \ + \ + if (FILTER(si, obj)) { \ + if (!(si->space & space_old) || locked(obj) || ((FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) && (INITGUARDIANOBJ(ls) = FWDADDRESS(obj), 1))) { \ + INITGUARDIANNEXT(ls) = pend_hold_ls; \ + pend_hold_ls = ls; \ + } else { \ + tconc = GUARDIANTCONC(ls); \ + if (!OLDSPACE(tconc) || locked(tconc) || ((FWDMARKER(tconc) == forward_marker) && (INITGUARDIANTCONC(ls) = FWDADDRESS(tconc), 1))) { \ + INITGUARDIANNEXT(ls) = final_ls; \ + final_ls = ls; \ + } else { \ + INITGUARDIANNEXT(ls) = pend_final_ls; \ + pend_final_ls = ls; \ + } \ + } \ + } \ + } \ +} + +/* tc: thread context + * max_cg: maximum copied generation, i.e., maximum generation subject to collection. max_cg >= 0 && max_cg <= 255. + * min_tg: minimum target generation. max_tg == 0 ? min_tg == 0 : min_tg > 0 && min_tg <= max_tg; + * max_tg: maximum target generation. max_tg == max_cg || max_tg == max_cg + 1. + * Objects in generation g are collected into generation MIN(max_tg, MAX(min_tg, g+1)). + */ +void GCENTRY GCENTRY_PROTO(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg) { + IGEN g; ISPC s; + seginfo *oldspacesegments, *si, *nextsi; + ptr ls; + bucket_pointer_list *buckets_to_rebuild; +#ifndef NO_LOCKED_OLDSPACE_OBJECTS + ptr locked_oldspace_objects; +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + DECLARE_CTGS(max_cg, min_tg, max_tg); + + /* flush instruction cache: effectively clear_code_mod but safer */ + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { + ptr tc = (ptr)THREADTC(Scar(ls)); + S_flush_instruction_cache(tc); + } + + tlcs_to_rehash = Snil; +#ifndef NO_DIRTY_NEWSPACE_POINTERS + new_dirty_cards = NULL; +#endif /* !NO_DIRTY_NEWSPACE_POINTERS */ + + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { + ptr tc = (ptr)THREADTC(Scar(ls)); + S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc)); + EAP(tc) = REAL_EAP(tc) = AP(tc) = (ptr)0; + } + + /* perform after ScanDirty */ + if (S_checkheap) S_check_heap(0); + +#ifdef DEBUG +(void)printf("max_cg = %x; go? ", max_cg); (void)fflush(stdout); (void)getc(stdin); +#endif + + /* set up generations to be copied */ + for (g = 0; g <= max_cg; g++) { + S_G.bytes_of_generation[g] = 0; + for (s = 0; s <= max_real_space; s++) { + S_G.base_loc[g][s] = FIX(0); + S_G.first_loc[g][s] = FIX(0); + S_G.next_loc[g][s] = FIX(0); + S_G.bytes_left[g][s] = 0; + S_G.bytes_of_space[g][s] = 0; + } + } + + /* set up target generation sweep_loc and orig_next_loc pointers */ + for (g = min_tg; g <= max_tg; g += 1) { + for (s = 0; s <= max_real_space; s++) { + /* for all but max_tg (and max_tg as well, if max_tg == max_cg), this + will set orig_net_loc and sweep_loc to 0 */ + orig_next_loc[g][s] = sweep_loc[g][s] = S_G.next_loc[g][s]; + } + } + + /* mark segments from which objects are to be copied */ + oldspacesegments = (seginfo *)NULL; + for (g = 0; g <= max_cg; g += 1) { + for (s = 0; s <= max_real_space; s += 1) { + for (si = S_G.occupied_segments[g][s]; si != NULL; si = nextsi) { + nextsi = si->next; + si->next = oldspacesegments; + oldspacesegments = si; + si->space = s | space_old; /* NB: implicitly clearing space_locked */ + } + S_G.occupied_segments[g][s] = NULL; + } + } + +#ifdef ENABLE_OBJECT_COUNTS + /* clear object counts & bytes for copied generations; bump timestamp */ + {INT i; + for (g = 0; g <= max_cg; g += 1) { + for (i = 0; i < countof_types; i += 1) { + S_G.countof[g][i] = 0; + S_G.bytesof[g][i] = 0; + } + if (g == 0) { + S_G.gctimestamp[g] += 1; + } else { + S_G.gctimestamp[g] = S_G.gctimestamp[0]; + } + } + } +#endif /* ENABLE_OBJECT_COUNTS */ + + /* pre-collection handling of locked objects. */ + +#ifndef NO_LOCKED_OLDSPACE_OBJECTS + /* create a single sorted_locked_object vector for all copied generations + * to accelerate the search for locked objects in copy(). copy wants + * a vector of some size n=2^k-1 so it doesn't have to check bounds */ + ls = Snil; + /* note: append_bang and dosort reuse pairs, which can result in older + * objects pointing to newer ones...but we don't care since they are all + * oldspace and going away after this collection. */ + for (g = 0; g <= max_cg; g += 1) { + ls = append_bang(S_G.locked_objects[g], ls); + S_G.locked_objects[g] = Snil; + S_G.unlocked_objects[g] = Snil; + } + if (ls == Snil) { + sorted_locked_objects = FIX(0); + locked_oldspace_objects = Snil; + } else { + ptr v, x, y; uptr i, n; + + /* dosort is destructive, so have to store the result back */ + locked_oldspace_objects = ls = dosort(ls, list_length(ls)); + + /* create vector of smallest size n=2^k-1 that will fit all of + the list's unique elements */ + i = count_unique(ls); + for (n = 1; n < i; n = (n << 1) | 1); + sorted_locked_objects = v = S_vector_in(space_new, 0, n); + + /* copy list elements in, skipping duplicates */ + INITVECTIT(v,0) = x = Scar(ls); + i = 1; + while ((ls = Scdr(ls)) != Snil) { + if ((y = Scar(ls)) != x) { + INITVECTIT(v, i) = x = y; + i += 1; + } + } + + /* fill remaining slots with largest ptr value */ + while (i < n) { INITVECTIT(v, i) = MAXPTR; i += 1; } + } +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + + /* sweep older locked and unlocked objects */ + for (g = max_cg + 1; g <= static_generation; INCRGEN(g)) { + for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) + sweep_locked(tc, Scar(ls), 0 ACTUAL_CTGS); + for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls)) + sweep_locked(tc, Scar(ls), 0 ACTUAL_CTGS); + } + +#ifndef NO_LOCKED_OLDSPACE_OBJECTS + /* sweep younger locked objects, working from sorted vector to avoid redundant sweeping of duplicates */ + if (sorted_locked_objects != FIX(0)) { + uptr i; ptr x, v, *vp; + v = sorted_locked_objects; + i = Svector_length(v); + x = *(vp = &INITVECTIT(v, 0)); + do sweep_locked(tc, x, 1 ACTUAL_CTGS); while (--i != 0 && (x = *++vp) != MAXPTR); + } +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + + /* sweep non-oldspace threads, since any thread may have an active stack */ + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { + ptr thread; + + /* someone may have their paws on the list */ + if (FWDMARKER(ls) == forward_marker) ls = FWDADDRESS(ls); + + thread = Scar(ls); + if (!OLDSPACE(thread)) sweep_thread(thread ACTUAL_CTGS); + } + relocate_pure(&S_threads); + + /* relocate nonempty oldspace symbols and set up list of buckets to rebuild later */ + buckets_to_rebuild = NULL; + for (g = 0; g <= max_cg; g += 1) { + bucket_list *bl, *blnext; bucket *b; bucket_pointer_list *bpl; bucket **oblist_cell; ptr sym; iptr idx; + for (bl = S_G.buckets_of_generation[g]; bl != NULL; bl = blnext) { + blnext = bl->cdr; + b = bl->car; + /* mark this bucket old for the rebuilding loop */ + b->next = (bucket *)((uptr)b->next | 1); + sym = b->sym; + idx = UNFIX(SYMHASH(sym)) % S_G.oblist_length; + oblist_cell = &S_G.oblist[idx]; + if (!((uptr)*oblist_cell & 1)) { + /* mark this bucket in the set */ + *oblist_cell = (bucket *)((uptr)*oblist_cell | 1); + /* repurpose the bucket list element for the list of buckets to rebuild later */ + /* idiot_checks verifies these have the same size */ + bpl = (bucket_pointer_list *)bl; + bpl->car = oblist_cell; + bpl->cdr = buckets_to_rebuild; + buckets_to_rebuild = bpl; + } + if (FWDMARKER(sym) != forward_marker && + /* coordinate with alloc.c */ + (SYMVAL(sym) != sunbound || SYMPLIST(sym) != Snil || SYMSPLIST(sym) != Snil)) { + ptr ignore; + copy(sym, SegInfo(ptr_get_segment(sym)), &ignore ACTUAL_CTGS); + } + } + S_G.buckets_of_generation[g] = NULL; + } + + /* relocate the protected C pointers */ + {uptr i; + for (i = 0; i < S_G.protect_next; i++) + relocate_pure(S_G.protected[i]); + } + + /* sweep areas marked dirty by assignments into older generations */ + sweep_dirty(ONLY_ACTUAL_CTGS); + + sweep_generation(tc ACTUAL_CTGS); + + /* handle guardians */ + { ptr pend_hold_ls, final_ls, pend_final_ls; + ptr obj, rep, tconc, next; + + /* move each entry in guardian lists into one of: + * pend_hold_ls if obj accessible + * final_ls if obj not accessible and tconc accessible + * pend_final_ls if obj not accessible and tconc not accessible */ + pend_hold_ls = final_ls = pend_final_ls = Snil; + + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { + ptr tc = (ptr)THREADTC(Scar(ls)); + partition_guardians(GUARDIANENTRIES(tc), NONSTATICINHEAP); + GUARDIANENTRIES(tc) = Snil; + } + + for (g = 0; g <= max_cg; g += 1) { + partition_guardians(S_G.guardians[g], ALWAYSTRUE); + S_G.guardians[g] = Snil; + } + + /* invariants after partition_guardians: + * for entry in pend_hold_ls, obj is !OLDSPACE or locked + * for entry in final_ls, obj is OLDSPACE and !locked + * for entry in final_ls, tconc is !OLDSPACE or locked + * for entry in pend_final_ls, obj and tconc are OLDSPACE and !locked + */ + + while (1) { + IBOOL relocate_rep = final_ls != Snil; + + /* relocate & add the final objects to their tconcs */ + for (ls = final_ls; ls != Snil; ls = GUARDIANNEXT(ls)) { + ptr old_end, new_end; + + rep = GUARDIANREP(ls); + /* ftype_guardian_rep is a marker for reference-counted ftype pointer */ + if (rep == ftype_guardian_rep) { + INT b; uptr *addr; + rep = GUARDIANOBJ(ls); + if (FWDMARKER(rep) == forward_marker) rep = FWDADDRESS(rep); + /* Caution: Building in assumption about shape of an ftype pointer */ + addr = RECORDINSTIT(rep, 0); + LOCKED_DECR(addr, b); + if (!b) continue; + } + + relocate_pure(&rep); + + /* if tconc was old it's been forwarded */ + tconc = GUARDIANTCONC(ls); + + old_end = Scdr(tconc); + new_end = S_cons_in(space_impure, 0, FIX(0), FIX(0)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[0][countof_pair] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + + SETCAR(old_end,rep); + SETCDR(old_end,new_end); + SETCDR(tconc,new_end); + } + + /* copy each entry in pend_hold_ls into its target generation if tconc accessible */ + ls = pend_hold_ls; pend_hold_ls = Snil; + for ( ; ls != Snil; ls = next) { + ptr p; + + next = GUARDIANNEXT(ls); + + /* discard static pend_hold_ls entries */ + g = compute_target_generation(GENERATION(ls) ACTUAL_CTGS); + if (g == static_generation) continue; + + tconc = GUARDIANTCONC(ls); + + if (OLDSPACE(tconc) && !locked(tconc)) { + if (FWDMARKER(tconc) == forward_marker) + tconc = FWDADDRESS(tconc); + else { + INITGUARDIANNEXT(ls) = pend_hold_ls; + pend_hold_ls = ls; + continue; + } + } + + rep = GUARDIANREP(ls); + relocate_pure(&rep); + relocate_rep = 1; + +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[g][countof_guardian] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_pure, g, typemod, size_guardian_entry, p); + INITGUARDIANOBJ(p) = GUARDIANOBJ(ls); + INITGUARDIANREP(p) = rep; + INITGUARDIANTCONC(p) = tconc; + INITGUARDIANNEXT(p) = S_G.guardians[g]; + S_G.guardians[g] = p; + } + + if (!relocate_rep) break; + + sweep_generation(tc ACTUAL_CTGS); + + /* move each entry in pend_final_ls into one of: + * final_ls if tconc forwarded + * pend_final_ls if tconc not forwarded */ + ls = pend_final_ls; final_ls = pend_final_ls = Snil; + for ( ; ls != Snil; ls = next) { + tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls); + + if (FWDMARKER(tconc) == forward_marker) { + INITGUARDIANTCONC(ls) = FWDADDRESS(tconc); + INITGUARDIANNEXT(ls) = final_ls; + final_ls = ls; + } else { + INITGUARDIANNEXT(ls) = pend_final_ls; + pend_final_ls = ls; + } + } + } + } + + /* handle weak pairs */ + resweep_dirty_weak_pairs(ONLY_ACTUAL_CTGS); + resweep_weak_pairs(ONLY_ACTUAL_CTGS); + + /* still-pending ephemerons all go to bwp */ + clear_trigger_ephemerons(); + + /* forward car fields of locked and unlocked older weak pairs */ + for (g = max_cg + 1; g <= static_generation; INCRGEN(g)) { + for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) { + ptr x = Scar(ls); + if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) + forward_or_bwp(&INITCAR(x), Scar(x)); + } + for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls)) { + ptr x = Scar(ls); + if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) + forward_or_bwp(&INITCAR(x), Scar(x)); + } + } + +#ifndef NO_LOCKED_OLDSPACE_OBJECTS + /* forward car fields of locked oldspace weak pairs */ + if (sorted_locked_objects != FIX(0)) { + uptr i; ptr x, v, *vp; + v = sorted_locked_objects; + i = Svector_length(v); + x = *(vp = &INITVECTIT(v, 0)); + do { + if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) { + forward_or_bwp(&INITCAR(x), Scar(x)); + } + } while (--i != 0 && (x = *++vp) != MAXPTR); + } +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + + /* post-gc oblist handling. rebuild old buckets in the target generation, pruning unforwarded symbols */ + { bucket_list *bl; bucket *b, *bnext; bucket_pointer_list *bpl; bucket **pb; ptr sym; + for (bpl = buckets_to_rebuild; bpl != NULL; bpl = bpl->cdr) { + pb = bpl->car; + for (b = (bucket *)((uptr)*pb - 1); b != NULL && ((uptr)(b->next) & 1); b = bnext) { + bnext = (bucket *)((uptr)(b->next) - 1); + sym = b->sym; + if (locked(sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) { + IGEN g = GENERATION(sym); + find_room(space_data, g, typemod, sizeof(bucket), b); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[g][countof_oblist] += 1; + S_G.bytesof[g][countof_oblist] += sizeof(bucket); +#endif /* ENABLE_OBJECT_COUNTS */ + b->sym = sym; + *pb = b; + pb = &b->next; + if (g != static_generation) { + find_room(space_data, g, typemod, sizeof(bucket_list), bl); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[g][countof_oblist] += 1; + S_G.bytesof[g][countof_oblist] += sizeof(bucket_list); +#endif /* ENABLE_OBJECT_COUNTS */ + bl->car = b; + bl->cdr = S_G.buckets_of_generation[g]; + S_G.buckets_of_generation[g] = bl; + } + } else { + S_G.oblist_count -= 1; + } + } + *pb = b; + } + } + + /* rebuild rtds_with_counts lists, dropping otherwise inaccessible rtds */ + { IGEN g, newg; ptr ls, lsls, p; + for (g = 0, lsls = Snil; g <= max_cg; g += 1) { + lsls = S_cons_in(space_new, 0, S_G.rtds_with_counts[g], lsls); + S_G.rtds_with_counts[g] = Snil; + } + for (; lsls != Snil; lsls = Scdr(lsls)) { + for (ls = Scar(lsls); ls != Snil; ls = Scdr(ls)) { + p = Scar(ls); + if (!OLDSPACE(p) || locked(p) || (FWDMARKER(p) == forward_marker && (p = FWDADDRESS(p), 1))) { + newg = GENERATION(p); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_pair] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + S_G.rtds_with_counts[newg] = S_cons_in(space_impure, newg, p, S_G.rtds_with_counts[newg]); + } + } + } + } + +#ifndef WIN32 + /* rebuild child_process list, reaping any that have died and refusing + to promote into the static generation. */ + { IGEN g, newg; ptr ls, newls; + for (g = max_cg; g >= 0; g -= 1) { + newg = compute_target_generation(g ACTUAL_CTGS); + if (newg == static_generation) newg = S_G.max_nonstatic_generation; + newls = newg == g ? Snil : S_child_processes[newg]; + for (ls = S_child_processes[g], S_child_processes[g] = Snil; ls != Snil; ls = Scdr(ls)) { + INT pid = UNFIX(Scar(ls)), status, retpid; + retpid = waitpid(pid, &status, WNOHANG); + if (retpid == 0 || (retpid == pid && !(WIFEXITED(status) || WIFSIGNALED(status)))) { + newls = S_cons_in(space_impure, newg, FIX(pid), newls); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_pair] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + } + } + S_child_processes[newg] = newls; + } + } +#endif /* WIN32 */ + +#ifndef NO_LOCKED_OLDSPACE_OBJECTS + /* post-collection handling of locked objects. This must come after + any use of relocate or any other use of sorted_locked_objects */ + if (sorted_locked_objects != FIX(0)) { + ptr ls, x, v, *vp; iptr i; uptr last_seg = 0, addr, seg, n; IGEN newg = 0; + + v = sorted_locked_objects; + + /* work from sorted vector to avoid redundant processing of duplicates */ + i = Svector_length(v); + x = *(vp = &INITVECTIT(v, 0)); + do { + /* promote the segment(s) containing x to the target generation. + reset the space_old bit to prevent the segments from being + reclaimed; set the locked bit to prevent sweeping by + sweep_dirty (since the segments may contain a mix of objects, + many of which have been discarded). */ + addr = (uptr)UNTYPE_ANY(x); + if ((seg = addr_get_segment(addr)) == last_seg) { + /* the generation has already been updated on this segment, and newg is still valid. + this isn't just an optimization. if we recompute newg based on the already updated + generation, we could get the wrong result. good thing the vector is sorted. */ + seg += 1; + } else { + newg = compute_target_generation(GENERATION(x) ACTUAL_CTGS); + } + + n = size_object(x); + +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_locked] += 1; + S_G.bytesof[newg][countof_locked] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + + addr += n - 1; + last_seg = addr_get_segment(addr); + while (seg <= last_seg) { + seginfo *si = SegInfo(seg); + si->generation = newg; + si->space = (si->space & ~space_old) | space_locked; + seg += 1; + } + } while (--i != 0 && (x = *++vp) != MAXPTR); + + /* add every object, including duplicates, to target-generation list(s). we do so + even when newg == static_generation so we can keep track of static objects that need to + be swept at the start of collection. (we could weed out pure static objects.) */ + for (newg = min_tg; newg < max_tg; newg += 1) S_G.locked_objects[newg] = Snil; + if (max_tg == max_cg) S_G.locked_objects[max_cg] = Snil; + for (ls = locked_oldspace_objects; ls != Snil; ls = Scdr(ls)) { + x = Scar(ls); + newg = GENERATION(x); + S_G.locked_objects[newg] = S_cons_in(space_impure, newg, x, S_G.locked_objects[newg]); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_pair] += 1; +#endif /* ENABLE_OBJECT_COUNTS */ + } + } +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + + /* move old space segments to empty space */ + for (si = oldspacesegments; si != NULL; si = nextsi) { + nextsi = si->next; + s = si->space; + if (s & space_locked) { + /* note: the oldspace bit is cleared above for locked objects */ + s &= ~space_locked; + g = si->generation; + if (g == static_generation) S_G.number_of_nonstatic_segments -= 1; + si->next = S_G.occupied_segments[g][s]; + S_G.occupied_segments[g][s] = si; + } else { + chunkinfo *chunk = si->chunk; + if (si->generation != static_generation) S_G.number_of_nonstatic_segments -= 1; + S_G.number_of_empty_segments += 1; + si->space = space_empty; + si->next = chunk->unused_segs; + chunk->unused_segs = si; +#ifdef WIPECLEAN + memset((void *)build_ptr(si->number,0), 0xc7, bytes_per_segment); +#endif + if ((chunk->nused_segs -= 1) == 0) { + if (chunk->bytes != (minimum_segment_request + 1) * bytes_per_segment) { + /* release oversize chunks back to the O/S immediately to avoid allocating + * small stuff into them and thereby invite fragmentation */ + S_free_chunk(chunk); + } else { + S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS]); + } + } else { + S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + } + } + } + + S_G.g0_bytes_after_last_gc = S_G.bytes_of_generation[0]; + + if (max_cg >= S_G.min_free_gen) S_free_chunks(); + + S_flush_instruction_cache(tc); + +#ifndef NO_DIRTY_NEWSPACE_POINTERS + /* mark dirty those newspace cards to which we've added wrong-way pointers */ + { dirtycardinfo *ndc; + for (ndc = new_dirty_cards; ndc != NULL; ndc = ndc->next) + S_mark_card_dirty(ndc->card, ndc->youngest); + } +#endif /* !NO_DIRTY_NEWSPACE_POINTERS */ + + if (S_checkheap) S_check_heap(1); + + /* post-collection rehashing of tlcs. + must come after any use of relocate. + logically comes after gc is entirely complete */ + while (tlcs_to_rehash != Snil) { + ptr b, next; uptr old_idx, new_idx; + ptr tlc = Scar(tlcs_to_rehash); + ptr ht = TLCHT(tlc); + ptr vec = PTRFIELD(ht,eq_hashtable_vec_disp); + uptr veclen = Svector_length(vec); + ptr key = Scar(TLCKEYVAL(tlc)); + + /* scan to end of bucket to find the index */ + for (b = TLCNEXT(tlc); !Sfixnump(b); b = TLCNEXT(b)); + old_idx = UNFIX(b); + + if (key == Sbwp_object && PTRFIELD(ht,eq_hashtable_subtype_disp) != FIX(eq_hashtable_subtype_normal)) { + /* remove tlc */ + b = Svector_ref(vec, old_idx); + if (b == tlc) { + SETVECTIT(vec, old_idx, TLCNEXT(b)); + } else { + for (;;) { next = TLCNEXT(b); if (next == tlc) break; b = next; } + SETTLCNEXT(b,TLCNEXT(next)); + } + INITTLCNEXT(tlc) = Sfalse; + INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(UNFIX(PTRFIELD(ht,eq_hashtable_size_disp)) - 1); + } else if ((new_idx = ((uptr)key >> primary_type_bits) & (veclen - 1)) != old_idx) { + /* remove tlc from old bucket */ + b = Svector_ref(vec, old_idx); + if (b == tlc) { + SETVECTIT(vec, old_idx, TLCNEXT(b)); + } else { + for (;;) { next = TLCNEXT(b); if (next == tlc) break; b = next; } + SETTLCNEXT(b,TLCNEXT(next)); + } + /* and add to new bucket */ + SETTLCNEXT(tlc, Svector_ref(vec, new_idx)); + SETVECTIT(vec, new_idx, tlc); + } + tlcs_to_rehash = Scdr(tlcs_to_rehash); + } + + S_resize_oblist(); + + /* tell profile_release_counters to look for bwp'd counters at least through max_tg */ + if (S_G.prcgeneration < max_tg) S_G.prcgeneration = max_tg; +} + +#define sweep_space(s, from_g, body) {\ + slp = &sweep_loc[from_g][s];\ + nlp = &S_G.next_loc[from_g][s];\ + if (*slp == 0) *slp = S_G.first_loc[from_g][s];\ + pp = (ptr *)*slp;\ + while (pp != (nl = (ptr *)*nlp))\ + do\ + if ((p = *pp) == forward_marker)\ + pp = (ptr *)*(pp + 1);\ + else\ + body\ + while (pp != nl);\ + *slp = (ptr)pp; \ +} + +static void resweep_weak_pairs(ONLY_FORMAL_CTGS) { + IGEN from_g; ptr *slp, *nlp; ptr *pp, p, *nl; + + for (from_g = MIN_TG; from_g <= MAX_TG; from_g += 1) { + sweep_loc[from_g][space_weakpair] = orig_next_loc[from_g][space_weakpair]; + sweep_space(space_weakpair, from_g, { + forward_or_bwp(pp, p); + pp += 2; + }) + } +} + +static void forward_or_bwp(ptr *pp, ptr p) { + seginfo *si; + /* adapted from relocate */ + if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) { + if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { + *pp = FWDADDRESS(p); + } else { + *pp = Sbwp_object; + } + } +} + +static void sweep_generation(ptr tc FORMAL_CTGS) { + IGEN from_g; ptr *slp, *nlp; ptr *pp, p, *nl; + + do { + change = 0; + for (from_g = MIN_TG; from_g <= MAX_TG; from_g += 1) { + sweep_space(space_impure, from_g, { + relocate_impure_help(pp, p, from_g); + p = *(pp += 1); + relocate_impure_help(pp, p, from_g); + pp += 1; + }) + + sweep_space(space_symbol, from_g, { + p = TYPE((ptr)pp, type_symbol); + sweep_symbol(p, from_g ACTUAL_CTGS); + pp += size_symbol / sizeof(ptr); + }) + + sweep_space(space_port, from_g, { + p = TYPE((ptr)pp, type_typed_object); + sweep_port(p, from_g ACTUAL_CTGS); + pp += size_port / sizeof(ptr); + }) + + sweep_space(space_weakpair, from_g, { + p = *(pp += 1); + relocate_impure_help(pp, p, from_g); + pp += 1; + }) + + sweep_space(space_ephemeron, from_g, { + p = TYPE((ptr)pp, type_pair); + add_ephemeron_to_pending(p); + pp += size_ephemeron / sizeof(ptr); + }) + + sweep_space(space_pure, from_g, { + relocate_pure_help(pp, p); + p = *(pp += 1); + relocate_pure_help(pp, p); + pp += 1; + }) + + sweep_space(space_continuation, from_g, { + p = TYPE((ptr)pp, type_closure); + sweep_continuation(p ACTUAL_CTGS); + pp += size_continuation / sizeof(ptr); + }) + + sweep_space(space_pure_typed_object, from_g, { + p = TYPE((ptr)pp, type_typed_object); + pp = (ptr *)((uptr)pp + sweep_typed_object(p, from_g ACTUAL_CTGS)); + }) + + sweep_space(space_code, from_g, { + p = TYPE((ptr)pp, type_typed_object); + sweep_code_object(tc, p ACTUAL_CTGS); + pp += size_code(CODELEN(p)) / sizeof(ptr); + }) + + sweep_space(space_impure_record, from_g, { + p = TYPE((ptr)pp, type_typed_object); + sweep_record(p, from_g ACTUAL_CTGS); + pp = (ptr *)((iptr)pp + + size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); + }) + } + + /* Waiting until sweeping doesn't trigger a change reduces the + chance that an ephemeron must be registered as a + segment-specific trigger or gets triggered for recheck, but + it doesn't change the worst-case complexity. */ + if (!change) + check_pending_ephemerons(ONLY_ACTUAL_CTGS); + } while (change); +} + +#ifndef NO_LOCKED_OLDSPACE_OBJECTS +static iptr size_object(ptr p) { + ITYPE t; ptr tf; + + if ((t = TYPEBITS(p)) == type_pair) { + seginfo *si; + if ((si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~(space_locked | space_old)) == space_ephemeron) + return size_ephemeron; + else + return size_pair; + } else if (t == type_closure) { + ptr code = CLOSCODE(p); + if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) + return size_continuation; + else + return size_closure(CLOSLEN(p)); + } else if (t == type_symbol) { + return size_symbol; + } else if (t == type_flonum) { + return size_flonum; + /* typed objects */ + } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { + return size_vector(Svector_length(p)); + } else if (TYPEP(tf, mask_string, type_string)) { + return size_string(Sstring_length(p)); + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + return size_bytevector(Sbytevector_length(p)); + } else if (TYPEP(tf, mask_record, type_record)) { + return size_record_inst(UNFIX(RECORDDESCSIZE(tf))); + } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { + return size_fxvector(Sfxvector_length(p)); + } else if (TYPEP(tf, mask_box, type_box)) { + return size_box; + } else if ((iptr)tf == type_ratnum) { + return size_ratnum; + } else if ((iptr)tf == type_exactnum) { + return size_exactnum; + } else if ((iptr)tf == type_inexactnum) { + return size_inexactnum; + } else if (TYPEP(tf, mask_bignum, type_bignum)) { + return size_bignum(BIGLEN(p)); + } else if (TYPEP(tf, mask_port, type_port)) { + return size_port; + } else if (TYPEP(tf, mask_code, type_code)) { + return size_code(CODELEN(p)); + } else if ((iptr)tf == type_thread) { + return size_thread; + } else if ((iptr)tf == type_rtd_counts) { + return size_rtd_counts; + } else { + S_error_abort("size_object(gc): illegal type"); + return 0 /* not reached */; + } +} +#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */ + +static iptr sweep_typed_object(ptr p, IGEN from_g FORMAL_CTGS) { + ptr tf = TYPEFIELD(p); + + if (TYPEP(tf, mask_record, type_record)) { + sweep_record(p, from_g ACTUAL_CTGS); + return size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p)))); + } else if (TYPEP(tf, mask_thread, type_thread)) { + sweep_thread(p ACTUAL_CTGS); + return size_thread; + } else { + S_error_abort("sweep_typed_object(gc): unexpected type"); + return 0 /* not reached */; + } +} + +static void sweep_symbol(ptr p, IGEN from_g FORMAL_CTGS) { + ptr val, code; + + relocate_impure(&INITSYMVAL(p), from_g); + val = SYMVAL(p); + code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p); + relocate_pure(&code); + INITSYMCODE(p,code); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); +} + +static void sweep_port(ptr p, IGEN from_g FORMAL_CTGS) { + relocate_impure(&PORTHANDLER(p), from_g); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); + + if (PORTTYPE(p) & PORT_FLAG_OUTPUT) { + iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p); + relocate_impure(&PORTOBUF(p), from_g); + PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n); + } + + if (PORTTYPE(p) & PORT_FLAG_INPUT) { + iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p); + relocate_impure(&PORTIBUF(p), from_g); + PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n); + } +} + +static void sweep_thread(ptr p FORMAL_CTGS) { + ptr tc = (ptr)THREADTC(p); + INT i; + + if (tc != (ptr)0) { + ptr old_stack = SCHEMESTACK(tc); + if (OLDSPACE(old_stack)) { + iptr clength = (uptr)SFP(tc) - (uptr)old_stack; + /* include SFP[0], which contains the return address */ + SCHEMESTACK(tc) = copy_stack(old_stack, &SCHEMESTACKSIZE(tc), clength + sizeof(ptr) ACTUAL_CTGS); + SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + clength); + ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + SCHEMESTACKSIZE(tc) - stack_slop); + } + STACKCACHE(tc) = Snil; + relocate_pure(&CCHAIN(tc)); + /* U32 RANDOMSEED(tc) */ + /* I32 ACTIVE(tc) */ + relocate_pure(&STACKLINK(tc)); + /* iptr SCHEMESTACKSIZE */ + relocate_pure(&WINDERS(tc)); + relocate_return_addr(&FRAME(tc,0)); + sweep_stack((uptr)SCHEMESTACK(tc), (uptr)SFP(tc), (uptr)FRAME(tc,0) ACTUAL_CTGS); + U(tc) = V(tc) = W(tc) = X(tc) = Y(tc) = 0; + /* immediate SOMETHINGPENDING(tc) */ + /* immediate TIMERTICKS */ + /* immediate DISABLE_COUNT */ + /* immediate SIGNALINTERRUPTPENDING */ + /* void* SIGNALINTERRUPTQUEUE(tc) */ + /* immediate KEYBOARDINTERRUPTPENDING */ + relocate_pure(&THREADNO(tc)); + relocate_pure(&CURRENTINPUT(tc)); + relocate_pure(&CURRENTOUTPUT(tc)); + relocate_pure(&CURRENTERROR(tc)); + /* immediate BLOCKCOUNTER */ + relocate_pure(&SFD(tc)); + relocate_pure(&CURRENTMSO(tc)); + relocate_pure(&TARGETMACHINE(tc)); + relocate_pure(&FXLENGTHBV(tc)); + relocate_pure(&FXFIRSTBITSETBV(tc)); + relocate_pure(&NULLIMMUTABLEVECTOR(tc)); + relocate_pure(&NULLIMMUTABLEFXVECTOR(tc)); + relocate_pure(&NULLIMMUTABLEBYTEVECTOR(tc)); + relocate_pure(&NULLIMMUTABLESTRING(tc)); + /* immediate METALEVEL */ + relocate_pure(&COMPILEPROFILE(tc)); + /* immediate GENERATEINSPECTORINFORMATION */ + /* immediate GENERATEPROFILEFORMS */ + /* immediate OPTIMIZELEVEL */ + relocate_pure(&SUBSETMODE(tc)); + /* immediate SUPPRESSPRIMITIVEINLINING */ + relocate_pure(&DEFAULTRECORDEQUALPROCEDURE(tc)); + relocate_pure(&DEFAULTRECORDHASHPROCEDURE(tc)); + relocate_pure(&COMPRESSFORMAT(tc)); + relocate_pure(&COMPRESSLEVEL(tc)); + /* void* LZ4OUTBUFFER(tc) */ + /* U64 INSTRCOUNTER(tc) */ + /* U64 ALLOCCOUNTER(tc) */ + relocate_pure(&PARAMETERS(tc)); + for (i = 0 ; i < virtual_register_count ; i += 1) { + relocate_pure(&VIRTREG(tc, i)); + } + DSTBV(tc) = SRCBV(tc) = Sfalse; + } +} + +static void sweep_continuation(ptr p FORMAL_CTGS) { + relocate_pure(&CONTWINDERS(p)); + + /* bug out for shot 1-shot continuations */ + if (CONTLENGTH(p) == scaled_shot_1_shot_flag) return; + + if (OLDSPACE(CONTSTACK(p))) + CONTSTACK(p) = copy_stack(CONTSTACK(p), &CONTLENGTH(p), CONTCLENGTH(p) ACTUAL_CTGS); + + relocate_pure(&CONTLINK(p)); + relocate_return_addr(&CONTRET(p)); + + /* use CLENGTH to avoid sweeping unoccupied portion of one-shots */ + sweep_stack((uptr)CONTSTACK(p), (uptr)CONTSTACK(p) + CONTCLENGTH(p), (uptr)CONTRET(p) ACTUAL_CTGS); +} + +/* assumes stack has already been copied to newspace */ +static void sweep_stack(uptr base, uptr fp, uptr ret FORMAL_CTGS) { + ptr *pp; iptr oldret; + ptr num; + + while (fp != base) { + if (fp < base) + S_error_abort("sweep_stack(gc): malformed stack"); + fp = fp - ENTRYFRAMESIZE(ret); + pp = (ptr *)fp; + + oldret = ret; + ret = (iptr)(*pp); + relocate_return_addr(pp); + + num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { + uptr mask = UNFIX(num); + while (mask != 0) { + pp += 1; + if (mask & 0x0001) relocate_pure(pp); + mask >>= 1; + } + } else { + iptr index; + + relocate_pure(&ENTRYLIVEMASK(oldret)); + num = ENTRYLIVEMASK(oldret); + index = BIGLEN(num); + while (index-- != 0) { + INT bits = bigit_bits; + bigit mask = BIGIT(num,index); + while (bits-- > 0) { + pp += 1; + if (mask & 1) relocate_pure(pp); + mask >>= 1; + } + } + } + } +} + +static void sweep_record(ptr x, IGEN from_g FORMAL_CTGS) { + ptr *pp; ptr num; ptr rtd; + + /* record-type descriptor was forwarded in copy */ + rtd = RECORDINSTTYPE(x); + num = RECORDDESCPM(rtd); + pp = &RECORDINSTIT(x,0); + + /* sweep cells for which bit in pm is set; quit when pm == 0. */ + if (Sfixnump(num)) { + /* ignore bit for already forwarded rtd */ + uptr mask = (uptr)UNFIX(num) >> 1; + if (mask == (uptr)-1 >> 1) { + ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; + while (pp < ppend) { + relocate_impure(pp, from_g); + pp += 1; + } + } else { + while (mask != 0) { + if (mask & 1) { relocate_impure(pp, from_g); } + mask >>= 1; + pp += 1; + } + } + } else { + iptr index; bigit mask; INT bits; + + /* bignum pointer mask may have been forwarded */ + relocate_pure(&RECORDDESCPM(rtd)); + num = RECORDDESCPM(rtd); + index = BIGLEN(num) - 1; + /* ignore bit for already forwarded rtd */ + mask = BIGIT(num,index) >> 1; + bits = bigit_bits - 1; + for (;;) { + do { + if (mask & 1) { relocate_impure(pp, from_g); } + mask >>= 1; + pp += 1; + } while (--bits > 0); + if (index-- == 0) break; + mask = BIGIT(num,index); + bits = bigit_bits; + } + } +} + +static IGEN sweep_dirty_record(ptr x, IGEN youngest FORMAL_CTGS) { + ptr *pp; ptr num; ptr rtd; + + /* warning: assuming rtd is immutable */ + rtd = RECORDINSTTYPE(x); + + /* warning: assuming MPM field is immutable */ + num = RECORDDESCMPM(rtd); + pp = &RECORDINSTIT(x,0); + + /* sweep cells for which bit in mpm is set */ + if (Sfixnump(num)) { + /* ignore bit for assumed immutable rtd */ + uptr mask = (uptr)UNFIX(num) >> 1; + while (mask != 0) { + if (mask & 1) relocate_dirty(pp, youngest); + mask >>= 1; + pp += 1; + } + } else { + iptr index; bigit mask; INT bits; + + index = BIGLEN(num) - 1; + /* ignore bit for assumed immutable rtd */ + mask = BIGIT(num,index) >> 1; + bits = bigit_bits - 1; + for (;;) { + do { + if (mask & 1) relocate_dirty(pp, youngest); + mask >>= 1; + pp += 1; + } while (--bits > 0); + if (index-- == 0) break; + mask = BIGIT(num,index); + bits = bigit_bits; + } + } + + return youngest; +} + +static void sweep_code_object(ptr tc, ptr co FORMAL_CTGS) { + ptr t, oldco; iptr a, m, n; + +#ifdef DEBUG + if ((CODETYPE(co) & mask_code) != type_code) { + (void)printf("unexpected type %x sweeping code object %p\n", CODETYPE(co), co); + (void)fflush(stdout); + } +#endif + + relocate_pure(&CODENAME(co)); + relocate_pure(&CODEARITYMASK(co)); + relocate_pure(&CODEINFO(co)); + relocate_pure(&CODEPINFOS(co)); + + t = CODERELOC(co); + m = RELOCSIZE(t); + oldco = RELOCCODE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj; + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + relocate_pure(&obj); + S_set_code_obj("gc", RELOC_TYPE(entry), co, a, obj, item_off); + } + + /* Don't copy non-oldspace relocation tables, since we may be + sweeping a locked code object that is older than max_target_generation + Doing so would be a waste of work anyway. */ + if (OLDSPACE(t)) { + IGEN newg = compute_target_generation(GENERATION(t) ACTUAL_CTGS); + if (newg == static_generation && !S_G.retain_static_relocation && (CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0) { + CODERELOC(co) = (ptr)0; + } else { + ptr oldt = t; + n = size_reloc_table(RELOCSIZE(oldt)); +#ifdef ENABLE_OBJECT_COUNTS + S_G.countof[newg][countof_relocation_table] += 1; + S_G.bytesof[newg][countof_relocation_table] += n; +#endif /* ENABLE_OBJECT_COUNTS */ + find_room(space_data, newg, typemod, n, t); + copy_ptrs(typemod, t, oldt, n); + RELOCCODE(t) = co; + CODERELOC(co) = t; + } + } else { + RELOCCODE(t) = co; + } + + S_record_code_mod(tc, (uptr)&CODEIT(co,0), (uptr)CODELEN(co)); +} + +typedef struct _weakseginfo { + seginfo *si; + IGEN youngest[cards_per_segment]; + struct _weakseginfo *next; +} weakseginfo; + +static weakseginfo *weaksegments_to_resweep; + +static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si) { + if (si->min_dirty_byte != 0xff) { + S_error_abort("record_dirty(gc): unexpected mutation while sweeping"); + } + + if (to_g < from_g) { + seginfo *oldfirst = DirtySegments(from_g, to_g); + DirtySegments(from_g, to_g) = si; + si->dirty_prev = &DirtySegments(from_g, to_g); + si->dirty_next = oldfirst; + if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next; + si->min_dirty_byte = to_g; + } +} + +static void sweep_dirty(ONLY_FORMAL_CTGS) { + IGEN youngest, min_youngest; + ptr *pp, *ppend, *nl; + uptr seg, d; + ISPC s; + IGEN from_g, to_g; + seginfo *dirty_si, *nextsi; + + weaksegments_to_resweep = NULL; + + /* clear dirty segment lists for copied generations */ + for (from_g = 1; from_g <= MAX_CG; from_g += 1) { + for (to_g = 0; to_g < from_g; to_g += 1) { + DirtySegments(from_g, to_g) = NULL; + } + } + + /* NB: could have problems if a card is moved from some current or to-be-swept (from_g, to_g) to some previously + swept list due to a dirty_set while we sweep. believe this can't happen as of 6/14/2013. if it can, it + might be sufficient to process the lists in reverse order. */ + for (from_g = MAX_CG + 1; from_g <= static_generation; INCRGEN(from_g)) { + for (to_g = 0; to_g <= MAX_CG; to_g += 1) { + for (dirty_si = DirtySegments(from_g, to_g), DirtySegments(from_g, to_g) = NULL; dirty_si != NULL; dirty_si = nextsi) { + nextsi = dirty_si->dirty_next; + seg = dirty_si->number; + s = dirty_si->space; + + if (s & space_locked) continue; + + /* reset min dirty byte so we can detect if byte is set while card is swept */ + dirty_si->min_dirty_byte = 0xff; + + min_youngest = 0xff; + nl = from_g == MAX_TG ? (ptr *)orig_next_loc[from_g][s] : (ptr *)S_G.next_loc[from_g][s]; + ppend = build_ptr(seg, 0); + + if (s == space_weakpair) { + weakseginfo *next = weaksegments_to_resweep; + find_room(space_data, 0, typemod, ptr_align(sizeof(weakseginfo)), weaksegments_to_resweep); + weaksegments_to_resweep->si = dirty_si; + weaksegments_to_resweep->next = next; + } + + d = 0; + while (d < cards_per_segment) { + uptr dend = d + sizeof(iptr); + iptr *dp = (iptr *)(dirty_si->dirty_bytes + d); + /* check sizeof(iptr) bytes at a time for 0xff */ + if (*dp == -1) { + pp = ppend; + ppend += bytes_per_card; + if (pp <= nl && nl < ppend) ppend = nl; + d = dend; + } else { + while (d < dend) { + pp = ppend; + ppend += bytes_per_card / sizeof(ptr); + if (pp <= nl && nl < ppend) ppend = nl; + + if (dirty_si->dirty_bytes[d] <= MAX_CG) { + /* assume we won't find any wrong-way pointers */ + youngest = 0xff; + + if (s == space_impure) { + while (pp < ppend && *pp != forward_marker) { + /* handle two pointers at a time */ + relocate_dirty(pp, youngest); + pp += 1; + relocate_dirty(pp, youngest); + pp += 1; + } + } else if (s == space_symbol) { + /* old symbols cannot overlap segment boundaries + since any object that spans multiple + generations begins at the start of a segment, + and symbols are much smaller (we assume) + than the segment size. */ + pp = (ptr *)build_ptr(seg,0) + + ((pp - (ptr *)build_ptr(seg,0)) / + (size_symbol / sizeof(ptr))) * + (size_symbol / sizeof(ptr)); + + while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a symbol. no harm. */ + ptr p, val, code; + + p = TYPE((ptr)pp, type_symbol); + + val = SYMVAL(p); + relocate_dirty(&val, youngest); + INITSYMVAL(p) = val; + code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p); + relocate_dirty(&code, youngest); + INITSYMCODE(p,code); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); + + pp += size_symbol / sizeof(ptr); + } + } else if (s == space_port) { + /* old ports cannot overlap segment boundaries + since any object that spans multiple + generations begins at the start of a segment, + and ports are much smaller (we assume) + than the segment size. */ + pp = (ptr *)build_ptr(seg,0) + + ((pp - (ptr *)build_ptr(seg,0)) / + (size_port / sizeof(ptr))) * + (size_port / sizeof(ptr)); + + while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a port. no harm. */ + ptr p = TYPE((ptr)pp, type_typed_object); + + relocate_dirty(&PORTHANDLER(p), youngest); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); + + if (PORTTYPE(p) & PORT_FLAG_OUTPUT) { + iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p); + relocate_dirty(&PORTOBUF(p), youngest); + PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n); + } + + if (PORTTYPE(p) & PORT_FLAG_INPUT) { + iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p); + relocate_dirty(&PORTIBUF(p), youngest); + PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n); + } + + pp += size_port / sizeof(ptr); + } + } else if (s == space_impure_record) { /* abandon hope all ye who enter here */ + uptr j; ptr p, pnext; seginfo *si; + + /* synchronize on first record that overlaps the dirty + area, then relocate any mutable pointers in that + record and those that follow within the dirty area. */ + + /* find first segment of group of like segments */ + j = seg - 1; + while ((si = MaybeSegInfo(j)) != NULL && + si->space == s && + si->generation == from_g) + j -= 1; + j += 1; + + /* now find first record in segment seg */ + /* we count on following fact: if an object spans two + or more segments, then he starts at the beginning + of a segment */ + for (;;) { + p = TYPE(build_ptr(j,0),type_typed_object); + pnext = (ptr)((iptr)p + + size_record_inst(UNFIX(RECORDDESCSIZE( + RECORDINSTTYPE(p))))); + if (ptr_get_segment(pnext) >= seg) break; + j = ptr_get_segment(pnext) + 1; + } + + /* now find first within dirty area */ + while ((ptr *)UNTYPE(pnext, type_typed_object) <= pp) { + p = pnext; + pnext = (ptr)((iptr)p + + size_record_inst(UNFIX(RECORDDESCSIZE( + RECORDINSTTYPE(p))))); + } + + /* now sweep */ + while ((ptr *)UNTYPE(p, type_typed_object) < ppend) { + /* quit on end of segment */ + if (FWDMARKER(p) == forward_marker) break; + + youngest = sweep_dirty_record(p, youngest ACTUAL_CTGS); + p = (ptr)((iptr)p + + size_record_inst(UNFIX(RECORDDESCSIZE( + RECORDINSTTYPE(p))))); + } + } else if (s == space_weakpair) { + while (pp < ppend && *pp != forward_marker) { + /* skip car field and handle cdr field */ + pp += 1; + relocate_dirty(pp, youngest); + pp += 1; + } + } else if (s == space_ephemeron) { + while (pp < ppend && *pp != forward_marker) { + ptr p = TYPE((ptr)pp, type_pair); + youngest = check_dirty_ephemeron(p, youngest ACTUAL_CTGS); + pp += size_ephemeron / sizeof(ptr); + } + } else { + S_error_abort("sweep_dirty(gc): unexpected space"); + } + + if (s == space_weakpair) { + weaksegments_to_resweep->youngest[d] = youngest; + } else { + dirty_si->dirty_bytes[d] = youngest < from_g ? youngest : 0xff; + } + if (youngest < min_youngest) min_youngest = youngest; + } else { + if (dirty_si->dirty_bytes[d] < min_youngest) min_youngest = dirty_si->dirty_bytes[d]; + } + d += 1; + } + } + } + if (s != space_weakpair) { + record_dirty_segment(from_g, min_youngest, dirty_si); + } + } + } + } +} + +static void resweep_dirty_weak_pairs(ONLY_FORMAL_CTGS) { + weakseginfo *ls; + ptr *pp, *ppend, *nl, p; + IGEN from_g, min_youngest, youngest, pg, newpg; + uptr d; + + for (ls = weaksegments_to_resweep; ls != NULL; ls = ls->next) { + seginfo *dirty_si = ls->si; + from_g = dirty_si->generation; + nl = from_g == MAX_TG ? (ptr *)orig_next_loc[from_g][space_weakpair] : (ptr *)S_G.next_loc[from_g][space_weakpair]; + ppend = build_ptr(dirty_si->number, 0); + min_youngest = 0xff; + d = 0; + while (d < cards_per_segment) { + uptr dend = d + sizeof(iptr); + iptr *dp = (iptr *)(dirty_si->dirty_bytes + d); + /* check sizeof(iptr) bytes at a time for 0xff */ + if (*dp == -1) { + d = dend; + ppend += bytes_per_card; + } else { + while (d < dend) { + pp = ppend; + ppend += bytes_per_card / sizeof(ptr); + if (pp <= nl && nl < ppend) ppend = nl; + if (dirty_si->dirty_bytes[d] <= MAX_CG) { + youngest = ls->youngest[d]; + while (pp < ppend) { + p = *pp; + seginfo *si; + + /* handle car field */ + if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { + pg = si->generation; + newpg = compute_target_generation(pg ACTUAL_CTGS); + if (si->space & space_old) { + if (locked(p)) { + if (newpg < youngest) youngest = newpg; + } else if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { + *pp = FWDADDRESS(p); + if (newpg < youngest) youngest = newpg; + } else { + *pp = Sbwp_object; + } + } else { + if (pg < youngest) youngest = pg; + } + } + + /* skip cdr field */ + pp += 2; + } + + dirty_si->dirty_bytes[d] = youngest < from_g ? youngest : 0xff; + if (youngest < min_youngest) min_youngest = youngest; + } else { + if (dirty_si->dirty_bytes[d] < min_youngest) min_youngest = dirty_si->dirty_bytes[d]; + } + d += 1; + } + } + } + record_dirty_segment(from_g, min_youngest, dirty_si); + } +} + +static ptr pending_ephemerons = NULL; +/* Ephemerons that we haven't looked at, chained through `next`. */ + +static ptr trigger_ephemerons = NULL; +/* Ephemerons that we've checked and added to segment triggers, + chained through `next`. Ephemerons attached to a segment are + chained through `trigger-next`. A #t in `trigger-next` means that + the ephemeron has been processed, so we don't need to remove it + from the trigger list in a segment. */ + +static ptr repending_ephemerons = NULL; +/* Ephemerons in `trigger_ephemerons` that we need to inspect again, + removed from the triggering segment and chained here through + `trigger-next`. */ + +static void add_ephemeron_to_pending(ptr pe) { + /* We could call check_ephemeron directly here, but the indirection + through `pending_ephemerons` can dramatically decrease the number + of times that we have to trigger re-checking, especially since + check_pending_pehemerons() is run only after all other sweep + opportunities are exhausted. */ + EPHEMERONNEXT(pe) = pending_ephemerons; + pending_ephemerons = pe; +} + +static void add_trigger_ephemerons_to_repending(ptr pe) { + ptr last_pe = pe, next_pe = EPHEMERONTRIGGERNEXT(pe); + while (next_pe != NULL) { + last_pe = next_pe; + next_pe = EPHEMERONTRIGGERNEXT(next_pe); + } + EPHEMERONTRIGGERNEXT(last_pe) = repending_ephemerons; + repending_ephemerons = pe; +} + +static void check_ephemeron(ptr pe, IBOOL add_to_trigger FORMAL_CTGS) { + ptr p; + seginfo *si; + IGEN from_g = GENERATION(pe); + + p = Scar(pe); + if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) { + if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { +#ifndef NO_DIRTY_NEWSPACE_POINTERS + IGEN pg = compute_target_generation(si->generation ACTUAL_CTGS); + if (pg < from_g) record_new_dirty_card(&INITCAR(pe), pg); +#endif + INITCAR(pe) = FWDADDRESS(p); + relocate_impure(&INITCDR(pe), from_g); + if (!add_to_trigger) + EPHEMERONTRIGGERNEXT(pe) = Strue; /* in trigger list, #t means "done" */ + } else { + /* Not reached, so far; install as trigger */ + EPHEMERONTRIGGERNEXT(pe) = si->trigger_ephemerons; + si->trigger_ephemerons = pe; + if (add_to_trigger) { + EPHEMERONNEXT(pe) = trigger_ephemerons; + trigger_ephemerons = pe; + } + } + } else { + relocate_impure(&INITCDR(pe), from_g); + } +} + +static void check_pending_ephemerons(ONLY_FORMAL_CTGS) { + ptr pe, next_pe; + + pe = pending_ephemerons; + pending_ephemerons = NULL; + while (pe != NULL) { + next_pe = EPHEMERONNEXT(pe); + check_ephemeron(pe, 1 ACTUAL_CTGS); + pe = next_pe; + } + + pe = repending_ephemerons; + repending_ephemerons = NULL; + while (pe != NULL) { + next_pe = EPHEMERONTRIGGERNEXT(pe); + check_ephemeron(pe, 0 ACTUAL_CTGS); + pe = next_pe; + } +} + +/* Like check_ephemeron(), but for a dirty, old-generation + ephemeron (that was not yet added to the pending list), so we can + be less pessimistic than setting `youngest` to the target + generation: */ +static IGEN check_dirty_ephemeron(ptr pe, IGEN youngest FORMAL_CTGS) { + ptr p; + seginfo *si; + IGEN pg; + + p = Scar(pe); + if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { + if (si->space & space_old && !locked(p)) { + if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { + INITCAR(pe) = FWDADDRESS(p); + if (youngest != MIN_TG && (pg = compute_target_generation(si->generation ACTUAL_CTGS)) < youngest) + youngest = pg; + relocate_dirty(&INITCDR(pe), youngest); + } else { + /* Not reached, so far; add to pending list */ + add_ephemeron_to_pending(pe); + /* Make the consistent (but pessimistic w.r.t. to wrong-way + pointers) assumption that the key will stay live and move + to the target generation. That assumption covers the value + part, too, since it can't end up younger than the target + generation. */ + if (youngest != MIN_TG && (pg = compute_target_generation(si->generation ACTUAL_CTGS)) < youngest) + youngest = pg; + } + } else { + if (youngest != MIN_TG && (pg = si->generation) < youngest) + youngest = pg; + relocate_dirty(&INITCDR(pe), youngest); + } + } else { + /* Non-collectable key means that the value determines + `youngest`: */ + relocate_dirty(&INITCDR(pe), youngest); + } + + return youngest; +} + +static void clear_trigger_ephemerons(void) { + ptr pe; + + if (pending_ephemerons != NULL) + S_error_abort("clear_trigger_ephemerons(gc): non-empty pending list"); + + pe = trigger_ephemerons; + trigger_ephemerons = NULL; + while (pe != NULL) { + if (EPHEMERONTRIGGERNEXT(pe) == Strue) { + /* The ephemeron was triggered and retains its key and value */ + } else { + seginfo *si; + ptr p = Scar(pe); + /* Key never became reachable, so clear key and value */ + INITCAR(pe) = Sbwp_object; + INITCDR(pe) = Sbwp_object; + + /* Remove trigger */ + si = SegInfo(ptr_get_segment(p)); + si->trigger_ephemerons = NULL; + } + pe = EPHEMERONNEXT(pe); + } +} diff --git a/c/gcwrapper.c b/c/gcwrapper.c new file mode 100644 index 0000000..f00f9cd --- /dev/null +++ b/c/gcwrapper.c @@ -0,0 +1,864 @@ +/* gcwrapper.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +static IBOOL memqp(ptr x, ptr ls); +static IBOOL remove_first_nomorep(ptr x, ptr *pls, IBOOL look); +static void segment_tell(uptr seg); +static void check_heap_dirty_msg(char *msg, ptr *x); +static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g); +static void check_dirty_space(ISPC s); +static void check_dirty(void); + +static IBOOL checkheap_noisy; + +void S_gc_init(void) { + IGEN g; INT i; + + S_checkheap = 0; /* 0 for disabled, 1 for enabled */ + S_checkheap_errors = 0; /* count of errors detected by checkheap */ + checkheap_noisy = 0; /* 0 for error output only; 1 for more noisy output */ + S_G.prcgeneration = static_generation; + + if (S_checkheap) { + printf(checkheap_noisy ? "NB: check_heap is enabled and noisy\n" : "NB: check_heap_is_enabled\n"); + fflush(stdout); + } + +#ifndef WIN32 + for (g = 0; g <= static_generation; g++) { + S_child_processes[g] = Snil; + } +#endif /* WIN32 */ + + if (!S_boot_time) return; + + for (g = 0; g <= static_generation; g++) { + S_G.guardians[g] = Snil; + S_G.locked_objects[g] = Snil; + S_G.unlocked_objects[g] = Snil; + } + S_G.max_nonstatic_generation = + S_G.new_max_nonstatic_generation = + S_G.min_free_gen = + S_G.new_min_free_gen = default_max_nonstatic_generation; + + for (g = 0; g <= static_generation; g += 1) { + for (i = 0; i < countof_types; i += 1) { + S_G.countof[g][i] = 0; + S_G.bytesof[g][i] = 0; + } + S_G.gctimestamp[g] = 0; + S_G.rtds_with_counts[g] = Snil; + } + + S_G.countof[static_generation][countof_oblist] += 1; + S_G.bytesof[static_generation][countof_oblist] += S_G.oblist_length * sizeof(bucket *); + + S_protect(&S_G.static_id); + S_G.static_id = S_intern((const unsigned char *)"static"); + + S_protect(&S_G.countof_names); + S_G.countof_names = S_vector(countof_types); + for (i = 0; i < countof_types; i += 1) { + INITVECTIT(S_G.countof_names, i) = FIX(0); + S_G.countof_size[i] = 0; + } + INITVECTIT(S_G.countof_names, countof_pair) = S_intern((const unsigned char *)"pair"); + S_G.countof_size[countof_pair] = size_pair; + INITVECTIT(S_G.countof_names, countof_symbol) = S_intern((const unsigned char *)"symbol"); + S_G.countof_size[countof_symbol] = size_symbol; + INITVECTIT(S_G.countof_names, countof_flonum) = S_intern((const unsigned char *)"flonum"); + S_G.countof_size[countof_flonum] = size_flonum; + INITVECTIT(S_G.countof_names, countof_closure) = S_intern((const unsigned char *)"procedure"); + S_G.countof_size[countof_closure] = 0; + INITVECTIT(S_G.countof_names, countof_continuation) = S_intern((const unsigned char *)"continuation"); + S_G.countof_size[countof_continuation] = size_continuation; + INITVECTIT(S_G.countof_names, countof_bignum) = S_intern((const unsigned char *)"bignum"); + S_G.countof_size[countof_bignum] = 0; + INITVECTIT(S_G.countof_names, countof_ratnum) = S_intern((const unsigned char *)"ratnum"); + S_G.countof_size[countof_ratnum] = size_ratnum; + INITVECTIT(S_G.countof_names, countof_inexactnum) = S_intern((const unsigned char *)"inexactnum"); + S_G.countof_size[countof_inexactnum] = size_inexactnum; + INITVECTIT(S_G.countof_names, countof_exactnum) = S_intern((const unsigned char *)"exactnum"); + S_G.countof_size[countof_exactnum] = size_exactnum; + INITVECTIT(S_G.countof_names, countof_box) = S_intern((const unsigned char *)"box"); + S_G.countof_size[countof_box] = size_box; + INITVECTIT(S_G.countof_names, countof_port) = S_intern((const unsigned char *)"port"); + S_G.countof_size[countof_port] = size_port; + INITVECTIT(S_G.countof_names, countof_code) = S_intern((const unsigned char *)"code"); + S_G.countof_size[countof_code] = 0; + INITVECTIT(S_G.countof_names, countof_thread) = S_intern((const unsigned char *)"thread"); + S_G.countof_size[countof_thread] = size_thread; + INITVECTIT(S_G.countof_names, countof_tlc) = S_intern((const unsigned char *)"tlc"); + S_G.countof_size[countof_tlc] = size_tlc; + INITVECTIT(S_G.countof_names, countof_rtd_counts) = S_intern((const unsigned char *)"rtd-counts"); + S_G.countof_size[countof_rtd_counts] = size_rtd_counts; + INITVECTIT(S_G.countof_names, countof_stack) = S_intern((const unsigned char *)"stack"); + S_G.countof_size[countof_stack] = 0; + INITVECTIT(S_G.countof_names, countof_relocation_table) = S_intern((const unsigned char *)"reloc-table"); + S_G.countof_size[countof_relocation_table] = 0; + INITVECTIT(S_G.countof_names, countof_weakpair) = S_intern((const unsigned char *)"weakpair"); + S_G.countof_size[countof_weakpair] = size_pair; + INITVECTIT(S_G.countof_names, countof_vector) = S_intern((const unsigned char *)"vector"); + S_G.countof_size[countof_vector] = 0; + INITVECTIT(S_G.countof_names, countof_string) = S_intern((const unsigned char *)"string"); + S_G.countof_size[countof_string] = 0; + INITVECTIT(S_G.countof_names, countof_fxvector) = S_intern((const unsigned char *)"fxvector"); + S_G.countof_size[countof_fxvector] = 0; + INITVECTIT(S_G.countof_names, countof_bytevector) = S_intern((const unsigned char *)"bytevector"); + S_G.countof_size[countof_bytevector] = 0; + INITVECTIT(S_G.countof_names, countof_locked) = S_intern((const unsigned char *)"locked"); + S_G.countof_size[countof_locked] = 0; + INITVECTIT(S_G.countof_names, countof_guardian) = S_intern((const unsigned char *)"guardian"); + S_G.countof_size[countof_guardian] = size_guardian_entry; + INITVECTIT(S_G.countof_names, countof_oblist) = S_intern((const unsigned char *)"oblist"); + S_G.countof_size[countof_guardian] = 0; + INITVECTIT(S_G.countof_names, countof_ephemeron) = S_intern((const unsigned char *)"ephemron"); + S_G.countof_size[countof_ephemeron] = 0; + for (i = 0; i < countof_types; i += 1) { + if (Svector_ref(S_G.countof_names, i) == FIX(0)) { + fprintf(stderr, "uninitialized countof_name at index %d\n", i); + S_abnormal_exit(); + } + } +} + +IGEN S_maxgen(void) { + return S_G.new_max_nonstatic_generation; +} + +void S_set_maxgen(IGEN g) { + if (g < 0 || g >= static_generation) { + fprintf(stderr, "invalid maxgen %d\n", g); + S_abnormal_exit(); + } + if (S_G.new_min_free_gen == S_G.new_max_nonstatic_generation || S_G.new_min_free_gen > g) { + S_G.new_min_free_gen = g; + } + S_G.new_max_nonstatic_generation = g; +} + +IGEN S_minfreegen(void) { + return S_G.new_min_free_gen; +} + +void S_set_minfreegen(IGEN g) { + S_G.new_min_free_gen = g; + if (S_G.new_max_nonstatic_generation == S_G.max_nonstatic_generation) { + S_G.min_free_gen = g; + } +} + +static IBOOL memqp(ptr x, ptr ls) { + for (;;) { + if (ls == Snil) return 0; + if (Scar(ls) == x) return 1; + ls = Scdr(ls); + } +} + +static IBOOL remove_first_nomorep(ptr x, ptr *pls, IBOOL look) { + ptr ls; + + for (;;) { + ls = *pls; + if (ls == Snil) break; + if (Scar(ls) == x) { + ls = Scdr(ls); + *pls = ls; + if (look) return !memqp(x, ls); + break; + } + pls = &Scdr(ls); + } + + /* must return 0 if we don't look for more */ + return 0; +} + +IBOOL Slocked_objectp(ptr x) { + seginfo *si; IGEN g; IBOOL ans; ptr ls; + + if (IMMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1; + + tc_mutex_acquire() + + ans = 0; + for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) { + if (x == Scar(ls)) { + ans = 1; + break; + } + } + + tc_mutex_release() + + return ans; +} + +ptr S_locked_objects(void) { + IGEN g; ptr ans; ptr ls; + + tc_mutex_acquire() + + ans = Snil; + for (g = 0; g <= static_generation; INCRGEN(g)) { + for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) { + ans = Scons(Scar(ls), ans); + } + } + + tc_mutex_release() + + return ans; +} + +void Slock_object(ptr x) { + seginfo *si; IGEN g; + + tc_mutex_acquire() + + /* weed out pointers that won't be relocated */ + if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { + S_pants_down += 1; + /* add x to locked list. remove from unlocked list */ + S_G.locked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.locked_objects[g]); + if (S_G.enable_object_counts) { + if (g != 0) S_G.countof[g][countof_pair] += 1; + } + if (si->space & space_locked) + (void)remove_first_nomorep(x, &S_G.unlocked_objects[g], 0); + S_pants_down -= 1; + } + + tc_mutex_release() +} + +void Sunlock_object(ptr x) { + seginfo *si; IGEN g; + + tc_mutex_acquire() + + if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { + S_pants_down += 1; + /* remove first occurrence of x from locked list. if there are no + others, add x to unlocked list */ + if (remove_first_nomorep(x, &S_G.locked_objects[g], si->space & space_locked)) { + S_G.unlocked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.unlocked_objects[g]); + if (S_G.enable_object_counts) { + if (g != 0) S_G.countof[g][countof_pair] += 1; + } + } + S_pants_down -= 1; + } + + tc_mutex_release() +} + +ptr s_help_unregister_guardian(ptr *pls, ptr tconc, ptr result) { + ptr rep, ls; + while ((ls = *pls) != Snil) { + if (GUARDIANTCONC(ls) == tconc) { + result = Scons(((rep = GUARDIANREP(ls)) == ftype_guardian_rep ? GUARDIANOBJ(ls) : rep), result); + *pls = ls = GUARDIANNEXT(ls); + } else { + ls = *(pls = &GUARDIANNEXT(ls)); + } + } + return result; +} + +ptr S_unregister_guardian(ptr tconc) { + ptr result, tc; IGEN g; + tc_mutex_acquire() + tc = get_thread_context(); + /* in the interest of thread safety, gather entries only in the current thread, ignoring any others */ + result = s_help_unregister_guardian(&GUARDIANENTRIES(tc), tconc, Snil); + /* plus, of course, any already known to the storage-management system */ + for (g = 0; g <= static_generation; INCRGEN(g)) { + result = s_help_unregister_guardian(&S_G.guardians[g], tconc, result); + } + tc_mutex_release() + return result; +} + +#ifndef WIN32 +void S_register_child_process(INT child) { + tc_mutex_acquire() + S_child_processes[0] = Scons(FIX(child), S_child_processes[0]); + tc_mutex_release() +} +#endif /* WIN32 */ + +IBOOL S_enable_object_counts(void) { + return S_G.enable_object_counts; +} + +void S_set_enable_object_counts(IBOOL eoc) { + S_G.enable_object_counts = eoc; +} + +ptr S_object_counts(void) { + IGEN grtd, g; ptr ls; iptr i; ptr outer_alist; + + tc_mutex_acquire() + + outer_alist = Snil; + + /* add rtds w/nonozero counts to the alist */ + for (grtd = 0; grtd <= static_generation; INCRGEN(grtd)) { + for (ls = S_G.rtds_with_counts[grtd]; ls != Snil; ls = Scdr(ls)) { + ptr rtd = Scar(ls); + ptr counts = RECORDDESCCOUNTS(rtd); + IGEN g; + uptr size = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + ptr inner_alist = Snil; + + S_fixup_counts(counts); + for (g = 0; g <= static_generation; INCRGEN(g)) { + uptr count = RTDCOUNTSIT(counts, g); IGEN gcurrent = g; + if (g == S_G.new_max_nonstatic_generation) { + while (g < S_G.max_nonstatic_generation) { + g += 1; + count += RTDCOUNTSIT(counts, g); + } + } + if (count != 0) inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(count * size))), inner_alist); + } + if (inner_alist != Snil) outer_alist = Scons(Scons(rtd, inner_alist), outer_alist); + } + } + + /* add primary types w/nonozero counts to the alist */ + for (i = 0 ; i < countof_types; i += 1) { + ptr inner_alist = Snil; + for (g = 0; g <= static_generation; INCRGEN(g)) { + IGEN gcurrent = g; + uptr count = S_G.countof[g][i]; + uptr bytes = S_G.bytesof[g][i]; + + if (g == S_G.new_max_nonstatic_generation) { + while (g < S_G.max_nonstatic_generation) { + g += 1; + /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */ + /* coverity[overrun-buffer-val] */ + count += S_G.countof[g][i]; + /* coverity[overrun-buffer-val] */ + bytes += S_G.bytesof[g][i]; + } + } + + if (count != 0) { + if (bytes == 0) bytes = count * S_G.countof_size[i]; + inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist); + } + } + if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist); + } + + tc_mutex_release() + + return outer_alist; +} + +/* Scompact_heap(). Compact into as few O/S chunks as possible and + * move objects into static generation + */ +void Scompact_heap(void) { + ptr tc = get_thread_context(); + S_pants_down += 1; + S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, static_generation); + S_pants_down -= 1; +} + +/* S_check_heap checks for various kinds of heap consistency + It currently checks for: + dangling references in space_impure (generation > 0) and space_pure + extra dirty bits + missing dirty bits + + Some additional things it should check for but doesn't: + correct dirty bytes, following sweep_dirty conventions + dangling references in in space_code and space_continuation + dirty bits set for non-impure segments outside of generation zero + proper chaining of segments of a space and generation: + chains contain all and only the appropriate segments + + If noisy is nonzero, additional comments may be included in the output +*/ + +static void segment_tell(uptr seg) { + seginfo *si; + ISPC s, s1; + static char *spacename[max_space+1] = { alloc_space_names }; + + printf("segment %#tx", (ptrdiff_t)seg); + if ((si = MaybeSegInfo(seg)) == NULL) { + printf(" out of heap bounds\n"); + } else { + printf(" generation=%d", si->generation); + s = si->space; + s1 = si->space & ~(space_old|space_locked); + if (s1 < 0 || s1 > max_space) + printf(" space-bogus (%d)", s); + else { + printf(" space-%s", spacename[s1]); + if (s & space_old) printf(" oldspace"); + if (s & space_locked) printf(" locked"); + } + printf("\n"); + } + fflush(stdout); +} + +void S_ptr_tell(ptr p) { + segment_tell(ptr_get_segment(p)); +} + +void S_addr_tell(ptr p) { + segment_tell(addr_get_segment(p)); +} + +static void check_heap_dirty_msg(char *msg, ptr *x) { + INT d; seginfo *si; + + si = SegInfo(addr_get_segment(x)); + d = (INT)(((uptr)x >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)); + printf("%s dirty byte %d found in segment %#tx, card %d at %#tx\n", msg, si->dirty_bytes[d], (ptrdiff_t)(si->number), d, (ptrdiff_t)x); + printf("from "); segment_tell(addr_get_segment(x)); + printf("to "); segment_tell(addr_get_segment(*x)); +} + +void S_check_heap(IBOOL aftergc) { + uptr seg; INT d; ISPC s; IGEN g; IDIRTYBYTE dirty; IBOOL found_eos; IGEN pg; + ptr p, *pp1, *pp2, *nl; + iptr i; + uptr empty_segments = 0; + uptr used_segments = 0; + uptr static_segments = 0; + uptr nonstatic_segments = 0; + + check_dirty(); + + for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { + chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i]; + while (chunk != NULL) { + seginfo *si = chunk->unused_segs; + iptr count = 0; + while(si) { + count += 1; + if (si->space != space_empty) { + S_checkheap_errors += 1; + printf("!!! unused segment has unexpected space\n"); + } + si = si->next; + } + if ((chunk->segs - count) != chunk->nused_segs) { + S_checkheap_errors += 1; + printf("!!! unexpected used segs count %td with %td total segs and %td segs on the unused list\n", + (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs, (ptrdiff_t)count); + } + used_segments += chunk->nused_segs; + empty_segments += count; + chunk = chunk->next; + } + } + + for (s = 0; s <= max_real_space; s += 1) { + seginfo *si; + for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) { + for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) { + nonstatic_segments += 1; + } + } + for (si = S_G.occupied_segments[static_generation][s]; si != NULL; si = si->next) { + static_segments += 1; + } + } + + if (used_segments != nonstatic_segments + static_segments) { + S_checkheap_errors += 1; + printf("!!! found %#tx used segments and %#tx occupied segments\n", + (ptrdiff_t)used_segments, + (ptrdiff_t)(nonstatic_segments + static_segments)); + } + + if (S_G.number_of_nonstatic_segments != nonstatic_segments) { + S_checkheap_errors += 1; + printf("!!! S_G.number_of_nonstatic_segments %#tx is different from occupied number %#tx\n", + (ptrdiff_t)S_G.number_of_nonstatic_segments, + (ptrdiff_t)nonstatic_segments); + } + + if (S_G.number_of_empty_segments != empty_segments) { + S_checkheap_errors += 1; + printf("!!! S_G.number_of_empty_segments %#tx is different from unused number %#tx\n", + (ptrdiff_t)S_G.number_of_empty_segments, + (ptrdiff_t)empty_segments); + } + + for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { + chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i]; + while (chunk != NULL) { + uptr nsegs; seginfo *si; + for (si = &chunk->sis[0], nsegs = chunk->segs; nsegs != 0; nsegs -= 1, si += 1) { + seginfo *recorded_si; uptr recorded_seg; + if ((seg = si->number) != (recorded_seg = (chunk->base + chunk->segs - nsegs))) { + S_checkheap_errors += 1; + printf("!!! recorded segment number %#tx differs from actual segment number %#tx", (ptrdiff_t)seg, (ptrdiff_t)recorded_seg); + } + if ((recorded_si = SegInfo(seg)) != si) { + S_checkheap_errors += 1; + printf("!!! recorded segment %#tx seginfo %#tx differs from actual seginfo %#tx", (ptrdiff_t)seg, (ptrdiff_t)recorded_si, (ptrdiff_t)si); + } + s = si->space; + g = si->generation; + + if (s == space_new) { + if (g != 0) { + S_checkheap_errors += 1; + printf("!!! unexpected generation %d segment %#tx in space_new\n", g, (ptrdiff_t)seg); + } + } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair /* || s == space_ephemeron */) { + /* out of date: doesn't handle space_port, space_continuation, space_code, space_pure_typed_object, space_impure_record */ + nl = (ptr *)S_G.next_loc[g][s]; + + /* check for dangling references */ + pp1 = (ptr *)build_ptr(seg, 0); + pp2 = (ptr *)build_ptr(seg + 1, 0); + if (pp1 <= nl && nl < pp2) pp2 = nl; + + while (pp1 != pp2) { + seginfo *psi; ISPC ps; + p = *pp1; + if (p == forward_marker) break; + if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && ((ps = psi->space) & space_old || ps == space_empty)) { + S_checkheap_errors += 1; + printf("!!! dangling reference at %#tx to %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)p); + printf("from: "); segment_tell(seg); + printf("to: "); segment_tell(ptr_get_segment(p)); + } + pp1 += 1; + } + + /* verify that dirty bits are set appropriately */ + /* out of date: doesn't handle space_impure_record, space_port, and maybe others */ + /* also doesn't check the SYMCODE for symbols */ + if (s == space_impure || s == space_symbol || s == space_weakpair /* || s == space_ephemeron */) { + found_eos = 0; + pp2 = pp1 = build_ptr(seg, 0); + for (d = 0; d < cards_per_segment; d += 1) { + if (found_eos) { + if (si->dirty_bytes[d] != 0xff) { + S_checkheap_errors += 1; + printf("!!! Dirty byte set past end-of-segment for segment %#tx, card %d\n", (ptrdiff_t)seg, d); + segment_tell(seg); + } + continue; + } + + pp2 += bytes_per_card / sizeof(ptr); + if (pp1 <= nl && nl < pp2) { + found_eos = 1; + pp2 = nl; + } + +#ifdef DEBUG + printf("pp1 = %#tx, pp2 = %#tx, nl = %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)pp2, (ptrdiff_t)nl); + fflush(stdout); +#endif + + dirty = 0xff; + while (pp1 != pp2) { + seginfo *psi; + p = *pp1; + + if (p == forward_marker) { + found_eos = 1; + break; + } + if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && (pg = psi->generation) < g) { + if (pg < dirty) dirty = pg; + if (si->dirty_bytes[d] > pg) { + S_checkheap_errors += 1; + check_heap_dirty_msg("!!! INVALID", pp1); + } + else if (checkheap_noisy) + check_heap_dirty_msg("... ", pp1); + } + pp1 += 1; + } + if (checkheap_noisy && si->dirty_bytes[d] < dirty) { + /* sweep_dirty won't sweep, and update dirty byte, for + cards with dirty pointers to segments older than the + maximum copied generation, so we can get legitimate + conservative dirty bytes even after gc */ + printf("... Conservative dirty byte %x (%x) %sfor segment %#tx card %d ", + si->dirty_bytes[d], dirty, + (aftergc ? "after gc " : ""), + (ptrdiff_t)seg, d); + segment_tell(seg); + } + } + } + } + if (aftergc && s != space_empty && !(s & space_locked) && (g == 0 || (s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron && s != space_impure_record))) { + for (d = 0; d < cards_per_segment; d += 1) { + if (si->dirty_bytes[d] != 0xff) { + S_checkheap_errors += 1; + printf("!!! Unnecessary dirty byte %x (%x) after gc for segment %#tx card %d ", + si->dirty_bytes[d], 0xff, (ptrdiff_t)(si->number), d); + segment_tell(seg); + } + } + } + } + chunk = chunk->next; + } + } +} + +static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g) { + seginfo *si = DirtySegments(from_g, to_g); + while (si != NULL) { + if (si == x) return 1; + si = si->dirty_next; + } + return 0; +} + +static void check_dirty_space(ISPC s) { + IGEN from_g, to_g, min_to_g; INT d; seginfo *si; + + for (from_g = 0; from_g <= static_generation; from_g += 1) { + for (si = S_G.occupied_segments[from_g][s]; si != NULL; si = si->next) { + if (si->space & space_locked) continue; + min_to_g = 0xff; + for (d = 0; d < cards_per_segment; d += 1) { + to_g = si->dirty_bytes[d]; + if (to_g != 0xff) { + if (to_g < min_to_g) min_to_g = to_g; + if (from_g == 0) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): space %d, generation %d segment %#tx card %d is marked dirty\n", s, from_g, (ptrdiff_t)(si->number), d); + } + } + } + if (min_to_g != si->min_dirty_byte) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): space %d, generation %d segment %#tx min_dirty_byte is %d while actual min is %d\n", s, from_g, (ptrdiff_t)(si->number), si->min_dirty_byte, min_to_g); + segment_tell(si->number); + } else if (min_to_g != 0xff) { + if (!dirty_listedp(si, from_g, min_to_g)) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): space %d, generation %d segment %#tx is marked dirty but not in dirty-segment list\n", s, from_g, (ptrdiff_t)(si->number)); + segment_tell(si->number); + } + } + } + } +} + +static void check_dirty(void) { + IGEN from_g, to_g; seginfo *si; + + for (from_g = 1; from_g <= static_generation; from_g = from_g == S_G.max_nonstatic_generation ? static_generation : from_g + 1) { + for (to_g = 0; (from_g == static_generation) ? (to_g <= S_G.max_nonstatic_generation) : (to_g < from_g); to_g += 1) { + si = DirtySegments(from_g, to_g); + if (from_g > S_G.max_nonstatic_generation && from_g != static_generation) { + if (si != NULL) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): unexpected nonempty from-generation %d, to-generation %d dirty segment list\n", from_g, to_g); + } + } else { + while (si != NULL) { + ISPC s = si->space & ~space_locked; + IGEN g = si->generation; + IGEN mingval = si->min_dirty_byte; + if (g != from_g) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): generation %d segment %#tx in %d -> %d dirty list\n", g, (ptrdiff_t)(si->number), from_g, to_g); + } + if (mingval != to_g) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): dirty byte = %d for segment %#tx in %d -> %d dirty list\n", mingval, (ptrdiff_t)(si->number), from_g, to_g); + } + if (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_impure_record && s != space_weakpair && s != space_ephemeron) { + S_checkheap_errors += 1; + printf("!!! (check_dirty): unexpected space %d for dirty segment %#tx\n", s, (ptrdiff_t)(si->number)); + } + si = si->dirty_next; + } + } + } + } + + check_dirty_space(space_impure); + check_dirty_space(space_symbol); + check_dirty_space(space_port); + check_dirty_space(space_impure_record); + check_dirty_space(space_weakpair); + check_dirty_space(space_ephemeron); + + fflush(stdout); +} + +void S_fixup_counts(ptr counts) { + IGEN g; U64 timestamp; + + timestamp = RTDCOUNTSTIMESTAMP(counts); + for (g = 0; g <= static_generation; INCRGEN(g)) { + if (timestamp >= S_G.gctimestamp[g]) break; + RTDCOUNTSIT(counts, g) = 0; + } + RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0]; +} + +void S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg) { + ptr tc = get_thread_context(); + ptr code; + + code = CP(tc); + if (Sprocedurep(code)) code = CLOSCODE(code); + Slock_object(code); + + /* Scheme side grabs mutex before calling S_do_gc */ + S_pants_down += 1; + + if (S_G.new_max_nonstatic_generation > S_G.max_nonstatic_generation) { + S_G.min_free_gen = S_G.new_min_free_gen; + S_G.max_nonstatic_generation = S_G.new_max_nonstatic_generation; + } + + if (max_tg == max_cg && max_cg == S_G.new_max_nonstatic_generation && max_cg < S_G.max_nonstatic_generation) { + IGEN new_g, old_g, from_g, to_g; ISPC s; seginfo *si, *nextsi, *tail; + /* reducing max_nonstatic_generation */ + new_g = S_G.new_max_nonstatic_generation; + old_g = S_G.max_nonstatic_generation; + /* first, collect everything to old_g, ignoring min_tg */ + S_gc(tc, old_g, old_g, old_g); + /* now transfer old_g info to new_g, and clear old_g info */ + S_G.bytes_of_generation[new_g] = S_G.bytes_of_generation[old_g]; S_G.bytes_of_generation[old_g] = 0; + for (s = 0; s <= max_real_space; s += 1) { + S_G.first_loc[new_g][s] = S_G.first_loc[old_g][s]; S_G.first_loc[old_g][s] = FIX(0); + S_G.base_loc[new_g][s] = S_G.base_loc[old_g][s]; S_G.base_loc[old_g][s] = FIX(0); + S_G.next_loc[new_g][s] = S_G.next_loc[old_g][s]; S_G.next_loc[old_g][s] = FIX(0); + S_G.bytes_left[new_g][s] = S_G.bytes_left[old_g][s]; S_G.bytes_left[old_g][s] = 0; + S_G.bytes_of_space[new_g][s] = S_G.bytes_of_space[old_g][s]; S_G.bytes_of_space[old_g][s] = 0; + S_G.occupied_segments[new_g][s] = S_G.occupied_segments[old_g][s]; S_G.occupied_segments[old_g][s] = NULL; + for (si = S_G.occupied_segments[new_g][s]; si != NULL; si = si->next) { + si->generation = new_g; + } + } + S_G.guardians[new_g] = S_G.guardians[old_g]; S_G.guardians[old_g] = Snil; + S_G.locked_objects[new_g] = S_G.locked_objects[old_g]; S_G.locked_objects[old_g] = Snil; + S_G.unlocked_objects[new_g] = S_G.unlocked_objects[old_g]; S_G.unlocked_objects[old_g] = Snil; + S_G.buckets_of_generation[new_g] = S_G.buckets_of_generation[old_g]; S_G.buckets_of_generation[old_g] = NULL; + if (S_G.enable_object_counts) { + INT i; ptr ls; + for (i = 0; i < countof_types; i += 1) { + S_G.countof[new_g][i] = S_G.countof[old_g][i]; S_G.countof[old_g][i] = 0; + S_G.bytesof[new_g][i] = S_G.bytesof[old_g][i]; S_G.bytesof[old_g][i] = 0; + } + S_G.rtds_with_counts[new_g] = S_G.rtds_with_counts[old_g]; S_G.rtds_with_counts[old_g] = Snil; + for (ls = S_G.rtds_with_counts[new_g]; ls != Snil; ls = Scdr(ls)) { + ptr counts = RECORDDESCCOUNTS(Scar(ls)); + RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0; + } + for (ls = S_G.rtds_with_counts[static_generation]; ls != Snil; ls = Scdr(ls)) { + ptr counts = RECORDDESCCOUNTS(Scar(ls)); + RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0; + } + } +#ifndef WIN32 + S_child_processes[new_g] = S_child_processes[old_g]; +#endif + + /* change old_g dirty bytes in static generation to new_g; splice list of old_g + seginfos onto front of new_g seginfos */ + for (from_g = 1; from_g <= static_generation; INCRGEN(from_g)) { + for (to_g = 0; (from_g == static_generation) ? (to_g <= S_G.max_nonstatic_generation) : (to_g < from_g); to_g += 1) { + if ((si = DirtySegments(from_g, to_g)) != NULL) { + if (from_g == old_g) { + DirtySegments(from_g, to_g) = NULL; + DirtySegments(new_g, to_g) = si; + si->dirty_prev = &DirtySegments(new_g, to_g); + } else if (from_g == static_generation) { + if (to_g == old_g) { + DirtySegments(from_g, to_g) = NULL; + tail = DirtySegments(from_g, new_g); + DirtySegments(from_g, new_g) = si; + si->dirty_prev = &DirtySegments(from_g, new_g); + for (;;) { + INT d; + si->min_dirty_byte = new_g; + for (d = 0; d < cards_per_segment; d += 1) { + if (si->dirty_bytes[d] == old_g) si->dirty_bytes[d] = new_g; + } + nextsi = si->dirty_next; + if (nextsi == NULL) break; + si = nextsi; + } + if (tail != NULL) tail->dirty_prev = &si->dirty_next; + si->dirty_next = tail; + } else { + do { + INT d; + for (d = 0; d < cards_per_segment; d += 1) { + if (si->dirty_bytes[d] == old_g) si->dirty_bytes[d] = new_g; + } + si = si->dirty_next; + } while (si != NULL); + } + } else { + S_error_abort("S_do_gc(gc): unexpected nonempty dirty segment list"); + } + } + } + } + + /* tell profile_release_counters to scan only through new_g */ + if (S_G.prcgeneration == old_g) S_G.prcgeneration = new_g; + + /* finally reset max_nonstatic_generation */ + S_G.min_free_gen = S_G.new_min_free_gen; + S_G.max_nonstatic_generation = new_g; + } else { + S_gc(tc, max_cg, min_tg, max_tg); + } + + /* eagerly give collecting thread, the only one guaranteed to be + active, a fresh allocation area. the other threads have to trap + to get_more_room if and when they awake and try to allocate */ + S_reset_allocation_pointer(tc); + + S_pants_down -= 1; + + Sunlock_object(code); +} + + +void S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg) { + if (max_cg == 0 && min_tg == 1 && max_tg == 1 && S_G.locked_objects[0] == Snil) + S_gc_011(tc); + else if (max_tg == static_generation || S_G.enable_object_counts) + S_gc_oce(tc, max_cg, min_tg, max_tg); + else + S_gc_ocd(tc, max_cg, min_tg, max_tg); +} diff --git a/c/globals.h b/c/globals.h new file mode 100644 index 0000000..f08c2b9 --- /dev/null +++ b/c/globals.h @@ -0,0 +1,156 @@ +/* globals.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* globals that do NOT need to be preserved in a saved heap. + * they must be initialized each time the system is brought up. */ + +/* gc.c */ +EXTERN IBOOL S_checkheap; +EXTERN uptr S_checkheap_errors; +#ifndef WIN32 +EXTERN ptr S_child_processes[static_generation+1]; +#endif /* WIN32 */ + +/* scheme.c */ +EXTERN IBOOL S_boot_time; +EXTERN IBOOL S_errors_to_console; +EXTERN ptr S_threads; +EXTERN uptr S_nthreads; +EXTERN uptr S_pagesize; +EXTERN void (*S_abnormal_exit_proc)(); +EXTERN char *Sschemeheapdirs; +EXTERN char *Sdefaultheapdirs; +#ifdef PTHREADS +EXTERN s_thread_key_t S_tc_key; +EXTERN scheme_mutex_t S_tc_mutex; +EXTERN s_thread_cond_t S_collect_cond; +EXTERN INT S_tc_mutex_depth; +#endif + +/* segment.c */ +#ifdef segment_t2_bits +#ifdef segment_t3_bits +EXTERN t2table *S_segment_info[1< +#include + +#ifdef FLUSHCACHE +oops, no S_flushcache_max_gap or S_doflush +#endif /* FLUSHCACHE */ + +void S_machine_init(void) {} diff --git a/c/intern.c b/c/intern.c new file mode 100644 index 0000000..3758a3b --- /dev/null +++ b/c/intern.c @@ -0,0 +1,389 @@ +/* intern.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +static void oblist_insert(ptr sym, iptr idx, IGEN g); +static iptr hash(const unsigned char *s, iptr n); +static iptr hash_sc(const string_char *s, iptr n); +static iptr hash_uname(const string_char *s, iptr n); +static ptr mkstring(const string_char *s, iptr n); + +/* list of some primes to use for oblist sizes */ +#if (ptr_bits == 32) +static iptr oblist_lengths[] = { + 1031, + 2053, + 4099, + 8209, + 16411, + 32771, + 65537, + 131101, + 262147, + 524309, + 1048583, + 2097169, + 4194319, + 8388617, + 16777259, + 33554467, + 67108879, + 134217757, + 268435459, + 536870923, + 1073741827, + 0}; +#endif +#if (ptr_bits == 64) +static iptr oblist_lengths[] = { + 1031, + 2053, + 4099, + 8209, + 16411, + 32771, + 65537, + 131101, + 262147, + 524309, + 1048583, + 2097169, + 4194319, + 8388617, + 16777259, + 33554467, + 67108879, + 134217757, + 268435459, + 536870923, + 1073741827, + 2147483659, + 4294967311, + 8589934609, + 17179869209, + 34359738421, + 68719476767, + 137438953481, + 274877906951, + 549755813911, + 1099511627791, + 2199023255579, + 4398046511119, + 8796093022237, + 17592186044423, + 35184372088891, + 70368744177679, + 140737488355333, + 281474976710677, + 562949953421381, + 1125899906842679, + 2251799813685269, + 4503599627370517, + 9007199254740997, + 18014398509482143, + 36028797018963971, + 72057594037928017, + 144115188075855881, + 288230376151711813, + 576460752303423619, + 1152921504606847009, + 2305843009213693967, + 4611686018427388039, + 0}; +#endif + +void S_intern_init(void) { + IGEN g; + + if (!S_boot_time) return; + + S_G.oblist_length_pointer = &oblist_lengths[3]; + S_G.oblist_length = *S_G.oblist_length_pointer; + S_G.oblist_count = 0; + S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1); + for (g = 0; g < static_generation; g += 1) S_G.buckets_of_generation[g] = NULL; +} + +static void oblist_insert(ptr sym, iptr idx, IGEN g) { + bucket *b, *oldb, **pb; + + find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket), b); + b->sym = sym; + if (g == 0) { + b->next = S_G.oblist[idx]; + S_G.oblist[idx] = b; + } else { + for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next); + b->next = oldb; + *pb = b; + } + + if (g != static_generation) { + bucket_list *bl; + find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket_list), bl); + bl->car = b; + bl->cdr = S_G.buckets_of_generation[g]; + S_G.buckets_of_generation[g] = bl; + } + + S_G.oblist_count += 1; +} + +void S_resize_oblist(void) { + bucket **new_oblist, *b, *oldb, **pb, *bnext; + iptr *new_oblist_length_pointer, new_oblist_length, i, idx; + ptr sym; + IGEN g; + + new_oblist_length_pointer = S_G.oblist_length_pointer; + + if (S_G.oblist_count < S_G.oblist_length) { + while (new_oblist_length_pointer != &oblist_lengths[0] && *(new_oblist_length_pointer - 1) >= S_G.oblist_count) { + new_oblist_length_pointer -= 1; + } + } else if (S_G.oblist_count > S_G.oblist_length) { + while (*(new_oblist_length_pointer + 1) != 0 && *(new_oblist_length_pointer + 1) <= S_G.oblist_count) { + new_oblist_length_pointer += 1; + } + } + + if (new_oblist_length_pointer == S_G.oblist_length_pointer) return; + + new_oblist_length = *new_oblist_length_pointer; + new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1); + + for (i = 0; i < S_G.oblist_length; i += 1) { + for (b = S_G.oblist[i]; b != NULL; b = bnext) { + bnext = b->next; + sym = b->sym; + idx = UNFIX(SYMHASH(sym)) % new_oblist_length; + g = GENERATION(sym); + + for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next); + b->next = oldb; + *pb = b; + } + } + + S_freemem(S_G.oblist, S_G.oblist_length * sizeof(bucket *)); + S_G.bytesof[static_generation][countof_oblist] += (new_oblist_length - S_G.oblist_length) * sizeof(bucket *); + + S_G.oblist_length_pointer = new_oblist_length_pointer; + S_G.oblist_length = new_oblist_length; + S_G.oblist = new_oblist; +} + +/* hash function: multiplier weights each character, h = n factors in the length */ +#define multiplier 3 + +static iptr hash(const unsigned char *s, iptr n) { + iptr h = n + 401887359; + while (n--) h = h * multiplier + *s++; + return h & most_positive_fixnum; +} + +static iptr hash_sc(const string_char *s, iptr n) { + iptr h = n + 401887359; + while (n--) h = h * multiplier + Schar_value(*s++); + return h & most_positive_fixnum; +} + +static iptr hash_uname(const string_char *s, iptr n) { + /* attempting to get dissimilar hash codes for gensyms created in the same session */ + iptr i = n, h = 0; iptr pos = 1; int d, c; + + while (i-- > 0) { + if ((c = Schar_value(s[i])) == '-') { + if (pos <= 10) break; + return (h + 523658599) & most_positive_fixnum; + } + d = c - '0'; + if (d < 0 || d > 9) break; + h += d * pos; + pos *= 10; + } + + return hash_sc(s, n); +} + +static ptr mkstring(const string_char *s, iptr n) { + iptr i; + ptr str = S_string(NULL, n); + for (i = 0; i != n; i += 1) STRIT(str, i) = s[i]; + return str; +} + +/* handles single-byte characters, implicit length */ +ptr S_intern(const unsigned char *s) { + iptr n = strlen((const char *)s); + iptr hc = hash(s, n); + iptr idx = hc % S_G.oblist_length; + ptr sym; + bucket *b; + + tc_mutex_acquire() + + b = S_G.oblist[idx]; + while (b != NULL) { + sym = b->sym; + if (!GENSYMP(sym)) { + ptr str = SYMNAME(sym); + if (Sstring_length(str) == n) { + iptr i; + for (i = 0; ; i += 1) { + if (i == n) { + tc_mutex_release() + return sym; + } + if (Sstring_ref(str, i) != s[i]) break; + } + } + } + b = b->next; + } + + sym = S_symbol(S_string((const char *)s, n)); + INITSYMHASH(sym) = FIX(hc); + oblist_insert(sym, idx, 0); + + tc_mutex_release() + return sym; +} + +/* handles string_chars, explicit length */ +ptr S_intern_sc(const string_char *name, iptr n, ptr name_str) { + iptr hc = hash_sc(name, n); + iptr idx = hc % S_G.oblist_length; + ptr sym; + bucket *b; + + tc_mutex_acquire() + + b = S_G.oblist[idx]; + while (b != NULL) { + sym = b->sym; + if (!GENSYMP(sym)) { + ptr str = SYMNAME(sym); + if (Sstring_length(str) == n) { + iptr i; + for (i = 0; ; i += 1) { + if (i == n) { + tc_mutex_release() + return sym; + } + if (STRIT(str, i) != name[i]) break; + } + } + } + b = b->next; + } + + /* if (name_str == Sfalse) */ name_str = mkstring(name, n); + sym = S_symbol(name_str); + INITSYMHASH(sym) = FIX(hc); + oblist_insert(sym, idx, 0); + + tc_mutex_release() + return sym; +} + +ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uname_str) { + iptr hc = hash_uname(uname, ulen); + iptr idx = hc % S_G.oblist_length; + ptr sym; + bucket *b; + + tc_mutex_acquire() + + b = S_G.oblist[idx]; + while (b != NULL) { + sym = b->sym; + if (GENSYMP(sym)) { + ptr str = Scar(SYMNAME(sym)); + if (Sstring_length(str) == ulen) { + iptr i; + for (i = 0; ; i += 1) { + if (i == ulen) { + tc_mutex_release() + return sym; + } + if (STRIT(str, i) != uname[i]) break; + } + } + } + b = b->next; + } + + if (pname_str == Sfalse) pname_str = mkstring(pname, plen); + if (uname_str == Sfalse) uname_str = mkstring(uname, ulen); + sym = S_symbol(Scons(uname_str, pname_str)); + INITSYMHASH(sym) = FIX(hc); + oblist_insert(sym, idx, 0); + + tc_mutex_release() + return sym; +} + +void S_intern_gensym(ptr sym) { + ptr uname_str = Scar(SYMNAME(sym)); + const string_char *uname = &STRIT(uname_str, 0); + iptr ulen = Sstring_length(uname_str); + iptr hc = hash_uname(uname, ulen); + iptr idx = hc % S_G.oblist_length; + bucket *b; + + tc_mutex_acquire() + + b = S_G.oblist[idx]; + while (b != NULL) { + ptr x = b->sym; + if (GENSYMP(x)) { + ptr str = Scar(SYMNAME(x)); + if (Sstring_length(str) == ulen) { + iptr i; + for (i = 0; ; i += 1) { + if (i == ulen) { + tc_mutex_release() + S_error1("intern-gensym", "unique name ~s already interned", uname_str); + } + if (Sstring_ref(str, i) != uname[i]) break; + } + } + } + b = b->next; + } + + INITSYMHASH(sym) = FIX(hc); + oblist_insert(sym, idx, GENERATION(sym)); + + tc_mutex_release() +} + +/* retrofit existing symbols once nonprocedure_code is available */ +void S_retrofit_nonprocedure_code(void) { + ptr npc, sym, val; bucket_list *bl; + + npc = S_G.nonprocedure_code; + + /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */ + for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) { + sym = bl->car->sym; + val = SYMVAL(sym); + SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : npc); + } +} diff --git a/c/io.c b/c/io.c new file mode 100644 index 0000000..9c2eea6 --- /dev/null +++ b/c/io.c @@ -0,0 +1,277 @@ +/* io.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" +#include +#include +#include +#ifdef WIN32 +#include +#include +#pragma comment(lib, "shell32.lib") +#else /* WIN32 */ +#include +#include +#include +#endif /* WIN32 */ + +/* locally defined functions */ +#ifdef WIN32 +static ptr s_wstring_to_bytevector(const wchar_t *s); +#else +static ptr s_string_to_bytevector(const char *s); +#endif + +/* raises an exception if insufficient space cannot be malloc'd. + otherwise returns a freshly allocated version of inpath with ~ (home directory) + prefix expanded, if possible */ +char *S_malloc_pathname(const char *inpath) { + char *outpath; const char *ip; + +#ifdef WIN32 + if (*inpath == '~' && (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip))) { + wchar_t* homew; + if (SUCCEEDED(SHGetKnownFolderPath(&FOLDERID_Profile, 0, NULL, &homew))) { + char *home = Swide_to_utf8(homew); + CoTaskMemFree(homew); + if (NULL != home) { + size_t n1, n2; + n1 = strlen(home); + n2 = strlen(ip) + 1; + if ((outpath = malloc(n1 + n2)) == NULL) { + free(home); + S_error("expand_pathname", "malloc failed"); + } + memcpy(outpath, home, n1); + memcpy(outpath + n1, ip, n2); + free(home); + return outpath; + } + } + } +#else /* WIN32 */ + if (*inpath == '~') { + const char *dir; size_t n1, n2; struct passwd *pwent; + if (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip)) { + if ((dir = getenv("HOME")) == NULL) + if ((pwent = getpwuid(getuid())) != NULL) + dir = pwent->pw_dir; + } else { + char *userbuf; const char *user_start = ip; + do { ip += 1; } while (*ip != 0 && !DIRMARKERP(*ip)); + if ((userbuf = malloc(ip - user_start + 1)) == NULL) S_error("expand_pathname", "malloc failed"); + memcpy(userbuf, user_start, ip - user_start); + userbuf[ip - user_start] = 0; + dir = (pwent = getpwnam(userbuf)) != NULL ? pwent->pw_dir : NULL; + free(userbuf); + } + if (dir != NULL) { + n1 = strlen(dir); + n2 = strlen(ip) + 1; + if ((outpath = malloc(n1 + n2)) == NULL) S_error("expand_pathname", "malloc failed"); + memcpy(outpath, dir, n1); + memcpy(outpath + n1, ip, n2); + return outpath; + } + } +#endif /* WIN32 */ + + /* if no ~ or tilde dir can't be found, copy inpath */ + { + size_t n = strlen(inpath) + 1; + if ((outpath = (char *)malloc(n)) == NULL) S_error("expand_pathname", "malloc failed"); + memcpy(outpath, inpath, n); + return outpath; + } +} + +#ifdef WIN32 +wchar_t *S_malloc_wide_pathname(const char *inpath) { + char *path = S_malloc_pathname(inpath); + wchar_t *wpath = Sutf8_to_wide(path); + free(path); + return wpath; +} +#endif + +IBOOL S_fixedpathp(const char *inpath) { + char c; IBOOL res; char *path; + + path = S_malloc_pathname(inpath); + res = (c = *path) == 0 + || DIRMARKERP(c) +#ifdef WIN32 + || ((*(path + 1) == ':') && (c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')) +#endif + || ((c == '.') + && ((c = *(path + 1)) == 0 + || DIRMARKERP(c) + || (c == '.' && ((c = *(path + 2)) == 0 || DIRMARKERP(c))))); + free(path); + return res; +} + +IBOOL S_file_existsp(const char *inpath, IBOOL followp) { +#ifdef WIN32 + wchar_t *wpath; IBOOL res; + WIN32_FILE_ATTRIBUTE_DATA filedata; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + return 0; + } else { + res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata); + free(wpath); + return res; + } +#else /* WIN32 */ + struct STATBUF statbuf; char *path; IBOOL res; + + path = S_malloc_pathname(inpath); + res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0; + free(path); + return res; +#endif /* WIN32 */ +} + +IBOOL S_file_regularp(const char *inpath, IBOOL followp) { +#ifdef WIN32 + wchar_t *wpath; IBOOL res; + WIN32_FILE_ATTRIBUTE_DATA filedata; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + return 0; + } else { + res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata) + && (filedata.dwFileAttributes & (FILE_ATTRIBUTE_DEVICE | FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT)) == 0; + free(wpath); + return res; + } +#else /* WIN32 */ + struct STATBUF statbuf; char *path; IBOOL res; + + path = S_malloc_pathname(inpath); + res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0 + && (statbuf.st_mode & S_IFMT) == S_IFREG; + free(path); + return res; +#endif /* WIN32 */ +} + +IBOOL S_file_directoryp(const char *inpath, IBOOL followp) { +#ifdef WIN32 + wchar_t *wpath; IBOOL res; + WIN32_FILE_ATTRIBUTE_DATA filedata; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + return 0; + } else { + res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata) + && filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY; + free(wpath); + return res; + } +#else /* WIN32 */ + struct STATBUF statbuf; char *path; IBOOL res; + + path = S_malloc_pathname(inpath); + res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0 + && (statbuf.st_mode & S_IFMT) == S_IFDIR; + free(path); + return res; +#endif /* WIN32 */ +} + +IBOOL S_file_symbolic_linkp(const char *inpath) { +#ifdef WIN32 + wchar_t *wpath; IBOOL res; + WIN32_FILE_ATTRIBUTE_DATA filedata; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + return 0; + } else { + res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata) + && filedata.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT; + free(wpath); + return res; + } +#else /* WIN32 */ + struct STATBUF statbuf; char *path; IBOOL res; + + path = S_malloc_pathname(inpath); + res = LSTAT(path, &statbuf) == 0 && (statbuf.st_mode & S_IFMT) == S_IFLNK; + free(path); + return res; +#endif /* WIN32 */ +} + +#ifdef WIN32 +static ptr s_wstring_to_bytevector(const wchar_t *s) { + iptr n; ptr bv; + if ((n = wcslen(s)) == 0) return S_G.null_bytevector; + n *= sizeof(wchar_t); + bv = S_bytevector(n); + memcpy(&BVIT(bv,0), s, n); + return bv; +} + +ptr S_find_files(const char *wildpath) { + wchar_t *wwildpath; + intptr_t handle; + struct _wfinddata_t fileinfo; + + if ((wwildpath = S_malloc_wide_pathname(wildpath)) == NULL) + return S_LastErrorString(); + + if ((handle = _wfindfirst(wwildpath, &fileinfo)) == (intptr_t)-1) { + free(wwildpath); + return S_strerror(errno); + } else { + ptr ls = Snil; + do { + ls = Scons(s_wstring_to_bytevector(fileinfo.name), ls); + } while (_wfindnext(handle, &fileinfo) == 0); + _findclose(handle); + free(wwildpath); + return ls; + } +} +#else /* WIN32 */ +static ptr s_string_to_bytevector(const char *s) { + iptr n; ptr bv; + if ((n = strlen(s)) == 0) return S_G.null_bytevector; + bv = S_bytevector(n); + memcpy(&BVIT(bv,0), s, n); + return bv; +} + +ptr S_directory_list(const char *inpath) { + char *path; DIR *dirp; + + path = S_malloc_pathname(inpath); + if ((dirp = opendir(path)) == (DIR *)0) { + free(path); + return S_strerror(errno); + } else { + struct dirent *dep; ptr ls = Snil; + + while ((dep = readdir(dirp)) != (struct dirent *)0) + ls = Scons(s_string_to_bytevector(dep->d_name), ls); + closedir(dirp); + free(path); + return ls; + } +} +#endif /* WIN32 */ diff --git a/c/itest.c b/c/itest.c new file mode 100644 index 0000000..21c1847 --- /dev/null +++ b/c/itest.c @@ -0,0 +1,247 @@ +/* itest.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define r_EOF 0 +#define r_LPAREN 1 +#define r_RPAREN 2 +#define r_CONST 3 + +static INT digit_value(ICHAR c, INT r) { + switch (r) { + case 2: + if ('0' <= c && c <= '1') return c - '0'; + break; + case 8: + if ('0' <= c && c <= '8') return c - '0'; + break; + case 10: + if ('0' <= c && c <= '9') return c - '0'; + break; + case 16: + if ('0' <= c && c <= '9') return c - '0'; + if ('a' <= c && c <= 'f') return c - 'a'; + if ('A' <= c && c <= 'F') return c - 'A'; + default: + break; + } + return -1; +} + +static INT read_int(ptr *v, ptr n, INT r, IBOOL sign) { + INT i, c; + + for (;;) { + if ((i = digit_value((c = getchar()), r)) == -1) { + ungetc(c, stdin); + break; + } + n = S_add(S_mul(n, FIX(r)), FIX(i)); + } + *v = sign ? S_sub(FIX(0), n) : n; + return r_CONST; +} + +static INT read_token(ptr *v) { + ICHAR c = getchar(); + switch (c) { + case SEOF: return r_EOF; + case '\n': + case ' ': return read_token(v); + case ';': + for (;;) { + switch (getchar()) { + case SEOF: + return r_EOF; + case '\n': + return read_token(v); + default: + break; + } + } + case '(': return r_LPAREN; + case ')': return r_RPAREN; + case '#': { + ICHAR c = getchar(); + INT r = 10; + switch (c) { + case 'x': + r = 16; + case 'o': + if (r == 0) r = 8; + case 'b': + if (r == 10) r = 2; + case 'd': { + INT i; + IBOOL sign = 0; + c = getchar(); + if (c == '+') + c = getchar(); + else if (c == '-') { + sign = 1; + c = getchar(); + } + + if ((i = digit_value(c, r)) != -1) + return read_int(v, FIX(i), r, sign); + } + default: + printf("malformed hash prefix ignored\n"); + return read_token(v); + } + } + case '+': + case '-': { + INT i, c2; + if ((i = digit_value((c2 = getchar()), 10)) == -1) { + ungetc(c2, stdin); + } else { + return read_int(v, FIX(i), 10, c == '-'); + } + } + case '*': + case '/': + case 'q': + case 'r': + case 'g': + case '=': + case '<': + case 'f': + case 'c': + case 'd': + *v = Schar(c); + return r_CONST; + default: { + INT i; + if ((i = digit_value(c, 10)) != -1) + return read_int(v, FIX(i), 10, 0); + } + break; + } + printf("invalid character %d ignored\n", c); + return read_token(v); +} + +static ptr readx(INT t, ptr v); + +static ptr read_list(void) { + INT t; ptr v, x; + + t = read_token(&v); + if (t == r_RPAREN) return Snil; + x = readx(t, v); + return Scons(x, read_list()); +} + +static ptr readx(INT t, ptr v) { + + switch (t) { + case r_EOF: + printf("unexpected EOF\n"); + exit(1); + case r_LPAREN: return read_list(); + case r_RPAREN: + printf("unexpected right paren ignored\n"); + t = read_token(&v); + return readx(t, v); + case r_CONST: return v; + default: + printf("invalid token %d\n", t); + exit(1); + } +} + +static ptr read_top(void) { + INT t; ptr v; + + t = read_token(&v); + switch (t) { + case r_EOF: return Seof_object; + case r_RPAREN: return read_top(); + default: return readx(t, v); + } +} + +static ptr eval(ptr x); + +#define First(x) eval(Scar(Scdr(x))) +#define Second(x) eval(Scar(Scdr(Scdr(x)))) + +static ptr eval(ptr x) { + if (Spairp(x)) { + switch (Schar_value(Scar(x))) { + case '+': return S_add(First(x), Second(x)); + case '-': return S_sub(First(x), Second(x)); + case '*': return S_mul(First(x), Second(x)); + case '/': return S_div(First(x), Second(x)); + case 'q': return S_trunc(First(x), Second(x)); + case 'r': return S_rem(First(x), Second(x)); + case 'g': return S_gcd(First(x), Second(x)); + case '=': { + ptr x1 = First(x), x2 = Second(x); + if (Sfixnump(x1) && Sfixnump(x2)) + return Sboolean(x1 == x2); + else if (Sbignump(x1) && Sbignump(x2)) + return Sboolean(S_big_eq(x1, x2)); + else return Sfalse; + } + case '<': { + ptr x1 = First(x), x2 = Second(x); + if (Sfixnump(x1)) + if (Sfixnump(x2)) + return Sboolean(x1 < x2); + else + return Sboolean(!BIGSIGN(x2)); + else + if (Sfixnump(x2)) + return Sboolean(BIGSIGN(x1)); + else + return Sboolean(S_big_lt(x1, x2)); + } + case 'f': return Sflonum(S_floatify(First(x))); + case 'c': + S_gc(get_thread_context(), UNFIX(First(x)),UNFIX(Second(x))); + return Svoid; + case 'd': return S_decode_float(Sflonum_value(First(x))); + default: + S_prin1(x); + putchar('\n'); + printf("unrecognized operator, returning zero\n"); + return FIX(0); + } + } else + return x; +} + +#undef PROMPT +#undef NOISY +static void bignum_test(void) { + ptr x; + for (;;) { +#ifdef PROMPT + putchar('*'); + putchar(' '); +#endif + x = read_top(); + if (x == Seof_object) { putchar('\n'); exit(0); } +#ifdef NOISY + S_prin1(x); + putchar('\n'); +#endif + x = eval(x); + S_prin1(x); + putchar('\n'); + } +} diff --git a/c/main.c b/c/main.c new file mode 100644 index 0000000..de8c719 --- /dev/null +++ b/c/main.c @@ -0,0 +1,376 @@ +/* main.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include +#include +#include +#include "scheme.h" +#include "config.h" + +/**** + CUSTOM_INIT may be defined as a function with the signature shown to + perform boot-time initialization, e.g., registering foreign symbols. +****/ +#ifndef CUSTOM_INIT +#define CUSTOM_INIT ((void (*)(void))0) +#endif /* CUSTOM_INIT */ + +/**** + ABNORMAL_EXIT may be defined as a function with the signature shown to + take some action, such as printing a special error message or performing + a nonlocal exit with longjmp, when the Scheme system exits abnormally, + i.e., when an unrecoverable error occurs. If left null, the default + is to call exit(1). +****/ +#ifndef ABNORMAL_EXIT +#define ABNORMAL_EXIT ((void (*)(void))0) +#endif /* ABNORMAL_EXIT */ + +#ifndef SCHEME_SCRIPT +#define SCHEME_SCRIPT "scheme-script" +#endif + +static const char *path_last(const char *p) { + const char *s; +#ifdef WIN32 + char c; + if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') + if (*(p + 1) == ':') + p += 2; + + for (s = p; *s != 0; s += 1) + if ((c = *s) == '/' || c == '\\') p = ++s; +#else /* WIN32 */ + for (s = p; *s != 0; s += 1) if (*s == '/') p = ++s; +#endif /* WIN32 */ + return p; +} + +#if defined(WIN32) && !defined(__MINGW32__) +#define GETENV Sgetenv +#define GETENV_FREE free +int wmain(int argc, wchar_t* wargv[], wchar_t* wenvp[]) { + const char** argv = (char**)malloc((argc + 1) * sizeof(char*)); + int i; + for (i = 0; i < argc; i++) { + wchar_t* warg = wargv[i]; + if (NULL == (argv[i] = Swide_to_utf8(warg))) { + fprintf_s(stderr, "Invalid argument: %S\n", warg); + exit(1); + } + } + argv[argc] = NULL; +#else /* WIN32 */ +#define GETENV getenv +#define GETENV_FREE (void) +int main(int argc, const char *argv[]) { +#endif /* WIN32 */ + int n, new_argc = 1; +#ifdef SAVEDHEAPS + int compact = 1, savefile_level = 0; + const char *savefile = (char *)0; +#endif /* SAVEDHEAPS */ + const char *execpath = argv[0]; + const char *scriptfile = (char *)0; + const char *programfile = (char *)0; + const char *libdirs = (char *)0; + const char *libexts = (char *)0; + int status; + const char *arg; + int quiet = 0; + int eoc = 0; + int optlevel = 0; + int debug_on_exception = 0; + int import_notify = 0; + int compile_imported_libraries = 0; +#ifdef FEATURE_EXPEDITOR + int expeditor_enable = 1; + const char *expeditor_history_file = ""; /* use "" for default location */ +#endif /* FEATURE_EXPEDITOR */ + + if (strcmp(Skernel_version(), VERSION) != 0) { + (void) fprintf(stderr, "unexpected shared library version %s for %s version %s\n", Skernel_version(), execpath, VERSION); + exit(1); + } + + Sscheme_init(ABNORMAL_EXIT); + + if (strcmp(path_last(execpath), SCHEME_SCRIPT) == 0) { + if (argc < 2) { + (void) fprintf(stderr,"%s requires program-path argument\n", execpath); + exit(1); + } + argv[0] = programfile = argv[1]; + n = 1; + while (++n < argc) argv[new_argc++] = argv[n]; + } else { + /* process command-line arguments, registering boot and heap files */ + for (n = 1; n < argc; n += 1) { + arg = argv[n]; + if (strcmp(arg,"--") == 0) { + while (++n < argc) argv[new_argc++] = argv[n]; + } else if (strcmp(arg,"-b") == 0 || strcmp(arg,"--boot") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + Sregister_boot_file(argv[n]); + } else if (strcmp(arg,"--eedisable") == 0) { + #ifdef FEATURE_EXPEDITOR + expeditor_enable = 0; + #endif /* FEATURE_EXPEDITOR */ + } else if (strcmp(arg,"--eehistory") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + #ifdef FEATURE_EXPEDITOR + if (strcmp(argv[n], "off") == 0) + expeditor_history_file = (char *)0; + else + expeditor_history_file = argv[n]; + #endif /* FEATURE_EXPEDITOR */ + } else if (strcmp(arg,"-q") == 0 || strcmp(arg,"--quiet") == 0) { + quiet = 1; + } else if (strcmp(arg,"--retain-static-relocation") == 0) { + Sretain_static_relocation(); + } else if (strcmp(arg,"--enable-object-counts") == 0) { + eoc = 1; +#ifdef SAVEDHEAPS + } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) { + compact = !compact; + } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + Sregister_heap_file(argv[n]); + } else if (strncmp(arg,"-s",2) == 0 && + (savefile_level = -2, + *(arg+2) == 0 || + *(arg+3) == 0 && + ((savefile_level = *(arg+2) - '+' - 1) == -1 || + (savefile_level = *(arg+2) - '0') >= 0 && + savefile_level <= 9)) || + strncmp(arg,"--saveheap",10) == 0 && + (savefile_level = -2, + *(arg+10) == 0 || + *(arg+11) == 0 && + ((savefile_level = *(arg+2) - '+' - 1) == -1 || + (savefile_level = *(arg+10) - '0') >= 0 && + savefile_level <= 9))) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + savefile = argv[n]; +#else /* SAVEDHEAPS */ + } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) { + fprintf(stderr, "-c and --compact options are not presently supported\n"); + exit(1); + } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) { + fprintf(stderr, "-h and --heap options are not presently supported\n"); + exit(1); + } else if (strncmp(arg,"-s",2) == 0 || strncmp(arg,"--saveheap",10) == 0) { + fprintf(stderr, "-s and --saveheap options are not presently supported\n"); + exit(1); +#endif /* SAVEDHEAPS */ + } else if (strcmp(arg,"--script") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + scriptfile = argv[n]; + while (++n < argc) argv[new_argc++] = argv[n]; + } else if (strcmp(arg,"--optimize-level") == 0) { + const char *nextarg; + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + nextarg = argv[n]; + if (strcmp(nextarg,"0") == 0) + optlevel = 0; + else if (strcmp(nextarg,"1") == 0) + optlevel = 1; + else if (strcmp(nextarg,"2") == 0) + optlevel = 2; + else if (strcmp(nextarg,"3") == 0) + optlevel = 3; + else { + (void) fprintf(stderr,"invalid optimize-level %s\n", nextarg); + exit(1); + } + } else if (strcmp(arg,"--debug-on-exception") == 0) { + debug_on_exception = 1; + } else if (strcmp(arg,"--import-notify") == 0) { + import_notify = 1; + } else if (strcmp(arg,"--libexts") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + libexts = argv[n]; + } else if (strcmp(arg,"--libdirs") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + libdirs = argv[n]; + } else if (strcmp(arg,"--compile-imported-libraries") == 0) { + compile_imported_libraries = 1; + } else if (strcmp(arg,"--program") == 0) { + if (++n == argc) { + (void) fprintf(stderr,"%s requires argument\n", arg); + exit(1); + } + programfile = argv[n]; + while (++n < argc) argv[new_argc++] = argv[n]; + } else if (strcmp(arg,"--help") == 0) { + fprintf(stderr,"usage: %s [options and files]\n", execpath); + fprintf(stderr,"options:\n"); + fprintf(stderr," -q, --quiet suppress greeting and prompt\n"); + fprintf(stderr," --script run as shell script\n"); + fprintf(stderr," --program run rnrs program as shell script\n"); +#ifdef WIN32 +#define sep ";" +#else +#define sep ":" +#endif + fprintf(stderr," --libdirs %s... set library directories\n", sep); + fprintf(stderr," --libexts %s... set library extensions\n", sep); + fprintf(stderr," --compile-imported-libraries compile libraries before loading\n"); + fprintf(stderr," --import-notify enable import search messages\n"); + fprintf(stderr," --optimize-level <0 | 1 | 2 | 3> set optimize-level\n"); + fprintf(stderr," --debug-on-exception on uncaught exception, call debug\n"); + fprintf(stderr," --eedisable disable expression editor\n"); + fprintf(stderr," --eehistory expression-editor history file\n"); + fprintf(stderr," --enable-object-counts have collector maintain object counts\n"); + fprintf(stderr," --retain-static-relocation keep reloc info for compute-size, etc.\n"); + fprintf(stderr," -b , --boot load boot file\n"); +// fprintf(stderr," -c, --compact toggle compaction flag\n"); +// fprintf(stderr," -h , --heap load heap file\n"); +// fprintf(stderr," -s[] , --saveheap[] save heap file\n"); + fprintf(stderr," --verbose trace boot/heap search process\n"); + fprintf(stderr," --version print version and exit\n"); + fprintf(stderr," --help print help and exit\n"); + fprintf(stderr," -- pass through remaining args\n"); + exit(0); + } else if (strcmp(arg,"--verbose") == 0) { + Sset_verbose(1); + } else if (strcmp(arg,"--version") == 0) { + fprintf(stderr,"%s\n", VERSION); + exit(0); + } else { + argv[new_argc++] = arg; + } + } + } + + /* must call Sbuild_heap after registering boot and heap files. + * Sbuild_heap() completes the initialization of the Scheme system + * and loads the boot or heap files. If no boot or heap files have + * been registered, the first argument to Sbuild_heap must be a + * non-null path string; in this case, Sbuild_heap looks for + * a heap or boot file named .boot, where is the last + * component of the path. If no heap files are loaded and + * CUSTOM_INIT is non-null, Sbuild_heap calls CUSTOM_INIT just + * prior to loading the boot file(s). */ + Sbuild_heap(execpath, CUSTOM_INIT); + +#define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who))) +#define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg) +#ifdef FunCRepl + { + ptr p; + + for (;;) { + CALL1("display", Sstring("* ")); + p = CALL0("read"); + if (Seof_objectp(p)) break; + p = CALL1("eval", p); + if (p != Svoid) CALL1("pretty-print", p); + } + CALL0("newline"); + status = 0; + } +#else /* FunCRepl */ + if (quiet) { + CALL1("suppress-greeting", Strue); + CALL1("waiter-prompt-string", Sstring("")); + } + if (eoc) { + CALL1("enable-object-counts", Strue); + } + if (optlevel != 0) { + CALL1("optimize-level", Sinteger(optlevel)); + } + if (debug_on_exception != 0) { + CALL1("debug-on-exception", Strue); + } + if (import_notify != 0) { + CALL1("import-notify", Strue); + } + if (libdirs == 0) { + char *cslibdirs = GETENV("CHEZSCHEMELIBDIRS"); + if (cslibdirs != 0) { + CALL1("library-directories", Sstring_utf8(cslibdirs, -1)); + GETENV_FREE(cslibdirs); + } + } else { + CALL1("library-directories", Sstring_utf8(libdirs, -1)); + } + if (libexts == 0) { + char *cslibexts = GETENV("CHEZSCHEMELIBEXTS"); + if (cslibexts != 0) { + CALL1("library-extensions", Sstring_utf8(cslibexts, -1)); + GETENV_FREE(cslibexts); + } + } else { + CALL1("library-extensions", Sstring_utf8(libexts, -1)); + } + if (compile_imported_libraries != 0) { + CALL1("compile-imported-libraries", Strue); + } +#ifdef FEATURE_EXPEDITOR + /* Senable_expeditor must be called before Scheme_start/Scheme_script (if at all) */ + if (!quiet && expeditor_enable) Senable_expeditor(expeditor_history_file); +#endif /* FEATURE_EXPEDITOR */ + + if (scriptfile != (char *)0) + /* Sscheme_script invokes the value of the scheme-script parameter */ + status = Sscheme_script(scriptfile, new_argc, argv); + else if (programfile != (char *)0) + /* Sscheme_program invokes the value of the scheme-program parameter */ + status = Sscheme_program(programfile, new_argc, argv); + else { + /* Sscheme_start invokes the value of the scheme-start parameter */ + status = Sscheme_start(new_argc, argv); + } +#endif /* FunCRepl */ + +#ifdef SAVEDHEAPS + if (status == 0 && savefile != (char *)0) { + if (compact) Scompact_heap(); + Ssave_heap(savefile, savefile_level); + } +#endif /* SAVEDHEAPS */ + + /* must call Scheme_deinit after saving the heap and before exiting */ + Sscheme_deinit(); + + exit(status); +} diff --git a/c/new-io.c b/c/new-io.c new file mode 100644 index 0000000..cbd2799 --- /dev/null +++ b/c/new-io.c @@ -0,0 +1,970 @@ +/* new-io.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" +#include +#include +#include +#ifdef WIN32 +#include +#else /* WIN32 */ +#include +#include +#include +#endif /* WIN32 */ +#include +#include "zlib.h" +#include "lz4.h" +#include "lz4hc.h" + +/* !!! UNLESS you enjoy spending endless days tracking down race conditions + !!! involving the garbage collector, please note: DEACTIVATE and + !!! REACTIVATE or LOCKandDEACTIVATE and REACTIVATEandLOCK should be used + !!! around operations that can block. While deactivated, the process + !!! MUST NOT touch any unlocked Scheme objects (ptrs) or allocate any + !!! new Scheme objects. It helps to bracket only small pieces of code + !!! with DEACTIVATE/REACTIVATE or LOCKandDEACTIVATE/REACTIVATE_and_LOCK. */ +#ifdef PTHREADS +/* assume the scheme wrapper has us in a critical section */ +#define DEACTIVATE(tc) if (DISABLECOUNT(tc) == FIX(1)) { deactivate_thread(tc); } +#define REACTIVATE(tc) if (DISABLECOUNT(tc) == FIX(1)) { reactivate_thread(tc); } +#define LOCKandDEACTIVATE(tc,bv) if (DISABLECOUNT(tc) == FIX(1)) { Slock_object(bv); deactivate_thread(tc); } +#define REACTIVATEandUNLOCK(tc,bv) if (DISABLECOUNT(tc) == FIX(1)) { reactivate_thread(tc); Sunlock_object(bv); } +#else /* PTHREADS */ +#define DEACTIVATE(tc) +#define REACTIVATE(tc) +#define LOCKandDEACTIVATE(tc,bv) +#define REACTIVATEandUNLOCK(tc,bv) +#endif /* PTHREADS */ + +/* locally defined functions */ +static ptr new_open_output_fd_helper(const char *filename, INT mode, + INT flags, INT no_create, INT no_fail, INT no_truncate, + INT append, INT lock, INT replace, INT compressed); +static INT lockfile(INT fd); +static int is_valid_zlib_length(iptr count); +static int is_valid_lz4_length(iptr count); + +/* + not_ok_is_fatal: !ok definitely implies error, so ignore glzerror + ok: whether the result of body seems to be ok + flag: will be set when an error is detected and cleared if no error + fd: the glzFile object to call glzerror on + body: the operation we are checking the error on +*/ +#ifdef EINTR +/* like FD_EINTR_GUARD and GZ_EINTR_GUARD but ignores EINTR. + used for calls to close so we don't close a file descriptor that + might already have been reallocated by a different thread */ +#define FD_GUARD(ok,flag,body) \ + do { body; \ + flag = !(ok) && errno != EINTR; \ + } while (0) +#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \ + do { body; \ + if (ok) { flag = 0; } \ + else { \ + INT errnum; \ + S_glzerror((fd),&errnum); \ + S_glzclearerr((fd)); \ + if (errnum == Z_ERRNO) { \ + flag = errno != EINTR; \ + } else { \ + flag = not_ok_is_fatal || errnum != Z_OK; \ + errno = 0; \ + } \ + } \ + } while (0) +/* like FD_GUARD and GZ_GUARD but spins on EINTR */ +#define FD_EINTR_GUARD(ok,flag,body) \ + do { body; \ + if (ok) { flag = 0; break; } \ + else if (errno != EINTR) { flag = 1; break; } \ + } while (1) +#define GZ_EINTR_GUARD(not_ok_is_fatal,ok,flag,fd,body) \ + do { body; \ + if (ok) { flag = 0; break; } \ + else { \ + INT errnum; \ + S_glzerror((fd),&errnum); \ + S_glzclearerr((fd)); \ + if (errnum == Z_ERRNO) { \ + if (errno != EINTR) { flag = 1; break; } \ + } else { \ + flag = not_ok_is_fatal || errnum != Z_OK; \ + errno = 0; \ + break; \ + } \ + } \ + } while (1) +#else /* EINTR */ +#define FD_GUARD(ok,flag,body) do { body; flag = !(ok); } while (0) +#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \ + do { body; \ + if (ok) { flag = 0; } \ + else { \ + INT errnum; \ + S_glzerror((fd),&errnum); \ + S_glzclearerr((fd)); \ + if (errnum == Z_ERRNO) { flag = 1; } \ + else { \ + flag = not_ok_is_fatal || errnum != Z_OK; \ + errno = 0; \ + } \ + } \ + } while (0) +#define FD_EINTR_GUARD FD_GUARD +#define GZ_EINTR_GUARD GZ_GUARD +#endif /* EINTR */ + +#ifndef O_BINARY +#define O_BINARY 0 +#endif /* O_BINARY */ + + +/* These functions are intended for use immediately upon opening + * (lockfile) fd. They need to be redesigned for general-purpose + * locking. */ +#ifdef FLOCK +static INT lockfile(INT fd) { return FLOCK(fd, LOCK_EX); } +#endif +#ifdef LOCKF +static INT lockfile(INT fd) { return lockf(fd, F_LOCK, (off_t)0); } +#endif + +#define MAKE_GZXFILE(x) Sinteger((iptr)x) +#define GZXFILE_GZFILE(x) ((glzFile)Sinteger_value(x)) + +INT S_gzxfile_fd(ptr x) { + return GZXFILE_GZFILE(x)->fd; +} + +glzFile S_gzxfile_gzfile(ptr x) { + return GZXFILE_GZFILE(x); +} + +ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) { + char *filename; + INT saved_errno = 0; + INT fd, dupfd, error, result, ok, flag; + glzFile file; +#ifdef PTHREADS + ptr tc = get_thread_context(); +#endif + + filename = S_malloc_pathname(infilename); + + /* NB: don't use infilename, which might point into a Scheme string, after this point */ + DEACTIVATE(tc) + FD_EINTR_GUARD(fd>=0, error, fd=OPEN(filename,O_BINARY|O_RDONLY,0)); + saved_errno = errno; + REACTIVATE(tc) + + /* NB: don't use free'd filename after this point */ + free(filename); + + if (error) { + ptr str = S_strerror(saved_errno); + switch (saved_errno) { + case EACCES: + return Scons(FIX(OPEN_ERROR_PROTECTION), str); + case ENOENT: + return Scons(FIX(OPEN_ERROR_EXISTSNOT), str); + default: + return Scons(FIX(OPEN_ERROR_OTHER), str); + } + } + + if (!compressed) { + return MAKE_FD(fd); + } + + if ((dupfd = DUP(fd)) == -1) { + ptr str = S_strerror(errno); + FD_GUARD(result == 0, error, result = CLOSE(fd)); + return Scons(FIX(OPEN_ERROR_OTHER), str); + } + + DEACTIVATE(tc) /* glzdopen_input reads the magic word from the file */ + if ((file = S_glzdopen_input(dupfd)) == Z_NULL) { + REACTIVATE(tc) + FD_GUARD(result == 0, error, result = CLOSE(fd)); + FD_GUARD(result == 0, error, result = CLOSE(dupfd)); + return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)")); + } + + compressed = !S_glzdirect(file); + REACTIVATE(tc) + + if (compressed) { + FD_GUARD(result == 0, error, result = CLOSE(fd)); + /* box indicates compressed */ + return Sbox(MAKE_GZXFILE(file)); + } + + GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file)); + if (flag) {} /* make the compiler happy */ + if (LSEEK(fd, 0, SEEK_SET) != 0) { /* glzdopen and glzdirect might not leave fd at position 0 */ + FD_GUARD(result == 0, error, result = CLOSE(fd)); + return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes")); + } + return MAKE_FD(fd); +} + +ptr S_compress_input_fd(INT fd, I64 pos) { + INT dupfd, error, result, ok, flag; IBOOL compressed; + glzFile file; +#ifdef PTHREADS + ptr tc = get_thread_context(); +#endif + + if ((dupfd = DUP(fd)) == -1) { + return S_strerror(errno); + } + + DEACTIVATE(tc) + if ((file = S_glzdopen_input(dupfd)) == Z_NULL) { + REACTIVATE(tc) + FD_GUARD(result == 0, error, result = CLOSE(dupfd)); + return Sstring("unable to allocate compression state (too many open files?)"); + } + + compressed = !S_glzdirect(file); + REACTIVATE(tc) + + if (compressed) { + FD_GUARD(result == 0, error, result = CLOSE(fd)); + if (error) {} /* make the compiler happy */ + /* box indicates compressed */ + return Sbox(MAKE_GZXFILE(file)); + } + + GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file)); + if (flag) {} /* make the compiler happy */ + if (LSEEK(fd, pos, SEEK_SET) != pos) { /* glzdirect does not leave fd at same position */ + return Sstring("unable to reset after reading header bytes"); + } + return MAKE_FD(fd); +} + +ptr S_compress_output_fd(INT fd) { + glzFile file; + ptr tc = get_thread_context(); + + file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc))); + + if (file == Z_NULL) + return Sstring("unable to allocate compression state (too many open files?)"); + + /* box indicates compressed */ + return Sbox(MAKE_GZXFILE(file)); +} + +static ptr new_open_output_fd_helper( + const char *infilename, INT mode, INT flags, + IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, + IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { + char *filename; + INT saved_errno = 0; + iptr error; + INT fd, result; + ptr tc = get_thread_context(); + + flags |= + (no_create ? 0 : O_CREAT) | + ((no_fail || no_create) ? 0 : O_EXCL) | + (no_truncate ? 0 : O_TRUNC) | + ((!append) ? 0 : O_APPEND); + + filename = S_malloc_pathname(infilename); + + if (replace && UNLINK(filename) != 0 && errno != ENOENT) { + ptr str = S_strerror(errno); + switch (errno) { + case EACCES: + return Scons(FIX(OPEN_ERROR_PROTECTION), str); + default: + return Scons(FIX(OPEN_ERROR_OTHER), str); + } + } + + /* NB: don't use infilename, which might point into a Scheme string, after this point */ + DEACTIVATE(tc) + FD_EINTR_GUARD(fd >= 0, error, fd = OPEN(filename, flags, mode)); + saved_errno = errno; + REACTIVATE(tc) + + /* NB: don't use free'd filename after this point */ + free(filename); + + if (error) { + ptr str = S_strerror(saved_errno); + switch (saved_errno) { + case EACCES: + return Scons(FIX(OPEN_ERROR_PROTECTION), str); + case EEXIST: + return Scons(FIX(OPEN_ERROR_EXISTS), str); + case ENOENT: + return Scons(FIX(OPEN_ERROR_EXISTSNOT), str); + default: + return Scons(FIX(OPEN_ERROR_OTHER), str); + } + } + + if (lock) { + DEACTIVATE(tc) + error = lockfile(fd); + saved_errno = errno; + REACTIVATE(tc) + if (error) { + FD_GUARD(result == 0, error, result = CLOSE(fd)); + return Scons(FIX(OPEN_ERROR_OTHER), S_strerror(saved_errno)); + } + } + + if (!compressed) { + return MAKE_FD(fd); + } + + glzFile file; + file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc))); + if (file == Z_NULL) { + FD_GUARD(result == 0, error, result = CLOSE(fd)); + return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state")); + } + + return MAKE_GZXFILE(file); +} + +ptr S_new_open_output_fd( + const char *filename, INT mode, + IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, + IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { + return new_open_output_fd_helper( + filename, mode, O_BINARY | O_WRONLY, + no_create, no_fail, no_truncate, + append, lock, replace, compressed); +} + +ptr S_new_open_input_output_fd( + const char *filename, INT mode, + IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, + IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { + if (compressed) + return Sstring("compressed input/output files not supported"); + else + return new_open_output_fd_helper( + filename, mode, O_BINARY | O_RDWR, + no_create, no_fail, no_truncate, + append, lock, replace, 0); +} + +ptr S_close_fd(ptr file, IBOOL gzflag) { + INT saved_errno = 0; + INT ok, flag; + INT fd = gzflag ? 0 : GET_FD(file); + glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL; +#ifdef PTHREADS + ptr tc = get_thread_context(); +#endif + + /* refuse to close stdin, stdout, and stderr fds */ + if (!gzflag && fd <= 2) return Strue; + + /* file is not locked; do not reference after deactivating thread! */ + file = (ptr)-1; + + /* NOTE: close automatically releases locks so we don't to call unlock*/ + DEACTIVATE(tc) + if (!gzflag) { + FD_GUARD(ok == 0, flag, ok = CLOSE(fd)); + } else { + /* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */ + GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = S_glzclose(gzfile)); + } + saved_errno = errno; + REACTIVATE(tc) + + if (!flag) { + return Strue; + } + + if (gzflag && saved_errno == 0) { + return Sstring("compression failed"); + } + + return S_strerror(saved_errno); +} + +#define GZ_IO_SIZE_T unsigned int + +#ifdef WIN32 +#define IO_SIZE_T unsigned int +static HANDLE hStdin = NULL; +static iptr read_console(char* buf, unsigned size) { + static char u8buf[1024]; + static int u8i = 0; + static int u8n = 0; + iptr n = 0; + do { + for (; size > 0 && u8n > 0; size--, u8n--, n++) + *buf++ = u8buf[u8i++]; + if (n == 0 && size > 0) { + wchar_t wbuf[256]; + DWORD wn; + if (!ReadConsoleW(hStdin, wbuf, 256, &wn, NULL) || wn == 0) + return 0; + u8n = WideCharToMultiByte(CP_UTF8, 0, wbuf, wn, u8buf, 1024, NULL, NULL); + u8i = 0; + } + } while (n == 0); + return n; +} +#else /* WIN32 */ +#define IO_SIZE_T size_t +#endif /* WIN32 */ + +/* Returns string on error, #!eof on end-of-file and integer-count otherwise */ +ptr S_bytevector_read(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) { + INT saved_errno = 0; + ptr tc = get_thread_context(); + iptr m, flag = 0; + INT fd = gzflag ? 0 : GET_FD(file); + glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL; + + /* file is not locked; do not reference after deactivating thread! */ + file = (ptr)-1; + +#if (iptr_bits > 32) + if ((WIN32 || gzflag) && (unsigned int)count != count) count = 0xffffffff; +#endif + + LOCKandDEACTIVATE(tc, bv) +#ifdef CHECK_FOR_ROSETTA + /* If we are running on Apple Silicon under Rosetta 2 translation, work around + a bug (present in 11.2.3 at least) in its handling of memory page protection + bits. One of the tasks that Rosetta handles is to appropriately twiddle the + execute and write bits based on what's happening to the memory in order to + preserve the illusion that the pages have RWX permissions, whereas Apple + Silicon enforces a W^X (write XOR execute) model. For some reason, this + bit-twiddling sometimes fails when the bytevector passed to `read` extends + onto a page that's currently R-X, causing the `read` to fail with EFAULT + ("bad address"). By writing to each subsequent page, we force Rosetta to + do the right magic to the protection bits. (Or at least it makes the error + go away and all the mats pass.) + */ + if (is_rosetta) { + for (iptr idx = start+count; idx > start; idx -= S_pagesize) { + volatile octet b = BVIT(bv,idx); + BVIT(bv,idx) = b; + } + } +#endif + +#ifdef WIN32 + if (!gzflag && fd == 0 && hStdin != NULL) { + DWORD error_code; + SetConsoleCtrlHandler(NULL, TRUE); + SetLastError(0); + m = read_console(&BVIT(bv,start), (IO_SIZE_T)count); + error_code = GetLastError(); + if (m == 0 && error_code == 0x3e3) { + /* Guard against Windows calling the ConsoleCtrlHandler after we + * turn it back on by waiting a bit. */ + Sleep(1); +#ifdef PTHREADS + /* threaded io.ss doesn't handle interrupts because + * with-tc-mutex disables them, so bail out. */ + SetConsoleCtrlHandler(NULL, FALSE); + REACTIVATEandUNLOCK(tc, bv) + S_noncontinuable_interrupt(); +#else + KEYBOARDINTERRUPTPENDING(tc) = Strue; + SOMETHINGPENDING(tc) = Strue; +#endif + } + SetConsoleCtrlHandler(NULL, FALSE); + } else +#endif /* WIN32 */ + { + if (!gzflag) { + FD_EINTR_GUARD( + m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), flag, + m = READ(fd,&BVIT(bv,start),(IO_SIZE_T)count)); + } else { + GZ_EINTR_GUARD( + 1, m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), + flag, gzfile, + m = S_glzread(gzfile, &BVIT(bv,start), (GZ_IO_SIZE_T)count)); + } + } + saved_errno = errno; + REACTIVATEandUNLOCK(tc, bv) + + if (Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) { + return Sstring("interrupt"); + } + + if (!flag) { + return m == 0 ? Seof_object : FIX(m); + } + + if (saved_errno == EAGAIN) { + return FIX(0); + } + + return S_strerror(saved_errno); +} + +/* Returns: + string on error, including if not supported, + n when read, + 0 on non-blocking and + #!eof otherwise */ +ptr S_bytevector_read_nb(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) { +#ifdef WIN32 + HANDLE h; + + /* assume compressed files are always ready */ + if (gzflag) return FIX(1); + + if ((h = (HANDLE)_get_osfhandle(GET_FD(file))) != INVALID_HANDLE_VALUE) { + switch (GetFileType(h)) { + case FILE_TYPE_CHAR: + /* if h is hStdin, PeekConsoleInput can tell us if a key down event + is waiting, but if it's not a newline, we can't be sure that + a read will succeed. so PeekConsoleInput is basically useless + for our purposes. */ + break; + case FILE_TYPE_PIPE: { + DWORD bytes; + if (PeekNamedPipe(h, NULL, 0, NULL, &bytes, NULL) && bytes == 0) return FIX(0); + /* try the read on error or if bytes > 0 */ + return S_bytevector_read(file, bv, start, count, gzflag); + } + default: { + if (WaitForSingleObject(h, 0) == WAIT_TIMEOUT) return FIX(0); + /* try the read on error or if bytes > 0 */ + return S_bytevector_read(file, bv, start, count, gzflag); + } + } + } + + return Sstring("cannot determine ready status"); +#else /* WIN32 */ + INT fcntl_flags; + ptr result; + INT fd; + + /* assume compressed files are always ready */ + if (gzflag) return FIX(1); + + fd = GET_FD(file); + + /* set NOBLOCK for nonblocking read */ + fcntl_flags = fcntl(fd, F_GETFL, 0); + if (!(fcntl_flags & NOBLOCK)) (void) fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK); + + result = S_bytevector_read(file, bv, start, count, gzflag); + + /* reset NOBLOCK for normal blocking read */ + if (!(fcntl_flags & NOBLOCK)) (void) fcntl(fd, F_SETFL, fcntl_flags); + + return result; +#endif /* WIN32 */ +} + +ptr S_bytevector_write(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) { + iptr i, s, c; + ptr tc = get_thread_context(); + INT flag = 0, saved_errno = 0; + INT fd = gzflag ? 0 : GET_FD(file); + glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL; + + for (s = start, c = count; c > 0; s += i, c -= i) { + iptr cx = c; + +#if (iptr_bits > 32) + if ((WIN32 || gzflag) && (unsigned int)cx != cx) cx = 0xffffffff; +#endif + + /* if we could know that fd is nonblocking, we wouldn't need to deactivate. + we could test ioctl, but some other thread could change it before we actually + get around to writing. */ + LOCKandDEACTIVATE(tc, bv) + if (gzflag) { + /* strangely, gzwrite returns 0 on error */ + GZ_EINTR_GUARD( + i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), + flag, gzfile, + i = S_glzwrite(gzfile, &BVIT(bv,s), (GZ_IO_SIZE_T)cx)); + } else { + FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), + flag, i = WRITE(fd, &BVIT(bv,s), (IO_SIZE_T)cx)); + } + saved_errno = errno; + REACTIVATEandUNLOCK(tc, bv) + + if (flag) { + if (saved_errno == EAGAIN) { flag = 0; } + break; + } + + /* we escape from loop if keyboard interrupt is pending, but this won't + do much good until we fix up the interrupt protocol to guarantee + that the interrupt handler is actually called */ + if (Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) { + if (i >= 0) s += i; + break; + } + } + + if (!flag) { + return FIX(s - start); + } + + if (saved_errno == EAGAIN) { + return FIX(0); + } + + if (gzflag && saved_errno == 0) { + return Sstring("compression failed"); + } + + return S_strerror(saved_errno); +} + +/* S_put_byte is a simplified version of S_bytevector_write for writing one + byte on unbuffered ports */ +ptr S_put_byte(ptr file, INT byte, IBOOL gzflag) { + iptr i; + ptr tc = get_thread_context(); + INT flag = 0, saved_errno = 0; + INT fd = gzflag ? 0 : GET_FD(file); + glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL; + octet buf[1]; + + buf[0] = (octet)byte; + + DEACTIVATE(tc) + if (gzflag) { + /* strangely, gzwrite returns 0 on error */ + GZ_EINTR_GUARD( + i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), + flag, gzfile, + i = S_glzwrite(gzfile, buf, 1)); + } else { + FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), + flag, i = WRITE(fd, buf, 1)); + } + saved_errno = errno; + REACTIVATE(tc) + + if (flag) { + if (saved_errno == EAGAIN) { flag = 0; } + } + + if (!flag) { + return FIX(i); + } + + if (saved_errno == EAGAIN) { + return FIX(0); + } + + if (gzflag && saved_errno == 0) { + return Sstring("compression failed"); + } + + return S_strerror(saved_errno); +} + +ptr S_get_fd_pos(ptr file, IBOOL gzflag) { + errno = 0; + if (gzflag) { + z_off_t offset = S_glzseek(GZXFILE_GZFILE(file), 0, SEEK_CUR); + if (offset != -1) return Sinteger64(offset); + } else { + OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR); + if (offset != -1) return Sinteger64(offset); + } + if (gzflag && errno == 0) return Sstring("compression failed"); + return S_strerror(errno); +} + +/* assume wrapper ensures 0 <= pos <= 2^63-1 */ +ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag) { + I64 offset64 = S_int64_value("set-file-position", pos); + + if (gzflag) { + z_off_t offset = (z_off_t)offset64; + if (sizeof(z_off_t) != sizeof(I64)) + if (offset != offset64) return Sstring("invalid position"); + errno = 0; + if (S_glzseek(GZXFILE_GZFILE(file),offset,SEEK_SET) == offset) return Strue; + if (errno == 0) return Sstring("compression failed"); + return S_strerror(errno); + } else { + OFF_T offset = (OFF_T)offset64; + if (sizeof(OFF_T) != sizeof(I64)) + if (offset != offset64) return Sstring("invalid position"); + if (LSEEK(GET_FD(file), offset, SEEK_SET) == offset) return Strue; + return S_strerror(errno); + } +} + +ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag) { +#ifdef WIN32 + return Sfalse; +#else /* WIN32 */ + INT fcntl_flags; + + if (gzflag) return Sfalse; + + fcntl_flags = fcntl(GET_FD(file), F_GETFL, 0); + + if (fcntl_flags == -1) { + return S_strerror(errno); + } + + return Sboolean(NOBLOCK & fcntl_flags); +#endif /* WIN32 */ +} + +ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag) { +#ifdef WIN32 + return Sstring("unsupported"); +#else /* WIN32 */ + iptr fd; + INT fcntl_flags; + + if (gzflag) { + if (x) return Sstring("Compressed non-blocking ports not supported"); + else return Strue; + } + + fd = GET_FD(file); + fcntl_flags = fcntl(fd, F_GETFL, 0); + + if (fcntl_flags == -1) { + return S_strerror(errno); + } + + if (x) { + if (fcntl_flags & NOBLOCK) { + return Strue; + } + if (0 == fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK)) { + return Strue; + } + return S_strerror(errno); + } else { + if (!(fcntl_flags & NOBLOCK)) { + return Strue; + } + if (0 == fcntl(fd, F_SETFL, fcntl_flags & ~NOBLOCK)) { + return Strue; + } + return S_strerror(errno); + } +#endif /* WIN32 */ +} + +ptr S_get_fd_length(ptr file, IBOOL gzflag) { + struct STATBUF statbuf; + + if (gzflag) return Sstring("Not supported on compressed files"); + + if (FSTAT(GET_FD(file), &statbuf) == 0) { + return Sinteger64(statbuf.st_size); + } + + return S_strerror(errno); +} + +ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag) { + INT fd, ok, flag = 0; + I64 len64; off_t len; +#ifdef PTHREADS + ptr tc = get_thread_context(); +#endif + + if (gzflag) return Sstring("Not supported on compressed files"); + + len64 = S_int64_value("set-file-length", length); + len = (off_t)len64; + if (sizeof(off_t) != sizeof(I64)) + if (len != len64) return Sstring("invalid length"); + + fd = GET_FD(file); + DEACTIVATE(tc) + FD_EINTR_GUARD(ok == 0, flag, ok = ftruncate(fd, len)); + REACTIVATE(tc) + + return flag ? S_strerror(errno) : Strue; +} + +void S_new_io_init(void) { + if (S_boot_time) { + S_set_symbol_value(S_intern((const unsigned char *)"$c-bufsiz"), Sinteger(SBUFSIZ)); + } +#ifdef WIN32 + { /* Get the console input handle for reading Unicode characters */ + HANDLE h; + DWORD mode; + if ((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE + && GetConsoleMode(h, &mode)) + hStdin = h; + } + /* transcoder, if any, does its own cr, lf translations */ + _setmode(_fileno(stdin), O_BINARY); + _setmode(_fileno(stdout), O_BINARY); + _setmode(_fileno(stderr), O_BINARY); + /* Set the console output to handle UTF-8 */ + SetConsoleOutputCP(CP_UTF8); +#endif /* WIN32 */ +} + +static int is_valid_zlib_length(iptr count) { + /* A zlib `uLong` may be the same as `unsigned long`, + which is not as big as `iptr` on 64-bit Windows. */ + return count == (iptr)(uLong)count; +} + +static int is_valid_lz4_length(iptr len) { + return (len <= LZ4_MAX_INPUT_SIZE); +} + +/* Accept `iptr` because we expect it to represent a bytevector size, + which always fits in `iptr`. Return `uptr`, because the result might + not fit in `iptr`. */ +uptr S_bytevector_compress_size(iptr s_count, INT compress_format) { + switch (compress_format) { + case COMPRESS_GZIP: + if (is_valid_zlib_length(s_count)) + return compressBound((uLong)s_count); + else { + /* Compression will report "source too long" */ + return 0; + } + case COMPRESS_LZ4: + if (is_valid_lz4_length(s_count)) + return LZ4_compressBound((uLong)s_count); + else { + /* Compression will report "source too long" */ + return 0; + } + default: + S_error1("S_bytevector_compress_size", "unexpected compress format ~s", FIX(compress_format)); + return 0; + } +} + +ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count, + ptr src_bv, iptr s_start, iptr s_count, + INT compress_format) { + ptr tc = get_thread_context(); + int compress_level = (INT)UNFIX(COMPRESSLEVEL(tc)); + + /* On error, an message-template string with ~s for the bytevector */ + switch (compress_format) { + case COMPRESS_GZIP: + { + int r; + uLong destLen; + + if (!is_valid_zlib_length(s_count)) + return Sstring("source bytevector ~s is too large"); + + destLen = (uLong)d_count; + + r = compress2(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count, S_zlib_compress_level(compress_level)); + + if (r == Z_OK) + return FIX(destLen); + else if (r == Z_BUF_ERROR) + return Sstring("destination bytevector is too small for compressed form of ~s"); + else + return Sstring("internal error compressing ~s"); + } + case COMPRESS_LZ4: + { + int destLen; + + if (!is_valid_lz4_length(s_count)) + return Sstring("source bytevector ~s is too large"); + + if (compress_level == COMPRESS_MIN) { + destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count); + } else { + destLen = LZ4_compress_HC((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count, S_lz4_compress_level(compress_level)); + } + + if (destLen > 0) + return Sfixnum(destLen); + else + return Sstring("compression failed for ~s"); + } + default: + S_error1("S_bytevector_compress", "unexpected compress format ~s", FIX(compress_format)); + return Sfalse; + } +} + +ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count, + ptr src_bv, iptr s_start, iptr s_count, + INT compress_format) { + /* On error, an message-template string with ~s for the bytevector */ + switch (compress_format) { + case COMPRESS_GZIP: + { + int r; + uLongf destLen; + + if (!is_valid_zlib_length(d_count)) + return Sstring("expected result size of uncompressed source ~s is too large"); + + destLen = (uLongf)d_count; + + r = uncompress(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count); + + if (r == Z_OK) + return FIX(destLen); + else if (r == Z_BUF_ERROR) + return Sstring("uncompressed ~s is larger than expected size"); + else if (r == Z_DATA_ERROR) + return Sstring("invalid data in source bytevector ~s"); + else + return Sstring("internal error uncompressing ~s"); + } + case COMPRESS_LZ4: + { + int r; + + if (!is_valid_lz4_length(d_count)) + return Sstring("expected result size of uncompressed source ~s is too large"); + + r = LZ4_decompress_safe((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count); + + if (r >= 0) + return Sfixnum(r); + else + return Sstring("internal error uncompressing ~s"); + } + default: + return Sstring("unexpected compress format ~s"); + } +} diff --git a/c/nocurses.h b/c/nocurses.h new file mode 100644 index 0000000..4b17450 --- /dev/null +++ b/c/nocurses.h @@ -0,0 +1,24 @@ +#ifndef ERR +# define ERR -1 +#endif + +#define setupterm(a, b, e) (*(e) = 0, ERR) +#define tputs(c, x, f) (f(c)) + +#define lines 0 +#define columns 0 + +#define cursor_left 0 +#define cursor_right 0 +#define cursor_up 0 +#define cursor_down 0 +#define enter_am_mode 0 +#define exit_am_mode 0 +#define clr_eos 0 +#define clr_eol 0 +#define clear_screen 0 +#define carriage_return 0 +#define bell 0 +#define scroll_reverse 0 +#define auto_right_margin 0 +#define eat_newline_glitch 0 diff --git a/c/number.c b/c/number.c new file mode 100644 index 0000000..105e94c --- /dev/null +++ b/c/number.c @@ -0,0 +1,2120 @@ +/* number.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* +*** + * assumptions: + * bigits are unsigned + * uptr is either one or two bigits wide +*** +*/ + +#include "system.h" + +/* locally defined functions */ +static ptr copy_normalize(ptr tc, const bigit *p, iptr len, IBOOL sign); +static IBOOL abs_big_lt(ptr x, ptr y, iptr xl, iptr yl); +static IBOOL abs_big_eq(ptr x, ptr y, iptr xl, iptr yl); +static ptr big_negate(ptr tc, ptr x); +static ptr big_add_pos(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign); +static ptr big_add_neg(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign); +static ptr big_add(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys); +static ptr big_mul(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign); +static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs, ptr *q, ptr *r); +static void big_trunc(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL qs, IBOOL rs, ptr *q, ptr *r); +static INT normalize(bigit *xp, bigit *yp, iptr xl, iptr yl); +static bigit quotient_digit(bigit *xp, bigit *yp, iptr yl); +static bigit qhat(bigit *xp, bigit *yp); +static ptr big_short_gcd(ptr tc, ptr x, bigit y, iptr xl); +static ptr big_gcd(ptr tc, ptr x, ptr y, iptr xl, iptr yl); +static ptr s_big_ash(ptr tc, bigit *xp, iptr xl, IBOOL sign, iptr cnt); +static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign); +static double big_floatify(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign); +static double floatify_normalize(bigit *p, iptr e, IBOOL sign, IBOOL sticky); +static double floatify_ratnum(ptr tc, ptr x); +static ptr big_logbitp(iptr n, ptr x, iptr xl, IBOOL xs); +static ptr big_logbit0(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs); +static ptr big_logbit1(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs); +static ptr big_logtest(ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys); +static ptr big_logand(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys); +static ptr big_logor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys); +static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys); + +/* use w/o trailing semicolon */ +#define PREPARE_BIGNUM(tc,x,l)\ + {if (x == FIX(0) || BIGLEN(x) < (l)) x = S_bignum(tc, (l)*2, 0);} + +#define bigit_mask (~(bigit)0) + +#define IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\ + ibigit _i_ = x;\ + PREPARE_BIGNUM(tc, B, 1)\ + *cnt = 1;\ + BIGIT(B,0) = (*sign = (_i_ < 0)) ? -_i_ : _i_;\ +} + +#define UBIGIT_TO_BIGNUM(tc,B,u,cnt) {\ + PREPARE_BIGNUM(tc, B, 1)\ + *cnt = 1;\ + BIGIT(B,0) = u;\ +} + +#define IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\ + ibigitbigit _i_ = x; bigitbigit _u_; bigit _b_;\ + PREPARE_BIGNUM(tc, B, 2)\ + _u_ = (*sign = (_i_ < 0)) ? -_i_ : _i_;\ + if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\ + *cnt = 1;\ + BIGIT(B,0) = (bigit)_u_;\ + } else {\ + *cnt = 2;\ + BIGIT(B,0) = (bigit)(_u_ >> bigit_bits);\ + BIGIT(B,1) = _b_;\ + }\ +} + +#define UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) {\ + bigitbigit _u_ = x; bigit _b_;\ + PREPARE_BIGNUM(tc, B, 2)\ + if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\ + *cnt = 1;\ + BIGIT(B,0) = (bigit)_u_;\ + } else {\ + *cnt = 2;\ + BIGIT(B,0) = (bigit)(_u_ >> bigit_bits);\ + BIGIT(B,1) = _b_;\ + }\ +} + +#define U32_bigits (32 / bigit_bits) + +#if (U32_bigits == 1) +#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) +#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt) +#endif + +#if (U32_bigits == 2) +#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) +#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) +#endif + +#define U64_bigits (64 / bigit_bits) + +#if (U64_bigits == 2) +#define I64_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) +#define U64_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) +#endif + +#if (U64_bigits == 4) +see v7.4 number.c for U64_TO_BIGNUM w/U64_bigits == 4 +#endif + +#define ptr_bigits (ptr_bits / bigit_bits) + +#if (ptr_bigits == 1) +#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) +#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt) +#endif + +#if (ptr_bigits == 2) +#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) +#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) +#endif + +#define FIXNUM_TO_BIGNUM(tc,B,p,cnt,sign) IPTR_TO_BIGNUM(tc,B,UNFIX(p),cnt,sign) + +ptr S_normalize_bignum(ptr x) { + uptr n = BIGIT(x, 0); iptr len = BIGLEN(x); IBOOL sign = BIGSIGN(x); + +#if (ptr_bigits == 1) + if (len == 1) { + if (sign) { + if (n <= -most_negative_fixnum) return FIX(-(iptr)n); + } else { + if (n <= most_positive_fixnum) return FIX(n); + } + } +#elif (ptr_bigits == 2) + if (len == 1) + return sign ? FIX(-(iptr)n) : FIX(n); + else if (len == 2) { + n = (n << bigit_bits) | BIGIT(x, 1); + if (sign) { + /* avoid -most-negative-fixnum to avoid bogus Sun compiler warning */ + if (n <= most_positive_fixnum+1) return FIX(-(iptr)n); + } else { + if (n <= most_positive_fixnum) return FIX(n); + } + } +#endif + + return x; +} + +static ptr copy_normalize(ptr tc, const bigit *p, iptr len, IBOOL sign) { + bigit *p1; uptr n; ptr b; + + for (;;) { + if ((n = *p) != 0) + break; + else if (--len == 0) + return FIX(0); + else p++; + } + +#if (ptr_bigits == 1) + if (len == 1) { + if (sign) { + if (n <= -most_negative_fixnum) return FIX(-(iptr)n); + } else { + if (n <= most_positive_fixnum) return FIX(n); + } + } +#elif (ptr_bigits == 2) + if (len == 1) + return sign ? FIX(-(iptr)n) : FIX(n); + else if (len == 2) { + n = (n << bigit_bits) | *(p+1); + if (sign) { + /* avoid -most-negative-fixnum to avoid bogus Sun compiler warning */ + if (n <= most_positive_fixnum+1) return FIX(-(iptr)n); + } else { + if (n <= most_positive_fixnum) return FIX(n); + } + } +#endif + + b = S_bignum(tc, len, sign); + for (p1 = &BIGIT(b, 0); len--;) *p1++ = *p++; + return b; +} + +/* -2^(b-1) <= x <= 2^b-1, where b = number of bits in a uptr */ +iptr S_integer_value(const char *who, ptr x) { + if (Sfixnump(x)) return UNFIX(x); + + if (Sbignump(x)) { + iptr xl; uptr u; + + if ((xl = BIGLEN(x)) > ptr_bigits) S_error1(who, "~s is out of range", x); + + u = BIGIT(x,0); + +#if (ptr_bigits == 2) + if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); +#endif + + if (!BIGSIGN(x)) return (iptr)u; + if (u < ((uptr)1 << (ptr_bits - 1))) return -(iptr)u; + if (u > ((uptr)1 << (ptr_bits - 1))) S_error1(who, "~s is out of range", x); +#if (fixnum_bits > 32) + return (iptr)0x8000000000000000; +#else + return (iptr)0x80000000; +#endif + } + + S_error1(who, "~s is not an integer", x); + + return 0 /* not reached */; +} + +/* -2^(b-1) <= x <= 2^b-1, where b = number of bits in a uptr */ +IBOOL S_integer_valuep(ptr x) { + if (Sfixnump(x)) return 1; + + if (Sbignump(x)) { + iptr xl; uptr u; + + if ((xl = BIGLEN(x)) > ptr_bigits) return 0; + + u = BIGIT(x,0); + +#if (ptr_bigits == 2) + if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); +#endif + + if (!BIGSIGN(x)) return 1; + return u <= ((uptr)1 << (ptr_bits - 1)); + } + + return 0; +} + +iptr Sinteger_value(ptr x) { + return S_integer_value("Sinteger_value", x); +} + +/* -2^31 <= x <= 2^32-1 */ +I32 S_int32_value(char *who, ptr x) { +#if (fixnum_bits > 32) + if (Sfixnump(x)) { + iptr n = UNFIX(x); + if (n < 0) { + I32 m = (I32)n; + if ((iptr)m == UNFIX(x)) return m; + } else { + U32 m = (U32)n; + if ((uptr)m == (uptr)UNFIX(x)) return (I32)m; + } + S_error1(who, "~s is out of range", x); + } + if (Sbignump(x)) S_error1(who, "~s is out of range", x); +#else /* (fixnum_bits > 32) */ + if (Sfixnump(x)) return UNFIX(x); + + if (Sbignump(x)) { + iptr xl; U32 u; + + if ((xl = BIGLEN(x)) > U32_bigits) S_error1(who, "~s is out of range", x); + + u = BIGIT(x,0); + +#if (U32_bigits == 2) + if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); +#endif + + if (!BIGSIGN(x)) return (I32)u; + if (u < ((U32)1 << 31)) return -(I32)u; + if (u > ((U32)1 << 31)) S_error1(who, "~s is out of range", x); + return (I32)0x80000000; + } +#endif /* (fixnum_bits > 32) */ + + S_error1(who, "~s is not an integer", x); + + return 0 /* not reached */; +} + +I32 Sinteger32_value(ptr x) { + return S_int32_value("Sinteger32_value", x); +} + +/* -2^63 <= x <= 2^64-1 */ +I64 S_int64_value(char *who, ptr x) { + if (Sfixnump(x)) return UNFIX(x); + + if (Sbignump(x)) { + iptr xl; U64 u; + + if ((xl = BIGLEN(x)) > U64_bigits) S_error1(who, "~s is out of range", x); + + u = BIGIT(x,0); + +#if (U64_bigits == 2) + if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); +#endif + + if (!BIGSIGN(x)) return (I64)u; + if (u < ((U64)1 << 63)) return -(I64)u; + if (u > ((U64)1 << 63)) S_error1(who, "~s is out of range", x); + return (I64)0x8000000000000000; + } + + S_error1(who, "~s is not an integer", x); + + return 0 /* not reached */; +} + +I64 Sinteger64_value(ptr x) { + return S_int64_value("Sinteger64_value", x); +} + +ptr Sunsigned(uptr u) { /* convert arg to Scheme integer */ + if (u <= most_positive_fixnum) + return FIX(u); + else { + ptr x = FIX(0); iptr xl; + UPTR_TO_BIGNUM(get_thread_context(), x, u, &xl) + SETBIGLENANDSIGN(x, xl, 0); + return x; + } +} + +ptr Sinteger(iptr i) { /* convert arg to Scheme integer */ + if (FIXRANGE(i)) + return FIX(i); + else { + ptr x = FIX(0); iptr xl; IBOOL xs; + IPTR_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs) + SETBIGLENANDSIGN(x, xl, xs); + return x; + } +} + +ptr Sunsigned32(U32 u) { /* convert arg to Scheme integer */ +#if (fixnum_bits > 32) + return FIX((uptr)u); +#else + if (u <= most_positive_fixnum) + return FIX((uptr)u); + else { + ptr x = FIX(0); iptr xl; + U32_TO_BIGNUM(get_thread_context(), x, u, &xl) + SETBIGLENANDSIGN(x, xl, 0); + return x; + } +#endif +} + +ptr Sinteger32(I32 i) { /* convert arg to Scheme integer */ +#if (fixnum_bits > 32) + return FIX((iptr)i); +#else + if (i > most_negative_fixnum && i <= most_positive_fixnum) + return FIX((iptr)i); + else { + ptr x = FIX(0); iptr xl; IBOOL xs; + I32_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs) + SETBIGLENANDSIGN(x, xl, xs); + return x; + } +#endif +} + +ptr Sunsigned64(U64 u) { /* convert arg to Scheme integer */ + if (u <= most_positive_fixnum) + return FIX((uptr)u); + else { + ptr x = FIX(0); iptr xl; + U64_TO_BIGNUM(get_thread_context(), x, u, &xl) + SETBIGLENANDSIGN(x, xl, 0); + return x; + } +} + +ptr Sinteger64(I64 i) { /* convert arg to Scheme integer */ + if (i > most_negative_fixnum && i <= most_positive_fixnum) + return FIX((iptr)i); + else { + ptr x = FIX(0); iptr xl; IBOOL xs; + I64_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs) + SETBIGLENANDSIGN(x, xl, xs); + return x; + } +} + +/* extended arithmetic macros: use w/o trailing semicolon */ +#define ELSH(n,x,k) { /* undefined when n == 0 */\ + INT _n_ = (INT)(n); bigit _b_ = *(x), _newk_ = _b_>>(bigit_bits-_n_);\ + *(x) = _b_<<_n_ | *(k);\ + *(k) = _newk_;} + +#define ERSH(n,x,k) { /* undefined when n == 0 */\ + INT _n_ = (INT)(n); bigit _b_ = *(x), _newk_ = _b_<<(bigit_bits-_n_);\ + *(x) = _b_>>_n_ | *(k);\ + *(k) = _newk_;} + +#define ERSH2(n,x,y,k) { /* undefined when n == 0 */\ + INT _n_ = (INT)(n); bigit _b_ = (x), _newk_ = _b_<<(bigit_bits-_n_);\ + *(y) = _b_>>_n_ | *(k);\ + *(k) = _newk_;} + +#define EADDC(a1, a2, sum, k) {\ + bigit _tmp1_, _tmp2_, _tmpk_;\ + _tmp1_ = (a1);\ + _tmp2_ = _tmp1_ + (a2);\ + _tmpk_ = _tmp2_ < _tmp1_;\ + _tmp1_ = _tmp2_ + *(k);\ + *k = _tmpk_ + (_tmp1_ < _tmp2_);\ + *sum = _tmp1_;} + +#define ESUBC(s1, s2, diff, b) {\ + bigit _tmp1_, _tmp2_, tmpb;\ + _tmp1_ = (s1);\ + _tmp2_ = _tmp1_ - (s2);\ + tmpb = _tmp2_ > _tmp1_;\ + _tmp1_ = _tmp2_ - *(b);\ + *b = tmpb + (_tmp1_ > _tmp2_);\ + *diff = _tmp1_;} + +/* bigit x bigit -> bigitbigit */ +#define EMUL(m1,m2,a1,low,high) {\ + bigitbigit _tmp_;\ + _tmp_ = (bigitbigit)m1 * m2 + a1;\ + *low = (bigit)(_tmp_ & (bigitbigit)bigit_mask);\ + *high = (bigit)(_tmp_ >> bigit_bits);} + +/* bigitbigit / bigit -> bigit */ +#define EDIV(high,low,divr,quo,rem) {\ + bigit _tmpr_; bigitbigit _tmp_;\ + _tmp_ = ((bigitbigit)high << bigit_bits) | low;\ + _tmpr_ = divr;\ + *quo = (bigit)(_tmp_ / _tmpr_);\ + *rem = (bigit)(_tmp_ % _tmpr_);} + +/* +*** +comparison +*** +*/ + +IBOOL S_big_lt(ptr x, ptr y) { + if (BIGSIGN(x)) + if (BIGSIGN(y)) + return abs_big_lt(y, x, BIGLEN(y), BIGLEN(x)); /* both negative */ + else + return 1; /* x negative, y positive */ + else + if (BIGSIGN(y)) + return 0; /* x positive, y negative */ + else + return abs_big_lt(x, y, BIGLEN(x), BIGLEN(y)); /* both positive */ +} + +IBOOL S_big_eq(ptr x, ptr y) { + return (BIGSIGN(x) == BIGSIGN(y)) && abs_big_eq(x, y, BIGLEN(x), BIGLEN(y)); +} + +static IBOOL abs_big_lt(ptr x, ptr y, iptr xl, iptr yl) { + if (xl != yl) + return xl < yl; + else { + bigit *xp, *yp; + + for (xp = &BIGIT(x,0), yp = &BIGIT(y,0); xl-- > 0; xp++, yp++) + if (*xp != *yp) return (*xp < *yp); + + return 0; + } +} + +static IBOOL abs_big_eq(ptr x, ptr y, iptr xl, iptr yl) { + if (xl != yl) + return 0; + else { + bigit *xp, *yp; + + for (xp = &BIGIT(x,0), yp = &BIGIT(y,0); xl-- > 0; xp++, yp++) + if (*xp != *yp) return 0; + + return 1; + } +} + +/* +*** +addition/subtraction +*** +*/ + +static ptr big_negate(ptr tc, ptr x) { + return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x)); +} + +ptr S_big_negate(ptr x) { + return big_negate(get_thread_context(), x); +} + +/* assumptions: BIGLEN(x) >= BIGLEN(y) */ +static ptr big_add_pos(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) { + iptr i; + bigit *xp, *yp, *zp; + bigit k = 0; + + PREPARE_BIGNUM(tc, W(tc),xl+1) + + xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl); + + for (i = yl; i-- > 0; ) + EADDC(*xp--, *yp--, zp--, &k) + for (i = xl - yl; k != 0 && i-- > 0; ) + EADDC(*xp--, 0, zp--, &k) + for (; i-- > 0; ) + *zp-- = *xp--; + + *zp = k; + + return copy_normalize(tc, zp,xl+1,sign); +} + +/* assumptions: x >= y */ +static ptr big_add_neg(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) { + iptr i; + bigit *xp, *yp, *zp; + bigit b = 0; + + PREPARE_BIGNUM(tc, W(tc),xl) + + xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl-1); + + for (i = yl; i-- > 0; ) + ESUBC(*xp--, *yp--, zp--, &b) + for (i = xl-yl; b != 0 && i-- > 0; ) + ESUBC(*xp--, 0, zp--, &b) + for (; i-- > 0; ) + *zp-- = *xp--; + + return copy_normalize(tc, zp+1,xl,sign); +} + +static ptr big_add(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) { + if (xs == ys) + if (xl < yl) + return big_add_pos(tc, y, x, yl, xl, xs); + else + return big_add_pos(tc, x, y, xl, yl, xs); + else + if (abs_big_lt(x, y, xl, yl)) + return big_add_neg(tc, y, x, yl, xl, ys); + else + return big_add_neg(tc, x, y, xl, yl, xs); +} + +/* arguments must be integers, fixnums or bignums */ +ptr S_add(ptr x, ptr y) { + ptr tc = get_thread_context(); + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + iptr n = UNFIX(x) + UNFIX(y); + return FIXRANGE(n) ? FIX(n) : Sinteger(n); + } else { + iptr xl; IBOOL xs; + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, BIGSIGN(y)); + } + } else { + if (Sfixnump(y)) { + iptr yl; IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys); + } else { + return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y)); + } + } +} + +/* arguments must be integers, fixnums or bignums */ +ptr S_sub(ptr x, ptr y) { + ptr tc = get_thread_context(); + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + iptr n = UNFIX(x) - UNFIX(y); + return FIXRANGE(n) ? FIX(n) : Sinteger(n); + } else { + iptr xl; IBOOL xs; + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, !BIGSIGN(y)); + } + } else { + if (Sfixnump(y)) { + iptr yl; IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), !ys); + } else { + return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), !BIGSIGN(y)); + } + } +} + +/* +*** +multiplication +*** +*/ + +static ptr big_mul(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) { + iptr xi, yi; + bigit *xp, *yp, *zp, *zpa; + bigit k, k1, prod; + + PREPARE_BIGNUM(tc, W(tc),xl+yl) + for (xi = xl, zp = &BIGIT(W(tc),xl+yl-1); xi-- > 0; ) *zp-- = 0; + + for (yi=yl,yp= &BIGIT(y,yl-1),zp= &BIGIT(W(tc),xl+yl-1); yi-- > 0; yp--, zp--) + if (*yp == 0) + *(zp-xl) = 0; + else { + for (xi=xl,k=0,zpa=zp,xp= &BIGIT(x,xl-1); xi-- > 0; xp--,zpa--) { + EMUL(*xp, *yp, *zpa, &prod, &k1) + EADDC(prod, 0, zpa, &k) + k += k1; + } + *zpa = k; + } + + return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign); +} + +/* SHORTRANGE is -floor(sqrt(most_positive_fixnum))..floor(sqrt(most_positive_fixnum)). + We don't use sqrt because it rounds up for fixnum_bits = 61 */ +#if (fixnum_bits == 30) +#define SHORTRANGE(x) (-23170 <= (x) && (x) <= 23170) +#elif (fixnum_bits == 61) +#define SHORTRANGE(x) (-0x3FFFFFFF <= (x) && (x) <= 0x3FFFFFFF) +#endif + +ptr S_mul(ptr x, ptr y) { + ptr tc = get_thread_context(); + + iptr xl, yl; IBOOL xs, ys; + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + iptr xn = UNFIX(x); + iptr yn = UNFIX(y); + if (SHORTRANGE(xn) && SHORTRANGE(yn)) + return FIX(xn * yn); + else { + FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc); + FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc); + } + } else { + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) x = X(tc); + yl = BIGLEN(y); ys = BIGSIGN(y); + } + } else { + if (Sfixnump(y)) { + xl = BIGLEN(x); xs = BIGSIGN(x); + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) y = Y(tc); + } else { + xl = BIGLEN(x); xs = BIGSIGN(x); + yl = BIGLEN(y); ys = BIGSIGN(y); + } + } + return big_mul(tc, x, y, xl, yl, xs ^ ys); +} + +/* +*** +division +*** +*/ + +/* arguments must be integers (fixnums or bignums), y must be nonzero */ +ptr S_div(ptr x, ptr y) { + ptr g, n, d; + ptr tc = get_thread_context(); + + g = S_gcd(x,y); + if (Sfixnump(y) ? UNFIX(y) < 0 : BIGSIGN(y)) { + g = Sfixnump(g) ? Sinteger(-UNFIX(g)) : big_negate(tc, g); + } + + S_trunc_rem(tc, x, g, &n, (ptr *)NULL); + S_trunc_rem(tc, y, g, &d, (ptr *)NULL); + + return S_rational(n, d); +} + +ptr S_trunc(ptr x, ptr y) { + ptr q; + S_trunc_rem(get_thread_context(), x, y, &q, (ptr *)NULL); + return q; +} + +ptr S_rem(ptr x, ptr y) { + ptr r; + S_trunc_rem(get_thread_context(), x, y, (ptr *)NULL, &r); + return r; +} + +/* arguments must be integers (fixnums or bignums), y must be nonzero */ +void S_trunc_rem(ptr tc, ptr origx, ptr y, ptr *q, ptr *r) { + iptr xl, yl; IBOOL xs, ys; ptr x = origx; + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + if (x == FIX(most_negative_fixnum) && y == FIX(-1)) { + iptr m = most_negative_fixnum /* pull out to avoid bogus Sun C warning */; + if (q != (ptr)NULL) *q = Sinteger(-m); + if (r != (ptr)NULL) *r = FIX(0); + return; + } else { + if (q != (ptr)NULL) *q = FIX((iptr)x / (iptr)y); + if (r != (ptr)NULL) *r = (ptr)((iptr)x % (iptr)y); + return; + } + } else { + FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc); + yl = BIGLEN(y); ys = BIGSIGN(y); + } + } else { + if (Sfixnump(y)) { + xl = BIGLEN(x); xs = BIGSIGN(x); + FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc); + } else { + xl = BIGLEN(x); xs = BIGSIGN(x); + yl = BIGLEN(y); ys = BIGSIGN(y); + } + } + + if (xl < yl) { + if (q != (ptr *)NULL) *q = FIX(0); + if (r != (ptr *)NULL) *r = origx; + } else if (yl == 1) /* must have two bigits for full algorithm */ + big_short_trunc(tc, x, BIGIT(y,0), xl, xs^ys, xs, q, r); + else + big_trunc(tc, x, y, xl, yl, xs^ys, xs, q, r); +} + +/* sparc C compiler barfs w/o full declaration */ +static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs, ptr *q, ptr *r) { + iptr i; + bigit *xp, *zp; + bigit k; + + PREPARE_BIGNUM(tc, W(tc),xl) + + for (i = xl, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i-- > 0; ) + EDIV(k, *xp++, s, zp++, &k) + + if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs); + if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs); +} + +static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r) + ptr tc, x, y; iptr xl, yl; IBOOL qs, rs; ptr *q, *r; { + iptr i; + bigit *p, *xp, *yp; + iptr m = xl-yl+1; + INT d; + bigit k; + + PREPARE_BIGNUM(tc, U(tc), xl+1) + for (i = xl, xp = &BIGIT(U(tc),xl+1), p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p; + *--xp = 0; + + PREPARE_BIGNUM(tc, V(tc), yl) + for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p; + + d = normalize(xp, yp, xl, yl); + + if (q == (ptr *)NULL) { + for (i = m; i-- > 0 ; xp++) (void) quotient_digit(xp, yp, yl); + } else { + PREPARE_BIGNUM(tc, W(tc),m) + p = &BIGIT(W(tc),0); + for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl); + *q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs); + } + + if (r != (ptr *)NULL) { + /* unnormalize the remainder */ + if (d != 0) { + for (i = yl, p = xp, k = 0; i-- > 0; p++) ERSH(d,p,&k) + } + *r = copy_normalize(tc, xp, yl, rs); + } +} + +static INT normalize(bigit *xp, bigit *yp, iptr xl, iptr yl) { + iptr i; + bigit *p, k, b; + INT shft; + + for (shft = bigit_bits-1, b = *yp; b >>= 1; shft -= 1); + + if (shft != 0) { + for (i = yl, p = yp+yl-1, k = 0; i-- > 0; p--) ELSH(shft,p,&k) + for (i = xl, p = xp+xl, k = 0; i-- > 0; p--) ELSH(shft,p,&k) + *xp = k; + } + + return shft; +} + +static bigit quotient_digit(bigit *xp, bigit *yp, iptr yl) { + bigit *p1, *p2, q, k, b, prod; + iptr i; + + q = qhat(xp, yp); + + for (i = yl, p1 = xp+yl, p2 = yp+yl-1, k = 0, b = 0; i-- > 0; p1--, p2--) { + EMUL(*p2, q, k, &prod, &k) + ESUBC(*p1, prod, p1, &b) + } + + ESUBC(*p1, k, p1, &b) + + if (b != 0) { + for (i = yl, p1 = xp+yl, p2 = yp+yl-1, k = 0; i-- > 0; p1--, p2--) { + EADDC(*p2, *p1, p1, &k) + } + EADDC(0,*p1,p1,&k) + q--; + } + + return q; +} + +static bigit qhat(bigit *xp, bigit *yp) { + bigit q, r, high, low, k; + + k = 0; + + if (*xp == *yp) { + q = bigit_mask; + EADDC(*(xp+1), *yp, &r, &k) + } else { + EDIV(*xp, *(xp+1), *yp, &q, &r) + } + + for (; k == 0; q--) { + EMUL(*(yp+1), q, 0, &low, &high) + if (high < r || (high == r && low <= *(xp+2))) break; + EADDC(r, *yp, &r, &k) + } + + return q; +} + +/* +*** +gcd +*** +*/ + +static ptr uptr_gcd(uptr x, uptr y) { + uptr r; + + while (y != 0) { + r = x % y; + x = y; + y = r; + } + + return Sunsigned(x); +} + +/* sparc C compiler barfs w/o full declaration */ +static ptr big_short_gcd(ptr tc, ptr x, bigit y, iptr xl) { + bigit *xp; + iptr i; + bigit r, q; + + if (y == 0) return BIGSIGN(x) ? big_negate(tc, x) : x; + + for (i = xl, r = 0, xp = &BIGIT(x,0); i-- > 0; ) + EDIV(r, *xp++, y, &q, &r) + + return uptr_gcd((uptr)y,(uptr)r); +} + +static ptr big_gcd(ptr tc, ptr x, ptr y, iptr xl, iptr yl) { + iptr i; + INT shft, asc; + bigit *p, *xp, *yp, k, b; + + /* Copy x to scratch bignum, with a leading zero */ + PREPARE_BIGNUM(tc, U(tc),xl+1) + xp = &BIGIT(U(tc),xl+1); + for (i = xl, p = &BIGIT(x,xl); i-- > 0; ) *--xp = *--p; + *--xp = 0; /* leave xp pointing at leading 0-bigit */ + + /* Copy y to scratch bignum, with a leading zero */ + PREPARE_BIGNUM(tc, V(tc),yl+1) + yp = &BIGIT(V(tc),yl+1); + for (i = yl, p = &BIGIT(y,yl); i-- > 0; ) *--yp = *--p; + *(yp-1) = 0; /* leave yp pointing just after leading 0-bigit */ + + /* initialize aggregate shift count (asc) */ + asc = 0; + + for (;;) { + /* find number of leading zeros in first bigit of y */ + for (shft = bigit_bits - 1, b = *yp; b >>= 1; shft--); + + /* find directed distance to shift and new asc */ + if (asc+shft >= bigit_bits) shft -= bigit_bits; + asc += shft; + + /* shift left or right; adjust lengths, xp and yp */ + if (shft < 0) { /* shift right */ + for (i = yl--, p = yp++, k = 0; i-- > 0; p++) ERSH(-shft,p,&k) + for (i = xl+1, p = xp, k = 0; i-- > 0; p++) ERSH(-shft,p,&k) + /* don't need two leading zeros */ + if (*(xp+1) == 0) xp++, xl--; + /* we have shrunk y, so test the length here */ + if (yl == 1) break; + } else if (shft > 0) { /* left shift */ + for (i=yl, p=yp+yl-1, k=0; i-- > 0; p--) ELSH(shft,p,&k) + for (i=xl+1, p=xp+xl, k=0; i-- > 0; p--) ELSH(shft,p,&k) + } + + /* destructive remainder x = x rem y */ + for (i = xl-yl+1; i-- > 0; xp++) (void) quotient_digit(xp, yp, yl); + + /* strip leading zero bigits. remainder is at most yl bigits long */ + for (i = yl ; *xp == 0 && i > 0; xp++, i--); + + /* swap x and y */ + p = yp; /* leading bigit of y */ + yp = xp; /* remainder */ + xp = p-1; /* new dividend w/leading zero */ + xl = yl; + yl = i; + + /* may have lopped off all or all but one bigit of the remainder */ + if (yl <= 1) break; + } + + /* point xp after the leading zero */ + xp += 1; + + /* if y is already zero, shift x and leave */ + if (yl == 0) { + if (asc != 0) { + for (i = xl, p = xp, k = 0; i-- > 0; p++) ERSH(asc,p,&k) + } + return copy_normalize(tc, xp,xl,0); + } else { + bigit d, r; + + d = *yp; + for (r = 0; xl-- > 0; xp++) EDIV(r, *xp, d, xp, &r) + return uptr_gcd((uptr)(d>>asc), (uptr)(r>>asc)); + } +} + +ptr S_gcd(ptr x, ptr y) { + ptr tc = get_thread_context(); + iptr xl, yl; IBOOL xs, ys; + + if (Sfixnump(x)) + if (Sfixnump(y)) { + iptr xi = UNFIX(x), yi = UNFIX(y); + if (xi < 0) xi = -xi; + if (yi < 0) yi = -yi; + return xi >= yi ? + uptr_gcd((uptr)xi, (uptr)yi) : + uptr_gcd((uptr)yi, (uptr)xi); + } else { + FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc); + yl = BIGLEN(y); ys = BIGSIGN(y); + } + else + if (Sfixnump(y)) { + xl = BIGLEN(x); xs = BIGSIGN(x); + FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc); + } else { + xl = BIGLEN(x); xs = BIGSIGN(x); + yl = BIGLEN(y); ys = BIGSIGN(y); + } + + if (xl == 1) + if (yl == 1) { + uptr xu = BIGIT(x,0), yu = BIGIT(y,0); + return xu >= yu ? uptr_gcd(xu, yu) : uptr_gcd(yu, xu); + } else + return big_short_gcd(tc, y, BIGIT(x,0), yl); + else + if (yl == 1) + return big_short_gcd(tc, x, BIGIT(y,0), xl); + else + if (abs_big_lt(x, y, xl, yl)) + return big_gcd(tc, y, x, yl, xl); + else + return big_gcd(tc, x, y, xl, yl); +} + +/* +*** +floating-point operations +*** +*/ + +#ifdef IEEE_DOUBLE +/* exponent stored + 1024, hidden bit to left of decimal point */ +#define bias 1023 +#define bitstoright 52 +#define m1mask 0xf +#ifdef WIN32 +#define hidden_bit 0x10000000000000 +#else +#define hidden_bit 0x10000000000000ULL +#endif +#ifdef LITTLE_ENDIAN_IEEE_DOUBLE +struct dblflt { + UINT m4: 16; + UINT m3: 16; + UINT m2: 16; + UINT m1: 4; + UINT e: 11; + UINT sign: 1; +}; +#else +struct dblflt { + UINT sign: 1; + UINT e: 11; + UINT m1: 4; + UINT m2: 16; + UINT m3: 16; + UINT m4: 16; +}; +#endif +#endif + +double S_random_double(U32 m1, U32 m2, U32 m3, U32 m4, double scale) { + /* helper for s_fldouble in prim5.c */ + union dxunion { + double d; + struct dblflt x; + } dx; + + dx.x.m1 = m1 >> 16 & m1mask; + dx.x.m2 = m2 >> 16; + dx.x.m3 = m3 >> 16; + dx.x.m4 = m4 >> 16; + dx.x.sign = 0; + dx.x.e = bias; + return (dx.d - 1.0) * scale; +} + +/* number of quotient bigits to guarantee at least 64 bits */ +/* +2 since first bigit may be zero and second may not be full */ +#define enough (64 / bigit_bits + 2) + +/* sparc C compiler barfs w/o full declaration */ +static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) { + iptr i; + bigit *xp, *zp, k; + + PREPARE_BIGNUM(tc, W(tc),enough+1) + + /* compute only as much of quotient as we need */ + for (i = 0, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i < enough; i++) + if (i < xl) + EDIV(k, *xp++, s, zp++, &k) + else + EDIV(k, 0, s, zp++, &k) + + /* then see if there's a bit set somewhere beyond */ + while (k == 0 && i++ < xl) k = *xp++; + + return floatify_normalize(&BIGIT(W(tc),0), xl*bigit_bits, sign, k != 0); +} + +static double big_floatify(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) { + iptr i, ul; + bigit *p, *xp, *yp, k; + + /* copy x to U(tc), scaling with added zero bigits as necessary */ + ul = xl < yl + enough-1 ? yl + enough-1 : xl; + PREPARE_BIGNUM(tc, U(tc), ul+1) + for (i = ul - xl, xp = &BIGIT(U(tc),ul+1); i-- > 0;) *--xp = 0; + for (i = xl, p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p; + *--xp = 0; + + /* copy y to V(tc) */ + PREPARE_BIGNUM(tc, V(tc), yl) + for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p; + + (void) normalize(xp, yp, ul, yl); + + PREPARE_BIGNUM(tc, W(tc),4) + p = &BIGIT(W(tc),0); + + /* compute 'enough' bigits of the quotient */ + for (i = enough; i-- > 0; xp++) *p++ = quotient_digit(xp, yp, yl); + + /* set k if remainder is nonzero */ + k = 0; + for (i = ul + 1, xp = &BIGIT(U(tc),ul); k == 0 && i-- > 0; xp--) k = *xp; + + return floatify_normalize(&BIGIT(W(tc),0), (xl-yl+1)*bigit_bits, sign, k != 0); +} + +/* come in with exactly 'enough' bigits */ +static double floatify_normalize(bigit *p, iptr e, IBOOL sign, IBOOL sticky) { + /* *p: first bigit; e: exponent; sign: sign; sticky: sticky bit */ + union dxunion { + double d; + struct dblflt x; + } dx; + bigit mhigh; + U64 mlow; + IBOOL cutbit = 0; + INT n; + + /* shift in what we need, plus at least one bit */ + mhigh = 0; mlow = 0; n = enough; + while (mhigh == 0 && mlow < hidden_bit * 2) { + mhigh = (bigit)(mlow >> (64-bigit_bits)); + mlow = (mlow << bigit_bits) | *p++; + n -= 1; + e -= bigit_bits; + } + + /* back up to align high bit on hidden bit, setting cut bit to last loser */ + do { + sticky = sticky || cutbit; + cutbit = (bigit)(mlow & 1); + mlow = (U64)mhigh << 63 | mlow >> 1; + mhigh = mhigh >> 1; + e = e + 1; + } while (mhigh != 0 || mlow >= hidden_bit * 2); + + e = e + bitstoright + bias; + + /* back up further if denormalized */ + if (e <= 0) { + for (;;) { + sticky = sticky || cutbit; + cutbit = (bigit)(mlow & 1); + mlow = mlow >> 1; + if (e == 0 || mlow == 0) break; + e = e + 1; + } + } + + if (e < 0) { + e = 0; /* NB: e < 0 => mlow == 0 */ + } else { + /* round up if necessary */ + if (cutbit) { + IBOOL round; + /* cutbit = 1 => at least half way to next number. round up if odd or + if there are any bits set to the right of cutbit */ + round = (mlow & 1) || sticky; + while (!round && n-- > 0) round = *p++ != 0; + if (round) { + mlow += 1; + if (e == 0 && mlow == hidden_bit) { + e = 1; /* squeaking into lowest normalized spot */ + } else if (mlow == hidden_bit * 2) { + /* don't bother with mlow = mlow >> 1 since hidden bit and up are ignored after this */ + e += 1; + } + } + } + + if (e > 2046) { /* infinity */ + e = 2047; + mlow = 0; + } + } + + /* fill in the fields */ + dx.x.sign = sign; + dx.x.e = (UINT)e; + dx.x.m1 = (UINT)(mlow >> 48 & m1mask); + dx.x.m2 = (UINT)(mlow >> 32 & 0xffff); + dx.x.m3 = (UINT)(mlow >> 16 & 0xffff); + dx.x.m4 = (UINT)(mlow & 0xffff); + + return dx.d; +} + +static double floatify_ratnum(ptr tc, ptr p) { + ptr x, y; iptr xl, yl; IBOOL xs; + + x = RATNUM(p); y = RATDEN(p); + + if (fixnum_bits <= bitstoright && Sfixnump(x) && Sfixnump(y)) + return (double)UNFIX(x) / (double)UNFIX(y); + + /* make sure we are dealing with bignums */ + if (Sfixnump(x)) { + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + x = X(tc); + } else { + xl = BIGLEN(x); + xs = BIGSIGN(x); + } + + if (Sfixnump(y)) { + IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + y = Y(tc); + } else { + yl = BIGLEN(y); + } + + /* need second bignum to be at least two bigits for full algorithm */ + if (yl == 1) + return big_short_floatify(tc, x, BIGIT(y,0), xl, xs); + else + return big_floatify(tc, x, y, xl, yl, xs); +} + +double S_floatify(ptr x) { + ptr tc = get_thread_context(); + + if (Sflonump(x)) return FLODAT(x); + else if (Sfixnump(x)) return (double)UNFIX(x); + else if (Sbignump(x)) return big_short_floatify(tc, x, 1, BIGLEN(x), BIGSIGN(x)); + else if (Sratnump(x)) return floatify_ratnum(tc, x); + else S_error1("", "~s is not a real number", x); + + return 0.0 /* not reached */; +} + +#ifdef IEEE_DOUBLE +ptr S_decode_float(double d) { + union dxunion { + double d; + struct dblflt x; + } dx; + IBOOL s; INT e; U64 m; + ptr x, p; + + /* pick apart the fields */ + dx.d = d; + s = dx.x.sign; + e = dx.x.e; + m = (U64)dx.x.m1 << 48 | (U64)dx.x.m2 << 32 | (U64)dx.x.m3 << 16 | (U64)dx.x.m4; + if (e != 0) { + e = e - bias - bitstoright; + m |= hidden_bit; + } else if (m != 0) { + /* denormalized */ + e = 1 - bias - bitstoright; + } + + /* compute significand */ + if (m <= most_positive_fixnum) + x = FIX((uptr)m); + else { + iptr xl; + x = FIX(0); + U64_TO_BIGNUM(get_thread_context(), x, m, &xl) + SETBIGLENANDSIGN(x, xl, 0); + } + + /* construct return vector */ + p = S_vector(3); + INITVECTIT(p,0) = x; + INITVECTIT(p, 1) = FIX(e); + INITVECTIT(p, 2) = s ? FIX(-1) : FIX(1); + return p; +} +#endif + +/* +*** +logical operations +*** +*/ + +static ptr s_big_ash(ptr tc, bigit *xp, iptr xl, IBOOL sign, iptr cnt) { + iptr i; + bigit *p1, *p2, k; + + if (cnt < 0) { /* shift to the right */ + iptr whole_bigits; + + /* decrement length to shift by whole bigits */ + if ((xl -= (whole_bigits = (cnt = -cnt) / bigit_bits)) <= 0) return sign ? FIX(-1) : FIX(0); + cnt -= whole_bigits * bigit_bits; + + /* shift by remaining count to scratch bignum, tracking bits shifted off to the right; + prepare a bignum one larger than probably needed, in case we have to deal with a + carry bit when rounding down for a negative number */ + PREPARE_BIGNUM(tc, W(tc),xl+1) + p1 = &BIGIT(W(tc), 0); + p2 = xp; + k = 0; + i = xl; + if (cnt == 0) { + do { *p1++ = *p2++; } while (--i > 0); + } else { + do { ERSH2(cnt,*p2,p1,&k); p1++; p2++; } while (--i > 0); + } + + if (sign) { + if (k == 0) { + /* check for one bits in the shifted-off bigits, looking */ + /* from both ends in an attempt to get out more quickly for what */ + /* seem like the most likely patterns. of course, there might */ + /* be no one bits (in which case this won't help) or they might be */ + /* only in the middle (in which case this will be slower) */ + p2 = (p1 = xp + xl) + whole_bigits; + while (p1 != p2) { + if ((k = *p1++) || p1 == p2 || (k = *--p2)) break; + } + } + + /* round down negative numbers by incrementing the magnitude if any + one bits were shifted off to the right */ + if (k) { + p1 = &BIGIT(W(tc), xl - 1); + for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1) + EADDC(0, *p1, p1, &k) + if (k) { + /* add carry bit back; we prepared a large enough bignum, + and since all of the middle are zero, we don't have to reshift */ + BIGIT(W(tc), xl) = 0; + BIGIT(W(tc), 0) = 1; + xl++; + } + } + } + + return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign); + } else { /* shift to the left */ + iptr xlplus, newxl; + + /* determine how many zero bigits to add on the end */ + xlplus = 0; + while (cnt >= bigit_bits) { + xlplus += 1; + cnt -= bigit_bits; + } + + /* maximum total length includes +1 for shift out of top bigit */ + newxl = xl + xlplus + 1; + + PREPARE_BIGNUM(tc, W(tc),newxl) + + /* fill bigits to right with zero */ + for (i = xlplus, p1 = &BIGIT(W(tc), newxl); i-- > 0; ) *--p1 = 0; + + /* shift to the left */ + for (i = xl, p2 = xp + xl, k = 0; i-- > 0; ) { + *--p1 = *--p2; + if (cnt != 0) ELSH(cnt, p1, &k); + } + *--p1 = k; + + return copy_normalize(tc, p1, newxl, sign); + } +} + +/* x is a bignum or fixnum, n is a fixnum */ +ptr S_ash(ptr x, ptr n) { + ptr tc = get_thread_context(); + iptr cnt = UNFIX(n); + + if (Sfixnump(x)) { + /* when we get here with a fixnum, we've done what we could in Scheme + code to avoid use of bignums, so go straight to it. it's difficult to + do much here anyway since semantics of signed >> are undefined in C */ + iptr xl; IBOOL xs; + + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs); + return s_big_ash(tc, &BIGIT(X(tc),0), xl, xs, cnt); + } else + return s_big_ash(tc, &BIGIT(x,0), BIGLEN(x), BIGSIGN(x), cnt); +} + +/* x is a bignum */ +ptr S_integer_length(ptr x) { + iptr a; bigit b; + + if (BIGSIGN(x)) x = S_sub(FIX(-1), x); + + b = BIGIT(x, 0); + a = 1; + while (b >>= 1) a += 1; + + return S_add(S_mul(FIX(BIGLEN(x) - 1), FIX(bigit_bits)), FIX(a)); +} + +/* x is a bignum */ +ptr S_big_first_bit_set(ptr x) { + iptr xl = BIGLEN(x); + bigit *xp = &BIGIT(x, xl); + bigit b; + iptr zbigits = 0; + INT zbits = 0; + + /* first bit set in signed magnitude is same as for two's complement, + since if x ends with k zeros, ~x+1 also ends with k zeros. */ + while ((b = *--xp) == 0) zbigits += 1; + while ((b & 1) == 0) { zbits += 1; b >>= 1; } + return S_add(S_mul(FIX(zbigits), FIX(bigit_bits)), FIX(zbits)); +} + +/* assumes fxstart - fxend > 0 */ +ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) { + ptr tc = get_thread_context(); + bigit *xp = &BIGIT(x, 0); + iptr start = UNFIX(fxstart), end = UNFIX(fxend), xl = BIGLEN(x); + iptr wl, bigits, i; + bigit *p1, *p2, k; + uptr bits, maskbits; + + /* shift by whole bigits by decrementing length */ + bigits = (unsigned)start / bigit_bits; + xl -= bigits; + if (xl <= 0) return FIX(0); + bits = (unsigned)bigits * bigit_bits; + start -= bits; + end -= bits; + + /* compute maximum length of result */ + bigits = (unsigned)end / bigit_bits; + if (xl <= bigits) { + wl = xl; + maskbits = 0; + } else { + end -= (unsigned)bigits * bigit_bits; + if (end != 0) { + wl = bigits + 1; + maskbits = bigit_bits - end; + } else { + wl = bigits; + maskbits = 0; + } + } + + /* copy to scratch bignum */ + PREPARE_BIGNUM(tc, W(tc),wl) + p1 = &BIGIT(W(tc), wl); + for (i = wl, p2 = xp + xl; i-- > 0; ) *--p1 = *--p2; + + /* kill unwanted bits at the top of the first bigit */ + if (maskbits != 0) *p1 = (*p1 << maskbits) >> maskbits; + + /* shift by remaining start bits */ + if (start != 0) { + k = 0; + for (i = wl; i > 0; i -= 1, p1 += 1) ERSH(start,p1,&k) + } + + return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0); +} + +/* logical operations simulate two's complement operations using the + following general strategy: + + 1. break into cases based on signs of operands + + 2. convert negative operands to two's complement + + 3. operate + + 4. convert negative results to two's complement and set sign bit. + sign of result is known based on signs of operands + + simplifications are made where possible to reduce number of operations. + + # = 2's complement; #x = ~x + 1 = ~(x - 1) if x > 0 +*/ + +ptr S_logand(ptr x, ptr y) { + ptr tc = get_thread_context(); + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + return (ptr)((iptr)x & (iptr)y); + } else { + iptr xl; IBOOL xs; + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + return big_logand(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs); + } + } else { + if (Sfixnump(y)) { + iptr yl; IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + return big_logand(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys); + } else { + if (BIGLEN(x) >= BIGLEN(y)) + return big_logand(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y)); + else + return big_logand(tc, y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x)); + } + } +} + +/* logand on signed-magnitude bignums + # = 2's complement; #x = ~x + 1 = ~(x - 1) if x > 0 + s&(x,y) = x&y know result >= 0 + s&(x,-y) = x&#y know result >= 0 + = x&~(y-1) + s&(-x,y) = s&(y,-x) + s&(-x,-y) = -(#(#x&#y)) know result < 0 + = -(~(~(x-1)&~(y-1))+1) + = -(((x-1)|(y-1))+1) de morgan's law +*/ + +/* assumes xl >= yl */ +static ptr big_logand(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) { + iptr i; + bigit *xp, *yp, *zp; + + if (xs == 0) { + if (ys == 0) { + PREPARE_BIGNUM(tc, W(tc),yl); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl); + for (i = yl; i > 0; i -= 1) *--zp = *--xp & *--yp; + return copy_normalize(tc, zp, yl, 0); + } else { + bigit yb; + + PREPARE_BIGNUM(tc, W(tc),xl); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl); + yb = 1; + for (i = yl; i > 0; i -= 1) { + bigit t1 = *--yp, t2 = t1 - yb; + yb = t2 > t1; + *--zp = *--xp & ~t2; + } + /* yb must be 0, since high-order bigit >= 1. effectively, this + means ~t2 would be all 1's from here on out. */ + for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp; + return copy_normalize(tc, zp, xl, 0); + } + } else { + if (ys == 0) { + bigit xb; + + PREPARE_BIGNUM(tc, W(tc),yl); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl); + xb = 1; + for (i = yl; i > 0; i -= 1) { + bigit t1 = *--xp, t2 = t1 - xb; + xb = t2 > t1; + *--zp = *--yp & ~t2; + } + return copy_normalize(tc, zp, yl, 0); + } else { + bigit xb, yb, k; + + PREPARE_BIGNUM(tc, W(tc),xl+1); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1); + k = yb = xb = 1; + for (i = yl; i > 0; i -= 1) { + bigit x1, x2, y1, y2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + y1 = *--yp; y2 = y1 - yb; yb = y2 > y1; + z1 = x2 | y2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + for (i = xl - yl; i > 0; i -= 1) { + bigit x1, x2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = x2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, xl+1, 1); + } + } +} + +/* logtest is like logand but returns a boolean value */ + +ptr S_logtest(ptr x, ptr y) { + ptr tc = get_thread_context(); + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + return Sboolean((iptr)x & (iptr)y); + } else { + iptr xl; IBOOL xs; + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + return big_logtest(y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs); + } + } else { + if (Sfixnump(y)) { + iptr yl; IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + return big_logtest(x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys); + } else { + if (BIGLEN(x) >= BIGLEN(y)) + return big_logtest(x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y)); + else + return big_logtest(y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x)); + } + } +} + +/* essentially the same logic as big_logand, but just produces true iff + logand would return a nonzero value */ + +/* assumes xl >= yl */ +static ptr big_logtest(ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) { + iptr i; + bigit *xp, *yp; + + if (xs == 0) { + if (ys == 0) { + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); + for (i = yl; i > 0; i -= 1) if (*--xp & *--yp) return Strue; + return Sfalse; + } else { + bigit yb; + + if (xl > yl) return Strue; + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); + yb = 1; i = yl; + for (;;) { + bigit t1 = *--yp, t2 = t1 - yb; + if (*--xp & ~t2) return Strue; + if (--i == 0) return Sfalse; + yb = t2 > t1; + } + } + } else { + if (ys == 0) { + bigit xb; + + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); + xb = 1; i = yl; + for (;;) { + bigit t1 = *--xp, t2 = t1 - xb; + if (*--yp & ~t2) return Strue; + if (--i == 0) return Sfalse; + xb = t2 > t1; + } + } else { + /* logand of two negative bignums is always nonzero */ + return Strue; + } + } +} + +/* k must be a nonnegative fixnum. x may be a bignum or fixnum */ +ptr S_logbitp(ptr k, ptr x) { + uptr n = UNFIX(k); + + if (Sfixnump(x)) { + if (n >= fixnum_bits) + return Sboolean((iptr)x < 0); + else + return Sboolean((iptr)x & ((iptr)FIX(1) << n)); + } else { + return big_logbitp(n, x, BIGLEN(x), BIGSIGN(x)); + } +} + +/* similar logic to big_logand */ + +static ptr big_logbitp(iptr n, ptr x, iptr xl, IBOOL xs) { + iptr i; + bigit *xp; + + if (xs == 0) { + i = xl - (n / bigit_bits + 1); + if (i < 0) return Sfalse; + + n = n % bigit_bits; + return Sboolean(BIGIT(x,i) & (1 << n)); + } else { + bigit xb; + + /* get out quick when 2^n has more bigits than x */ + if (n / bigit_bits >= xl) return Strue; + + xp = &BIGIT(x,xl); xb = 1; + for (i = xl; ; i -= 1) { + bigit t1 = *--xp, t2 = t1 - xb; + if (n < bigit_bits) return Sboolean(~t2 & (1 << n)); + xb = t2 > t1; + n -= bigit_bits; + } + } +} + +/* k must be a nonnegative fixnum. x may be a bignum or fixnum */ +ptr S_logbit0(ptr k, ptr x) { + ptr tc = get_thread_context(); + iptr n = UNFIX(k); + + if (Sfixnump(x)) { + if (n < fixnum_bits - 1) { + return FIX(UNFIX(x) & ~(1 << n)); + } else { + iptr xl; IBOOL xs; + + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs); + return big_logbit0(tc, x, n, X(tc), xl, xs); + } + } else { + return big_logbit0(tc, x, n, x, BIGLEN(x), BIGSIGN(x)); + } +} + +/* logbit0 on signed-magnitude bignums + y = 1 << n + s&(x,~y) = x&~y know result >= 0 + s&(-x,~y) = -#(#x&~y) know result < 0 + = -(~(~(x-1)&~y)+1) + = -(((x-1)|y)+1) +*/ + +/* adapted from big_logor algorithm */ +static ptr big_logbit0(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs) { + iptr i; + bigit *xp, *zp; + iptr yl = (n / bigit_bits) + 1; + + if (xs == 0) { + if (yl > xl) { + /* we'd just be clearing a bit that's already (virtually) cleared */ + return origx; + } else { + PREPARE_BIGNUM(tc, W(tc),xl); + xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),xl); + for (;;) { + if (n < bigit_bits) break; + *--zp = *--xp; + n -= bigit_bits; + } + *--zp = *--xp & ~(1 << n); + for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp; + return copy_normalize(tc, zp,xl,0); + } + } else { + bigit xb, k, x1, x2, z1, z2; + iptr zl = (yl > xl ? yl : xl) + 1; + + PREPARE_BIGNUM(tc, W(tc),zl); + xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl); + k = xb = 1; + i = xl; + for (;;) { + if (i > 0) { x1 = *--xp; i -= 1; } else x1 = 0; + x2 = x1 - xb; xb = x2 > x1; + if (n < bigit_bits) break; + z1 = x2; z2 = z1 + k; k = z2 < z1; + *--zp = z2; + n -= bigit_bits; + } + z1 = x2 | (1 << n); z2 = z1 + k; k = z2 < z1; + *--zp = z2; + for (; i > 0; i -= 1) { + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = x2; z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, zl, 1); + } +} + +/* k must be a nonnegative fixnum. x may be a bignum or fixnum */ +ptr S_logbit1(ptr k, ptr x) { + ptr tc = get_thread_context(); + iptr n = UNFIX(k); + + if (Sfixnump(x)) { + if (n < fixnum_bits - 1) { + return FIX(UNFIX(x) | ((uptr)1 << n)); + } else { + iptr xl; IBOOL xs; + + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs); + return big_logbit1(tc, x, n, X(tc), xl, xs); + } + } else { + return big_logbit1(tc, x, n, x, BIGLEN(x), BIGSIGN(x)); + } +} + +/* adapted from big_logor algorithm */ +static ptr big_logbit1(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs) { + iptr i; + bigit *xp, *zp; + iptr yl = (n / bigit_bits) + 1; + + if (xs == 0) { + bigit x1; + iptr zl = yl > xl ? yl : xl; + + PREPARE_BIGNUM(tc, W(tc),zl); + xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl); + + i = xl; + for (;;) { + if (i > 0) { x1 = *--xp; i -= 1; } else x1 = 0; + if (n < bigit_bits) break; + *--zp = x1; + n -= bigit_bits; + } + *--zp = x1 | (1 << n); + for (; i > 0; i -= 1) *--zp = *--xp; + return copy_normalize(tc, zp, zl, 0); + } else if (yl > xl) { + /* we'd just be setting a bit that's already (virtually) set */ + return origx; + } else { /* xl >= yl */ + bigit xb, k, x1, x2, z1, z2; + iptr zl = xl + 1; + + PREPARE_BIGNUM(tc, W(tc),zl); + xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl); + k = xb = 1; + for (;;) { + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + if (n < bigit_bits) break; + z1 = x2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + n -= bigit_bits; + } + z1 = x2 & ~(1 << n); + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + for (i = xl - yl; i > 0; i -= 1) { + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = x2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, zl, 1); + } +} + +ptr S_logor(ptr x, ptr y) { + ptr tc = get_thread_context(); + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + return (ptr)((iptr)x | (iptr)(y)); + } else { + iptr xl; IBOOL xs; + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + return big_logor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs); + } + } else { + if (Sfixnump(y)) { + iptr yl; IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + return big_logor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys); + } else { + if (BIGLEN(x) >= BIGLEN(y)) + return big_logor(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y)); + else + return big_logor(tc, y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x)); + } + } +} + +/* logor on signed-magnitude bignums + s|(x,y) = x|y know result >= 0 + s|(x,-y) = -(#(x|#y)) know result < 0 + = -(~(x|~(y-1))+1) + = -(((y-1)&~x)+1) + s|(-x,y) = -(((x-1)&~y)+1) + s|(-x,-y) = -(#(#x|#y)) know result < 0 + = -(~(~(x-1)|~(y-1))+1) + = -(((x-1)&(y-1))+1) de morgan's law +*/ + +/* assumes xl >= yl */ +static ptr big_logor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) { + iptr i; + bigit *xp, *yp, *zp; + + if (xs == 0) { + if (ys == 0) { + PREPARE_BIGNUM(tc, W(tc),xl); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl); + for (i = yl; i > 0; i -= 1) *--zp = *--xp | *--yp; + for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp; + return copy_normalize(tc, zp, xl, 0); + } else { + bigit yb, k; + + PREPARE_BIGNUM(tc, W(tc),yl+1); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1); + k = yb = 1; + for (i = yl; i > 0; i -= 1) { + bigit y1, y2, z1, z2; + y1 = *--yp; y2 = y1 - yb; yb = y2 > y1; + z1 = y2 & ~*--xp; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, yl+1, 1); + } + } else { + if (ys == 0) { + bigit xb, k; + + PREPARE_BIGNUM(tc, W(tc),xl+1); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1); + k = xb = 1; + for (i = yl; i > 0; i -= 1) { + bigit x1, x2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = x2 & ~*--yp; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + for (i = xl - yl; i > 0; i -= 1) { + bigit x1, x2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = x2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, xl+1, 1); + } else { + bigit xb, yb, k; + + PREPARE_BIGNUM(tc, W(tc),yl+1); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1); + k = yb = xb = 1; + for (i = yl; i > 0; i -= 1) { + bigit x1, x2, y1, y2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + y1 = *--yp; y2 = y1 - yb; yb = y2 > y1; + z1 = x2 & y2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, yl+1, 1); + } + } +} + +ptr S_logxor(ptr x, ptr y) { + ptr tc = get_thread_context(); + + if (Sfixnump(x)) { + if (Sfixnump(y)) { + return (ptr)((iptr)x ^ (iptr)(y)); + } else { + iptr xl; IBOOL xs; + FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) + return big_logxor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs); + } + } else { + if (Sfixnump(y)) { + iptr yl; IBOOL ys; + FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) + return big_logxor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys); + } else { + if (BIGLEN(x) >= BIGLEN(y)) + return big_logxor(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y)); + else + return big_logxor(tc, y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x)); + } + } +} + +/* logxor on signed-magnitude bignums + s^(x,y) = x^y know result >= 0 + s^(x,-y) = -(#(x^#y)) know result < 0 + = -(~(x^~(y-1))+1) + = -((x^(y-1))+1) since ~(a^~b) = a^b + s^(-x,y) = -((y^(x-1))+1) + s^(-x,-y) = #x^#y know result >= 0 + = ~(x-1)^~(y-1) + = (x-1)^(y-1) since ~a^~b = a^b +*/ + +/* assumes xl >= yl */ +static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) { + iptr i; + bigit *xp, *yp, *zp; + + if (xs == 0) { + if (ys == 0) { + PREPARE_BIGNUM(tc, W(tc),xl); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl); + for (i = yl; i > 0; i -= 1) *--zp = *--xp ^ *--yp; + for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp; + return copy_normalize(tc, zp, xl, 0); + } else { + bigit yb, k; + + PREPARE_BIGNUM(tc, W(tc),xl+1); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1); + k = yb = 1; + for (i = yl; i > 0; i -= 1) { + bigit y1, y2, z1, z2; + y1 = *--yp; y2 = y1 - yb; yb = y2 > y1; + z1 = *--xp ^ y2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + for (i = xl - yl; i > 0; i -= 1) { + bigit z1, z2; + z1 = *--xp; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, xl+1, 1); + } + } else { + if (ys == 0) { + bigit xb, k; + + PREPARE_BIGNUM(tc, W(tc),xl+1); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1); + k = xb = 1; + for (i = yl; i > 0; i -= 1) { + bigit x1, x2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = *--yp ^ x2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + for (i = xl - yl; i > 0; i -= 1) { + bigit x1, x2, z1, z2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + z1 = x2; + z2 = z1 + k; k = z2 < z1; + *--zp = z2; + } + *--zp = k; + return copy_normalize(tc, zp, xl+1, 1); + } else { + bigit xb, yb; + + PREPARE_BIGNUM(tc, W(tc),xl); + xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl); + yb = xb = 1; + for (i = yl; i > 0; i -= 1) { + bigit x1, x2, y1, y2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + y1 = *--yp; y2 = y1 - yb; yb = y2 > y1; + *--zp = x2 ^ y2; + } + for (i = xl - yl; i > 0; i -= 1) { + bigit x1, x2; + x1 = *--xp; x2 = x1 - xb; xb = x2 > x1; + *--zp = x2; + } + return copy_normalize(tc, zp, xl, 0); + } + } +} + +/* lognot on signed-magnitude bignums: + s~(x) = -#~x + = -(~~x+1) + = -(x+1) + s~(-x) = ~#x + = ~~(x-1) + = x-1 + therefore: + (define (lognot x) + (if (< x 0) + (- (- x) 1) + (- (+ x 1)))) + simplifying: + (define (lognot x) (- -1 x)) +*/ + +ptr S_lognot(ptr x) { + if (Sfixnump(x)) { + return FIX(~UNFIX(x)); + } else { + return S_sub(FIX(-1), x); + } +} + +void S_number_init(void) { + if ((int)(hidden_bit >> 22) != 0x40000000) { + fprintf(stderr, "hidden_bit >> 22 = %x\n", (int)(hidden_bit >> 22)); + S_abnormal_exit(); + } +} diff --git a/c/ppc32.c b/c/ppc32.c new file mode 100644 index 0000000..244ae91 --- /dev/null +++ b/c/ppc32.c @@ -0,0 +1,64 @@ +/* ppc32le.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +#include +#include +#include + +/* NB: when sysconf isn't helpful, hardcoding data max cache line size from PowerMac G4. + * NB: this may cause illegal instruction error on machines with smaller cache line sizes. Also, it + * NB: will make invalidating the caches slower on machines with larger cache line sizes. */ +#define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 + +static int l1_dcache_line_size, l1_icache_line_size, l1_max_cache_line_size; + +/* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */ +INT S_flushcache_max_gap(void) { + return l1_max_cache_line_size; +} + +void S_doflush(uptr start, uptr end) { + uptr i; + +#ifdef DEBUG + printf(" doflush(%x, %x)\n", start, end); fflush(stdout); +#endif + + start &= ~(l1_max_cache_line_size - 1); + end = (end + l1_max_cache_line_size) & ~(l1_max_cache_line_size - 1); + + for(i = start; i < end; i += l1_dcache_line_size) { + __asm__ __volatile__ ("dcbst 0, %0" :: "r" (i)); + } + __asm__ __volatile__ ("sync"); + + for(i = start; i < end; i += l1_icache_line_size) { + __asm__ __volatile__ ("icbi 0, %0" :: "r" (i)); + } + __asm__ __volatile__ ("sync ; isync"); +} + +void S_machine_init(void) { + if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) { + l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + } + if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) { + l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + } + l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; +} diff --git a/c/ppc32le.c b/c/ppc32le.c new file mode 100644 index 0000000..244ae91 --- /dev/null +++ b/c/ppc32le.c @@ -0,0 +1,64 @@ +/* ppc32le.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +#include +#include +#include + +/* NB: when sysconf isn't helpful, hardcoding data max cache line size from PowerMac G4. + * NB: this may cause illegal instruction error on machines with smaller cache line sizes. Also, it + * NB: will make invalidating the caches slower on machines with larger cache line sizes. */ +#define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 + +static int l1_dcache_line_size, l1_icache_line_size, l1_max_cache_line_size; + +/* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */ +INT S_flushcache_max_gap(void) { + return l1_max_cache_line_size; +} + +void S_doflush(uptr start, uptr end) { + uptr i; + +#ifdef DEBUG + printf(" doflush(%x, %x)\n", start, end); fflush(stdout); +#endif + + start &= ~(l1_max_cache_line_size - 1); + end = (end + l1_max_cache_line_size) & ~(l1_max_cache_line_size - 1); + + for(i = start; i < end; i += l1_dcache_line_size) { + __asm__ __volatile__ ("dcbst 0, %0" :: "r" (i)); + } + __asm__ __volatile__ ("sync"); + + for(i = start; i < end; i += l1_icache_line_size) { + __asm__ __volatile__ ("icbi 0, %0" :: "r" (i)); + } + __asm__ __volatile__ ("sync ; isync"); +} + +void S_machine_init(void) { + if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) { + l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + } + if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) { + l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + } + l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; +} diff --git a/c/prim.c b/c/prim.c new file mode 100644 index 0000000..4cb89d9 --- /dev/null +++ b/c/prim.c @@ -0,0 +1,288 @@ +/* prim.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +static void install_library_entry(ptr n, ptr x); +static void scheme_install_library_entry(void); +static void create_library_entry_vector(void); +static void install_c_entry(iptr i, ptr x); +static void create_c_entry_vector(void); +static void s_instantiate_code_object(void); +static void s_link_code_object(ptr co, ptr objs); +static IBOOL s_check_heap_enabledp(void); +static void s_enable_check_heap(IBOOL b); +static uptr s_check_heap_errors(void); + +static void install_library_entry(ptr n, ptr x) { + if (!Sfixnump(n) || UNFIX(n) < 0 || UNFIX(n) >= library_entry_vector_size) + S_error1("$install-library-entry", "invalid index ~s", n); + if (!Sprocedurep(x) && !Scodep(x)) + S_error2("$install-library-entry", "invalid entry ~s for ~s", x, n); + if (Svector_ref(S_G.library_entry_vector, UNFIX(n)) != Sfalse) { + printf("$install-library-entry: overwriting entry for %ld\n", (long)UNFIX(n)); + fflush(stdout); + } + SETVECTIT(S_G.library_entry_vector, UNFIX(n), x); + if (n == FIX(library_nonprocedure_code)) { + S_G.nonprocedure_code = x; + S_retrofit_nonprocedure_code(); + } +} + +ptr S_lookup_library_entry(iptr n, IBOOL errorp) { + ptr p; + + if (n < 0 || n >= library_entry_vector_size) + S_error1("$lookup-library-entry", "invalid index ~s", FIX(n)); + p = Svector_ref(S_G.library_entry_vector, n); + if (p == Sfalse && errorp) + S_error1("$lookup-library-entry", "entry ~s uninitialized", FIX(n)); + return p; +} + +static void scheme_install_library_entry(void) { + ptr tc = get_thread_context(); + install_library_entry(S_get_scheme_arg(tc, 1), S_get_scheme_arg(tc, 2)); +} + +static void create_library_entry_vector(void) { + iptr i; + + S_protect(&S_G.library_entry_vector); + S_G.library_entry_vector = S_vector(library_entry_vector_size); + for (i = 0; i < library_entry_vector_size; i++) + INITVECTIT(S_G.library_entry_vector, i) = Sfalse; +} + +#ifdef HPUX +#define proc2ptr(x) int2ptr((iptr)(x)) +ptr int2ptr(iptr f) +{ + if ((f & 2) == 0) + S_error("proc2ptr", "invalid C procedure"); + return (ptr)(f & ~0x3); +} +#else /* HPUX */ +#define proc2ptr(x) (ptr)(iptr)(x) +#endif /* HPUX */ + +static void install_c_entry(iptr i, ptr x) { + if (i < 0 || i >= c_entry_vector_size) + S_error1("install_c_entry", "invalid index ~s", FIX(i)); + if (Svector_ref(S_G.c_entry_vector, i) != Sfalse) + S_error1("install_c_entry", "duplicate entry for ~s", FIX(i)); + SETVECTIT(S_G.c_entry_vector, i, x); +} + +ptr S_lookup_c_entry(iptr i) { + ptr x; + + if (i < 0 || i >= c_entry_vector_size) + S_error1("lookup_c_entry", "invalid index ~s", FIX(i)); + if ((x = Svector_ref(S_G.c_entry_vector, i)) == Sfalse) + S_error1("lookup_c_entry", "uninitialized entry ~s", FIX(i)); + return x; +} + +static ptr s_get_thread_context(void) { + return get_thread_context(); +} + +static void create_c_entry_vector(void) { + INT i; + + S_protect(&S_G.c_entry_vector); + S_G.c_entry_vector = S_vector(c_entry_vector_size); + + for (i = 0; i < c_entry_vector_size; i++) + INITVECTIT(S_G.c_entry_vector, i) = Sfalse; + + install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context)); + install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context)); + install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood)); + install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error)); + install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow)); + install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood)); + install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol)); + install_c_entry(CENTRY_thread_list, (ptr)&S_threads); + install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize)); +#ifdef PTHREADS + install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond); + install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex); + install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread)); + install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread)); + install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread)); +#endif /* PTHREADS */ + install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error)); + install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error)); + install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error)); + install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry)); + install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry)); + install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room)); + install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set)); + install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object)); + install_c_entry(CENTRY_Sreturn, proc2ptr(S_return)); + install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result)); + install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results)); + + for (i = 0; i < c_entry_vector_size; i++) { +#ifndef PTHREADS + if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex + || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread + || i == CENTRY_unactivate_thread) + continue; +#endif /* NOT PTHREADS */ + if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) { + fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i); + S_abnormal_exit(); + } + } +} + +void S_prim_init(void) { + if (!S_boot_time) return; + + create_library_entry_vector(); + create_c_entry_vector(); + + Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp); + Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated); + Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes); + Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes); + Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes); + Sforeign_symbol("(cs)do_gc", (void *)S_do_gc); + Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp); + Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap); + Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors); + Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry); + Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object); + Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry); + Sforeign_symbol("(cs)lock_object", (void *)Slock_object); + Sforeign_symbol("(cs)unlock_object", (void *)Sunlock_object); + Sforeign_symbol("(cs)locked_objectp", (void *)Slocked_objectp); + Sforeign_symbol("(cs)locked_objects", (void *)S_locked_objects); + Sforeign_symbol("(cs)maxgen", (void *)S_maxgen); + Sforeign_symbol("(cs)set_maxgen", (void *)S_set_maxgen); + Sforeign_symbol("(cs)minfreegen", (void *)S_minfreegen); + Sforeign_symbol("(cs)set_minfreegen", (void *)S_set_minfreegen); + Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts); + Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts); + Sforeign_symbol("(cs)object_counts", (void *)S_object_counts); + Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian); + Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector); +} + +static void s_instantiate_code_object(void) { + ptr tc = get_thread_context(); + ptr old, cookie, proc; + ptr new, oldreloc, newreloc; + ptr pinfos; + uptr a, m, n; + iptr i, size; + + old = S_get_scheme_arg(tc, 1); + cookie = S_get_scheme_arg(tc, 2); + proc = S_get_scheme_arg(tc, 3); + + tc_mutex_acquire() + new = S_code(tc, CODETYPE(old), CODELEN(old)); + tc_mutex_release() + + oldreloc = CODERELOC(old); + size = RELOCSIZE(oldreloc); + newreloc = S_relocation_table(size); + RELOCCODE(newreloc) = new; + for (i = 0; i < size; i += 1) RELOCIT(newreloc, i) = RELOCIT(oldreloc, i); + + CODERELOC(new) = newreloc; + CODENAME(new) = CODENAME(old); + CODEARITYMASK(new) = CODEARITYMASK(old); + CODEFREE(new) = CODEFREE(old); + CODEINFO(new) = CODEINFO(old); + CODEPINFOS(new) = pinfos = CODEPINFOS(old); + if (pinfos != Snil) { + S_G.profile_counters = Scons(S_weak_cons(new, pinfos), S_G.profile_counters); + } + + for (i = 0; i < CODELEN(old); i++) CODEIT(new,i) = CODEIT(old,i); + + m = RELOCSIZE(newreloc); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj; + entry = RELOCIT(newreloc, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(newreloc, n); n += 1; + code_off = RELOCIT(newreloc, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry), old, a, item_off); + + /* we've seen the enemy, and he is us */ + if (obj == old) obj = new; + + /* if we find our cookie, insert proc; otherwise, insert the object + into new to get proper adjustment of relative addresses */ + if (obj == cookie) + S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, proc, item_off); + else + S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, obj, item_off); + } + S_flush_instruction_cache(tc); + + AC0(tc) = new; +} + +static void s_link_code_object(ptr co, ptr objs) { + ptr t; uptr a, m, n; + + t = CODERELOC(co); + m = RELOCSIZE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off); + objs = Scdr(objs); + } +} + +static INT s_check_heap_enabledp(void) { + return S_checkheap; +} + +static void s_enable_check_heap(IBOOL b) { + S_checkheap = b; +} + +static uptr s_check_heap_errors(void) { + return S_checkheap_errors; +} diff --git a/c/prim5.c b/c/prim5.c new file mode 100644 index 0000000..f552e74 --- /dev/null +++ b/c/prim5.c @@ -0,0 +1,2052 @@ +/* prim5.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" +#include "sort.h" + +#include +#include +#include +#include +#include + +/* locally defined functions */ +static INT s_errno(void); +static iptr s_addr_in_heap(uptr x); +static iptr s_ptr_in_heap(ptr x); +static ptr s_generation(ptr x); +static iptr s_fxmul(iptr x, iptr y); +static iptr s_fxdiv(iptr x, iptr y); +static ptr s_trunc_rem(ptr x, ptr y); +static ptr s_fltofx(ptr x); +static ptr s_weak_pairp(ptr p); +static ptr s_ephemeron_cons(ptr car, ptr cdr); +static ptr s_ephemeron_pairp(ptr p); +static ptr s_oblist(void); +static ptr s_bigoddp(ptr n); +static ptr s_float(ptr x); +static ptr s_decode_float(ptr x); +#ifdef segment_t2_bits +static void s_show_info(FILE *out); +#endif +static void s_show_chunks(FILE *out, ptr sorted_chunks); +static ptr sort_chunks(ptr ls, uptr n); +static ptr merge_chunks(ptr ls1, ptr ls2); +static ptr sorted_chunk_list(void); +static void s_showalloc(IBOOL show_dump, const char *outfn); +static ptr s_system(const char *s); +static ptr s_process(char *s, IBOOL stderrp); +static I32 s_chdir(const char *inpath); +static char *s_getwd(void); +static ptr s_set_code_byte(ptr p, ptr n, ptr x); +static ptr s_set_code_word(ptr p, ptr n, ptr x); +static ptr s_set_code_long(ptr p, ptr n, ptr x); +static void s_set_code_long2(ptr p, ptr n, ptr h, ptr l); +static ptr s_set_code_quad(ptr p, ptr n, ptr x); +static ptr s_set_reloc(ptr p, ptr n, ptr e); +static ptr s_flush_instruction_cache(void); +static ptr s_make_code(iptr flags, iptr free, ptr name, ptr arity_mark, iptr n, ptr info, ptr pinfos); +static ptr s_make_reloc_table(ptr codeobj, ptr n); +static ptr s_make_closure(ptr offset, ptr codeobj); +static ptr s_fxrandom(ptr n); +static ptr s_flrandom(ptr x); +static U32 s_random_seed(void); +static void s_set_random_seed(U32 x); +static ptr s_intern(ptr x); +static ptr s_intern2(ptr x, ptr n); +static ptr s_strings_to_gensym(ptr pname_str, ptr uname_str); +static ptr s_intern3(ptr x, ptr n, ptr m); +static ptr s_delete_file(const char *inpath); +static ptr s_delete_directory(const char *inpath); +static ptr s_rename_file(const char *inpath1, const char *inpath2); +static ptr s_mkdir(const char *inpath, INT mode); +static ptr s_chmod(const char *inpath, INT mode); +static ptr s_getmod(const char *inpath, IBOOL followp); +static ptr s_path_atime(const char *inpath, IBOOL followp); +static ptr s_path_ctime(const char *inpath, IBOOL followp); +static ptr s_path_mtime(const char *inpath, IBOOL followp); +static ptr s_fd_atime(INT fd); +static ptr s_fd_ctime(INT fd); +static ptr s_fd_mtime(INT fd); +static IBOOL s_fd_regularp(INT fd); +static void s_nanosleep(ptr sec, ptr nsec); +static ptr s_set_collect_trip_bytes(ptr n); +static void c_exit(I32 status); +static ptr s_get_reloc(ptr co); +#ifdef PTHREADS +static s_thread_rv_t s_backdoor_thread_start(void *p); +static iptr s_backdoor_thread(ptr p); +static ptr s_threads(void); +static void s_mutex_acquire(scheme_mutex_t *m); +static ptr s_mutex_acquire_noblock(scheme_mutex_t *m); +static void s_condition_broadcast(s_thread_cond_t *c); +static void s_condition_signal(s_thread_cond_t *c); +#endif +static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); +static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); +static ptr s_tlv(ptr x); +static void s_stlv(ptr x, ptr v); +static void s_test_schlib(void); +static void s_breakhere(ptr x); +static IBOOL s_interactivep(void); +static IBOOL s_same_devicep(INT fd1, INT fd2); +static uptr s_malloc(iptr n); +static void s_free(uptr n); +#ifdef FEATURE_ICONV +static ptr s_iconv_open(const char *tocode, const char *fromcode); +static void s_iconv_close(uptr cd); +static ptr s_iconv_from_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend); +static ptr s_iconv_to_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend); +#endif +#ifdef WIN32 +static ptr s_multibytetowidechar(unsigned cp, ptr inbv); +static ptr s_widechartomultibyte(unsigned cp, ptr inbv); +#endif +static ptr s_profile_counters(void); +static ptr s_profile_release_counters(void); + +#define require(test,who,msg,arg) if (!(test)) S_error1(who, msg, arg) + +ptr S_strerror(INT errnum) { + ptr p; char *msg; + + tc_mutex_acquire() +#ifdef WIN32 + msg = Swide_to_utf8(_wcserror(errnum)); + if (msg == NULL) + p = Sfalse; + else { + p = Sstring_utf8(msg, -1); + free(msg); + } +#else + p = (msg = strerror(errnum)) == NULL ? Sfalse : Sstring_utf8(msg, -1); +#endif + tc_mutex_release() + return p; +} + +static INT s_errno(void) { + return errno; +} + +static iptr s_addr_in_heap(uptr x) { + return MaybeSegInfo(addr_get_segment(x)) != NULL; +} + +static iptr s_ptr_in_heap(ptr x) { + return MaybeSegInfo(ptr_get_segment(x)) != NULL; +} + +static ptr s_generation(ptr x) { + seginfo *si = MaybeSegInfo(ptr_get_segment(x)); + return si == NULL ? Sfalse : FIX(si->generation); +} + +static iptr s_fxmul(iptr x, iptr y) { + return x * y; +} + +static iptr s_fxdiv(iptr x, iptr y) { + return x / y; +} + +static ptr s_trunc_rem(ptr x, ptr y) { + ptr q, r; + S_trunc_rem(get_thread_context(), x, y, &q, &r); + return Scons(q, r); +} + +static ptr s_fltofx(ptr x) { + return FIX((iptr)FLODAT(x)); +} + +static ptr s_weak_pairp(ptr p) { + seginfo *si; + return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_weakpair ? Strue : Sfalse; +} + +static ptr s_ephemeron_cons(ptr car, ptr cdr) { + ptr p; + + tc_mutex_acquire() + p = S_cons_in(space_ephemeron, 0, car, cdr); + tc_mutex_release() + return p; +} + +static ptr s_ephemeron_pairp(ptr p) { + seginfo *si; + return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_ephemeron ? Strue : Sfalse; +} + +static ptr s_oblist(void) { + ptr ls = Snil; + iptr idx = S_G.oblist_length; + bucket *b; + + while (idx-- != 0) { + for (b = S_G.oblist[idx]; b != NULL; b = b->next) { + ls = Scons(b->sym, ls); + } + } + + return ls; +} + +static ptr s_bigoddp(ptr n) { + return Sboolean(BIGIT(n, BIGLEN(n) - 1) & 1); /* last bigit */; +} + +static ptr s_float(ptr x) { + return Sflonum(S_floatify(x)); +} + +static ptr s_decode_float(ptr x) { + require(Sflonump(x),"decode-float","~s is not a float",x); + return S_decode_float(FLODAT(x)); +} + +#define FMTBUFSIZE 120 +#define CHUNKADDRLT(x, y) (((chunkinfo *)(Scar(x)))->addr < ((chunkinfo *)(Scar(y)))->addr) +mkmergesort(sort_chunks, merge_chunks, ptr, Snil, CHUNKADDRLT, INITCDR) + +static ptr sorted_chunk_list(void) { + chunkinfo *chunk; INT i, n = 0; ptr ls = Snil; + + for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { + for (chunk = (i == -1) ? S_chunks_full : S_chunks[i]; chunk != NULL; chunk = chunk->next) { + ls = Scons(chunk, ls); + n += 1; + } + } + + return sort_chunks(ls, n); +} + +#ifdef segment_t2_bits +static void s_show_info(FILE *out) { + void *max_addr = 0; + INT addrwidth; + const char *addrtitle = "address"; + char fmtbuf[FMTBUFSIZE]; + uptr i2; +#ifdef segment_t3_bits + INT byteswidth; + uptr i3; + for (i3 = 0; i3 < SEGMENT_T3_SIZE; i3 += 1) { + t2table *t2t = S_segment_info[i3]; + if (t2t != NULL) { + if ((void *)t2t > max_addr) max_addr = (void *)t2t; + for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) { + t1table *t1t = t2t->t2[i2]; + if (t1t != NULL) { + if ((void *)t1t > max_addr) max_addr = (void *)t1t; + } + } + } + } + addrwidth = snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_addr); + if (addrwidth < (INT)strlen(addrtitle)) addrwidth = (INT)strlen(addrtitle); + byteswidth = snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)(sizeof(t1table) > sizeof(t2table) ? sizeof(t1table) : sizeof(t2table))); + snprintf(fmtbuf, FMTBUFSIZE, "%%s %%-%ds %%-%ds\n\n", addrwidth, byteswidth); + fprintf(out, fmtbuf, "level", addrtitle, "bytes"); + snprintf(fmtbuf, FMTBUFSIZE, "%%-5d %%#0%dtx %%#0%dtx\n", addrwidth, byteswidth); + for (i3 = 0; i3 < SEGMENT_T3_SIZE; i3 += 1) { + t2table *t2t = S_segment_info[i3]; + if (t2t != NULL) { + fprintf(out, fmtbuf, 2, t2t, sizeof(t2table)); + for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) { + t1table *t1t = t2t->t2[i2]; + if (t1t != NULL) { + fprintf(out, fmtbuf, 1, (ptrdiff_t)t1t, (ptrdiff_t)sizeof(t1table)); + } + } + } + } +#else + for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) { + t1table *t1t = S_segment_info[i2]; + if (t1t != NULL) { + if ((void *)t1t > max_addr) max_addr = (void *)t1t; + } + } + addrwidth = 1 + snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_addr); + if (addrwidth < (INT)strlen(addrtitle) + 1) addrwidth = (INT)strlen(addrtitle) + 1; + snprintf(fmtbuf, FMTBUFSIZE, "%%s %%-%ds %%s\n\n", addrwidth); + fprintf(out, fmtbuf, "level", addrtitle, "bytes"); + snprintf(fmtbuf, FMTBUFSIZE, "%%-5d %%#0%dtx %%#tx\n", (ptrdiff_t)addrwidth); + for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) { + t1table *t1t = S_segment_info[i2]; + if (t1t != NULL) { + fprintf(out, fmtbuf, 1, (ptrdiff_t)t1t, (ptrdiff_t)sizeof(t1table)); + } + } +#endif +} +#endif + +static void s_show_chunks(FILE *out, ptr sorted_chunks) { + char fmtbuf[FMTBUFSIZE]; + chunkinfo *chunk; + void *max_addr = 0; + void *max_header_addr = 0; + iptr max_segs = 0; + INT addrwidth, byteswidth, headeraddrwidth, headerbyteswidth, segswidth, headerwidth; + const char *addrtitle = "address", *bytestitle = "bytes", *headertitle = "(+ header)"; + ptr ls; + + for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { + chunk = Scar(ls); + max_addr = chunk->addr; + if (chunk->segs > max_segs) max_segs = chunk->segs; + if ((void *)chunk > max_header_addr) max_header_addr = (void *)chunk; + } + + addrwidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_addr); + if (addrwidth < (INT)strlen(addrtitle)) addrwidth = (INT)strlen(addrtitle); + byteswidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)(max_segs * bytes_per_segment)); + if (byteswidth < (INT)strlen(bytestitle)) byteswidth = (INT)strlen(bytestitle); + headerbyteswidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)(sizeof(chunkinfo) + sizeof(seginfo) * max_segs)); + headeraddrwidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_header_addr); + segswidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%td", (ptrdiff_t)max_segs); + headerwidth = headerbyteswidth + headeraddrwidth + 13; + + snprintf(fmtbuf, FMTBUFSIZE, "%%-%ds %%-%ds %%-%ds %%s\n\n", addrwidth, byteswidth, headerwidth); + fprintf(out, fmtbuf, addrtitle, bytestitle, headertitle, "segments used"); + snprintf(fmtbuf, FMTBUFSIZE, "%%#0%dtx %%#0%dtx (+ %%#0%dtx bytes @ %%#0%dtx) %%%dtd of %%%dtd\n", + addrwidth, byteswidth, headerbyteswidth, headeraddrwidth, segswidth, segswidth); + for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { + chunk = Scar(ls); + fprintf(out, fmtbuf, (ptrdiff_t)chunk->addr, (ptrdiff_t)chunk->bytes, + (ptrdiff_t)(sizeof(chunkinfo) + sizeof(seginfo) * chunk->segs), + (ptrdiff_t)chunk, (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs); + } +} + +#define space_bogus (max_space + 1) +#define space_total (space_bogus + 1) +#define generation_total (static_generation + 1) +#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1) +static void s_showalloc(IBOOL show_dump, const char *outfn) { + FILE *out; + iptr count[generation_total+1][space_total+1]; + uptr bytes[generation_total+1][space_total+1]; + int i, column_size[generation_total+1]; + char fmtbuf[FMTBUFSIZE]; + static char *spacename[space_total+1] = { alloc_space_names, "bogus", "total" }; + static char spacechar[space_total+1] = { alloc_space_chars, '?', 't' }; + chunkinfo *chunk; seginfo *si; ISPC s; IGEN g; + ptr sorted_chunks; + + tc_mutex_acquire() + + if (outfn == NULL) { + out = stderr; + } else { +#ifdef WIN32 + wchar_t *outfnw = Sutf8_to_wide(outfn); + out = _wfopen(outfnw, L"w"); + free(outfnw); +#else + out = fopen(outfn, "w"); +#endif + if (out == NULL) { + ptr msg = S_strerror(errno); + if (msg != Sfalse) { + tc_mutex_release() + S_error2("fopen", "open of ~s failed: ~a", Sstring_utf8(outfn, -1), msg); + } else { + tc_mutex_release() + S_error1("fopen", "open of ~s failed", Sstring_utf8(outfn, -1)); + } + } + } + for (g = 0; g <= generation_total; INCRGEN(g)) + for (s = 0; s <= space_total; s++) + count[g][s] = bytes[g][s] = 0; + + for (g = 0; g <= static_generation; INCRGEN(g)) { + for (s = 0; s <= max_real_space; s++) { + /* add in bytes previously recorded */ + bytes[g][s] += S_G.bytes_of_space[g][s]; + /* add in bytes in active segments */ + if (S_G.next_loc[g][s] != FIX(0)) + bytes[g][s] += (char *)S_G.next_loc[g][s] - (char *)S_G.base_loc[g][s]; + } + } + + for (g = 0; g <= static_generation; INCRGEN(g)) { + for (s = 0; s <= max_real_space; s++) { + for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) { + count[g][s] += 1; + } + } + } + + for (g = 0; g < generation_total; INCRGEN(g)) { + for (s = 0; s < space_total; s++) { + count[g][space_total] += count[g][s]; + count[generation_total][s] += count[g][s]; + count[generation_total][space_total] += count[g][s]; + bytes[g][space_total] += bytes[g][s]; + bytes[generation_total][s] += bytes[g][s]; + bytes[generation_total][space_total] += bytes[g][s]; + } + } + + for (g = 0; g <= generation_total; INCRGEN(g)) { + if (count[g][space_total] != 0) { + int n = 1 + snprintf(fmtbuf, FMTBUFSIZE, "%td", (ptrdiff_t)count[g][space_total]); + column_size[g] = n < 8 ? 8 : n; + } + } + + fprintf(out, "Segments per space & generation:\n\n"); + fprintf(out, "%8s", ""); + for (g = 0; g <= generation_total; INCRGEN(g)) { + if (count[g][space_total] != 0) { + if (g == generation_total) { + /* coverity[uninit_use] */ + snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]); + fprintf(out, fmtbuf, "total"); + } else if (g == static_generation) { + /* coverity[uninit_use] */ + snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]); + fprintf(out, fmtbuf, "static"); + } else { + /* coverity[uninit_use] */ + snprintf(fmtbuf, FMTBUFSIZE, "%%%dd", column_size[g]); + fprintf(out, fmtbuf, g); + } + } + } + fprintf(out, "\n"); + for (s = 0; s <= space_total; s++) { + if (s != space_empty) { + if (count[generation_total][s] != 0) { + fprintf(out, "%7s:", spacename[s]); + for (g = 0; g <= generation_total; INCRGEN(g)) { + if (count[g][space_total] != 0) { + /* coverity[uninit_use] */ + snprintf(fmtbuf, FMTBUFSIZE, "%%%dtd", column_size[g]); + fprintf(out, fmtbuf, (ptrdiff_t)(count[g][s])); + } + } + fprintf(out, "\n"); + fprintf(out, "%8s", ""); + for (g = 0; g <= generation_total; INCRGEN(g)) { + if (count[g][space_total] != 0) { + if (count[g][s] != 0 && s <= max_real_space) { + /* coverity[uninit_use] */ + snprintf(fmtbuf, FMTBUFSIZE, "%%%dd%%%%", column_size[g] - 1); + fprintf(out, fmtbuf, + (int)(((double)bytes[g][s] / + ((double)count[g][s] * bytes_per_segment)) * 100.0)); + } else { + /* coverity[uninit_use] */ + snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]); + fprintf(out, fmtbuf, ""); + } + } + } + fprintf(out, "\n"); + } + } + } + + fprintf(out, "segment size = %#tx bytes. percentages show the portion actually occupied.\n", (ptrdiff_t)bytes_per_segment); + fprintf(out, "%td segments are presently reserved for future allocation or collection.\n", (ptrdiff_t)S_G.number_of_empty_segments); + + fprintf(out, "\nMemory chunks obtained and not returned to the O/S:\n\n"); + sorted_chunks = sorted_chunk_list(); + s_show_chunks(out, sorted_chunks); + +#ifdef segment_t2_bits + fprintf(out, "\nDynamic memory occupied by segment info table:\n\n"); + s_show_info(out); +#endif + + fprintf(out, "\nAdditional memory might be used by C libraries and programs in the\nsame address space.\n"); + + if (show_dump) { + iptr max_seg = 0; + int segwidth, segsperline; + iptr next_base = 0; + int segsprinted = 0; + char spaceline[100], genline[100]; + ptr ls; + + for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { + iptr last_seg; + chunk = Scar(ls); + last_seg = chunk->base + chunk->segs; + if (last_seg > max_seg) max_seg = last_seg; + } + + segwidth = snprintf(fmtbuf, FMTBUFSIZE, "%#tx ", (ptrdiff_t)max_seg); + segsperline = (99 - segwidth) & ~0xf; + + snprintf(fmtbuf, FMTBUFSIZE, " %%-%ds", segwidth); + snprintf(genline, 100, fmtbuf, ""); + + fprintf(out, "\nMap of occupied segments:\n"); + for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { + seginfo *si; ISPC real_s; + + chunk = Scar(ls); + + if (chunk->base != next_base && segsprinted != 0) { + for (;;) { + if (segsprinted == segsperline) { + fprintf(out, "\n%s", spaceline); + fprintf(out, "\n%s", genline); + break; + } + if (next_base == chunk->base) break; + spaceline[segwidth+segsprinted] = ' '; + genline[segwidth+segsprinted] = ' '; + segsprinted += 1; + next_base += 1; + } + } + + if (chunk->base > next_base && next_base != 0) { + fprintf(out, "\n-------- skipping %td segments --------", (ptrdiff_t)(chunk->base - next_base)); + } + + for (i = 0; i < chunk->segs; i += 1) { + if (segsprinted >= segsperline) segsprinted = 0; + + if (segsprinted == 0) { + if (i != 0) { + fprintf(out, "\n%s", spaceline); + fprintf(out, "\n%s", genline); + } + snprintf(fmtbuf, FMTBUFSIZE, "%%#0%dtx ", segwidth - 1); + snprintf(spaceline, 100, fmtbuf, (ptrdiff_t)(chunk->base + i)); + segsprinted = 0; + } + + si = &chunk->sis[i]; + real_s = si->space; + s = real_s & ~(space_locked | space_old); + if (s < 0 || s > max_space) s = space_bogus; + spaceline[segwidth+segsprinted] = + real_s & (space_locked | space_old) ? toupper(spacechar[s]) : spacechar[s]; + + g = si->generation; + genline[segwidth+segsprinted] = + (s == space_empty) ? '.' : + (g < 10) ? '0' + g : + (g < 36) ? 'A' + g - 10 : + (g == static_generation) ? '*' : '+'; + segsprinted += 1; + } + next_base = chunk->base + chunk->segs; + } + + if (segsprinted != 0) { + spaceline[segwidth+segsprinted] = 0; + genline[segwidth+segsprinted] = 0; + fprintf(out, "\n%s", spaceline); + fprintf(out, "\n%s", genline); + } + + fprintf(out, "\n\nSpaces:"); + for (s = 0; s < space_total; s += 1) + fprintf(out, "%s%c = %s", s % 5 == 0 ? "\n " : "\t", + spacechar[s], spacename[s]); + fprintf(out, "\n\nGenerations:\n 0-9: 0<=g<=9; A-Z: 10<=g<=35; +: g>=36; *: g=static; .: empty\n\n"); + } + + if (outfn == NULL) { + fflush(out); + } else { + fclose(out); + } + + tc_mutex_release() +} + +#include +#ifdef WIN32 +#include +#include +#include +#include +#include +#else /* WIN32 */ +#include +#include +#endif /* WIN32 */ + +static ptr s_system(const char *s) { + INT status; +#ifdef PTHREADS + ptr tc = get_thread_context(); +#endif + +#ifdef PTHREADS + if (DISABLECOUNT(tc) == FIX(0)) deactivate_thread(tc); +#endif + status = SYSTEM(s); +#ifdef PTHREADS + if (DISABLECOUNT(tc) == FIX(0)) reactivate_thread(tc); +#endif + + if ((status == -1) && (errno != 0)) { + ptr msg = S_strerror(errno); + + if (msg != Sfalse) + S_error1("system", "~a", msg); + else + S_error("system", "subprocess execution failed"); + } + +#ifdef WIN32 + return Sinteger(status); +#else + if WIFEXITED(status) return Sinteger(WEXITSTATUS(status)); + if WIFSIGNALED(status) return Sinteger(-WTERMSIG(status)); + S_error("system", "cannot determine subprocess exit status"); + return 0 /* not reached */; +#endif /* WIN32 */ +} + +static ptr s_process(char *s, IBOOL stderrp) { + INT ifd = -1, ofd = -1, efd = -1, child = -1; + +#ifdef WIN32 + HANDLE hToRead, hToWrite, hFromRead, hFromWrite, hFromReadErr, hFromWriteErr, hProcess; + STARTUPINFOW si = {0}; + PROCESS_INFORMATION pi; + char *comspec; + char *buffer; + wchar_t* bufferw; + + /* Create non-inheritable pipes, important to eliminate zombee children + * when the parent sides are closed. */ + if (!CreatePipe(&hToRead, &hToWrite, NULL, 0)) + S_error("process", "cannot open pipes"); + if (!CreatePipe(&hFromRead, &hFromWrite, NULL, 0)) { + CloseHandle(hToRead); + CloseHandle(hToWrite); + S_error("process", "cannot open pipes"); + } + if (stderrp && !CreatePipe(&hFromReadErr, &hFromWriteErr, NULL, 0)) { + CloseHandle(hToRead); + CloseHandle(hToWrite); + CloseHandle(hFromRead); + CloseHandle(hFromWrite); + S_error("process", "cannot open pipes"); + } + + si.cb = sizeof(STARTUPINFO); + si.dwFlags = STARTF_USESTDHANDLES; + hProcess = GetCurrentProcess(); + + /* Duplicate the ToRead handle so that the child can inherit it. */ + if (!DuplicateHandle(hProcess, hToRead, hProcess, &si.hStdInput, + GENERIC_READ, TRUE, 0)) { + CloseHandle(hToRead); + CloseHandle(hToWrite); + CloseHandle(hFromRead); + CloseHandle(hFromWrite); + if (stderrp) { + CloseHandle(hFromReadErr); + CloseHandle(hFromWriteErr); + } + S_error("process", "cannot open pipes"); + } + CloseHandle(hToRead); + + /* Duplicate the FromWrite handle so that the child can inherit it. */ + if (!DuplicateHandle(hProcess, hFromWrite, hProcess, &si.hStdOutput, + GENERIC_WRITE, TRUE, 0)) { + CloseHandle(si.hStdInput); + CloseHandle(hToWrite); + CloseHandle(hFromRead); + CloseHandle(hFromWrite); + if (stderrp) { + CloseHandle(hFromReadErr); + CloseHandle(hFromWriteErr); + } + S_error("process", "cannot open pipes"); + } + CloseHandle(hFromWrite); + + if (stderrp) { + /* Duplicate the FromWrite handle so that the child can inherit it. */ + if (!DuplicateHandle(hProcess, hFromWriteErr, hProcess, &si.hStdError, + GENERIC_WRITE, TRUE, 0)) { + CloseHandle(si.hStdInput); + CloseHandle(hToWrite); + CloseHandle(hFromRead); + CloseHandle(hFromWrite); + CloseHandle(hFromReadErr); + CloseHandle(hFromWriteErr); + S_error("process", "cannot open pipes"); + } + CloseHandle(hFromWriteErr); + } else { + si.hStdError = si.hStdOutput; + } + + if ((comspec = Sgetenv("COMSPEC"))) { + size_t n = strlen(comspec) + strlen(s) + 7; + buffer = (char *)_alloca(n); + snprintf(buffer, n, "\"%s\" /c %s", comspec, s); + free(comspec); + } else + buffer = s; + bufferw = Sutf8_to_wide(buffer); + if (!CreateProcessW(NULL, bufferw, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) { + free(bufferw); + CloseHandle(si.hStdInput); + CloseHandle(hToWrite); + CloseHandle(hFromRead); + CloseHandle(si.hStdOutput); + if (stderrp) { + CloseHandle(hFromReadErr); + CloseHandle(si.hStdError); + } + S_error("process", "cannot spawn subprocess"); + } + free(bufferw); + CloseHandle(si.hStdInput); + CloseHandle(si.hStdOutput); + if (stderrp) { + CloseHandle(si.hStdError); + } + CloseHandle(pi.hProcess); + CloseHandle(pi.hThread); + + ifd = _open_osfhandle((intptr_t)hFromRead, 0); + ofd = _open_osfhandle((intptr_t)hToWrite, 0); + if (stderrp) { + efd = _open_osfhandle((intptr_t)hFromReadErr, 0); + } + child = pi.dwProcessId; + +#else /* WIN32 */ + + INT tofds[2], fromfds[2], errfds[2]; + struct sigaction act, oint_act; + + if (pipe(tofds)) S_error("process","cannot open pipes"); + if (pipe(fromfds)) { + CLOSE(tofds[0]); CLOSE(tofds[1]); + S_error("process","cannot open pipes"); + } + if (stderrp) { + if (pipe(errfds)) { + CLOSE(tofds[0]); CLOSE(tofds[1]); + CLOSE(fromfds[0]); CLOSE(fromfds[1]); + S_error("process","cannot open pipes"); + } + } + + sigemptyset(&act.sa_mask); + act.sa_flags = 0; + act.sa_handler = SIG_IGN; + sigaction(SIGINT, &act, &oint_act); + + if ((child = fork()) == 0) { + /* child does this: */ + CLOSE(0); if (dup(tofds[0]) != 0) _exit(1); + CLOSE(1); if (dup(fromfds[1]) != 1) _exit(1); + CLOSE(2); if (dup(stderrp ? errfds[1] : 1) != 2) _exit(1); + {INT i; for (i = 3; i < NOFILE; i++) (void)CLOSE(i);} + execl("/bin/sh", "/bin/sh", "-c", s, NULL); + _exit(1) /* only if execl fails */; + /*NOTREACHED*/ + } else { + /* parent does this: */ + CLOSE(tofds[0]); CLOSE(fromfds[1]); if (stderrp) CLOSE(errfds[1]); + if (child < 0) { + CLOSE(tofds[1]); CLOSE(fromfds[0]); if (stderrp) CLOSE(errfds[0]); + sigaction(SIGINT, &oint_act, (struct sigaction *)0); + S_error("process", "cannot fork subprocess"); + /*NOTREACHED*/ + } else { + ifd = fromfds[0]; + ofd = tofds[1]; + if (stderrp) efd = errfds[0]; + sigaction(SIGINT, &oint_act, (struct sigaction *)0); + S_register_child_process(child); + } + } +#endif /* WIN32 */ + + if (stderrp) + return LIST4(FIX(ifd), FIX(efd), FIX(ofd), FIX(child)); + else + return LIST3(FIX(ifd), FIX(ofd), FIX(child)); +} + +static I32 s_chdir(const char *inpath) { + char *path; + I32 status; + + path = S_malloc_pathname(inpath); +#ifdef EINTR + while ((status = CHDIR(path)) != 0 && errno == EINTR) ; +#else /* EINTR */ + status = CHDIR(path); +#endif /* EINTR */ + free(path); + return status; +} + +#ifdef GETWD +static char *s_getwd() { + return GETWD((char *)&BVIT(S_bytevector(PATH_MAX), 0)); +} +#endif /* GETWD */ + +static ptr s_set_code_byte(ptr p, ptr n, ptr x) { + I8 *a; + + a = (I8 *)((uptr)p + UNFIX(n)); + *a = (I8)UNFIX(x); + return Svoid; +} + +static ptr s_set_code_word(ptr p, ptr n, ptr x) { + I16 *a; + + a = (I16 *)((uptr)p + UNFIX(n)); + *a = (I16)UNFIX(x); + return Svoid; +} + +static ptr s_set_code_long(ptr p, ptr n, ptr x) { + I32 *a; + + a = (I32 *)((uptr)p + UNFIX(n)); + *a = (I32)(Sfixnump(x) ? UNFIX(x) : Sinteger_value(x)); + return Svoid; +} + +static void s_set_code_long2(ptr p, ptr n, ptr h, ptr l) { + I32 *a; + + a = (I32 *)((uptr)p + UNFIX(n)); + *a = (I32)((UNFIX(h) << 16) + UNFIX(l)); +} + +static ptr s_set_code_quad(ptr p, ptr n, ptr x) { + I64 *a; + + a = (I64 *)((uptr)p + UNFIX(n)); + *a = Sfixnump(x) ? UNFIX(x) : S_int64_value("\\#set-code-quad!", x); + return Svoid; +} + +static ptr s_set_reloc(ptr p, ptr n, ptr e) { + iptr *a; + + a = (iptr *)(&RELOCIT(CODERELOC(p), UNFIX(n))); + *a = Sfixnump(e) ? UNFIX(e) : Sinteger_value(e); + return e; +} + +static ptr s_flush_instruction_cache(void) { + tc_mutex_acquire() + S_flush_instruction_cache(get_thread_context()); + tc_mutex_release() + return Svoid; +} + +static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) + iptr flags, free, n; ptr name, arity_mark, info, pinfos; { + ptr co; + + tc_mutex_acquire() + co = S_code(get_thread_context(), type_code | (flags << code_flags_offset), n); + tc_mutex_release() + CODEFREE(co) = free; + CODENAME(co) = name; + CODEARITYMASK(co) = arity_mark; + CODEINFO(co) = info; + CODEPINFOS(co) = pinfos; + if (pinfos != Snil) { + S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); + } + return co; +} + +static ptr s_make_reloc_table(ptr codeobj, ptr n) { + CODERELOC(codeobj) = S_relocation_table(UNFIX(n)); + RELOCCODE(CODERELOC(codeobj)) = codeobj; + return Svoid; +} + +static ptr s_make_closure(ptr offset, ptr codeobj) { + + return S_closure((ptr)((iptr)codeobj + UNFIX(offset)), 0); +} + +/* the random formula is based on Knuth. It returns a random fixnum + * between 0 and n-1. + */ +static ptr s_fxrandom(ptr p) { + ptr tc = get_thread_context(); + uptr t, n = UNFIX(p); + + t = (RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) >> 16; + t = t | ((RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) & 0xffff0000); + if (n <= 0xffffffff) /* trivially true if sizeof(ptr) <= sizeof(U32) */ + return FIX(t % n); + else { + t = (t << 16) | ((RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) >> 16); + t = (t << 16) | ((RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) >> 16); + return FIX(t % n); + } +} + +static ptr s_flrandom(ptr x) { + ptr tc = get_thread_context(); + U32 t1, t2, t3, t4; + + t1 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387; + t2 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387; + t3 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387; + t4 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387; + return Sflonum(S_random_double(t1, t2, t3, t4, FLODAT(x))); +} + +static U32 s_random_seed() { + ptr tc = get_thread_context(); + return RANDOMSEED(tc); +} + +static void s_set_random_seed(U32 x) { + ptr tc = get_thread_context(); + RANDOMSEED(tc) = x; +} + +static ptr s_intern(ptr x) { + require(Sstringp(x),"string->symbol","~s is not a string",x); + + return S_intern_sc(&STRIT(x, 0), Sstring_length(x), x); +} + +static ptr s_intern2(ptr x, ptr n) { + return S_intern_sc(&STRIT(x, 0), UNFIX(n), Sfalse); +} + +/* first n chars str are pretty name; remaining m-n are unique name */ +static ptr s_intern3(ptr x, ptr n, ptr m) { + iptr plen = UNFIX(n); + return S_intern3(&STRIT(x, 0), plen, &STRIT(x, plen), UNFIX(m) - plen, Sfalse, Sfalse); +} + +static ptr s_strings_to_gensym(ptr pname_str, ptr uname_str) { + return S_intern3(&STRIT(pname_str, 0), Sstring_length(pname_str), + &STRIT(uname_str, 0), Sstring_length(uname_str), + pname_str, uname_str); +} + +static ptr s_mkdir(const char *inpath, INT mode) { + INT status; ptr res; char *path; + + path = S_malloc_pathname(inpath); +#ifdef WIN32 + status = S_windows_mkdir(path); +#else /* WIN32 */ + status = mkdir(path, mode); +#endif /* WIN32 */ + + res = status == 0 ? Strue : S_strerror(errno); + free(path); + return res; +} + +static ptr s_delete_file(const char *inpath) { + ptr res; char *path; + + path = S_malloc_pathname(inpath); + res = UNLINK(path) == 0 ? Strue : S_strerror(errno); + free(path); + return res; +} + +static ptr s_delete_directory(const char *inpath) { + ptr res; char *path; + + path = S_malloc_pathname(inpath); + res = RMDIR(path) == 0 ? Strue : S_strerror(errno); + free(path); + return res; +} + +static ptr s_rename_file(const char *inpath1, const char *inpath2) { + ptr res; char *path1, *path2; + + path1 = S_malloc_pathname(inpath1); + path2 = S_malloc_pathname(inpath2); + res = RENAME(path1, path2) == 0 ? Strue : S_strerror(errno); + free(path1); + free(path2); + return res; +} + +static ptr s_chmod(const char *inpath, INT mode) { + ptr res; INT status; char *path; + + path = S_malloc_pathname(inpath); +#ifdef WIN32 + /* pathetic approximation: (a) only handles user permissions, (b) doesn't + handle execute permissions, (c) windows won't make file not readable */ + status = CHMOD(path, + (mode & 0400 ? S_IREAD : 0) | + (mode & 0200 ? S_IWRITE : 0)); +#else /* WIN32 */ + status = CHMOD(path, mode); +#endif /* WIN32 */ + res = status == 0 ? Strue : S_strerror(errno); + free(path); + return res; +} + +static ptr s_getmod(const char *inpath, IBOOL followp) { + ptr res; char *path; struct STATBUF statbuf; + + path = S_malloc_pathname(inpath); + + /* according to msdn, user read/write bits are set according to the file's + permission mode, and user execute bits are set according to the + filename extension. it says nothing about group and other execute bits. */ + + if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) { + res = S_strerror(errno); + } else { + res = FIX(statbuf.st_mode & 07777); + } + free(path); + return res; +} + +static ptr s_path_atime(const char *inpath, IBOOL followp) { +#ifdef WIN32 + ptr res; + wchar_t *wpath; + WIN32_FILE_ATTRIBUTE_DATA filedata; + __int64 total, sec; int nsec; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + res = S_LastErrorString(); + } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) { + DWORD err = GetLastError(); + res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ? + Sstring("no such file or directory") : + S_LastErrorString(); + } else { + total = filedata.ftLastAccessTime.dwHighDateTime; + total <<= 32; + total |= filedata.ftLastAccessTime.dwLowDateTime; + sec = total / 10000000 - 11644473600L; + nsec = (total % 10000000) * 100; + res = Scons(Sinteger64(sec), Sinteger32(nsec)); + } + free(wpath); + return res; +#else /* WIN32 */ + ptr res; + char *path; + struct STATBUF statbuf; + + path = S_malloc_pathname(inpath); + if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) { + res = S_strerror(errno); + } else { + res = Scons(Sinteger64(SECATIME(statbuf)), Sinteger32(NSECATIME(statbuf))); + } + free(path); + return res; +#endif /* WIN32 */ +} + +static ptr s_path_ctime(const char *inpath, IBOOL followp) { +#ifdef WIN32 + ptr res; + wchar_t *wpath; + WIN32_FILE_ATTRIBUTE_DATA filedata; + __int64 total, sec; int nsec; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + res = S_LastErrorString(); + } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) { + DWORD err = GetLastError(); + res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ? + Sstring("no such file or directory") : + S_LastErrorString(); + } else { + total = filedata.ftLastWriteTime.dwHighDateTime; + total <<= 32; + total |= filedata.ftLastWriteTime.dwLowDateTime; + sec = total / 10000000 - 11644473600L; + nsec = (total % 10000000) * 100; + res = Scons(Sinteger64(sec), Sinteger32(nsec)); + } + free(wpath); + return res; +#else /* WIN32 */ + ptr res; + char *path; + struct STATBUF statbuf; + + path = S_malloc_pathname(inpath); + if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) { + res = S_strerror(errno); + } else { + res = Scons(Sinteger64(SECCTIME(statbuf)), Sinteger32(NSECCTIME(statbuf))); + } + free(path); + return res; +#endif /* WIN32 */ +} + +static ptr s_path_mtime(const char *inpath, IBOOL followp) { +#ifdef WIN32 + ptr res; + wchar_t *wpath; + WIN32_FILE_ATTRIBUTE_DATA filedata; + __int64 total, sec; int nsec; + + if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) { + res = S_LastErrorString(); + } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) { + DWORD err = GetLastError(); + res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ? + Sstring("no such file or directory") : + S_LastErrorString(); + } else { + total = filedata.ftLastWriteTime.dwHighDateTime; + total <<= 32; + total |= filedata.ftLastWriteTime.dwLowDateTime; + sec = total / 10000000 - 11644473600L; + nsec = (total % 10000000) * 100; + res = Scons(Sinteger64(sec), Sinteger32(nsec)); + } + free(wpath); + return res; +#else /* WIN32 */ + ptr res; + char *path; + struct STATBUF statbuf; + + path = S_malloc_pathname(inpath); + if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) { + res = S_strerror(errno); + } else { + res = Scons(Sinteger64(SECMTIME(statbuf)), Sinteger32(NSECMTIME(statbuf))); + } + free(path); + return res; +#endif /* WIN32 */ +} + +static ptr s_fd_atime(INT fd) { + struct STATBUF statbuf; + + if (FSTAT(fd, &statbuf) != 0) return S_strerror(errno); + + return Scons(Sinteger64(SECATIME(statbuf)), Sinteger32(NSECATIME(statbuf))); +} + +static ptr s_fd_ctime(INT fd) { + struct STATBUF statbuf; + + if (FSTAT(fd, &statbuf) != 0) return S_strerror(errno); + + return Scons(Sinteger64(SECCTIME(statbuf)), Sinteger32(NSECCTIME(statbuf))); +} + +static ptr s_fd_mtime(INT fd) { + struct STATBUF statbuf; + + if (FSTAT(fd, &statbuf) != 0) return S_strerror(errno); + + return Scons(Sinteger64(SECMTIME(statbuf)), Sinteger32(NSECMTIME(statbuf))); +} + +static IBOOL s_fd_regularp(INT fd) { + struct STATBUF statbuf; + + if (FSTAT(fd, &statbuf) != 0) return 0; + + return statbuf.st_mode & S_IFREG; +} + +static void s_nanosleep(ptr xsec, ptr xnsec) { + ptr tc = get_thread_context(); + U64 sec = Sunsigned64_value(xsec); + U32 nsec = Sunsigned32_value(xnsec); +#ifdef PTHREADS + if (DISABLECOUNT(tc) == 0) { + deactivate_thread(tc) + } +#endif /* PTHREADS */ + /* give up our lightweight thread "quanta" */ + if (DISABLECOUNT(tc) == 0) { + TRAP(get_thread_context()) = (ptr)1; + } +#ifdef WIN32 + /* round to nearest ms represented by sec and nsec */ + Sleep((DWORD)(sec * 1000 + (nsec + 500000) / 1000000)); +#else /* WIN32 */ + struct timespec rqtp; + rqtp.tv_sec = sec; + rqtp.tv_nsec = nsec; + nanosleep(&rqtp, NULL); +#endif /* WIN32 */ +#ifdef PTHREADS + if (DISABLECOUNT(tc) == 0) { + reactivate_thread(tc) + } +#endif /* PTHREADS */ +} + +static int s_getpid(void) { + return GETPID(); +} + +static ptr s_set_collect_trip_bytes(ptr n) { + S_G.collect_trip_bytes = Sunsigned_value(n); + return Svoid; +} + +static void c_exit(UNUSED I32 status) { + S_abnormal_exit(); +} + +static double s_mod(double x, double y) { return fmod(x, y); } + +static double s_exp(double x) { return exp(x); } + +static double s_log(double x) { return log(x); } + +#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb) +#include +/* freebsd's pow delivers precise results for integer inputs, e.g., + * 10.0^21.0, only with * extended-precision (80-bit) floats */ +static double s_pow(double x, double y) { + fp_prec_t p; + p = fpgetprec(); + if (p != FP_PE) { + double ans; + fpsetprec(FP_PE); + ans = pow(x, y); + fpsetprec(p); + return ans; + } else + return pow(x, y); +} +#elif defined(MACOSX) +/* intel macosx delivers precise results for integer inputs, e.g., + * 10.0^21.0, only with long double version of pow */ +static double s_pow(double x, double y) { return powl(x, y); } +#else /* i3fb/ti3fb */ +static double s_pow(double x, double y) { return pow(x, y); } +#endif /* i3fb/ti3fb */ + +static double s_sqrt(double x) { return sqrt(x); } + +static double s_sin(double x) { return sin(x); } + +static double s_cos(double x) { return cos(x); } + +static double s_tan(double x) { return tan(x); } + +static double s_asin(double x) { return asin(x); } + +static double s_acos(double x) { return acos(x); } + +static double s_atan(double x) { return atan(x); } + +static double s_atan2(double x, double y) { return atan2(x, y); } + +static double s_sinh(double x) { return sinh(x); } + +static double s_cosh(double x) { return cosh(x); } + +static double s_tanh(double x) { return tanh(x); } + +static double s_floor(double x) { return floor(x); } + +static double s_ceil(double x) { return ceil(x); } + +static double s_hypot(double x, double y) { return HYPOT(x, y); } + +#ifdef ARCHYPERBOLIC +static double s_asinh(double x) { return asinh(x); } + +static double s_acosh(double x){ return acosh(x); } + +static double s_atanh(double x) { return atanh(x); } +#endif /* ARCHHYPERBOLIC */ + +#ifdef LOG1P +static double s_log1p(double x) { return log1p(x); } +#endif /* LOG1P */ + +static ptr s_getenv(char *name) { +#ifdef WIN32 + char *s = Sgetenv(name); +#else /* WIN32 */ + char *s = getenv(name); +#endif /* WIN32 */ + if (s == (char *)0) + return Sfalse; + else { + ptr r = Sstring_utf8(s, -1); +#ifdef WIN32 + free(s); +#endif + return r; + } +} + +static void s_putenv(char *name, char *value) { +#ifdef WIN32 + wchar_t* namew; + wchar_t* valuew; + BOOL rc; + namew = Sutf8_to_wide(name); + valuew = Sutf8_to_wide(value); + rc = SetEnvironmentVariableW(namew, valuew); + free(namew); + free(valuew); + if (rc == 0) + S_error1("putenv", "environment extension failed: ~a", S_LastErrorString()); +#else /* WIN32 */ + if (setenv(name, value, 1) != 0) { + ptr msg = S_strerror(errno); + + if (msg != Sfalse) + S_error1("putenv", "environment extension failed: ~a", msg); + else + S_error("putenv", "environment extension failed"); + } +#endif /* WIN32 */ +} + +#ifdef PTHREADS +/* backdoor thread is for testing thread creation by Sactivate_thread */ +#define display(s) { const char *S = (s); if (WRITE(1, S, (unsigned int)strlen(S))) {} } +static s_thread_rv_t s_backdoor_thread_start(void *p) { + display("backdoor thread started\n") + (void) Sactivate_thread(); + display("thread activated\n") + Scall0((ptr)p); + (void) Sdeactivate_thread(); + display("thread deactivated\n") + (void) Sactivate_thread(); + display("thread reactivated\n") + Scall0((ptr)p); + Sdestroy_thread(); + display("thread destroyed\n") + s_thread_return; +} + +static iptr s_backdoor_thread(ptr p) { + display("creating thread\n"); + return s_thread_create(s_backdoor_thread_start, (void *)p); +} + +static ptr s_threads(void) { + return S_threads; +} + +static void s_mutex_acquire(scheme_mutex_t *m) { + ptr tc = get_thread_context(); + + if (m == &S_tc_mutex) { + S_mutex_acquire(m); + return; + } + + if (S_mutex_tryacquire(m) == 0) return; + + if (DISABLECOUNT(tc) == 0) { + deactivate_thread(tc) + } + S_mutex_acquire(m); + if (DISABLECOUNT(tc) == 0) { + reactivate_thread(tc) + } +} + +static ptr s_mutex_acquire_noblock(scheme_mutex_t *m) { + return S_mutex_tryacquire(m) == 0 ? Strue : Sfalse; +} + +static void s_condition_broadcast(s_thread_cond_t *c) { + s_thread_cond_broadcast(c); +} + +static void s_condition_signal(s_thread_cond_t *c) { + s_thread_cond_signal(c); +} +#endif + +static ptr s_profile_counters(void) { + return S_G.profile_counters; +} + +/* s_profile_release_counters assumes and maintains the property that each pair's + tail is not younger than the pair and thereby avoids dirty sets. */ +static ptr s_profile_release_counters(void) { + ptr tossed, *p_keep, *p_toss, ls; + p_keep = &S_G.profile_counters; + p_toss = &tossed; + for (ls = *p_keep; ls != Snil && (MaybeSegInfo(ptr_get_segment(ls)))->generation <= S_G.prcgeneration; ls = Scdr(ls)) { + if (Sbwp_objectp(CAAR(ls))) { + *p_toss = ls; + p_toss = &Scdr(ls); + } else { + *p_keep = ls; + p_keep = &Scdr(ls); + } + } + *p_keep = ls; + *p_toss = Snil; + S_G.prcgeneration = 0; + return tossed; +} + +void S_dump_tc(ptr tc) { + INT i; + + printf("AC0=%p AC1=%p SFP=%p CP=%p\n", AC0(tc), AC1(tc), SFP(tc), CP(tc)); + printf("ESP=%p AP=%p EAP=%p\n", ESP(tc), AP(tc), EAP(tc)); + printf("TRAP=%p XP=%p YP=%p REAL_EAP=%p\n", TRAP(tc), XP(tc), YP(tc), REAL_EAP(tc)); + printf("CCHAIN=%p RANDOMSEED=%ld SCHEMESTACK=%p STACKCACHE=%p\n", CCHAIN(tc), (long)RANDOMSEED(tc), SCHEMESTACK(tc), STACKCACHE(tc)); + printf("STACKLINK=%p SCHEMESTACKSIZE=%ld WINDERS=%p U=%p\n", STACKLINK(tc), (long)SCHEMESTACKSIZE(tc), WINDERS(tc), U(tc)); + printf("V=%p W=%p X=%p Y=%p\n", V(tc), W(tc), X(tc), Y(tc)); + printf("SOMETHING=%p KBDPEND=%p SIGPEND=%p TIMERTICKS=%p\n", SOMETHINGPENDING(tc), KEYBOARDINTERRUPTPENDING(tc), SIGNALINTERRUPTPENDING(tc), TIMERTICKS(tc)); + printf("DISABLECOUNT=%p PARAMETERS=%p\n", DISABLECOUNT(tc), PARAMETERS(tc)); + for (i = 0 ; i < virtual_register_count ; i += 1) { + printf("VIRTREG[%d]=%p", i, VIRTREG(tc, i)); + if ((i & 0x11) == 0x11 || i == virtual_register_count - 1) printf("\n"); + } + fflush(stdout); +} + +void S_prim5_init(void) { + if (!S_boot_time) return; + +#ifdef PTHREADS + Sforeign_symbol("(cs)fork_thread", (void *)S_fork_thread); + Sforeign_symbol("(cs)make_mutex", (void *)S_make_mutex); + Sforeign_symbol("(cs)mutex_free", (void *)S_mutex_free); + Sforeign_symbol("(cs)backdoor_thread", (void *)s_backdoor_thread); + Sforeign_symbol("(cs)threads", (void *)s_threads); + Sforeign_symbol("(cs)mutex_acquire", (void *)s_mutex_acquire); + Sforeign_symbol("(cs)mutex_release", (void *)S_mutex_release); + Sforeign_symbol("(cs)mutex_acquire_noblock", (void *)s_mutex_acquire_noblock); + Sforeign_symbol("(cs)make_condition", (void *)S_make_condition); + Sforeign_symbol("(cs)condition_free", (void *)S_condition_free); + Sforeign_symbol("(cs)condition_broadcast", (void *)s_condition_broadcast); + Sforeign_symbol("(cs)condition_signal", (void *)s_condition_signal); + Sforeign_symbol("(cs)condition_wait", (void *)S_condition_wait); +#endif + Sforeign_symbol("(cs)s_addr_in_heap", (void *)s_addr_in_heap); + Sforeign_symbol("(cs)s_ptr_in_heap", (void *)s_ptr_in_heap); + Sforeign_symbol("(cs)generation", (void *)s_generation); + Sforeign_symbol("(cs)s_fltofx", (void *)s_fltofx); + Sforeign_symbol("(cs)s_weak_cons", (void *)S_weak_cons); + Sforeign_symbol("(cs)s_weak_pairp", (void *)s_weak_pairp); + Sforeign_symbol("(cs)s_ephemeron_cons", (void *)s_ephemeron_cons); + Sforeign_symbol("(cs)s_ephemeron_pairp", (void *)s_ephemeron_pairp); + Sforeign_symbol("(cs)continuation_depth", (void *)S_continuation_depth); + Sforeign_symbol("(cs)single_continuation", (void *)S_single_continuation); + Sforeign_symbol("(cs)c_exit", (void *)c_exit); + Sforeign_symbol("(cs)s_set_collect_trip_bytes", (void *)s_set_collect_trip_bytes); + Sforeign_symbol("(cs)s_oblist", (void *)s_oblist); + Sforeign_symbol("(cs)s_showalloc", (void *)s_showalloc); + Sforeign_symbol("(cs)s_system", (void *)s_system); + Sforeign_symbol("(cs)s_process", (void *)s_process); + Sforeign_symbol("(cs)s_set_code_byte", (void *)s_set_code_byte); + Sforeign_symbol("(cs)s_set_code_word", (void *)s_set_code_word); + Sforeign_symbol("(cs)s_set_code_long", (void *)s_set_code_long); + Sforeign_symbol("(cs)s_set_code_quad", (void *)s_set_code_quad); + Sforeign_symbol("(cs)s_set_reloc", (void *)s_set_reloc); + Sforeign_symbol("(cs)get_code_obj", (void *)S_get_code_obj); + Sforeign_symbol("(cs)s_flush_instruction_cache", (void *)s_flush_instruction_cache); + Sforeign_symbol("(cs)s_make_reloc_table", (void *)s_make_reloc_table); + Sforeign_symbol("(cs)s_make_closure", (void *)s_make_closure); + Sforeign_symbol("(cs)s_intern", (void *)s_intern); + Sforeign_symbol("(cs)s_intern2", (void *)s_intern2); + Sforeign_symbol("(cs)s_intern3", (void *)s_intern3); + Sforeign_symbol("(cs)s_strings_to_gensym", (void *)s_strings_to_gensym); + Sforeign_symbol("(cs)s_intern_gensym", (void *)S_intern_gensym); + Sforeign_symbol("(cs)cputime", (void *)S_cputime); + Sforeign_symbol("(cs)realtime", (void *)S_realtime); + Sforeign_symbol("(cs)clock_gettime", (void *)S_clock_gettime); + Sforeign_symbol("(cs)gmtime", (void *)S_gmtime); + Sforeign_symbol("(cs)asctime", (void *)S_asctime); + Sforeign_symbol("(cs)mktime", (void *)S_mktime); + Sforeign_symbol("(cs)unique_id", (void *)S_unique_id); + Sforeign_symbol("(cs)file_existsp", (void *)S_file_existsp); + Sforeign_symbol("(cs)file_regularp", (void *)S_file_regularp); + Sforeign_symbol("(cs)file_directoryp", (void *)S_file_directoryp); + Sforeign_symbol("(cs)file_symbolic_linkp", (void *)S_file_symbolic_linkp); + Sforeign_symbol("(cs)delete_file", (void *)s_delete_file); + Sforeign_symbol("(cs)delete_directory", (void *)s_delete_directory); + Sforeign_symbol("(cs)rename_file", (void *)s_rename_file); + Sforeign_symbol("(cs)mkdir", (void *)s_mkdir); + Sforeign_symbol("(cs)chmod", (void *)s_chmod); + Sforeign_symbol("(cs)getmod", (void *)s_getmod); + Sforeign_symbol("(cs)path_atime", (void *)s_path_atime); + Sforeign_symbol("(cs)path_ctime", (void *)s_path_ctime); + Sforeign_symbol("(cs)path_mtime", (void *)s_path_mtime); + Sforeign_symbol("(cs)fd_atime", (void *)s_fd_atime); + Sforeign_symbol("(cs)fd_ctime", (void *)s_fd_ctime); + Sforeign_symbol("(cs)fd_mtime", (void *)s_fd_mtime); + Sforeign_symbol("(cs)fd_regularp", (void *)s_fd_regularp); + Sforeign_symbol("(cs)nanosleep", (void *)s_nanosleep); + Sforeign_symbol("(cs)getpid", (void *)s_getpid); + Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read); + Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read); + Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float); + + Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd); + Sforeign_symbol("(cs)new_open_output_fd", (void *)S_new_open_output_fd); + Sforeign_symbol("(cs)new_open_input_output_fd", (void *)S_new_open_input_output_fd); + Sforeign_symbol("(cs)close_fd", (void *)S_close_fd); + Sforeign_symbol("(cs)gzxfile_fd", (void *)S_gzxfile_fd); + Sforeign_symbol("(cs)compress_input_fd", (void *)S_compress_input_fd); + Sforeign_symbol("(cs)compress_output_fd", (void *)S_compress_output_fd); + + Sforeign_symbol("(cs)bytevector_read", (void*)S_bytevector_read); + Sforeign_symbol("(cs)bytevector_read_nb", (void*)S_bytevector_read_nb); + Sforeign_symbol("(cs)bytevector_write", (void*)S_bytevector_write); + Sforeign_symbol("(cs)put_byte", (void*)S_put_byte); + Sforeign_symbol("(cs)get_fd_pos", (void*)S_get_fd_pos); + Sforeign_symbol("(cs)set_fd_pos", (void*)S_set_fd_pos); + Sforeign_symbol("(cs)get_fd_non_blocking", (void*)S_get_fd_non_blocking); + Sforeign_symbol("(cs)set_fd_non_blocking", (void*)S_set_fd_non_blocking); + Sforeign_symbol("(cs)get_fd_length", (void*)S_get_fd_length); + Sforeign_symbol("(cs)set_fd_length", (void*)S_set_fd_length); + + Sforeign_symbol("(cs)bytevector_compress_size", (void*)S_bytevector_compress_size); + Sforeign_symbol("(cs)bytevector_compress", (void*)S_bytevector_compress); + Sforeign_symbol("(cs)bytevector_uncompress", (void*)S_bytevector_uncompress); + + Sforeign_symbol("(cs)logand", (void *)S_logand); + Sforeign_symbol("(cs)logbitp", (void *)S_logbitp); + Sforeign_symbol("(cs)logbit0", (void *)S_logbit0); + Sforeign_symbol("(cs)logbit1", (void *)S_logbit1); + Sforeign_symbol("(cs)logtest", (void *)S_logtest); + Sforeign_symbol("(cs)logor", (void *)S_logor); + Sforeign_symbol("(cs)logxor", (void *)S_logxor); + Sforeign_symbol("(cs)lognot", (void *)S_lognot); + Sforeign_symbol("(cs)fxmul", (void *)s_fxmul); + Sforeign_symbol("(cs)fxdiv", (void *)s_fxdiv); + Sforeign_symbol("(cs)s_big_negate", (void *)S_big_negate); + Sforeign_symbol("(cs)add", (void *)S_add); + Sforeign_symbol("(cs)gcd", (void *)S_gcd); + Sforeign_symbol("(cs)mul", (void *)S_mul); + Sforeign_symbol("(cs)s_ash", (void *)S_ash); + Sforeign_symbol("(cs)s_big_positive_bit_field", (void *)S_big_positive_bit_field); + Sforeign_symbol("(cs)s_big_eq", (void *)S_big_eq); + Sforeign_symbol("(cs)s_big_lt", (void *)S_big_lt); + Sforeign_symbol("(cs)s_bigoddp", (void *)s_bigoddp); + Sforeign_symbol("(cs)s_div", (void *)S_div); + Sforeign_symbol("(cs)s_float", (void *)s_float); + Sforeign_symbol("(cs)s_flrandom", (void *)s_flrandom); + Sforeign_symbol("(cs)s_fxrandom", (void *)s_fxrandom); + Sforeign_symbol("(cs)s_integer_length", (void *)S_integer_length); + Sforeign_symbol("(cs)s_big_first_bit_set", (void *)S_big_first_bit_set); + Sforeign_symbol("(cs)s_make_code", (void *)s_make_code); + Sforeign_symbol("(cs)s_random_seed", (void *)s_random_seed); + Sforeign_symbol("(cs)s_set_code_long2", (void *)s_set_code_long2); + Sforeign_symbol("(cs)s_set_random_seed", (void *)s_set_random_seed); + Sforeign_symbol("(cs)ss_trunc", (void *)S_trunc); + Sforeign_symbol("(cs)ss_trunc_rem", (void *)s_trunc_rem); + Sforeign_symbol("(cs)sub", (void *)S_sub); + Sforeign_symbol("(cs)rem", (void *)S_rem); +#ifdef GETWD + Sforeign_symbol("(cs)s_getwd", (void *)s_getwd); +#endif + Sforeign_symbol("(cs)s_chdir", (void *)s_chdir); +#ifdef WIN32 + Sforeign_symbol("(cs)find_files", (void *)S_find_files); +#else + Sforeign_symbol("(cs)directory_list", (void *)S_directory_list); +#endif + Sforeign_symbol("(cs)dequeue_scheme_signals", (void *)S_dequeue_scheme_signals); + Sforeign_symbol("(cs)register_scheme_signal", (void *)S_register_scheme_signal); + + Sforeign_symbol("(cs)mod", (void *)s_mod); + Sforeign_symbol("(cs)exp", (void *)s_exp); + Sforeign_symbol("(cs)log", (void *)s_log); + Sforeign_symbol("(cs)pow", (void *)s_pow); + Sforeign_symbol("(cs)sqrt", (void *)s_sqrt); + Sforeign_symbol("(cs)sin", (void *)s_sin); + Sforeign_symbol("(cs)cos", (void *)s_cos); + Sforeign_symbol("(cs)tan", (void *)s_tan); + Sforeign_symbol("(cs)asin", (void *)s_asin); + Sforeign_symbol("(cs)acos", (void *)s_acos); + Sforeign_symbol("(cs)atan", (void *)s_atan); + Sforeign_symbol("(cs)atan2", (void *)s_atan2); + Sforeign_symbol("(cs)sinh", (void *)s_sinh); + Sforeign_symbol("(cs)cosh", (void *)s_cosh); + Sforeign_symbol("(cs)tanh", (void *)s_tanh); + Sforeign_symbol("(cs)floor", (void *)s_floor); + Sforeign_symbol("(cs)ceil", (void *)s_ceil); + Sforeign_symbol("(cs)hypot", (void *)s_hypot); + +#ifdef ARCHYPERBOLIC + Sforeign_symbol("(cs)asinh", (void *)s_asinh); + Sforeign_symbol("(cs)acosh", (void *)s_acosh); + Sforeign_symbol("(cs)atanh", (void *)s_atanh); +#endif /* ARCHHYPERBOLIC */ + +#ifdef LOG1P + Sforeign_symbol("(cs)log1p", (void *)s_log1p); +#endif /* LOG1P */ + + Sforeign_symbol("(cs)s_get_reloc", (void *)s_get_reloc); + Sforeign_symbol("(cs)getenv", (void *)s_getenv); + Sforeign_symbol("(cs)putenv", (void *)s_putenv); + Sforeign_symbol("(cs)byte-copy", (void *)s_byte_copy); + Sforeign_symbol("(cs)ptr-copy", (void *)s_ptr_copy); + Sforeign_symbol("(cs)boot-error", (void *)S_boot_error); + Sforeign_symbol("(cs)s_tlv", (void *)s_tlv); + Sforeign_symbol("(cs)s_stlv", (void *)s_stlv); + Sforeign_symbol("(cs)s_test_schlib", (void *)s_test_schlib); + Sforeign_symbol("(cs)Sinteger_value", (void *)Sinteger_value); + Sforeign_symbol("(cs)Sinteger32_value", (void *)Sinteger32_value); + Sforeign_symbol("(cs)Sinteger64_value", (void *)Sinteger64_value); + Sforeign_symbol("(cs)s_breakhere", (void *)s_breakhere); + Sforeign_symbol("(cs)s_interactivep", (void *)s_interactivep); + Sforeign_symbol("(cs)same_devicep", (void *)s_same_devicep); + Sforeign_symbol("(cs)malloc", (void *)s_malloc); + Sforeign_symbol("(cs)free", (void *)s_free); +#ifdef FEATURE_ICONV + Sforeign_symbol("(cs)s_iconv_open", (void *)s_iconv_open); + Sforeign_symbol("(cs)s_iconv_close", (void *)s_iconv_close); + Sforeign_symbol("(cs)s_iconv_from_string", (void *)s_iconv_from_string); + Sforeign_symbol("(cs)s_iconv_to_string", (void *)s_iconv_to_string); +#endif + Sforeign_symbol("(cs)s_strerror", (void *)S_strerror); + Sforeign_symbol("(cs)s_errno", (void *)s_errno); +#ifdef WIN32 + Sforeign_symbol("(cs)s_multibytetowidechar", (void *)s_multibytetowidechar); + Sforeign_symbol("(cs)s_widechartomultibyte", (void *)s_widechartomultibyte); +#endif + Sforeign_symbol("(cs)s_profile_counters", (void *)s_profile_counters); + Sforeign_symbol("(cs)s_profile_release_counters", (void *)s_profile_release_counters); +} + +static ptr s_get_reloc(ptr co) { + ptr t, ls; uptr a, m, n; + + require(Scodep(co),"s_get_reloc","~s is not a code object",co); + ls = Snil; + t = CODERELOC(co); + m = RELOCSIZE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj; + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry), co, a, item_off); + if (!Sfixnump(obj)) { + ptr x; + for (x = ls; ; x = Scdr(x)) { + if (x == Snil) { + ls = Scons(obj,ls); + break; + } else if (Scar(x) == obj) + break; + } + } + } + return ls; +} + +static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) { + void *srcaddr = (void *)((iptr)src + srcoff); + void *dstaddr = (void *)((iptr)dst + dstoff); + if (dst != src) + memcpy(dstaddr, srcaddr, cnt); + else + memmove(dstaddr, srcaddr, cnt); +} + +static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) { + void *srcaddr = (void *)((iptr)src + srcoff); + void *dstaddr = (void *)((iptr)dst + dstoff); + cnt = cnt << log2_ptr_bytes; + if (dst != src) + memcpy(dstaddr, srcaddr, cnt); + else + memmove(dstaddr, srcaddr, cnt); +} + +/* these are used only for testing */ +static ptr s_tlv(ptr x) { + return Stop_level_value(x); +} + +static void s_stlv(ptr x, ptr v) { + Sset_top_level_value(x, v); +} + +#define SCHLIBTEST(expr) {\ + test += 1;\ + if (!(expr)) S_error1("s_test_schlib", "test ~s failed", FIX(test));\ +} + +static void s_test_schlib(void) { + INT test = 0; + I32 n1 = 0x73215609; + I64 n2 = n1 * 37; + I32 n3 = (I32)1<<31; + I64 n4 = (I64)1<<63; + I32 n5 = -1; + + SCHLIBTEST(Sinteger_value(Sinteger(n1)) == n1) + SCHLIBTEST(Sinteger_value(Sinteger(-n1)) == -n1) + SCHLIBTEST(Sinteger_value(Sunsigned(n1)) == n1) + SCHLIBTEST(Sinteger_value(Sunsigned(-n1)) == -n1) + SCHLIBTEST(Sinteger32_value(Sinteger32(n1)) == n1) + SCHLIBTEST(Sinteger32_value(Sinteger32(-n1)) == -n1) + SCHLIBTEST(Sinteger32_value(Sunsigned32(n1)) == n1) + SCHLIBTEST(Sinteger32_value(Sunsigned32(-n1)) == -n1) + SCHLIBTEST(Sinteger64_value(Sinteger64(n1)) == n1) + SCHLIBTEST(Sinteger64_value(Sinteger64(-n1)) == -n1) + SCHLIBTEST(Sinteger64_value(Sunsigned64(n1)) == n1) + SCHLIBTEST(Sinteger64_value(Sunsigned64(-n1)) == -n1) +#if (ptr_bits == 64) + SCHLIBTEST(Sinteger_value(Sinteger(n2)) == n2) + SCHLIBTEST(Sinteger_value(Sinteger(-n2)) == -n2) + SCHLIBTEST(Sinteger_value(Sunsigned(n2)) == n2) + SCHLIBTEST(Sinteger_value(Sunsigned(-n2)) == -n2) +#endif + SCHLIBTEST(Sinteger64_value(Sinteger64(n2)) == n2) + SCHLIBTEST(Sinteger64_value(Sinteger64(-n2)) == -n2) + SCHLIBTEST(Sinteger64_value(Sunsigned64(n2)) == n2) + SCHLIBTEST(Sinteger64_value(Sunsigned64(-n2)) == -n2) + + SCHLIBTEST(Sinteger_value(Sinteger(n3)) == n3) + SCHLIBTEST(Sinteger_value(Sunsigned(n3)) == n3) + SCHLIBTEST(Sinteger32_value(Sinteger32(n3)) == n3) + SCHLIBTEST(Sinteger32_value(Sunsigned32(n3)) == n3) + SCHLIBTEST(Sinteger64_value(Sinteger64(n3)) == n3) + SCHLIBTEST(Sinteger64_value(Sunsigned64(n3)) == n3) +#if (ptr_bits == 64) + SCHLIBTEST(Sinteger_value(Sunsigned(n4)) == n4) + SCHLIBTEST(Sinteger_value(Sinteger(n4)) == n4) + SCHLIBTEST(Sinteger_value(Sunsigned(n4)) == n4) +#endif + SCHLIBTEST(Sinteger64_value(Sinteger64(n4)) == n4) + SCHLIBTEST(Sinteger64_value(Sunsigned64(n4)) == n4) + + SCHLIBTEST(Sinteger_value(Sinteger(n5)) == n5) + SCHLIBTEST(Sinteger_value(Sinteger(-n5)) == -n5) + SCHLIBTEST(Sinteger_value(Sunsigned(n5)) == n5) + SCHLIBTEST(Sinteger_value(Sunsigned(-n5)) == -n5) + SCHLIBTEST(Sinteger32_value(Sinteger32(n5)) == n5) + SCHLIBTEST(Sinteger32_value(Sinteger32(-n5)) == -n5) + SCHLIBTEST(Sinteger32_value(Sunsigned32(n5)) == n5) + SCHLIBTEST(Sinteger32_value(Sunsigned32(-n5)) == -n5) + SCHLIBTEST(Sinteger64_value(Sinteger64(n5)) == n5) + SCHLIBTEST(Sinteger64_value(Sinteger64(-n5)) == -n5) + SCHLIBTEST(Sinteger64_value(Sunsigned64(n5)) == n5) + SCHLIBTEST(Sinteger64_value(Sunsigned64(-n5)) == -n5) +} + +/* place to break when debugging */ +static void s_breakhere(UNUSED ptr x) { + return; +} + +static IBOOL s_interactivep(void) { + static INT interactivep = -1; + if (interactivep == -1) { +#ifdef WIN32 + HANDLE hStdout, hStdin; + CONSOLE_SCREEN_BUFFER_INFO csbiInfo; + DWORD InMode, OutMode; + interactivep = + (hStdin = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE + && (hStdout = GetStdHandle(STD_OUTPUT_HANDLE)) != INVALID_HANDLE_VALUE + && GetConsoleScreenBufferInfo(hStdout, &csbiInfo) + && GetConsoleMode(hStdin, &InMode) + && GetConsoleMode(hStdout, &OutMode); +#else /* WIN32 */ + interactivep = isatty(0) && isatty(1); +#endif /* WIN32 */ + } + return interactivep; +} + +static IBOOL s_same_devicep(INT fd1, INT fd2) { +#ifdef WIN32 + HANDLE h1, h2; DWORD mode1, mode2; + if ((h1 = (HANDLE)_get_osfhandle(fd1)) != INVALID_HANDLE_VALUE) + if ((h2 = (HANDLE)_get_osfhandle(fd2)) != INVALID_HANDLE_VALUE) + switch (GetFileType(h1)) { + case FILE_TYPE_CHAR: + if (GetFileType(h2) == FILE_TYPE_CHAR) + return GetConsoleMode(h1, &mode1) && GetConsoleMode(h2, &mode2); + break; + case FILE_TYPE_DISK: + if (GetFileType(h2) == FILE_TYPE_DISK) { + BY_HANDLE_FILE_INFORMATION info1, info2; + if (GetFileInformationByHandle(h1, &info1) && GetFileInformationByHandle(h1, &info2)) + return info1.dwVolumeSerialNumber == info2.dwVolumeSerialNumber + && info1.nFileIndexHigh == info2.nFileIndexHigh + && info1.nFileIndexLow == info2.nFileIndexLow; + } + break; + case FILE_TYPE_PIPE: + /* no clue */ + break; + default: break; + } +#else /* WIN32 */ + struct STATBUF statbuf1, statbuf2; + if (FSTAT(fd1, &statbuf1) == 0 && FSTAT(fd2, &statbuf2) == 0) + return statbuf1.st_ino == statbuf2.st_ino; +#endif /* WIN32 */ + + return 0; +} + +static uptr s_malloc(iptr n) { + void *p; + if ((p = malloc((size_t)n)) == NULL) { + ptr msg = S_strerror(errno); + + if (msg != Sfalse) + S_error1("foreign-alloc", "~a", msg); + else + S_error("foreign-alloc", "malloc failed"); + } + return (uptr)p; +} + +static void s_free(uptr addr) { + free((void *)addr); +} + +#ifdef FEATURE_ICONV +#ifdef WIN32 +typedef void *iconv_t; +typedef __declspec(dllimport) iconv_t (*iconv_open_ft)(const char *tocode, const char *fromcode); +typedef __declspec(dllimport) size_t (*iconv_ft)(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft); +typedef __declspec(dllimport) int (*iconv_close_ft)(iconv_t cd); + +static iconv_open_ft iconv_open_f = (iconv_open_ft)0; +static iconv_ft iconv_f = (iconv_ft)0; +static iconv_close_ft iconv_close_f = (iconv_close_ft)0; +#define ICONV_OPEN iconv_open_f +#define ICONV iconv_f +#define ICONV_CLOSE iconv_close_f +#else +#include +#define ICONV_OPEN iconv_open +#define ICONV iconv +#define ICONV_CLOSE iconv_close +#endif + +#ifdef WIN32 +static ptr s_iconv_trouble(HMODULE h, const char *what) { + wchar_t dllw[PATH_MAX]; + char *dll; + size_t n; + char *msg; + ptr r; + if (0 != GetModuleFileNameW(h, dllw, PATH_MAX)) + dll = Swide_to_utf8(dllw); + else + dll = NULL; + FreeLibrary(h); + n = strlen(what) + strlen(dll) + 17; + msg = (char *)malloc(n); + sprintf_s(msg, n, "cannot find %s in %s", what, dll); + free(dll); + r = Sstring_utf8(msg, -1); + free(msg); + return r; +} +#endif /* WIN32 */ + +static ptr s_iconv_open(const char *tocode, const char *fromcode) { + iconv_t cd; +#ifdef WIN32 + static int iconv_is_loaded = 0; + if (!iconv_is_loaded) { + HMODULE h = LoadLibraryW(L"iconv.dll"); + if (h == NULL) h = LoadLibraryW(L"libiconv.dll"); + if (h == NULL) h = LoadLibraryW(L"libiconv-2.dll"); + if (h == NULL) h = LoadLibraryW(L".\\iconv.dll"); + if (h == NULL) h = LoadLibraryW(L".\\libiconv.dll"); + if (h == NULL) h = LoadLibraryW(L".\\libiconv-2.dll"); + if (h == NULL) return Sstring("cannot load iconv.dll, libiconv.dll, or libiconv-2.dll"); + if ((iconv_open_f = (iconv_open_ft)GetProcAddress(h, "iconv_open")) == NULL && + (iconv_open_f = (iconv_open_ft)GetProcAddress(h, "libiconv_open")) == NULL) + return s_iconv_trouble(h, "iconv_open or libiconv_open"); + if ((iconv_f = (iconv_ft)GetProcAddress(h, "iconv")) == NULL && + (iconv_f = (iconv_ft)GetProcAddress(h, "libiconv")) == NULL) + return s_iconv_trouble(h, "iconv or libiconv"); + if ((iconv_close_f = (iconv_close_ft)GetProcAddress(h, "iconv_close")) == NULL && + (iconv_close_f = (iconv_close_ft)GetProcAddress(h, "libiconv_close")) == NULL) + return s_iconv_trouble(h, "iconv_close or libiconv_close"); + iconv_is_loaded = 1; + } +#endif /* WIN32 */ + + if ((cd = ICONV_OPEN(tocode, fromcode)) == (iconv_t)-1) return Sfalse; + + /* have to be able to cast to int, since iconv_open can return (iconv_t)-1 */ + return Sunsigned((uptr)cd); +} + +static void s_iconv_close(uptr cd) { + ICONV_CLOSE((iconv_t)cd); +} + +#define ICONV_BUFSIZ 400 + +static ptr s_iconv_from_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend) { + U32 buf[ICONV_BUFSIZ]; + char *inbuf, *outbuf; + size_t inbytesleft, outbytesleft; + uptr inmax, k, new_i, new_o; + + outbuf = (char *)&BVIT(out, o); + outbytesleft = oend - o; + + inmax = iend - i; + if (inmax > ICONV_BUFSIZ) inmax = ICONV_BUFSIZ; + if (inmax > outbytesleft) inmax = outbytesleft; + for (k = 0; k < inmax; k += 1) buf[k] = Sstring_ref(in, i + k); + + inbuf = (char *)buf; + inbytesleft = inmax * sizeof(string_char); + + /* we ignore the iconv return value because we consider success to be the consumption + of input or production of output. we set errno to 0 before calling iconv, even though + it should be set properly if neither input is consumed nor output is produced, because, + under Windows, the iconv dll might have been linked against a different C runtime + and might therefore set a different errno */ + errno = 0; + ICONV((iconv_t)cd, (ICONV_INBUF_TYPE)&inbuf, &inbytesleft, &outbuf, &outbytesleft); + new_i = i + inmax - inbytesleft / sizeof(string_char); + new_o = oend - outbytesleft; + if (new_i != i || new_o != o) return Scons(Sinteger(new_i), Sinteger(new_o)); + + switch (errno) { + case EILSEQ: return FIX(SICONV_INVALID); + case EINVAL: return FIX(SICONV_INCOMPLETE); + case E2BIG: return FIX(SICONV_NOROOM); + default: return FIX(SICONV_DUNNO); + } +} + +static ptr s_iconv_to_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend) { + U32 buf[ICONV_BUFSIZ]; + char *inbuf, *outbuf; + size_t inbytesleft, outbytesleft; + uptr outmax, k, new_i, new_o; + + inbuf = (char *)&BVIT(in, i); + inbytesleft = iend - i; + + outmax = oend - o; + if (outmax > ICONV_BUFSIZ) outmax = ICONV_BUFSIZ; + if (outmax > inbytesleft) outmax = inbytesleft; + + outbuf = (char *)buf; + outbytesleft = outmax * sizeof(string_char); + + /* see the comment about the iconv return value and errno in s_iconv_from_string */ + errno = 0; + ICONV((iconv_t)cd, (ICONV_INBUF_TYPE)&inbuf, &inbytesleft, &outbuf, &outbytesleft); + + outmax -= outbytesleft / sizeof(string_char); + for (k = 0; k < outmax; k += 1) Sstring_set(out, o + k, buf[k]); + new_i = iend - inbytesleft; + new_o = o + outmax; + if (new_i != i || new_o != o) return Scons(Sinteger(new_i), Sinteger(new_o)); + + switch (errno) { + case EILSEQ: return FIX(SICONV_INVALID); + case EINVAL: return FIX(SICONV_INCOMPLETE); + case E2BIG: return FIX(SICONV_NOROOM); + default: return FIX(SICONV_DUNNO); + } +} +#endif /* FEATURE_ICONV */ + +#ifdef WIN32 +static ptr s_multibytetowidechar(unsigned cp, ptr inbv) { + uptr inbytes; int outwords; ptr outbv; + + inbytes = Sbytevector_length(inbv); + +#if (ptr_bits > int_bits) + if ((int)inbytes != inbytes) S_error1("multibyte->string", "input size ~s is beyond MultiByteToWideChar's limit", Sinteger(inbytes)); +#endif + + if ((outwords = MultiByteToWideChar(cp, 0, &BVIT(inbv,0), (int)inbytes, NULL, 0)) == 0) + S_error1("multibyte->string", "conversion failed: ~a", S_LastErrorString()); + + outbv = S_bytevector(outwords * 2); + + if (MultiByteToWideChar(cp, 0, &BVIT(inbv,0), (int)inbytes, (wchar_t *)&BVIT(outbv, 0), outwords) == 0) + S_error1("multibyte->string", "conversion failed: ~a", S_LastErrorString()); + + return outbv; +} + +static ptr s_widechartomultibyte(unsigned cp, ptr inbv) { + uptr inwords; int outbytes; ptr outbv; + + inwords = Sbytevector_length(inbv) / 2; + +#if (ptr_bits > int_bits) + if ((int)inwords != inwords) S_error1("multibyte->string", "input size ~s is beyond WideCharToMultiByte's limit", Sinteger(inwords)); +#endif + + if ((outbytes = WideCharToMultiByte(cp, 0, (wchar_t *)&BVIT(inbv,0), (int)inwords, NULL, 0, NULL, NULL)) == 0) + S_error1("string->multibyte", "conversion failed: ~a", S_LastErrorString()); + + outbv = S_bytevector(outbytes); + + if (WideCharToMultiByte(cp, 0, (wchar_t *)&BVIT(inbv,0), (int)inwords, &BVIT(outbv, 0), outbytes, NULL, NULL) == 0) + S_error1("string->multibyte", "conversion failed: ~a", S_LastErrorString()); + + return outbv; +} +#endif /* WIN32 */ diff --git a/c/print.c b/c/print.c new file mode 100644 index 0000000..2b7cac4 --- /dev/null +++ b/c/print.c @@ -0,0 +1,288 @@ +/* print.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +static void pimmediate(ptr x); +static void pbox(ptr x); +static void pclo(ptr x); +static void pcode(ptr x); +static void pcons(ptr x); +static void pfile(ptr x); +static void pinexactnum(ptr x); +static IBOOL exact_real_negativep(ptr x); +static void pexactnum(ptr x); +static void prat(ptr x); +static void pchar(ptr x); +static void pstr(ptr x); +static void psym(ptr x); +static void pvec(ptr x); +static void pfxvector(ptr x); +static void pbytevector(ptr x); +static void pflonum(ptr x); +static void pfixnum(ptr x); +static void pbignum(ptr x); +static void wrint(ptr x); + +void S_print_init(void) {} + +void S_prin1(ptr x) { + if (Simmediatep(x)) pimmediate(x); + else if (Spairp(x)) pcons(x); + else if (Ssymbolp(x)) psym(x); + else if (Sfixnump(x)) pfixnum(x); + else if (Sbignump(x)) pbignum(x); + else if (Sstringp(x)) pstr(x); + else if (Sratnump(x)) prat(x); + else if (Sflonump(x)) (void) pflonum(x); + else if (Sinexactnump(x)) pinexactnum(x); + else if (Sexactnump(x)) pexactnum(x); + else if (Svectorp(x)) pvec(x); + else if (Sfxvectorp(x)) pfxvector(x); + else if (Sbytevectorp(x)) pbytevector(x); + else if (Sboxp(x)) pbox(x); + else if (Sprocedurep(x)) pclo(x); + else if (Scodep(x)) pcode(x); + else if (Sportp(x)) pfile(x); + else if (Srecordp(x)) printf("#"); + else printf("#"); + fflush(stdout); +} + + +static void pimmediate(ptr x) { + if (Scharp(x)) pchar(x); + else if (x == Snil) printf("()"); + else if (x == Strue) printf("#t"); + else if (x == Sfalse) printf("#f"); + else if (x == Seof_object) printf("#!eof"); + else if (x == Sbwp_object) printf("#!bwp"); + else if (x == sunbound) printf("#"); + else if (x == Svoid) printf("#"); + else printf("#"); +} + +static void pbox(ptr x) { + printf("#&"); + S_prin1(Sunbox(x)); +} + +static void pclo(UNUSED ptr x) { + if (CODETYPE(CLOSCODE(x)) & (code_flag_continuation << code_flags_offset)) + printf("#"); + else + printf("#"); +} + +static void pcode(UNUSED ptr x) { + printf("#"); +} + +static void pcons(ptr x) { + putchar('('); + while (1) { + S_prin1(Scar(x)); + x = Scdr(x); + if (!Spairp(x)) break; + putchar(' '); + } + if (x!=Snil) { + printf(" . "); + S_prin1(x); + } + putchar(')'); +} + + +static void pfile(UNUSED ptr x) { + printf("#"); +} + +static void pinexactnum(ptr x) { + S_prin1(TYPE(&INEXACTNUM_REAL_PART(x),type_flonum)); + if (INEXACTNUM_IMAG_PART(x) >= 0.0) putchar('+'); + S_prin1(TYPE(&INEXACTNUM_IMAG_PART(x),type_flonum)); + putchar('i'); +} + +static IBOOL exact_real_negativep(ptr x) { + if (Sratnump(x)) x = RATNUM(x); + return Sfixnump(x) ? UNFIX(x) < 0 : BIGSIGN(x); +} + +static void pexactnum(ptr x) { + S_prin1(EXACTNUM_REAL_PART(x)); + if (!exact_real_negativep(EXACTNUM_IMAG_PART(x))) putchar('+'); + S_prin1(EXACTNUM_IMAG_PART(x)); + putchar('i'); +} + +static void prat(ptr x) { + wrint(RATNUM(x)); + putchar('/'); + wrint(RATDEN(x)); +} + +static void pchar(ptr x) { + int k = Schar_value(x); + if (k >= 256) k = '?'; + printf("#\\"); + putchar(k); +} + +static void pstr(ptr x) { + iptr i, n = Sstring_length(x); + + putchar('"'); + for (i = 0; i < n; i += 1) { + int k = Sstring_ref(x, i); + if (k >= 256) k = '?'; + if ((k == '\\') || (k == '"')) putchar('\\'); + putchar(k); + } + putchar('"'); +} + +static void display_string(ptr x) { + iptr i, n = Sstring_length(x); + + for (i = 0; i < n; i += 1) { + int k = Sstring_ref(x, i); + if (k >= 256) k = '?'; + putchar(k); + } +} + +static void psym(ptr x) { + ptr name = SYMNAME(x); + if (Sstringp(name)) { + display_string(name); + } else if (Spairp(name)) { + if (Scar(name) != Sfalse) { + printf("#{"); + display_string(Scdr(name)); + printf(" "); + display_string(Scar(name)); + printf("}"); + } else { + printf("#"); + } + } else { + printf("#"); + } +} + +static void pvec(ptr x) { + iptr n; + + putchar('#'); + n = Svector_length(x); + wrint(FIX(n)); + putchar('('); + if (n != 0) { + iptr i = 0; + + while (1) { + S_prin1(Svector_ref(x, i)); + if (++i == n) break; + putchar(' '); + } + } + putchar(')'); +} + +static void pfxvector(ptr x) { + iptr n; + + putchar('#'); + n = Sfxvector_length(x); + wrint(FIX(n)); + printf("vfx("); + if (n != 0) { + iptr i = 0; + + while (1) { + pfixnum(Sfxvector_ref(x, i)); + if (++i == n) break; + putchar(' '); + } + } + putchar(')'); +} + +static void pbytevector(ptr x) { + iptr n; + + putchar('#'); + n = Sbytevector_length(x); + wrint(FIX(n)); + printf("vu8("); + if (n != 0) { + iptr i = 0; + + while (1) { + pfixnum(FIX(Sbytevector_u8_ref(x, i))); + if (++i == n) break; + putchar(' '); + } + } + putchar(')'); +} + +static void pflonum(ptr x) { + char buf[256], *s; + + /* use snprintf to get it in a string */ + (void) snprintf(buf, 256, "%.16g",FLODAT(x)); + + /* print the silly thing */ + printf("%s", buf); + + /* add .0 if it looks like an integer */ + s = buf; + while (*s != 'E' && *s != 'e' && *s != '.') + if (*s++ == 0) { + printf(".0"); + break; + } +} + +static void pfixnum(ptr x) { + if (UNFIX(x) < 0) { + putchar('-'); + x = S_sub(FIX(0), x); + } + wrint(x); +} + +static void pbignum(ptr x) { + if (BIGSIGN(x)) { + putchar('-'); + x = S_sub(FIX(0), x); + } + wrint(x); +} + +static void wrint(ptr x) { + ptr q, r; + + S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r); + if (q != 0) wrint(q); + putchar((INT)UNFIX(r) + '0'); +} diff --git a/c/scheme.c b/c/scheme.c new file mode 100644 index 0000000..04f4c03 --- /dev/null +++ b/c/scheme.c @@ -0,0 +1,1273 @@ +/* scheme.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" +#include "config.h" +#include +#include +#ifdef WIN32 +#include +#else +#include +#endif +#include +#include + +#ifndef O_BINARY +#define O_BINARY 0 +#endif /* O_BINARY */ + +static INT boot_count; +static IBOOL verbose; + +typedef enum { UNINITIALIZED, BOOTING, RUNNING, DEINITIALIZED } heap_state; +static heap_state current_state = UNINITIALIZED; + +/***************************************************************************/ +/* INITIALIZATION SUPPORT */ + +/* locally defined functions */ +static void main_init(void); +static void idiot_checks(void); +static INT run_script(const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp); + +extern void scheme_include(void); + +static void main_init(void) { + ptr tc = get_thread_context(); + ptr p; + INT i; + + /* create dependency for linker */ + scheme_statics(); + + /* force thread inline allocation to go through find_room until ready */ + AP(tc) = (ptr)0; + EAP(tc) = (ptr)0; + REAL_EAP(tc) = (ptr)0; + /* set up dummy CP so locking in read/write/Scall won't choke */ + CP(tc) = Svoid; + CODERANGESTOFLUSH(tc) = Snil; + + if (S_boot_time) S_G.protect_next = 0; + + S_segment_init(); + S_alloc_init(); + S_thread_init(); + S_intern_init(); + S_gc_init(); + S_number_init(); + S_schsig_init(); + S_new_io_init(); + S_print_init(); + S_stats_init(); + S_foreign_init(); + S_prim_init(); + S_prim5_init(); + S_fasl_init(); + S_machine_init(); + S_flushcache_init(); /* must come after S_machine_init(); */ +#ifdef FEATURE_EXPEDITOR + S_expeditor_init(); +#endif /* FEATURE_EXPEDITOR */ + + if (!S_boot_time) return; + + S_protect(&S_G.profile_counters); + S_G.profile_counters = Snil; + + FXLENGTHBV(tc) = p = S_bytevector(256); + for (i = 0; i < 256; i += 1) { + BVIT(p, i) = + (iptr)FIX(i & 0x80 ? 8 : i & 0x40 ? 7 : i & 0x20 ? 6 : i & 0x10 ? 5 : + i & 0x08 ? 4 : i & 0x04 ? 3 : i & 0x02 ? 2 : i & 0x01 ? 1 : 0); + } + + FXFIRSTBITSETBV(tc) = p = S_bytevector(256); + for (i = 0; i < 256; i += 1) { + BVIT(p, i) = + (iptr)FIX(i & 0x01 ? 0 : i & 0x02 ? 1 : i & 0x04 ? 2 : i & 0x08 ? 3 : + i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0); + } + + NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector(); + NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector(); + NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector(); + NULLIMMUTABLESTRING(tc) = S_null_immutable_string(); + + PARAMETERS(tc) = S_G.null_vector; + for (i = 0 ; i < virtual_register_count ; i += 1) { + VIRTREG(tc, i) = FIX(0); + } + + p = S_code(tc, type_code, size_rp_header); + CODERELOC(p) = S_relocation_table(0); + CODENAME(p) = Sfalse; + CODEARITYMASK(p) = FIX(0); + CODEFREE(p) = 0; + CODEINFO(p) = Sfalse; + CODEPINFOS(p) = Snil; + RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0; + RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0; + RPHEADERTOPLINK(&CODEIT(p, 0)) = + (uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p; + S_protect(&S_G.dummy_code_object); + S_G.dummy_code_object = p; + + S_protect(&S_G.error_invoke_code_object); + S_G.error_invoke_code_object = Snil; + S_protect(&S_G.invoke_code_object); + S_G.invoke_code_object = Snil; + + S_protect(&S_G.active_threads_id); + S_G.active_threads_id = S_intern((const unsigned char *)"$active-threads"); + S_set_symbol_value(S_G.active_threads_id, FIX(0)); + + S_protect(&S_G.heap_reserve_ratio_id); + S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio"); + SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio)); + + S_protect(&S_G.scheme_version_id); + S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version"); + S_protect(&S_G.make_load_binary_id); + S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary"); + S_protect(&S_G.load_binary); + S_G.load_binary = Sfalse; +} + +static ptr fixtest = FIX(-1); + +static void idiot_checks(void) { + IBOOL oops = 0; + + if (bytes_per_segment < S_pagesize) { + fprintf(stderr, "bytes_per_segment (%x) < S_pagesize (%lx)\n", + bytes_per_segment, (long)S_pagesize); + oops = 1; + } + if (sizeof(iptr) != sizeof(ptr)) { + fprintf(stderr, "sizeof(iptr) [%ld] != sizeof(ptr) [%ld]\n", + (long)sizeof(iptr), (long)sizeof(ptr)); + oops = 1; + } + if (sizeof(uptr) != sizeof(ptr)) { + fprintf(stderr, "sizeof(uptr) [%ld] != sizeof(ptr) [%ld]\n", + (long)sizeof(uptr), (long)sizeof(ptr)); + oops = 1; + } + if (sizeof(ptr) * 8 != ptr_bits) { + fprintf(stderr, "sizeof(ptr) * 8 [%ld] != ptr_bits [%d]\n", + (long)sizeof(ptr), ptr_bits); + oops = 1; + } + if (sizeof(int) * 8 != int_bits) { + fprintf(stderr, "sizeof(int) * 8 [%ld] != int_bits [%d]\n", + (long)sizeof(int), int_bits); + oops = 1; + } + if (sizeof(short) * 8 != short_bits) { + fprintf(stderr, "sizeof(short) * 8 [%ld] != short_bits [%d]\n", + (long)sizeof(short), short_bits); + oops = 1; + } + if (sizeof(long) * 8 != long_bits) { + fprintf(stderr, "sizeof(long) * 8 [%ld] != long_bits [%d]\n", + (long)sizeof(long), long_bits); + oops = 1; + } +#ifndef WIN32 + if (sizeof(long long) * 8 != long_long_bits) { + fprintf(stderr, "sizeof(long long) * 8 [%ld] != long_long_bits [%d]\n", + (long)sizeof(long long), long_long_bits); + oops = 1; + } +#endif + if (sizeof(wchar_t) * 8 != wchar_bits) { + fprintf(stderr, "sizeof(wchar_t) * 8 [%ld] != wchar_bits [%d]\n", + (long)sizeof(wchar_t), wchar_bits); + oops = 1; + } + if (sizeof(size_t) * 8 != size_t_bits) { + fprintf(stderr, "sizeof(size_t) * 8 [%ld] != size_t_bits [%d]\n", + (long)sizeof(size_t), size_t_bits); + oops = 1; + } +#ifndef WIN32 + if (sizeof(ssize_t) * 8 != size_t_bits) { + fprintf(stderr, "sizeof(ssize_t) * 8 [%ld] != size_t_bits [%d]\n", + (long)sizeof(ssize_t), size_t_bits); + oops = 1; + } +#endif + if (sizeof(ptrdiff_t) * 8 != ptrdiff_t_bits) { + fprintf(stderr, "sizeof(ptrdiff_t) * 8 [%ld] != ptrdiff_t_bits [%d]\n", + (long)sizeof(ptrdiff_t), ptrdiff_t_bits); + oops = 1; + } + if (sizeof(time_t) * 8 != time_t_bits) { + fprintf(stderr, "sizeof(time_t) * 8 [%ld] != time_t_bits [%d]\n", + (long)sizeof(time_t), time_t_bits); + oops = 1; + } + if (sizeof(bigit) * 8 != bigit_bits) { + fprintf(stderr, "sizeof(bigit) * 8 [%ld] != bigit_bits [%d]\n", + (long)sizeof(bigit), bigit_bits); + oops = 1; + } + if (sizeof(bigitbigit) != 2 * sizeof(bigit)) { + fprintf(stderr, "sizeof(bigitbigit) [%ld] != sizeof(bigit) [%ld] * 2\n", + (long)sizeof(bigitbigit), (long)sizeof(bigit)); + oops = 1; + } + if (sizeof(char) != 1) { + fprintf(stderr, "sizeof(char) [%ld] != 1\n", (long)sizeof(char)); + oops = 1; + } + if (sizeof(I8) != 1) { + fprintf(stderr, "sizeof(I8) [%ld] != 1\n", (long)sizeof(I8)); + oops = 1; + } + if (sizeof(U8) != 1) { + fprintf(stderr, "sizeof(U8) [%ld] != 1\n", (long)sizeof(U8)); + oops = 1; + } + if (sizeof(I16) != 2) { + fprintf(stderr, "sizeof(I16) [%ld] != 2\n", (long)sizeof(I16)); + oops = 1; + } + if (sizeof(U16) != 2) { + fprintf(stderr, "sizeof(U16) [%ld] != 2\n", (long)sizeof(U16)); + oops = 1; + } + if (sizeof(I32) != 4) { + fprintf(stderr, "sizeof(I32) [%ld] != 4\n", (long)sizeof(I32)); + oops = 1; + } + if (sizeof(U32) != 4) { + fprintf(stderr, "sizeof(U32) [%ld] != 4\n", (long)sizeof(U32)); + oops = 1; + } + if (sizeof(I64) != 8) { + fprintf(stderr, "sizeof(I64) [%ld] != 8\n", (long)sizeof(I64)); + oops = 1; + } + if (sizeof(U64) != 8) { + fprintf(stderr, "sizeof(U64) [%ld] != 8\n", (long)sizeof(U64)); + oops = 1; + } + if (sizeof(string_char) != string_char_bytes) { + fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes); + oops = 1; + } + if (UNFIX(fixtest) != -1) { + fprintf(stderr, "UNFIX operation failed\n"); + oops = 1; + } + if (strlen(VERSION)+1 > HEAP_VERSION_LENGTH) { + fprintf(stderr, "insufficient space for version in heap header\n"); + oops = 1; + } + if (strlen(MACHINE_TYPE)+1 > HEAP_MACHID_LENGTH) { + fprintf(stderr, "insufficient space for machine id in heap header\n"); + oops = 1; + } +#define big 0 +#define little 1 + if (native_endianness == big) { + uptr x[1]; + *x = 1; + if (*(char *)x != 0) { + fprintf(stderr, "endianness claimed to be big, appears to be little\n"); + oops = 1; + } + } else { + uptr x[1]; + *x = 1; + if (*(char *)x == 0) { + fprintf(stderr, "endianness claimed to be little, appears to be big\n"); + oops = 1; + } + } + + if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) { + /* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */ + fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n"); + oops = 1; + } + + if ((cards_per_segment & (sizeof(iptr) - 1)) != 0) { + /* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */ + fprintf(stderr, "cards_per_segment is not a multiple of sizeof(iptr)\n"); + oops = 1; + } + if (((uptr)(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) { + /* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */ + fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n"); + oops = 1; + } + if (!Sfixnump(type_vector | ~mask_vector)) { + /* gc counts on vector type/length looking like a fixnum, so it can put vectors in space_impure */ + fprintf(stderr, "vector type/length field does not look like a fixnum\n"); + oops = 1; + } + + if (oops) S_abnormal_exit(); +} + +/***************************************************************************/ +/* SUPPORT FOR CALLING INTO SCHEME */ + +/* locally defined functions */ +static ptr boot_call(ptr tc, ptr p, INT n); +static void check_ap(ptr tc); + +/* arguments and ac0 set up */ +static ptr boot_call(ptr tc, ptr p, INT n) { + AC1(tc) = p; + CP(tc) = Svoid; /* don't have calling code object */ + + AC0(tc) = (ptr)(uptr)n; + S_call_help(tc, 0, 0); + check_ap(tc); + + CP(tc) = Svoid; /* leave clean so direct Scall won't choke */ + + switch ((iptr)AC1(tc)) { + case 1: + p = AC0(tc); + break; + case 0: + p = Svoid; + break; + default: + p = S_get_scheme_arg(tc, 1); + break; + } + return p; +} + +static void check_ap(ptr tc) { + if ((uptr)AP(tc) & (byte_alignment - 1)) { + (void) fprintf(stderr, "ap is not double word aligned\n"); + S_abnormal_exit(); + } + if ((ptr *)AP(tc) > (ptr *)EAP(tc)) { + (void) fprintf(stderr, "ap is greater than eap\n"); + S_abnormal_exit(); + } +} + +void S_generic_invoke(ptr tc, ptr code) { +#if defined(PPCAIX) + struct {caddr_t entry, toc, static_link;} hdr; + hdr.entry = (caddr_t)&CODEIT(code,0); + hdr.toc = (caddr_t)0; + hdr.static_link = (caddr_t)0; + (*((void (*)(ptr))(void *)&hdr))(tc); +#elif defined(PPCNT) + /* under NT, function headers contain no static link */ + struct {I32 entry, toc;} hdr; + typedef void (*ugly)(ptr); + ugly p; + hdr.entry = (I32)&CODEIT(code,0); + hdr.toc = (I32)0; + /* MSVC++ bombs with internal compiler error if we don't split this up */ + p = (ugly)&hdr; + p(tc); +#elif defined(PARISC) + struct {I32 entry, env;} hdr; + typedef void (*ugly)(ptr); + ugly p; + hdr.entry = (I32)&CODEIT(code,0); + hdr.env = (I32)0; + p = (ugly)((I32)&hdr + 2); + p(tc); +#elif defined(WIN32) && !defined(__MINGW32__) + __try { + (*((void (*)(ptr))(void *)&CODEIT(code,0)))(tc); + } + __except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ? + EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH) + { + if (S_pants_down) + S_error_abort("nonrecoverable invalid memory reference"); + else + S_error_reset("invalid memory reference"); + } +#else + (*((void (*)(ptr))(void *)&CODEIT(code,0)))(tc); +#endif +} + +/***************************************************************************/ +/* MISCELLANEOUS HELPERS */ + +/* locally defined functions */ +static IBOOL next_path(char *path, const char *name, const char *ext, const char **sp, const char **dsp); +static const char *path_last(const char *path); +static char *get_defaultheapdirs(void); + +static const char *path_last(p) const char *p; { + const char *s; +#ifdef WIN32 + char c; + + if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') + if (*(p + 1) == ':') + p += 2; +#endif + + for (s = p; *s != 0; s += 1) + if (DIRMARKERP(*s)) p = ++s; + return p; +} + +#ifdef WIN32 +#ifndef DEFAULT_HEAP_PATH +/* by default, look in executable directory or in parallel boot directory */ +#define DEFAULT_HEAP_PATH "%x;%x\\..\\..\\boot\\%m" +#endif +#define SEARCHPATHSEP ';' +#define PATHSEP '\\' + +static char *get_defaultheapdirs() { + char *result; + wchar_t buf[PATH_MAX]; + DWORD len = sizeof(buf); + if (ERROR_SUCCESS != RegGetValueW(HKEY_LOCAL_MACHINE, L"Software\\Chez Scheme\\csv" VERSION, L"HeapSearchPath", RRF_RT_REG_SZ, NULL, buf, &len)) + return DEFAULT_HEAP_PATH; + else if ((result = Swide_to_utf8(buf))) + return result; + else + return DEFAULT_HEAP_PATH; +} +#else /* not WIN32: */ +#define SEARCHPATHSEP ':' +#define PATHSEP '/' +#ifndef DEFAULT_HEAP_PATH +#define DEFAULT_HEAP_PATH "/usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m" +#endif + +static char *get_defaultheapdirs() { + return DEFAULT_HEAP_PATH; +} +#endif /* WIN32 */ + +/* next_path isolates the next entry in the two-part search path sp/dsp, + * leaving the full path with name affixed in path and *sp / *dsp pointing + * past the current entry. it returns 1 on success and 0 if at the end of + * the search path. path should be a pointer to an unoccupied buffer + * PATH_MAX characters long. either or both of sp/dsp may be empty, + * but neither may be null, i.e., (char *)0. */ +static IBOOL next_path(char *path, const char *name, const char *ext, + const char **sp, const char **dsp) { + char *p; + const char *s, *t; + +#define setp(c) if (p >= path + PATH_MAX) { fprintf(stderr, "search path entry too long\n"); S_abnormal_exit(); } else *p++ = (c) + for (;;) { + s = *sp; + p = path; + /* copy first searchpath entry into path, substituting MACHINE_TYPE for %m, + * VERSION for %v, % for %%, and : (; windows) for %: (%; windows) */ + while (*s != 0 && *s != SEARCHPATHSEP) { + switch (*s) { + case '%': + s += 1; + switch (*s) { +#ifdef WIN32 + case 'x': { + wchar_t exepath[PATH_MAX]; DWORD n; + s += 1; + n = GetModuleFileNameW(NULL, exepath, PATH_MAX); + if (n == 0 || (n == PATH_MAX && GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { + fprintf(stderr, "warning: executable path is too long; ignoring %%x\n"); + } else { + char *tstart; + const char *tend; + tstart = Swide_to_utf8(exepath); + t = tstart; + tend = path_last(t); + if (tend != t) tend -= 1; /* back up to directory separator */ + while (t != tend) setp(*t++); + free(tstart); + } + break; + } +#endif + case 'm': + s += 1; + t = MACHINE_TYPE; + while (*t != 0) setp(*t++); + break; + case 'v': + s += 1; + t = VERSION; + while (*t != 0) setp(*t++); + break; + case '%': + case SEARCHPATHSEP: + setp(*s++); + break; + default: + fprintf(stderr, "warning: ignoring extra %% in search path\n"); + break; + } + break; + default: + setp(*s++); + break; + } + } + + /* unless entry was null, append name and ext onto path and return true with + * updated path, sp, and possibly dsp */ + if (s != *sp) { + if ((p > path) && !DIRMARKERP(*(p - 1))) { setp(PATHSEP); } + t = name; + while (*t != 0) setp(*t++); + t = ext; + while (*t != 0) setp(*t++); + setp(0); + *sp = s; + return 1; + } + + /* if current segment is empty, move to next segment. if next segment + * is empty, return false */ + if (*s == 0) { + if (*(*sp = *dsp) == 0) return 0; + *dsp = ""; + } else { + *sp = s + 1; + } + } +#undef setp +} + +/***************************************************************************/ +/* BOOT FILES */ + +typedef struct { + INT fd; + char path[PATH_MAX]; +} boot_desc; + +#define MAX_BOOT_FILES 10 +static boot_desc bd[MAX_BOOT_FILES]; + +/* locally defined functions */ +static char get_u8(INT fd); +static uptr get_uptr(INT fd, uptr *pn); +static INT get_string(INT fd, char *s, iptr max, INT *c); +static IBOOL find_boot(const char *name, const char *ext, int fd, IBOOL errorp); +static void load(ptr tc, iptr n, IBOOL base); +static void check_boot_file_state(const char *who); + +static IBOOL find_boot(const char *name, const char *ext, int fd, IBOOL errorp) { + char pathbuf[PATH_MAX], buf[PATH_MAX]; + uptr n = 0; + INT c; + const char *path; + char *expandedpath; + + if ((fd != -1) || S_fixedpathp(name)) { + if (strlen(name) >= PATH_MAX) { + fprintf(stderr, "boot-file path is too long %s\n", name); + S_abnormal_exit(); + } + + path = name; + + if (fd == -1) { + expandedpath = S_malloc_pathname(path); + fd = OPEN(expandedpath, O_BINARY|O_RDONLY, 0); + free(expandedpath); + } + + if (fd == -1) { + if (errorp) { + fprintf(stderr, "cannot open boot file %s\n", path); + S_abnormal_exit(); + } else { + if (verbose) fprintf(stderr, "trying %s...cannot open\n", path); + return 0; + } + } + if (verbose) fprintf(stderr, "trying %s...opened\n", path); + + /* check for magic number */ + if (get_u8(fd) != fasl_type_header || + get_u8(fd) != 0 || + get_u8(fd) != 0 || + get_u8(fd) != 0 || + get_u8(fd) != 'c' || + get_u8(fd) != 'h' || + get_u8(fd) != 'e' || + get_u8(fd) != 'z') { + fprintf(stderr, "malformed fasl-object header in %s\n", path); + S_abnormal_exit(); + } + + /* check version */ + if (get_uptr(fd, &n) != 0) { + fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + + if (n != scheme_version) { + fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n)); + /* use separate fprintf since S_format_scheme_version returns static string */ + fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); + CLOSE(fd); + S_abnormal_exit(); + } + + /* check machine type */ + if (get_uptr(fd, &n) != 0) { + fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + + if (n != machine_type) { + fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, + S_lookup_machine_type(n), S_lookup_machine_type(machine_type)); + CLOSE(fd); + S_abnormal_exit(); + } + } else { + const char *sp = Sschemeheapdirs; + const char *dsp = Sdefaultheapdirs; + + path = pathbuf; + for (;;) { + if (!next_path(pathbuf, name, ext, &sp, &dsp)) { + if (errorp) { + fprintf(stderr, "cannot find compatible boot file %s%s in search path:\n \"%s%s\"\n", + name, ext, + Sschemeheapdirs, Sdefaultheapdirs); + S_abnormal_exit(); + } else { + if (verbose) fprintf(stderr, "no compatible %s%s found\n", name, ext); + return 0; + } + } + + expandedpath = S_malloc_pathname(path); + fd = OPEN(expandedpath, O_BINARY|O_RDONLY, 0); + free(expandedpath); + if (fd == -1) { + if (verbose) fprintf(stderr, "trying %s...cannot open\n", path); + continue; + } + + if (verbose) fprintf(stderr, "trying %s...opened\n", path); + + /* check for magic number */ + if (get_u8(fd) != fasl_type_header || + get_u8(fd) != 0 || + get_u8(fd) != 0 || + get_u8(fd) != 0 || + get_u8(fd) != 'c' || + get_u8(fd) != 'h' || + get_u8(fd) != 'e' || + get_u8(fd) != 'z') { + if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path); + CLOSE(fd); + continue; + } + + /* check version */ + if (get_uptr(fd, &n) != 0) { + if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + continue; + } + + if (n != scheme_version) { + if (verbose) { + fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n)); + /* use separate fprintf since S_format_scheme_version returns static string */ + fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); + } + CLOSE(fd); + continue; + } + + /* check machine type */ + if (get_uptr(fd, &n) != 0) { + if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + continue; + } + + if (n != machine_type) { + if (verbose) + fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, + S_lookup_machine_type(n), S_lookup_machine_type(machine_type)); + CLOSE(fd); + continue; + } + + break; + } + } + + if (verbose) fprintf(stderr, "version and machine type check\n"); + + if (get_u8(fd) != '(') { /* ) */ + fprintf(stderr, "malformed boot file %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + + /* ( */ + if ((c = get_u8(fd)) == ')') { + if (boot_count != 0) { + fprintf(stderr, "base boot file %s must come before other boot files\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + } else { + if (boot_count == 0) { + for (;;) { + /* try to load heap or boot file this boot file requires */ + if (get_string(fd, buf, PATH_MAX, &c) != 0) { + fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + if (find_boot(buf, ".boot", -1, 0)) break; + if (c == ')') { + char *sep; char *wastebuf[8]; + fprintf(stderr, "cannot find subordinate boot file"); + if (LSEEK(fd, 0, SEEK_SET) != 0 || READ(fd, wastebuf, 8) != 8) { /* attempt to rewind and read magic number */ + fprintf(stderr, "---retry with verbose flag for more information\n"); + CLOSE(fd); + S_abnormal_exit(); + } + (void) get_uptr(fd, &n); /* version */ + (void) get_uptr(fd, &n); /* machine type */ + (void) get_u8(fd); /* open paren */ + c = get_u8(fd); + for (sep = " "; ; sep = "or ") { + if (c == ')') break; + (void) get_string(fd, buf, PATH_MAX, &c); + fprintf(stderr, "%s%s.boot ", sep, buf); + } + fprintf(stderr, "required by %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + } + } + + /* skip to end of header */ + while (c != ')') { + if (c < 0) { + fprintf(stderr, "malformed boot file %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + c = get_u8(fd); + } + } + + if (boot_count >= MAX_BOOT_FILES) { + fprintf(stderr, "exceeded maximum number of boot files (%d)\n", MAX_BOOT_FILES); + S_abnormal_exit(); + } + + bd[boot_count].fd = fd; + strcpy(bd[boot_count].path, path); + boot_count += 1; + + return 1; +} + +static char get_u8(INT fd) { + char buf[1]; + if (READ(fd, &buf, 1) != 1) return -1; + return buf[0]; +} + +static uptr get_uptr(INT fd, uptr *pn) { + uptr n, m; int c; octet k; + + if ((c = get_u8(fd)) < 0) return -1; + k = (octet)c; + n = k >> 1; + while (k & 1) { + if ((c = get_u8(fd)) < 0) return -1; + k = (octet)c; + m = n << 7; + if (m >> 7 != n) return -1; + n = m | (k >> 1); + } + *pn = n; + return 0; +} + +static INT get_string(INT fd, char *s, iptr max, INT *c) { + while (max-- > 0) { + if (*c < 0) return -1; + if (*c == ' ' || *c == ')') { + if (*c == ' ') *c = get_u8(fd); + *s = 0; + return 0; + } + *s++ = *c; + *c = get_u8(fd); + } + return -1; +} + +static IBOOL loadecho = 0; +#define LOADSKIP 0 + +static int set_load_binary(iptr n) { + if (!Ssymbolp(SYMVAL(S_G.scheme_version_id))) return 0; // set by back.ss + ptr make_load_binary = SYMVAL(S_G.make_load_binary_id); + if (Sprocedurep(make_load_binary)) { + S_G.load_binary = Scall1(make_load_binary, Sstring_utf8(bd[n].path, -1)); + return 1; + } + return 0; +} + +static void load(ptr tc, iptr n, IBOOL base) { + ptr x; iptr i; + + if (base) { + S_G.error_invoke_code_object = S_boot_read(bd[n].fd, bd[n].path); + if (!Scodep(S_G.error_invoke_code_object)) { + (void) fprintf(stderr, "first object on boot file not code object\n"); + S_abnormal_exit(); + } + + S_G.invoke_code_object = S_boot_read(bd[n].fd, bd[n].path); + if (!Scodep(S_G.invoke_code_object)) { + (void) fprintf(stderr, "second object on boot file not code object\n"); + S_abnormal_exit(); + } + S_G.base_rtd = S_boot_read(bd[n].fd, bd[n].path); + if (!Srecordp(S_G.base_rtd)) { + S_abnormal_exit(); + } + } + + i = 0; + while (i++ < LOADSKIP && S_boot_read(bd[n].fd, bd[n].path) != Seof_object); + + while ((x = S_boot_read(bd[n].fd, bd[n].path)) != Seof_object) { + if (loadecho) { + printf("%ld: ", (long)i); + fflush(stdout); + } + if (Sprocedurep(x)) { + S_initframe(tc, 0); + x = boot_call(tc, x, 0); + } else if (Sprocedurep(S_G.load_binary) || set_load_binary(n)) { + S_initframe(tc, 1); + S_put_arg(tc, 1, x); + x = boot_call(tc, S_G.load_binary, 1); + } + if (loadecho) { + S_prin1(x); + putchar('\n'); + fflush(stdout); + } + i += 1; + } + + S_G.load_binary = Sfalse; + CLOSE(bd[n].fd); +} + +/***************************************************************************/ +/* HEAP FILES */ + +#ifdef DEBUG +#define debug(x) {x} +#else +#define debug(x) +#endif + +#include +#include + +#ifdef WIN32 +#include +#endif /* WIN32 */ + +#ifdef MMAP_HEAP +#include +#endif + +#ifndef O_BINARY +#define O_BINARY 0 +#endif /* O_BINARY */ + +#define check(expr,path) {if ((INT)(expr) < 0) {perror(path); S_abnormal_exit();}} + +/***************************************************************************/ +/* EXPORTED ROUTINES */ + +const char *Skernel_version(void) { + return VERSION; +} + +extern void Sset_verbose(INT v) { + verbose = v; +} + +extern void Sretain_static_relocation(void) { + S_G.retain_static_relocation = 1; +} + +#if defined(CHECK_FOR_ROSETTA) +#include +int is_rosetta = 0; +static void init_rosetta_check(void) { + int val = 0; + size_t size = sizeof(val); + if (sysctlbyname("sysctl.proc_translated", &val, &size, NULL, 0) != 0) { + if (errno == ENOENT) { + is_rosetta = 0; + } else { + perror("checking to see if running under Rosetta"); + // if for some reason we can't tell whether we are running under Rosetta or not, + // default to the safer choice. It doesn't impact correctness to do the Rosetta + // workarounds when they are not needed. + is_rosetta = 1; + } + } + is_rosetta = val; +} +#endif + +#ifdef ITEST +#include "itest.c" +#endif + +static void default_abnormal_exit(void) { + exit(1); +} + +extern void Sscheme_init(void (*abnormal_exit)(void)) { + S_abnormal_exit_proc = abnormal_exit ? abnormal_exit : default_abnormal_exit; + S_errors_to_console = 1; + + /* set before idiot checks */ + S_pagesize = GETPAGESIZE(); + + idiot_checks(); +#if defined(CHECK_FOR_ROSETTA) + init_rosetta_check(); +#endif + + switch (current_state) { + case RUNNING: + fprintf(stderr, "error (Sscheme_init): call Sscheme_deinit first to terminate\n"); + S_abnormal_exit(); + case BOOTING: + fprintf(stderr, "error (Sscheme_init): already initialized\n"); + S_abnormal_exit(); + case UNINITIALIZED: + case DEINITIALIZED: + break; + } + current_state = BOOTING; + + S_G.retain_static_relocation = 0; + S_G.enable_object_counts = 0; + + boot_count = 0; + +#ifdef WIN32 + Sschemeheapdirs = Sgetenv("SCHEMEHEAPDIRS"); +#else + Sschemeheapdirs = getenv("SCHEMEHEAPDIRS"); +#endif + if (Sschemeheapdirs == (char *)0) { + Sschemeheapdirs = ""; + if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = ""; + } else if (*Sschemeheapdirs != 0 && Sschemeheapdirs[strlen(Sschemeheapdirs)-1] == SEARCHPATHSEP) { + if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = ""; + } else { + Sdefaultheapdirs = ""; + } + +#ifdef PTHREADS + { + int status; + if ((status = s_thread_key_create(&S_tc_key)) != 0) + S_error_abort(strerror(status)); + s_thread_setspecific(S_tc_key, S_G.thread_context); + } +#endif + +#ifdef ITEST + S_boot_time = 1; + main_init(); + + bignum_test(); + exit(0); +#endif +} + +static void check_boot_file_state(const char *who) { + switch (current_state) { + case UNINITIALIZED: + case DEINITIALIZED: + fprintf(stderr, "error (%s): uninitialized; call Sscheme_init first\n", who); + if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit(); + case RUNNING: + fprintf(stderr, "error (%s): already running\n", who); + S_abnormal_exit(); + case BOOTING: + break; + } +} + +extern void Sregister_boot_file(const char *name) { + check_boot_file_state("Sregister_boot_file"); + find_boot(name, "", -1, 1); +} + +extern void Sregister_boot_file_fd(const char *name, int fd) { + check_boot_file_state("Sregister_boot_file_fd"); + find_boot(name, "", fd, 1); +} + +extern void Sregister_heap_file(UNUSED const char *path) { + fprintf(stderr, "Sregister_heap_file: saved heap files are not presently supported\n"); + S_abnormal_exit(); +} + +extern void Sbuild_heap(const char *kernel, void (*custom_init)(void)) { + ptr tc = Svoid; /* initialize to make gcc happy */ + ptr p; + + switch (current_state) { + case UNINITIALIZED: + case DEINITIALIZED: + fprintf(stderr, "error (Sbuild_heap): uninitialized; call Sscheme_init first\n"); + if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit(); + case RUNNING: + fprintf(stderr, "error (Sbuild_heap): already running\n"); + S_abnormal_exit(); + case BOOTING: + break; + } + current_state = RUNNING; + + S_boot_time = 1; + + if (boot_count == 0) { + const char *name; + + if (!kernel) { + fprintf(stderr, "no boot file or executable name specified\n"); + S_abnormal_exit(); + } + + name = path_last(kernel); + if (strlen(name) >= PATH_MAX) { + fprintf(stderr, "executable name too long: %s\n", name); + S_abnormal_exit(); + } + +#ifdef WIN32 + { /* strip off trailing .exe, if any */ + static char buf[PATH_MAX]; + iptr n; + + n = strlen(name) - 4; + if (n >= 0 && (_stricmp(name + n, ".exe") == 0)) { + strcpy(buf, name); + buf[n] = 0; + name = buf; + } + } +#endif + + if (!find_boot(name, ".boot", -1, 0)) { + fprintf(stderr, "cannot find compatible %s.boot in search path\n \"%s%s\"\n", + name, + Sschemeheapdirs, Sdefaultheapdirs); + S_abnormal_exit(); + } + } + + if (boot_count != 0) { + INT i = 0; + + main_init(); + if (custom_init) custom_init(); + + S_threads = Snil; + S_nthreads = 0; + S_set_symbol_value(S_G.active_threads_id, FIX(0)); + /* pass a parent tc of Svoid, since this call establishes the initial + * thread context and hence there is no parent thread context. */ + tc = (ptr)THREADTC(S_create_thread_object("startup", tc)); +#ifdef PTHREADS + s_thread_setspecific(S_tc_key, tc); +#endif + + /* #scheme-init enables interrupts */ + TRAP(tc) = (ptr)most_positive_fixnum; + DISABLECOUNT(tc) = Sfixnum(1); + COMPRESSFORMAT(tc) = FIX(COMPRESS_LZ4); + COMPRESSLEVEL(tc) = FIX(COMPRESS_MEDIUM); + + load(tc, i++, 1); + S_boot_time = 0; + + while (i < boot_count) load(tc, i++, 0); + } + + if (boot_count != 0) Scompact_heap(); + + /* complete the initialization on the Scheme side */ + p = S_symbol_value(S_intern((const unsigned char *)"$scheme-init")); + if (!Sprocedurep(p)) { + (void) fprintf(stderr,"\n$scheme-init is not bound to a procedure\n"); + S_abnormal_exit(); + } + + S_initframe(tc, 0); + (void)boot_call(tc, p, 0); + + /* should be okay to invoke Scheme's error handler now */ + S_errors_to_console = 0; +} + +extern void Senable_expeditor(const char *history_file) { + Scall1(S_symbol_value(Sstring_to_symbol("$enable-expeditor")), Strue); + if (history_file != (const char *)0) + Scall1(S_symbol_value(Sstring_to_symbol("$expeditor-history-file")), + Sstring_utf8(history_file, -1)); +} + +extern INT Sscheme_start(INT argc, const char *argv[]) { + ptr tc = get_thread_context(); + ptr arglist, p; INT i; + + switch (current_state) { + case UNINITIALIZED: + case DEINITIALIZED: + fprintf(stderr, "error (Sscheme_start): uninitialized; call Sscheme_init and Sbuild_heap first\n"); + if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit(); + case BOOTING: + fprintf(stderr, "error (Sscheme_start): no heap built yet; call Sbuild_heap first\n"); + S_abnormal_exit(); + case RUNNING: + break; + } + + arglist = Snil; + for (i = argc - 1; i > 0; i -= 1) + arglist = Scons(Sstring_utf8(argv[i], -1), arglist); + + p = S_symbol_value(S_intern((const unsigned char *)"$scheme")); + if (!Sprocedurep(p)) { + (void) fprintf(stderr,"\n$scheme is not bound to a procedure\n"); + S_abnormal_exit(); + } + + S_initframe(tc, 1); + S_put_arg(tc, 1, arglist); + p = boot_call(tc, p, 1); + + if (S_integer_valuep(p)) return (INT)Sinteger_value(p); + return p == Svoid ? 0 : 1; +} + +static INT run_script(const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp) { + ptr tc = get_thread_context(); + ptr arglist, p; INT i; + + switch (current_state) { + case UNINITIALIZED: + case DEINITIALIZED: + fprintf(stderr, "error (%s): uninitialized; call Sscheme_init and Sbuild_heap first\n", who); + if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit(); + case BOOTING: + fprintf(stderr, "error (%s): no heap built yet; call Sbuild_heap first\n", who); + S_abnormal_exit(); + case RUNNING: + break; + } + + arglist = Snil; + for (i = argc - 1; i > 0; i -= 1) + arglist = Scons(Sstring_utf8(argv[i], -1), arglist); + + p = S_symbol_value(S_intern((const unsigned char *)"$script")); + if (!Sprocedurep(p)) { + (void) fprintf(stderr,"\n$script is not bound to a procedure\n"); + S_abnormal_exit(); + } + + S_initframe(tc, 3); + S_put_arg(tc, 1, Sboolean(programp)); + S_put_arg(tc, 2, Sstring_utf8(scriptfile, -1)); + S_put_arg(tc, 3, arglist); + p = boot_call(tc, p, 3); + + if (S_integer_valuep(p)) return (INT)Sinteger_value(p); + return p == Svoid ? 0 : 1; +} + +extern INT Sscheme_script(const char *scriptfile, INT argc, const char *argv[]) { + return run_script("Sscheme_script", scriptfile, argc, argv, 0); +} + +extern INT Sscheme_program(const char *programfile, INT argc, const char *argv[]) { + return run_script("Sscheme_program", programfile, argc, argv, 1); +} + +extern void Ssave_heap(UNUSED const char *path, UNUSED INT level) { + fprintf(stderr, "Ssave_heap: saved heap files are not presently supported\n"); + S_abnormal_exit(); +} + +extern void Sscheme_deinit(void) { + ptr p, tc = get_thread_context(); + + switch (current_state) { + case UNINITIALIZED: + case DEINITIALIZED: + fprintf(stderr, "error (Sscheme_deinit): not yet initialized or running\n"); + if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit(); + case BOOTING: + fprintf(stderr, "error (Sscheme_deinit): not yet running\n"); + S_abnormal_exit(); + case RUNNING: + break; + } + + p = S_symbol_value(S_intern((const unsigned char *)"$close-files")); + S_initframe(tc, 0); + boot_call(tc, p, 0); + + S_errors_to_console = 1; + current_state = DEINITIALIZED; +} diff --git a/c/scheme.exe.manifest b/c/scheme.exe.manifest new file mode 100644 index 0000000..a43d11b --- /dev/null +++ b/c/scheme.exe.manifest @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/c/scheme.rc b/c/scheme.rc new file mode 100644 index 0000000..3f39adc --- /dev/null +++ b/c/scheme.rc @@ -0,0 +1,29 @@ +#include "winver.h" + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 9,5,9,0 + PRODUCTVERSION 9,5,9,0 + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS VOS__WINDOWS32 + FILETYPE VFT_APP + FILESUBTYPE VFT2_UNKNOWN +{ + BLOCK "StringFileInfo" { + BLOCK "04090000" { + VALUE "CompanyName", "Cisco Systems, Inc." + VALUE "FileDescription", "Chez Scheme Version 9.5.9" + VALUE "FileVersion", "9.5.9" + VALUE "InternalName", "scheme.exe" + VALUE "LegalCopyright", "Copyright 1984-2022 Cisco Systems, Inc. Licensed under the Apache License, Version 2.0." + VALUE "OriginalFilename", "scheme.exe" + VALUE "ProductName", "Chez Scheme" + VALUE "ProductVersion", "9.5.9" + } + } + BLOCK "VarFileInfo" { + VALUE "Translation", 0x409, 0 + } +} + +scheme ICON "cs.ico" diff --git a/c/schlib.c b/c/schlib.c new file mode 100644 index 0000000..e958964 --- /dev/null +++ b/c/schlib.c @@ -0,0 +1,307 @@ +/* schlib.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +static ptr S_call(ptr tc, ptr cp, iptr argcnt); + +/* Sinteger_value is in number.c */ + +/* Sinteger32_value is in number.c */ + +/* Sinteger64_value is in number.c */ + +void Sset_box(ptr x, ptr y) { + SETBOXREF(x, y); +} + +void Sset_car(ptr x, ptr y) { + SETCAR(x, y); +} + +void Sset_cdr(ptr x, ptr y) { + SETCDR(x, y); +} + +void Svector_set(ptr x, iptr i, ptr y) { + SETVECTIT(x, i, y); +} + +/* Scons is in alloc.c */ + +ptr Sstring_to_symbol(const char *s) { + return S_intern((const unsigned char *)s); +} + +ptr Ssymbol_to_string(ptr x) { + ptr name = SYMNAME(x); + if (Sstringp(name)) + return name; + else if (Spairp(name)) + return Scdr(name); + else + /* don't have access to prefix or count, and can't handle arbitrary + prefixes anyway, so always punt */ + return S_string("gensym", -1); +} + +/* Sflonum is in alloc.c */ + +ptr Smake_vector(iptr n, ptr x) { + ptr p; iptr i; + + p = S_vector(n); + for (i = 0; i < n; i += 1) INITVECTIT(p, i) = x; + return p; +} + +ptr Smake_fxvector(iptr n, ptr x) { + ptr p; iptr i; + + p = S_fxvector(n); + for (i = 0; i < n; i += 1) Sfxvector_set(p, i, x); + return p; +} + +ptr Smake_bytevector(iptr n, int x) { + ptr p; iptr i; + + p = S_bytevector(n); + for (i = 0; i < n; i += 1) Sbytevector_u8_set(p, i, (octet)x); + return p; +} + +ptr Smake_string(iptr n, int c) { + ptr p; iptr i; + + p = S_string((char *)NULL, n); + for (i = 0; i < n; i += 1) Sstring_set(p, i, c); + return p; +} + +ptr Smake_uninitialized_string(iptr n) { + return S_string((char *)NULL, n); +} + +ptr Sstring(const char *s) { + return S_string(s, -1); +} + +ptr Sstring_of_length(const char *s, iptr n) { + return S_string(s, n); +} + +/* Sstring_utf8 is in alloc.c */ + +/* Sbox is in alloc.c */ + +/* Sinteger is in number.c */ + +/* Sunsigned is in number.c */ + +/* Sunsigned32 is in number.c */ + +/* Sunsigned64 is in number.c */ + +ptr Stop_level_value(ptr x) { + ptr tc = get_thread_context(); + IBOOL enabled = (DISABLECOUNT(tc) == 0); + if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1); + x = Scall1(S_symbol_value(Sstring_to_symbol("$c-tlv")), x); + if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1); + return x; +} + +void Sset_top_level_value(ptr x, ptr y) { + ptr tc = get_thread_context(); + IBOOL enabled = (DISABLECOUNT(tc) == 0); + if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1); + Scall2(S_symbol_value(Sstring_to_symbol("$c-stlv!")), x, y); + if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1); +} + +#include + +/* consider rewriting these to avoid multiple calls to get_thread_context */ +ptr Scall0(ptr cp) { + ptr tc = get_thread_context(); + S_initframe(tc,0); + return S_call(tc, cp, 0); +} + +ptr Scall1(ptr cp, ptr x1) { + ptr tc = get_thread_context(); + S_initframe(tc, 1); + S_put_arg(tc, 1, x1); + return S_call(tc, cp, 1); +} + +ptr Scall2(ptr cp, ptr x1, ptr x2) { + ptr tc = get_thread_context(); + S_initframe(tc, 2); + S_put_arg(tc, 1, x1); + S_put_arg(tc, 2, x2); + return S_call(tc, cp, 2); +} + +ptr Scall3(ptr cp, ptr x1, ptr x2, ptr x3) { + ptr tc = get_thread_context(); + S_initframe(tc, 3); + S_put_arg(tc, 1, x1); + S_put_arg(tc, 2, x2); + S_put_arg(tc, 3, x3); + return S_call(tc, cp, 3); +} + +void Sinitframe(iptr n) { + ptr tc = get_thread_context(); + S_initframe(tc, n); +} + +void S_initframe(ptr tc, iptr n) { + /* check for and handle stack overflow */ + if ((ptr *)SFP(tc) + n + 2 > (ptr *)ESP(tc)) + S_overflow(tc, (n+2)*sizeof(ptr)); + + /* intermediate frame contains old RA + cchain */; + SFP(tc) = (ptr)((ptr *)SFP(tc) + 2); +} + +void Sput_arg(iptr i, ptr x) { + ptr tc = get_thread_context(); + S_put_arg(tc, i, x); +} + +void S_put_arg(ptr tc, iptr i, ptr x) { + if (i <= asm_arg_reg_cnt) + REGARG(tc, i) = x; + else + FRAME(tc, i - asm_arg_reg_cnt) = x; +} + +ptr Scall(ptr cp, iptr argcnt) { + ptr tc = get_thread_context(); + return S_call(tc, cp, argcnt); +} + +static ptr S_call(ptr tc, ptr cp, iptr argcnt) { + AC0(tc) = (ptr)argcnt; + AC1(tc) = cp; + S_call_help(tc, 1, 0); + return AC0(tc); +} + +/* args are set up, argcnt in ac0, closure in ac1 */ +void S_call_help(ptr tc_in, IBOOL singlep, IBOOL lock_ts) { + /* declaring code and tc volatile should be unnecessary, but it quiets gcc + and avoids occasional invalid memory violations on Windows */ + void *jb; volatile ptr code; + volatile ptr tc = tc_in; + + /* lock caller's code object, since his return address is sitting in + the C stack and we may end up in a garbage collection */ + code = CP(tc); + if (Sprocedurep(code)) code = CLOSCODE(code); + if (!IMMEDIATE(code) && !Scodep(code)) + S_error_abort("S_call_help: invalid code pointer"); + Slock_object(code); + + CP(tc) = AC1(tc); + + jb = CREATEJMPBUF(); + if (jb == NULL) + S_error_abort("unable to allocate memory for jump buffer"); + if (lock_ts) { + /* Lock a code object passed in TS, which is a more immediate + caller whose return address is on the C stack */ + Slock_object(TS(tc)); + CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc)); + } else { + CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc)); + } + + FRAME(tc, -1) = CCHAIN(tc); + + switch (SETJMP(jb)) { + case 0: /* first time */ + S_generic_invoke(tc, S_G.invoke_code_object); + S_error_abort("S_generic_invoke return"); + break; + case -1: /* error */ + S_generic_invoke(tc, S_G.error_invoke_code_object); + S_error_abort("S_generic_invoke return"); + break; + case 1: { /* normal return */ + ptr yp = CCHAIN(tc); + FREEJMPBUF(CAAR(yp)); + CCHAIN(tc) = Scdr(yp); + break; + } + default: + S_error_abort("unexpected SETJMP return value"); + break; + } + + /* verify single return value */ + if (singlep && (iptr)AC1(tc) != 1) + S_error1("", "returned ~s values to single value return context", + FIX((iptr)AC1(tc))); + + /* restore caller to cp so that we can lock it again another day. we + restore the code object rather than the original closure, as the + closure may have been relocated or reclaimed by now */ + CP(tc) = code; +} + +void S_call_one_result(void) { + ptr tc = get_thread_context(); + S_call_help(tc, 1, 1); +} + +void S_call_any_results(void) { + ptr tc = get_thread_context(); + S_call_help(tc, 0, 1); +} + +/* cchain = ((jb . (co . maybe-co)) ...) */ +void S_return(void) { + ptr tc = get_thread_context(); + ptr xp, yp; + + SFP(tc) = (ptr)((ptr *)SFP(tc) - 2); + + /* grab saved cchain */ + yp = FRAME(tc, 1); + + /* verify saved cchain is sublist of current cchain */ + for (xp = CCHAIN(tc); xp != yp; xp = Scdr(xp)) + if (xp == Snil) + S_error("", "attempt to return to stale foreign context"); + + /* error checks are done; now unlock affected code objects */ + for (xp = CCHAIN(tc); ; xp = Scdr(xp)) { + ptr p = CDAR(xp); + Sunlock_object(Scar(p)); + if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p)); + if (xp == yp) break; + FREEJMPBUF(CAAR(xp)); + } + + /* reset cchain and return via longjmp */ + CCHAIN(tc) = yp; + LONGJMP(CAAR(yp), 1); +} diff --git a/c/schsig.c b/c/schsig.c new file mode 100644 index 0000000..5776bb6 --- /dev/null +++ b/c/schsig.c @@ -0,0 +1,783 @@ +/* schsig.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" +#include + +/* locally defined functions */ +static void S_promote_to_multishot(ptr k); +static void split(ptr k, ptr *s); +static void reset_scheme(void); +static NORETURN void do_error(iptr type, const char *who, const char *s, ptr args); +static void handle_call_error(ptr tc, iptr type, ptr x); +static void init_signal_handlers(void); +static void keyboard_interrupt(ptr tc); + +ptr S_get_scheme_arg(ptr tc, iptr n) { + + if (n <= asm_arg_reg_cnt) return REGARG(tc, n); + else return FRAME(tc, n - asm_arg_reg_cnt); +} + +void S_put_scheme_arg(ptr tc, iptr n, ptr x) { + + if (n <= asm_arg_reg_cnt) REGARG(tc, n) = x; + else FRAME(tc, n - asm_arg_reg_cnt) = x; +} + +static void S_promote_to_multishot(ptr k) { + while (CONTLENGTH(k) != CONTCLENGTH(k)) { + CONTLENGTH(k) = CONTCLENGTH(k); + k = CONTLINK(k); + } +} + +/* k must be is a multi-shot continuation, and s (the split point) + * must be strictly between the base and end of k's stack segment. */ +static void split(ptr k, ptr *s) { + iptr m, n; + seginfo *si; + + tc_mutex_acquire() + /* set m to size of lower piece, n to size of upper piece */ + m = (uptr)s - (uptr)CONTSTACK(k); + n = CONTCLENGTH(k) - m; + + si = SegInfo(ptr_get_segment(k)); + /* insert a new continuation between k and link(k) */ + CONTLINK(k) = S_mkcontinuation(si->space, + si->generation, + CLOSENTRY(k), + CONTSTACK(k), + m, m, + CONTLINK(k), + *s, + Snil); + CONTLENGTH(k) = CONTCLENGTH(k) = n; + CONTSTACK(k) = (ptr)s; + *s = (ptr)DOUNDERFLOW; + tc_mutex_release() +} + +/* We may come in to S_split_and_resize with a multi-shot continuation whose + * stack segment exceeds the copy bound or is too large to fit along + * with the return values in the current stack. We may also come in to + * S_split_and_resize with a one-shot continuation for which all of the + * above is true and for which there is insufficient space between the + * top frame and the end of the stack. If we have to split a 1-shot, we + * promote it to multi-shot; doing otherwise is too much trouble. */ +void S_split_and_resize(void) { + ptr tc = get_thread_context(); + ptr k; iptr value_count; iptr n; + + /* cp = continuation, ac0 = return value count */ + k = CP(tc); + value_count = (iptr)AC0(tc); + + if (CONTCLENGTH(k) > underflow_limit) { + iptr frame_size; + ptr *front_stack_ptr, *end_stack_ptr, *split_point, *guard; + + front_stack_ptr = (ptr *)CONTSTACK(k); + end_stack_ptr = (ptr *)((uptr)front_stack_ptr + CONTCLENGTH(k)); + + guard = (ptr *)((uptr)end_stack_ptr - underflow_limit); + + /* set split point to base of top frame */ + frame_size = ENTRYFRAMESIZE(CONTRET(k)); + split_point = (ptr *)((uptr)end_stack_ptr - frame_size); + + /* split only if we have more than one frame */ + if (split_point != front_stack_ptr) { + /* walk the stack to set split_point at first frame above guard */ + /* note that first frame may have put us below the guard already */ + for (;;) { + ptr *p; + frame_size = ENTRYFRAMESIZE(*split_point); + p = (ptr *)((uptr)split_point - frame_size); + if (p < guard) break; + split_point = p; + } + + /* promote to multi-shot if necessary */ + S_promote_to_multishot(k); + + /* split */ + split(k, split_point); + } + } + + /* make sure the stack is big enough to hold continuation + * this is conservative: really need stack-base + clength <= esp + * and clength + size(values) < stack-size; also, size may include + * argument register values */ + n = CONTCLENGTH(k) + (value_count * sizeof(ptr)) + stack_slop; + if (n >= SCHEMESTACKSIZE(tc)) { + tc_mutex_acquire() + S_reset_scheme_stack(tc, n); + tc_mutex_release() + } +} + +iptr S_continuation_depth(ptr k) { + iptr n, frame_size; ptr *stack_base, *stack_ptr; + + n = 0; + /* terminate on shot 1-shot, which could be null_continuation */ + while (CONTLENGTH(k) != scaled_shot_1_shot_flag) { + stack_base = (ptr *)CONTSTACK(k); + frame_size = ENTRYFRAMESIZE(CONTRET(k)); + stack_ptr = (ptr *)((uptr)stack_base + CONTCLENGTH(k)); + for (;;) { + stack_ptr = (ptr *)((uptr)stack_ptr - frame_size); + n += 1; + if (stack_ptr == stack_base) break; + frame_size = ENTRYFRAMESIZE(*stack_ptr); + } + k = CONTLINK(k); + } + return n; +} + +ptr S_single_continuation(ptr k, iptr n) { + iptr frame_size; ptr *stack_base, *stack_top, *stack_ptr; + + /* bug out on shot 1-shots, which could be null_continuation */ + while (CONTLENGTH(k) != scaled_shot_1_shot_flag) { + stack_base = (ptr *)CONTSTACK(k); + stack_top = (ptr *)((uptr)stack_base + CONTCLENGTH(k)); + stack_ptr = stack_top; + frame_size = ENTRYFRAMESIZE(CONTRET(k)); + for (;;) { + if (n == 0) { + /* promote to multi-shot if necessary, even if we don't end + * up in split, since inspector assumes multi-shot */ + S_promote_to_multishot(k); + + if (stack_ptr != stack_top) { + split(k, stack_ptr); + k = CONTLINK(k); + } + + stack_ptr = (ptr *)((uptr)stack_ptr - frame_size); + if (stack_ptr != stack_base) + split(k, stack_ptr); + + return k; + } else { + n -= 1; + stack_ptr = (ptr *)((uptr)stack_ptr - frame_size); + if (stack_ptr == stack_base) break; + frame_size = ENTRYFRAMESIZE(*stack_ptr); + } + } + k = CONTLINK(k); + } + + return Sfalse; +} + +void S_handle_overflow(void) { + ptr tc = get_thread_context(); + + /* default frame size is enough */ + S_overflow(tc, 0); +} + +void S_handle_overflood(void) { + ptr tc = get_thread_context(); + + /* xp points to where esp needs to be */ + S_overflow(tc, ((ptr *)XP(tc) - (ptr *)SFP(tc))*sizeof(ptr)); +} + +void S_handle_apply_overflood(void) { + ptr tc = get_thread_context(); + + /* ac0 contains the argument count for the called procedure */ + /* could reduce request by default frame size and number of arg registers */ + /* the "+ 1" is for the return address slot */ + S_overflow(tc, ((iptr)AC0(tc) + 1) * sizeof(ptr)); +} + +/* allocates a new stack + * --the old stack below the sfp is turned into a continuation + * --the old stack above the sfp is copied to the new stack + * --return address must be in first frame location + * --scheme registers are preserved or reset + * frame_request is how much (in bytes) to increase the default frame size + */ +void S_overflow(ptr tc, iptr frame_request) { + ptr *sfp; + iptr above_split_size, sfp_offset; + ptr *split_point, *guard, *other_guard; + iptr split_stack_length, split_stack_clength; + ptr nuate; + + sfp = (ptr *)SFP(tc); + nuate = SYMVAL(S_G.nuate_id); + if (!Scodep(nuate)) { + S_error_abort("overflow: nuate not yet defined"); + } + + guard = (ptr *)((uptr)sfp - underflow_limit); + /* leave at least stack_slop headroom in the old stack to reduce the need for return-point overflow checks */ + other_guard = (ptr *)((uptr)SCHEMESTACK(tc) + (uptr)SCHEMESTACKSIZE(tc) - (uptr)stack_slop); + if ((uptr)other_guard < (uptr)guard) guard = other_guard; + + /* split only if old stack contains more than underflow_limit bytes */ + if (guard > (ptr *)SCHEMESTACK(tc)) { + iptr frame_size; + + /* set split point to base of the frame below the current one */ + frame_size = ENTRYFRAMESIZE(*sfp); + split_point = (ptr *)((uptr)sfp - frame_size); + + /* split only if we have more than one frame */ + if (split_point != (ptr *)SCHEMESTACK(tc)) { + /* walk the stack to set split_point at first frame above guard */ + /* note that first frame may have put us below the guard already */ + for (;;) { + ptr *p; + + frame_size = ENTRYFRAMESIZE(*split_point); + p = (ptr *)((uptr)split_point - frame_size); + if (p < guard) break; + split_point = p; + } + + split_stack_clength = (uptr)split_point - (uptr)SCHEMESTACK(tc); + + /* promote to multi-shot if current stack is shrimpy */ + if (SCHEMESTACKSIZE(tc) < default_stack_size / 4) { + split_stack_length = split_stack_clength; + S_promote_to_multishot(STACKLINK(tc)); + } else { + split_stack_length = SCHEMESTACKSIZE(tc); + } + + /* create a continuation */ + tc_mutex_acquire() + STACKLINK(tc) = S_mkcontinuation(space_new, + 0, + CODEENTRYPOINT(nuate), + SCHEMESTACK(tc), + split_stack_length, + split_stack_clength, + STACKLINK(tc), + *split_point, + Snil); + tc_mutex_release() + + /* overwrite old return address with dounderflow */ + *split_point = (ptr)DOUNDERFLOW; + } + } else { + split_point = (ptr *)SCHEMESTACK(tc); + } + + above_split_size = SCHEMESTACKSIZE(tc) - ((uptr)split_point - (uptr)SCHEMESTACK(tc)); + + /* allocate a new stack, retaining same relative sfp */ + sfp_offset = (uptr)sfp - (uptr)split_point; + tc_mutex_acquire() + S_reset_scheme_stack(tc, above_split_size + frame_request); + tc_mutex_release() + SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + sfp_offset); + + /* copy up everything above the split point. we don't know where the + current frame ends, so we copy through the end of the old stack */ + {ptr *p, *q; iptr n; + p = (ptr *)SCHEMESTACK(tc); + q = split_point; + for (n = above_split_size; n != 0; n -= sizeof(ptr)) *p++ = *q++; + } +} + +void S_error_abort(const char *s) { + fprintf(stderr, "%s\n", s); + S_abnormal_exit(); +} + +void S_abnormal_exit(void) { + S_abnormal_exit_proc(); + fprintf(stderr, "abnormal_exit procedure did not exit\n"); + exit(1); +} + +static void reset_scheme(void) { + ptr tc = get_thread_context(); + + tc_mutex_acquire() + /* eap should always be up-to-date now that we write-through to the tc + when making any changes to eap when eap is a real register */ + S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc)); + S_reset_allocation_pointer(tc); + S_reset_scheme_stack(tc, stack_slop); + FRAME(tc,0) = (ptr)DOUNDERFLOW; + tc_mutex_release() +} + +/* error_resets occur with the system in an unknown state, + * thus we must reset with no opportunity for debugging + */ + +void S_error_reset(const char *s) { + + if (!S_errors_to_console) reset_scheme(); + do_error(ERROR_RESET, "", s, Snil); +} + +void S_error(const char *who, const char *s) { + do_error(ERROR_OTHER, who, s, Snil); +} + +void S_error1(const char *who, const char *s, ptr x) { + do_error(ERROR_OTHER, who, s, LIST1(x)); +} + +void S_error2(const char *who, const char *s, ptr x, ptr y) { + do_error(ERROR_OTHER, who, s, LIST2(x,y)); +} + +void S_error3(const char *who, const char *s, ptr x, ptr y, ptr z) { + do_error(ERROR_OTHER, who, s, LIST3(x,y,z)); +} + +void S_boot_error(ptr who, ptr msg, ptr args) { + printf("error caught before error-handing subsystem initialized\n"); + printf("who: "); + S_prin1(who); + printf("\nmsg: "); + S_prin1(msg); + printf("\nargs: "); + S_prin1(args); + printf("\n"); + fflush(stdout); + S_abnormal_exit(); +} + +static void do_error(iptr type, const char *who, const char *s, ptr args) { + ptr tc = get_thread_context(); + + if (S_errors_to_console || tc == (ptr)0 || CCHAIN(tc) == Snil) { + if (strlen(who) == 0) + printf("Error: %s\n", s); + else + printf("Error in %s: %s\n", who, s); + S_prin1(args); putchar('\n'); + fflush(stdout); + S_abnormal_exit(); + } + + args = Scons(FIX(type), + Scons((strlen(who) == 0 ? Sfalse : Sstring_utf8(who,-1)), + Scons(Sstring_utf8(s, -1), args))); + +#ifdef PTHREADS + while (S_tc_mutex_depth > 0) { + S_mutex_release(&S_tc_mutex); + S_tc_mutex_depth -= 1; + } +#endif /* PTHREADS */ + + TRAP(tc) = (ptr)1; + AC0(tc) = (ptr)1; + CP(tc) = S_symbol_value(S_G.error_id); + S_put_scheme_arg(tc, 1, args); + LONGJMP(CAAR(CCHAIN(tc)), -1); +} + +static void handle_call_error(ptr tc, iptr type, ptr x) { + ptr p, arg1; + iptr argcnt; + + argcnt = (iptr)AC0(tc); + arg1 = argcnt == 0 ? Snil : S_get_scheme_arg(tc, 1); + p = Scons(FIX(type), Scons(FIX(argcnt), Scons(x, Scons(arg1, Snil)))); + + if (S_errors_to_console) { + printf("Call error: "); + S_prin1(p); putchar('\n'); fflush(stdout); + S_abnormal_exit(); + } + + CP(tc) = S_symbol_value(S_G.error_id); + S_put_scheme_arg(tc, 1, p); + AC0(tc) = (ptr)(argcnt==0 ? 1 : argcnt); + TRAP(tc) = (ptr)1; /* Why is this here? */ +} + +void S_handle_docall_error(void) { + ptr tc = get_thread_context(); + + handle_call_error(tc, ERROR_CALL_NONPROCEDURE, CP(tc)); +} + +void S_handle_arg_error(void) { + ptr tc = get_thread_context(); + + handle_call_error(tc, ERROR_CALL_ARGUMENT_COUNT, CP(tc)); +} + +void S_handle_nonprocedure_symbol(void) { + ptr tc = get_thread_context(); + ptr s; + + s = XP(tc); + handle_call_error(tc, + (SYMVAL(s) == sunbound ? + ERROR_CALL_UNBOUND : + ERROR_CALL_NONPROCEDURE_SYMBOL), + s); +} + +void S_handle_values_error(void) { + ptr tc = get_thread_context(); + + handle_call_error(tc, ERROR_VALUES, Sfalse); +} + +void S_handle_mvlet_error(void) { + ptr tc = get_thread_context(); + + handle_call_error(tc, ERROR_MVLET, Sfalse); +} + +static void keyboard_interrupt(ptr tc) { + KEYBOARDINTERRUPTPENDING(tc) = Strue; + SOMETHINGPENDING(tc) = Strue; +} + +/* used in printf below +static uptr list_length(ptr ls) { + uptr i = 0; + while (ls != Snil) { ls = Scdr(ls); i += 1; } + return i; +} +*/ + +void S_fire_collector(void) { + ptr crp_id = S_G.collect_request_pending_id; + +/* printf("firing collector!\n"); fflush(stdout); */ + + if (!Sboolean_value(S_symbol_value(crp_id))) { + ptr ls; + +/* printf("really firing collector!\n"); fflush(stdout); */ + + tc_mutex_acquire() + /* check again in case some other thread beat us to the punch */ + if (!Sboolean_value(S_symbol_value(crp_id))) { +/* printf("firing collector nthreads = %d\n", list_length(S_threads)); fflush(stdout); */ + S_set_symbol_value(crp_id, Strue); + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) + SOMETHINGPENDING(THREADTC(Scar(ls))) = Strue; + } + tc_mutex_release() + } +} + +void S_noncontinuable_interrupt(void) { + ptr tc = get_thread_context(); + + reset_scheme(); + KEYBOARDINTERRUPTPENDING(tc) = Sfalse; + do_error(ERROR_NONCONTINUABLE_INTERRUPT,"","",Snil); +} + +#ifdef WIN32 +ptr S_dequeue_scheme_signals(ptr tc) { + return Snil; +} + +ptr S_allocate_scheme_signal_queue(void) { + return (ptr)0; +} + +void S_register_scheme_signal(iptr sig) { + S_error("register_scheme_signal", "unsupported in this version"); +} + +/* code courtesy Bob Burger, burgerrg@sagian.com + We cannot call noncontinuable_interrupt, because we are not allowed + to perform a longjmp inside a signal handler; instead, we don't + handle the signal, which will cause the process to terminate. +*/ + +static BOOL WINAPI handle_signal(DWORD dwCtrlType) { + switch (dwCtrlType) { + case CTRL_C_EVENT: + case CTRL_BREAK_EVENT: { +#ifdef PTHREADS + /* get_thread_context() always returns 0, so assume main thread */ + ptr tc = S_G.thread_context; +#else + ptr tc = get_thread_context(); +#endif + if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) + return(FALSE); + keyboard_interrupt(tc); + return(TRUE); + } + } + return(FALSE); +} + +static void init_signal_handlers(void) { + SetConsoleCtrlHandler(handle_signal, TRUE); +} +#else /* WIN32 */ + +#include + +static void handle_signal(INT sig, siginfo_t *si, void *data); +static IBOOL enqueue_scheme_signal(ptr tc, INT sig); +static ptr allocate_scheme_signal_queue(void); +static void forward_signal_to_scheme(INT sig); + +#define RESET_SIGNAL {\ + sigset_t set;\ + sigemptyset(&set);\ + sigaddset(&set, sig);\ + sigprocmask(SIG_UNBLOCK,&set,(sigset_t *)0);\ +} + +/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, then start dropping them. */ +#define SIGNALQUEUESIZE 64 +static IBOOL scheme_signals_registered; + +/* we use a simple queue for pending signals. signals are enqueued only by the + C signal handler and dequeued only by the Scheme event handler. since the signal + handler and event handler run in the same thread, there's no need for locks + or write barriers. */ + +struct signal_queue { + INT head; + INT tail; + INT data[SIGNALQUEUESIZE]; +}; + +static IBOOL enqueue_scheme_signal(ptr tc, INT sig) { + struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc)); + /* ignore the signal if we failed to allocate the queue */ + if (queue == NULL) return 0; + INT tail = queue->tail; + INT next_tail = tail + 1; + if (next_tail == SIGNALQUEUESIZE) next_tail = 0; + /* ignore the signal if the queue is full */ + if (next_tail == queue->head) return 0; + queue->data[tail] = sig; + queue->tail = next_tail; + return 1; +} + +ptr S_dequeue_scheme_signals(ptr tc) { + ptr ls = Snil; + struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc)); + if (queue == NULL) return ls; + INT head = queue->head; + INT tail = queue->tail; + INT i = tail; + while (i != head) { + if (i == 0) i = SIGNALQUEUESIZE; + i -= 1; + ls = Scons(Sfixnum(queue->data[i]), ls); + } + queue->head = tail; + return ls; +} + +static void forward_signal_to_scheme(INT sig) { + ptr tc = get_thread_context(); + + if (enqueue_scheme_signal(tc, sig)) { + SIGNALINTERRUPTPENDING(tc) = Strue; + SOMETHINGPENDING(tc) = Strue; + } + RESET_SIGNAL +} + +static ptr allocate_scheme_signal_queue(void) { + /* silently fail to allocate space for signals if malloc returns NULL */ + struct signal_queue *queue = malloc(sizeof(struct signal_queue)); + if (queue != (struct signal_queue *)0) { + queue->head = queue->tail = 0; + } + return (ptr)queue; +} + +ptr S_allocate_scheme_signal_queue(void) { + return scheme_signals_registered ? allocate_scheme_signal_queue() : (ptr)0; +} + +void S_register_scheme_signal(iptr sig) { + struct sigaction act; + + tc_mutex_acquire() + if (!scheme_signals_registered) { + ptr ls; + scheme_signals_registered = 1; + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { + SIGNALINTERRUPTQUEUE(THREADTC(Scar(ls))) = S_allocate_scheme_signal_queue(); + } + } + tc_mutex_release() + + sigfillset(&act.sa_mask); + act.sa_flags = 0; + act.sa_handler = forward_signal_to_scheme; + sigaction(sig, &act, (struct sigaction *)0); +} + +static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) { +/* printf("handle_signal(%d) for tc %x\n", sig, UNFIX(get_thread_context())); fflush(stdout); */ + /* check for particular signals */ + switch (sig) { + case SIGINT: { + ptr tc = get_thread_context(); + /* disable keyboard interrupts in subordinate threads until we think + of something more clever to do with them */ + if (tc == S_G.thread_context) { + if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) { + /* this is a no-no, but the only other options are to ignore + the signal or to kill the process */ + RESET_SIGNAL + S_noncontinuable_interrupt(); + } + keyboard_interrupt(tc); + } + RESET_SIGNAL + break; + } +#ifdef SIGQUIT + case SIGQUIT: + RESET_SIGNAL + S_abnormal_exit(); +#endif /* SIGQUIT */ + case SIGILL: + RESET_SIGNAL + S_error_reset("illegal instruction"); + case SIGFPE: + RESET_SIGNAL + S_error_reset("arithmetic overflow"); +#ifdef SIGBUS + case SIGBUS: +#endif /* SIGBUS */ + case SIGSEGV: + RESET_SIGNAL + if (S_pants_down) + S_error_abort("nonrecoverable invalid memory reference"); + else + S_error_reset("invalid memory reference"); + default: + RESET_SIGNAL + S_error_reset("unexpected signal"); + } +} + +static void init_signal_handlers(void) { + struct sigaction act; + + sigemptyset(&act.sa_mask); + + /* drop pending keyboard interrupts */ + act.sa_flags = 0; + act.sa_handler = SIG_IGN; + sigaction(SIGINT, &act, (struct sigaction *)0); + + /* ignore broken pipe signals */ + act.sa_flags = 0; + act.sa_handler = SIG_IGN; + sigaction(SIGPIPE, &act, (struct sigaction *)0); + + /* set up to catch SIGINT w/no system call restart */ +#ifdef SA_INTERRUPT + act.sa_flags = SA_INTERRUPT|SA_SIGINFO; +#else + act.sa_flags = SA_SIGINFO; +#endif /* SA_INTERRUPT */ + act.sa_sigaction = handle_signal; + sigaction(SIGINT, &act, (struct sigaction *)0); +#ifdef BSDI + siginterrupt(SIGINT, 1); +#endif + + /* set up to catch selected signals */ + act.sa_flags = SA_SIGINFO; + act.sa_sigaction = handle_signal; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; +#endif /* SA_RESTART */ +#ifdef SIGQUIT + sigaction(SIGQUIT, &act, (struct sigaction *)0); +#endif /* SIGQUIT */ + sigaction(SIGILL, &act, (struct sigaction *)0); + sigaction(SIGFPE, &act, (struct sigaction *)0); +#ifdef SIGBUS + sigaction(SIGBUS, &act, (struct sigaction *)0); +#endif /* SIGBUS */ + sigaction(SIGSEGV, &act, (struct sigaction *)0); +} + +#endif /* WIN32 */ + +void S_schsig_init(void) { + if (S_boot_time) { + ptr p; + + S_protect(&S_G.nuate_id); + S_G.nuate_id = S_intern((const unsigned char *)"$nuate"); + S_set_symbol_value(S_G.nuate_id, FIX(0)); + + S_protect(&S_G.null_continuation_id); + S_G.null_continuation_id = S_intern((const unsigned char *)"$null-continuation"); + + S_protect(&S_G.collect_request_pending_id); + S_G.collect_request_pending_id = S_intern((const unsigned char *)"$collect-request-pending"); + + p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0); + CODERELOC(p) = S_relocation_table(0); + CODENAME(p) = Sfalse; + CODEARITYMASK(p) = FIX(0); + CODEFREE(p) = 0; + CODEINFO(p) = Sfalse; + CODEPINFOS(p) = Snil; + + S_set_symbol_value(S_G.null_continuation_id, + S_mkcontinuation(space_new, + 0, + CODEENTRYPOINT(p), + FIX(0), + scaled_shot_1_shot_flag, scaled_shot_1_shot_flag, + FIX(0), + FIX(0), + Snil)); + + S_protect(&S_G.error_id); + S_G.error_id = S_intern((const unsigned char *)"$c-error"); +#ifndef WIN32 + scheme_signals_registered = 0; +#endif + } + + + S_pants_down = 0; + S_set_symbol_value(S_G.collect_request_pending_id, Sfalse); + + init_signal_handlers(); +} diff --git a/c/segment.c b/c/segment.c new file mode 100644 index 0000000..24fb377 --- /dev/null +++ b/c/segment.c @@ -0,0 +1,503 @@ +/* segment.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* +Low-level Memory management strategy: + * use getmem-allocated multiple-segment chunks of memory + * maintain getmem-allocated list of chunks + * maintain getmem-allocated segment info and dirty vector tables + * after each collection, run through the list of chunks. If all + segments in a chunk are empty, the chunk is a candidate for return + to the O/S. Return (freemem) as many chunks as possible without going + below a user-defined threshold of empty segments (determined as a + multiple of the occupied nonstatic segments). Bias return to the + most recently allocated chunks. + * getmem/freemem may be implemented with malloc/free; we use them + relatively infrequently so performance isn't an issue. +*/ + +#define debug(x) ; +/* #define debug(x) {x; fflush(stdout);} */ + +#include "system.h" +#include "sort.h" +#include + +static void out_of_memory(void); +static void initialize_seginfo(seginfo *si, ISPC s, IGEN g); +static seginfo *allocate_segments(uptr nreq); +static void expand_segment_table(uptr base, uptr end, seginfo *si); +static void contract_segment_table(uptr base, uptr end); +static void add_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list); +static seginfo *sort_seginfo(seginfo *si, uptr n); +static seginfo *merge_seginfo(seginfo *si1, seginfo *si2); + +void S_segment_init(void) { + IGEN g; ISPC s; int i; + + if (!S_boot_time) return; + + S_chunks_full = NULL; + for (i = PARTIAL_CHUNK_POOLS; i >= 0; i -= 1) S_chunks[i] = NULL; + for (g = 0; g <= static_generation; g++) { + for (s = 0; s <= max_real_space; s++) { + S_G.occupied_segments[g][s] = NULL; + } + } + S_G.number_of_nonstatic_segments = 0; + S_G.number_of_empty_segments = 0; +} + +static uptr membytes = 0; +static uptr maxmembytes = 0; + +static void out_of_memory(void) { + (void) fprintf(stderr,"out of memory\n"); + S_abnormal_exit(); +} + +#if defined(USE_MALLOC) +void *S_getmem(iptr bytes, IBOOL zerofill) { + void *addr; + + if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); + + debug(printf("getmem(%p) -> %p\n", bytes, addr)) + if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; + if (zerofill) memset(addr, 0, bytes); + return addr; +} + +void S_freemem(void *addr, iptr bytes) { + debug(printf("freemem(%p, %p)\n", addr, bytes)) + free(addr); + membytes -= bytes; +} +#endif + +#if defined(USE_VIRTUAL_ALLOC) +#include +void *S_getmem(iptr bytes, IBOOL zerofill) { + void *addr; + + if ((uptr)bytes < S_pagesize) { + if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); + debug(printf("getmem malloc(%p) -> %p\n", bytes, addr)) + if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; + if (zerofill) memset(addr, 0, bytes); + } else { + uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); + if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == (void *)0) out_of_memory(); + if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes; + debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", bytes, p_bytes, addr)) + } + + return addr; +} + +void S_freemem(void *addr, iptr bytes) { + if ((uptr)bytes < S_pagesize) { + debug(printf("freemem free(%p, %p)\n", addr, bytes)) + membytes -= bytes; + free(addr); + } else { + uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); + debug(printf("freemem VirtualFree(%p, %p => %p)\n", addr, bytes, p_bytes)) + membytes -= p_bytes; + VirtualFree(addr, 0, MEM_RELEASE); + } +} +#endif + +#if defined(USE_MMAP) +#include +#ifndef MAP_ANONYMOUS +#define MAP_ANONYMOUS MAP_ANON +#endif +void *S_getmem(iptr bytes, IBOOL zerofill) { + void *addr; + + if ((uptr)bytes < S_pagesize) { + if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); + debug(printf("getmem malloc(%p) -> %p\n", bytes, addr)) + if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; + if (zerofill) memset(addr, 0, bytes); + } else { + uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); +#ifdef MAP_32BIT + /* try for first 2GB of the memory space first of x86_64 so that we have a + better chance of having short jump instructions */ + if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS|MAP_32BIT, -1, 0)) == (void *)-1) { +#endif + if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0)) == (void *)-1) { + out_of_memory(); + debug(printf("getmem mmap(%p) -> %p\n", bytes, addr)) + } +#ifdef MAP_32BIT + } +#endif + if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes; + debug(printf("getmem mmap(%p => %p) -> %p\n", bytes, p_bytes, addr)) + } + + return addr; +} + +void S_freemem(void *addr, iptr bytes) { + if ((uptr)bytes < S_pagesize) { + debug(printf("freemem free(%p, %p)\n", addr, bytes)) + free(addr); + membytes -= bytes; + } else { + uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); + debug(printf("freemem munmap(%p, %p => %p)\n", addr, bytes, p_bytes)) + munmap(addr, p_bytes); + membytes -= p_bytes; + } +} +#endif + +void S_move_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list) { + if ((*chunk->prev = chunk->next) != NULL) chunk->next->prev = chunk->prev; + add_to_chunk_list(chunk, pchunk_list); +} + +static void add_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list) { + if ((chunk->next = *pchunk_list) != NULL) (*pchunk_list)->prev = &chunk->next; + chunk->prev = pchunk_list; + *pchunk_list = chunk; +} + +#define SEGLT(x, y) ((x)->number < (y)->number) +#define SEGCDR(x) ((x)->next) +mkmergesort(sort_seginfo, merge_seginfo, seginfo *, NULL, SEGLT, SEGCDR) + +static void sort_chunk_unused_segments(chunkinfo *chunk) { + seginfo *si, *nextsi, *sorted, *unsorted; uptr n; + + /* bail out early if we find the unused segments list is already sorted */ + if ((unsorted = chunk->unused_segs)->sorted) return; + + /* find the sorted tail so we can just sort in the unsorted ones */ + si = unsorted; + n = 1; + for (;;) { + si->sorted = 1; + if ((nextsi = si->next) == NULL || nextsi->sorted) { + sorted = nextsi; + si->next = NULL; + break; + } + si = nextsi; + n += 1; + } + + sorted = merge_seginfo(sort_seginfo(unsorted, n), sorted); + + chunk->unused_segs = sorted; +} + +static INT find_index(iptr n) { + INT index = (INT)((n >> 2) + 1); + + return (index < PARTIAL_CHUNK_POOLS-1) ? index : PARTIAL_CHUNK_POOLS-1; +} + +static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) { + INT d; + + si->space = s; + si->generation = g; + si->sorted = 0; + si->min_dirty_byte = 0xff; + si->trigger_ephemerons = NULL; + for (d = 0; d < cards_per_segment; d += sizeof(ptr)) { + iptr *dp = (iptr *)(si->dirty_bytes + d); + /* fill sizeof(iptr) bytes at a time with 0xff */ + *dp = -1; + } +} + +iptr S_find_segments(ISPC s, IGEN g, iptr n) { + chunkinfo *chunk, *nextchunk; + seginfo *si, *nextsi, **prevsi; + iptr nunused_segs, j; + INT i, loser_index; + + if (g != static_generation) S_G.number_of_nonstatic_segments += n; + + debug(printf("attempting to find %d segments for space %d, generation %d\n", n, s, g)) + + if (n == 1) { + for (i = 0; i <= PARTIAL_CHUNK_POOLS; i++) { + chunk = S_chunks[i]; + if (chunk != NULL) { + si = chunk->unused_segs; + chunk->unused_segs = si->next; + + if (chunk->unused_segs == NULL) { + S_move_to_chunk_list(chunk, &S_chunks_full); + } else if (i == PARTIAL_CHUNK_POOLS) { + S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + } + + chunk->nused_segs += 1; + initialize_seginfo(si, s, g); + si->next = S_G.occupied_segments[g][s]; + S_G.occupied_segments[g][s] = si; + S_G.number_of_empty_segments -= 1; + return si->number; + } + } + } else { + loser_index = (n == 2) ? 0 : find_index(n-1); + for (i = find_index(n); i <= PARTIAL_CHUNK_POOLS; i += 1) { + chunk = S_chunks[i]; + while (chunk != NULL) { + if (n < (nunused_segs = (chunk->segs - chunk->nused_segs))) { + sort_chunk_unused_segments(chunk); + si = chunk->unused_segs; + prevsi = &chunk->unused_segs; + while (nunused_segs >= n) { + nextsi = si; + j = n - 1; + for (;;) { + nunused_segs -= 1; + if (nextsi->number + 1 != nextsi->next->number) { + si = nextsi->next; + prevsi = &nextsi->next; + break; + } + nextsi = nextsi->next; + if (--j == 0) { + *prevsi = nextsi->next; + if (chunk->unused_segs == NULL) { + S_move_to_chunk_list(chunk, &S_chunks_full); + } else if (i == PARTIAL_CHUNK_POOLS) { + S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + } + chunk->nused_segs += n; + nextsi->next = S_G.occupied_segments[g][s]; + S_G.occupied_segments[g][s] = si; + for (j = n, nextsi = si; j > 0; j -= 1, nextsi = nextsi->next) { + initialize_seginfo(nextsi, s, g); + } + S_G.number_of_empty_segments -= n; + return si->number; + } + } + } + } + nextchunk = chunk->next; + if (i != loser_index && i != PARTIAL_CHUNK_POOLS) { + S_move_to_chunk_list(chunk, &S_chunks[loser_index]); + } + chunk = nextchunk; + } + } + } + + /* we couldn't find space, so ask for more */ + si = allocate_segments(n); + for (nextsi = si; n > 0; n -= 1, nextsi += 1) { + initialize_seginfo(nextsi, s, g); + /* add segment to appropriate list of occupied segments */ + nextsi->next = S_G.occupied_segments[g][s]; + S_G.occupied_segments[g][s] = nextsi; + } + return si->number; +} + +/* allocate_segments(n) + * allocates a group of n contiguous fresh segments, returning the + * segment number of the first segment of the group. + */ +static seginfo *allocate_segments(nreq) uptr nreq; { + uptr nact, bytes, base; void *addr; + iptr i; + chunkinfo *chunk; seginfo *si; + + nact = nreq < minimum_segment_request ? minimum_segment_request : nreq; + + bytes = (nact + 1) * bytes_per_segment; + addr = S_getmem(bytes, 0); + debug(printf("allocate_segments addr = %p\n", addr)) + + base = addr_get_segment((uptr)addr + bytes_per_segment - 1); + /* if the base of the first segment is the same as the base of the chunk, and + the last segment isn't the last segment in memory (which could cause 'next' and 'end' + pointers to wrap), we've actually got nact + 1 usable segments in this chunk */ + if (build_ptr(base, 0) == addr && base + nact != ((uptr)1 << (ptr_bits - segment_offset_bits)) - 1) + nact += 1; + + chunk = S_getmem(sizeof(chunkinfo) + sizeof(seginfo) * nact, 0); + debug(printf("allocate_segments chunk = %p\n", chunk)) + chunk->addr = addr; + chunk->base = base; + chunk->bytes = bytes; + chunk->segs = nact; + chunk->nused_segs = nreq; + chunk->unused_segs = NULL; + + expand_segment_table(base, base + nact, &chunk->sis[0]); + + /* initialize seginfos */ + for (i = nact - 1; i >= 0; i -= 1) { + si = &chunk->sis[i]; + si->chunk = chunk; + si->number = i + base; + if (i >= (iptr)nreq) { + si->space = space_empty; + si->generation = 0; + si->sorted = 1; /* inserting in reverse order, so emptys are always sorted */ + si->next = chunk->unused_segs; + chunk->unused_segs = si; + } + } + + /* account for trailing empty segments */ + if (nact > nreq) { + S_G.number_of_empty_segments += nact - nreq; + add_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + } else { + add_to_chunk_list(chunk, &S_chunks_full); + } + + return &chunk->sis[0]; +} + +void S_free_chunk(chunkinfo *chunk) { + chunkinfo *nextchunk = chunk->next; + contract_segment_table(chunk->base, chunk->base + chunk->segs); + S_G.number_of_empty_segments -= chunk->segs; + *chunk->prev = nextchunk; + if (nextchunk != NULL) nextchunk->prev = chunk->prev; + S_freemem(chunk->addr, chunk->bytes); + S_freemem(chunk, sizeof(chunkinfo) + sizeof(seginfo) * chunk->segs); +} + +/* retain approximately heap-reserve-ratio segments for every + * nonempty nonstatic segment. */ +void S_free_chunks(void) { + iptr ntofree; + chunkinfo *chunk, *nextchunk; + + ntofree = S_G.number_of_empty_segments - + (iptr)(Sflonum_value(SYMVAL(S_G.heap_reserve_ratio_id)) * S_G.number_of_nonstatic_segments); + + for (chunk = S_chunks[PARTIAL_CHUNK_POOLS]; ntofree > 0 && chunk != NULL; chunk = nextchunk) { + nextchunk = chunk->next; + ntofree -= chunk->segs; + S_free_chunk(chunk); + } +} + +uptr S_curmembytes(void) { + return membytes; +} + +uptr S_maxmembytes(void) { + return maxmembytes; +} + +void S_resetmaxmembytes(void) { + maxmembytes = membytes; +} + +static void expand_segment_table(uptr base, uptr end, seginfo *si) { +#ifdef segment_t2_bits +#ifdef segment_t3_bits + t2table *t2i; +#endif + t1table **t2, *t1i; uptr n; +#endif + seginfo **t1, **t1end; + +#ifdef segment_t2_bits + while (base != end) { +#ifdef segment_t3_bits + if ((t2i = S_segment_info[SEGMENT_T3_IDX(base)]) == NULL) { + S_segment_info[SEGMENT_T3_IDX(base)] = t2i = (t2table *)S_getmem(sizeof(t2table), 1); + } + t2 = t2i->t2; +#else + t2 = S_segment_info; +#endif + if ((t1i = t2[SEGMENT_T2_IDX(base)]) == NULL) { + t2[SEGMENT_T2_IDX(base)] = t1i = (t1table *)S_getmem(sizeof(t1table), 1); +#ifdef segment_t3_bits + t2i->refcount += 1; +#endif + } + t1 = t1i->t1 + SEGMENT_T1_IDX(base); + t1end = t1 + end - base < t1i->t1 + SEGMENT_T1_SIZE ? t1 + end - base : t1i->t1 + SEGMENT_T1_SIZE; + n = t1end - t1; + t1i->refcount += n; + + while (t1 < t1end) *t1++ = si++; + base += n; + } +#else + t1 = S_segment_info + SEGMENT_T1_IDX(base); + t1end = t1 + end - base; + while (t1 < t1end) *t1++ = si++; +#endif +} + +static void contract_segment_table(uptr base, uptr end) { +#ifdef segment_t2_bits +#ifdef segment_t3_bits + t2table *t2i; +#endif + t1table **t2, *t1i; uptr n; +#endif + seginfo **t1, **t1end; + +#ifdef segment_t2_bits + while (base != end) { +#ifdef segment_t3_bits + t2i = S_segment_info[SEGMENT_T3_IDX(base)]; + t2 = t2i->t2; +#else + t2 = S_segment_info; +#endif + t1i = t2[SEGMENT_T2_IDX(base)]; + t1 = t1i->t1 + SEGMENT_T1_IDX(base); + t1end = t1 + end - base < t1i->t1 + SEGMENT_T1_SIZE ? t1 + end - base : t1i->t1 + SEGMENT_T1_SIZE; + n = t1end - t1; + if ((t1i->refcount -= n) == 0) { + S_freemem((void *)t1i, sizeof(t1table)); +#ifdef segment_t3_bits + if ((t2i->refcount -= 1) == 0) { + S_freemem((void *)t2i, sizeof(t2table)); + S_segment_info[SEGMENT_T3_IDX(base)] = NULL; + } else { + S_segment_info[SEGMENT_T3_IDX(base)]->t2[SEGMENT_T2_IDX(base)] = NULL; + } +#else + S_segment_info[SEGMENT_T2_IDX(base)] = NULL; +#endif + } else { + while (t1 < t1end) *t1++ = NULL; + } + base += n; + } +#else + t1 = S_segment_info + SEGMENT_T1_IDX(base); + t1end = t1 + end - base; + while (t1 < t1end) *t1++ = NULL; +#endif +} diff --git a/c/segment.h b/c/segment.h new file mode 100644 index 0000000..0d6c3b0 --- /dev/null +++ b/c/segment.h @@ -0,0 +1,83 @@ +/* segment.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#ifdef WIN32 +# ifndef __MINGW32__ +# undef FORCEINLINE +# define FORCEINLINE static __forceinline +# endif +#else +#define FORCEINLINE static inline +#endif + +/* segment_info */ + +#define SEGMENT_T1_SIZE (1<>segment_t1_bits)&(SEGMENT_T2_SIZE-1)) +#define SEGMENT_T3_SIZE (1<>(segment_t2_bits+segment_t1_bits)) + +FORCEINLINE seginfo *SegInfo(uptr i) { + return S_segment_info[SEGMENT_T3_IDX(i)]->t2[SEGMENT_T2_IDX(i)]->t1[SEGMENT_T1_IDX(i)]; +} + +FORCEINLINE seginfo *MaybeSegInfo(uptr i) { + t2table *t2i; t1table *t1i; + if ((t2i = S_segment_info[SEGMENT_T3_IDX(i)]) == NULL) return NULL; + if ((t1i = t2i->t2[SEGMENT_T2_IDX(i)]) == NULL) return NULL; + return t1i->t1[SEGMENT_T1_IDX(i)]; +} + +#else /* segment_t3_bits */ +#ifdef segment_t2_bits + +#define SEGMENT_T2_SIZE (1<>segment_t1_bits) +#define SEGMENT_T3_SIZE 0 + +FORCEINLINE seginfo *SegInfo(uptr i) { + return S_segment_info[SEGMENT_T2_IDX(i)]->t1[SEGMENT_T1_IDX(i)]; +} + +FORCEINLINE seginfo *MaybeSegInfo(uptr i) { + t1table *t1i; + if ((t1i = S_segment_info[SEGMENT_T2_IDX(i)]) == NULL) return NULL; + return t1i->t1[SEGMENT_T1_IDX(i)]; +} + +#else /* segment_t2_bits */ + +#define SEGMENT_T2_SIZE 0 +#define SEGMENT_T3_SIZE 0 + +FORCEINLINE seginfo *SegInfo(uptr i) { + return S_segment_info[SEGMENT_T1_IDX(i)]; +} + +FORCEINLINE seginfo *MaybeSegInfo(uptr i) { + return S_segment_info[SEGMENT_T1_IDX(i)]; +} + +#endif /* segment_t2_bits */ +#endif /* segment_t3_bits */ + +#define SegmentSpace(i) (SegInfo(i)->space) +#define SegmentGeneration(i) (SegInfo(i)->generation) diff --git a/c/sort.h b/c/sort.h new file mode 100644 index 0000000..ae0652b --- /dev/null +++ b/c/sort.h @@ -0,0 +1,40 @@ +/* sort.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define mkmergesort(sort, merge, type, nil, lt, cdr)\ +type sort(type ls, uptr len) {\ + if (len == 1) {\ + cdr(ls) = nil;\ + return ls;\ + } else {\ + uptr head_len, i; type tail;\ + head_len = len >> 1;\ + for (tail = ls, i = head_len; i != 0; i -= 1) tail = cdr(tail);\ + return merge(sort(ls, head_len), sort(tail, len - head_len));\ + }\ +}\ +type merge(type ls1, type ls2) {\ + type p; type *pp = &p;\ + for (;;) {\ + if (ls1 == nil) { *pp = ls2; break; }\ + if (ls2 == nil) { *pp = ls1; break; }\ + if (lt(ls2, ls1))\ + { *pp = ls2; pp = &cdr(ls2); ls2 = cdr(ls2); }\ + else\ + { *pp = ls1; pp = &cdr(ls1); ls1 = cdr(ls1); }\ + }\ + return p;\ +} diff --git a/c/statics.c b/c/statics.c new file mode 100644 index 0000000..d5618d0 --- /dev/null +++ b/c/statics.c @@ -0,0 +1,22 @@ +/* statics.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#define EXTERN +#include "system.h" + +/* The C linker may require a reference to a function to pull in all + the common declarations. */ +void scheme_statics(void) { } diff --git a/c/stats.c b/c/stats.c new file mode 100644 index 0000000..8f7b68a --- /dev/null +++ b/c/stats.c @@ -0,0 +1,528 @@ +/* stats.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#if defined(SOLARIS) +/* make gmtime_r and localtime_r visible */ +#ifndef _REENTRANT +#define _REENTRANT +#endif +/* make two-argument ctime_r and two-argument asctime_r visible */ +#define _POSIX_PTHREAD_SEMANTICS +#endif /* defined(SOLARIS) */ + +#include "system.h" + +#ifdef WIN32 +#include +#include +#else /* WIN32 */ +#include +#include +#include +#endif + +static struct timespec starting_mono_tp; + +static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff); + +/******** unique-id ********/ + +#if (time_t_bits == 32) +#define S_integer_time_t(x) Sinteger32((iptr)(x)) +#elif (time_t_bits == 64) +#define S_integer_time_t(x) Sinteger64(x) +#endif + +#ifdef WIN32 + +#include + +ptr S_unique_id(void) { + union {UUID uuid; U32 foo[4];} u; + u.foo[0] = 0; + u.foo[1] = 0; + u.foo[2] = 0; + u.foo[3] = 0; + UuidCreate(&u.uuid); + return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))), + Sunsigned32(u.foo[3])))); +} + +#elif defined(USE_OSSP_UUID) /* WIN32 */ + +#include + +ptr S_unique_id(void) { + uuid_t *uuid; + U32 bin[4]; + void *bin_ptr = &bin; + size_t bin_len = sizeof(bin); + + uuid_create(&uuid); + uuid_make(uuid, UUID_MAKE_V4); + uuid_export(uuid, UUID_FMT_BIN, &bin_ptr, &bin_len); + uuid_destroy(uuid); + + return S_add(S_ash(Sunsigned32(bin[0]), Sinteger(8*3*sizeof(U32))), + S_add(S_ash(Sunsigned32(bin[1]), Sinteger(8*2*sizeof(U32))), + S_add(S_ash(Sunsigned32(bin[2]), Sinteger(8*sizeof(U32))), + Sunsigned32(bin[3])))); +} + +#elif defined(USE_NETBSD_UUID) /* USE_OSSP_UUID */ + +#include + +ptr S_unique_id(void) { + uuid_t uuid; + uint32_t status; + unsigned char bin[16]; + ptr n; + unsigned int i; + + uuid_create(&uuid, &status); + uuid_enc_le(bin, &uuid); + + n = Sinteger(0); + for (i = 0; i < sizeof(bin); i++) { + n = S_add(n, S_ash(Sinteger(bin[i]), Sinteger(8*i))); + } + + return n; +} + +#else /* USE_NETBSD_UUID */ + +#include + +ptr S_unique_id(void) { + union {uuid_t uuid; U32 foo[4];} u; + u.foo[0] = 0; + u.foo[1] = 0; + u.foo[2] = 0; + u.foo[3] = 0; + uuid_generate(u.uuid); + return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))), + Sunsigned32(u.foo[3])))); +} + +#endif /* WIN32 */ + + +/******** time and date support ********/ + +#ifdef WIN32 + +static __int64 hires_cps = 0; + +typedef void (WINAPI *GetSystemTimeAsFileTime_t)(LPFILETIME lpSystemTimeAsFileTime); + +static GetSystemTimeAsFileTime_t s_GetSystemTimeAsFileTime = GetSystemTimeAsFileTime; + +void S_gettime(INT typeno, struct timespec *tp) { + switch (typeno) { + case time_process: { + FILETIME ftKernel, ftUser, ftDummy; + + if (GetProcessTimes(GetCurrentProcess(), &ftDummy, &ftDummy, + &ftKernel, &ftUser)) { + __int64 kernel, user, total; + kernel = ftKernel.dwHighDateTime; + kernel <<= 32; + kernel |= ftKernel.dwLowDateTime; + user = ftUser.dwHighDateTime; + user <<= 32; + user |= ftUser.dwLowDateTime; + total = user + kernel; + tp->tv_sec = (time_t)(total / 10000000); + tp->tv_nsec = (long)((total % 10000000) * 100); + break; + } else { + clock_t n = clock();; + /* if GetProcessTimes fails, we're probably running Windows 95 */ + tp->tv_sec = (time_t)(n / CLOCKS_PER_SEC); + tp->tv_nsec = (long)((n % CLOCKS_PER_SEC) * (1000000000 / CLOCKS_PER_SEC)); + break; + } + } + + case time_thread: { + FILETIME ftKernel, ftUser, ftDummy; + + if (GetThreadTimes(GetCurrentThread(), &ftDummy, &ftDummy, + &ftKernel, &ftUser)) { + __int64 kernel, user, total; + kernel = ftKernel.dwHighDateTime; + kernel <<= 32; + kernel |= ftKernel.dwLowDateTime; + user = ftUser.dwHighDateTime; + user <<= 32; + user |= ftUser.dwLowDateTime; + total = user + kernel; + tp->tv_sec = (time_t)(total / 10000000); + tp->tv_nsec = (long)((total % 10000000) * 100); + break; + } else { + clock_t n = clock();; + /* if GetThreadTimes fails, we're probably running Windows 95 */ + tp->tv_sec = (time_t)(n / CLOCKS_PER_SEC); + tp->tv_nsec = (long)((n % CLOCKS_PER_SEC) * (1000000000 / CLOCKS_PER_SEC)); + break; + } + } + + case time_duration: + case time_monotonic: { + LARGE_INTEGER count; + + if (hires_cps == 0 && QueryPerformanceFrequency(&count)) + hires_cps = count.QuadPart; + + if (hires_cps && QueryPerformanceCounter(&count)) { + tp->tv_sec = (time_t)(count.QuadPart / hires_cps); + tp->tv_nsec = (long)((count.QuadPart % hires_cps) * (1000000000 / hires_cps)); + break; + } else { + DWORD count = GetTickCount(); + tp->tv_sec = (time_t)(count / 1000); + tp->tv_nsec = (long)((count % 1000) * 1000000); + break; + } + } + + case time_utc: { + FILETIME ft; __int64 total; + + s_GetSystemTimeAsFileTime(&ft); + total = ft.dwHighDateTime; + total <<= 32; + total |= ft.dwLowDateTime; + /* measurement interval is 100 nanoseconds = 1/10 microseconds */ + /* adjust by number of seconds between Windows (1601) and Unix (1970) epochs */ + tp->tv_sec = (time_t)(total / 10000000 - 11644473600L); + tp->tv_nsec = (long)((total % 10000000) * 100); + break; + } + + default: + S_error1("S_gettime", "unexpected typeno ~s", Sinteger(typeno)); + break; + } +} + +static struct tm *gmtime_r(const time_t *timep, struct tm *result) { + return gmtime_s(result, timep) == 0 ? result : NULL; +} + +static struct tm *localtime_r(const time_t *timep, struct tm *result) { + return localtime_s(result, timep) == 0 ? result : NULL; +} + +static char *ctime_r(const time_t *timep, char *buf) { + return ctime_s(buf, 26, timep) == 0 ? buf : NULL; +} + +static char *asctime_r(const struct tm *tm, char *buf) { + return asctime_s(buf, 26, tm) == 0 ? buf : NULL; +} + +#else /* WIN32 */ + +void S_gettime(INT typeno, struct timespec *tp) { + switch (typeno) { + case time_thread: +#ifdef CLOCK_THREAD_CPUTIME_ID + if (clock_gettime(CLOCK_THREAD_CPUTIME_ID, tp) == 0) return; +#endif + /* fall through */ + /* to utc case in case no thread timer */ + case time_process: +#ifdef CLOCK_PROCESS_CPUTIME_ID + if (clock_gettime(CLOCK_PROCESS_CPUTIME_ID, tp) == 0) return; +#endif + /* fall back on getrusage if clock_gettime fails */ + { + struct rusage rbuf; + + if (getrusage(RUSAGE_SELF,&rbuf) != 0) + S_error1("S_gettime", "failed: ~s", S_strerror(errno)); + tp->tv_sec = rbuf.ru_utime.tv_sec + rbuf.ru_stime.tv_sec; + tp->tv_nsec = (rbuf.ru_utime.tv_usec + rbuf.ru_stime.tv_usec) * 1000; + if (tp->tv_nsec >= 1000000000) { + tp->tv_sec += 1; + tp->tv_nsec -= 1000000000; + } + return; + } + case time_duration: + case time_monotonic: +#ifdef CLOCK_MONOTONIC_HR + if (clock_gettime(CLOCK_MONOTONIC_HR, tp) == 0) return; +#endif +#ifdef CLOCK_MONOTONIC + if (clock_gettime(CLOCK_MONOTONIC, tp) == 0) return; +#endif +#ifdef CLOCK_HIGHRES + if (clock_gettime(CLOCK_HIGHRES, tp) == 0) return; +#endif + /* fall through */ + /* to utc case in case no monotonic timer */ + case time_utc: +#ifdef CLOCK_REALTIME_HR + if (clock_gettime(CLOCK_REALTIME_HR, tp) == 0) return; +#endif +#ifdef CLOCK_REALTIME + if (clock_gettime(CLOCK_REALTIME, tp) == 0) return; +#endif + /* fall back on gettimeofday if clock_gettime fails */ + { + struct timeval tvtp; + + if (gettimeofday(&tvtp,NULL) != 0) + S_error1("S_gettime", "failed: ~s", S_strerror(errno)); + tp->tv_sec = (time_t)tvtp.tv_sec; + tp->tv_nsec = (long)(tvtp.tv_usec * 1000); + return; + } + default: + S_error1("S_gettime", "unexpected typeno ~s", Sinteger(typeno)); + break; + } +} + +#endif /* WIN32 */ + +ptr S_clock_gettime(I32 typeno) { + struct timespec tp; + time_t sec; I32 nsec; + + S_gettime(typeno, &tp); + + sec = tp.tv_sec; + nsec = tp.tv_nsec; + + if (typeno == time_monotonic || typeno == time_duration) { + sec -= starting_mono_tp.tv_sec; + nsec -= starting_mono_tp.tv_nsec; + if (nsec < 0) { + sec -= 1; + nsec += 1000000000; + } + } + + return Scons(S_integer_time_t(sec), Sinteger(nsec)); +} + +ptr S_gmtime(ptr tzoff, ptr tspair) { + time_t tx; + struct tm tmx; + ptr dtvec = S_vector(dtvec_size); + + if (tspair == Sfalse) { + struct timespec tp; + + S_gettime(time_utc, &tp); + tx = tp.tv_sec; + INITVECTIT(dtvec, dtvec_nsec) = Sinteger(tp.tv_nsec); + } else { + tx = Sinteger_value(Scar(tspair)); + INITVECTIT(dtvec, dtvec_nsec) = Scdr(tspair); + } + + if (tzoff == Sfalse) { + if (localtime_r(&tx, &tmx) == NULL) return Sfalse; + tmx.tm_isdst = -1; /* have mktime determine the DST status */ + if (mktime(&tmx) == (time_t)-1) return Sfalse; + (void) adjust_time_zone(dtvec, &tmx, Sfalse); + } else { + tx += Sinteger_value(tzoff); + if (gmtime_r(&tx, &tmx) == NULL) return Sfalse; + INITVECTIT(dtvec, dtvec_tzoff) = tzoff; + INITVECTIT(dtvec, dtvec_isdst) = Sfalse; + INITVECTIT(dtvec, dtvec_tzname) = Sfalse; + } + + INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec); + INITVECTIT(dtvec, dtvec_min) = Sinteger(tmx.tm_min); + INITVECTIT(dtvec, dtvec_hour) = Sinteger(tmx.tm_hour); + INITVECTIT(dtvec, dtvec_mday) = Sinteger(tmx.tm_mday); + INITVECTIT(dtvec, dtvec_mon) = Sinteger(tmx.tm_mon + 1); + INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year); + INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday); + INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday); + + return dtvec; +} + +ptr S_asctime(ptr dtvec) { + char buf[26]; + + if (dtvec == Sfalse) { + time_t tx = time(NULL); + if (ctime_r(&tx, buf) == NULL) return Sfalse; + } else { + struct tm tmx; + tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec)); + tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min)); + tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour)); + tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday)); + tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1; + tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year)); + tmx.tm_wday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_wday)); + tmx.tm_yday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_yday)); + tmx.tm_isdst = (int)Sboolean_value(Svector_ref(dtvec, dtvec_isdst)); + if (asctime_r(&tmx, buf) == NULL) return Sfalse; + } + + return S_string(buf, 24) /* all but trailing newline */; +} + +ptr S_mktime(ptr dtvec) { + time_t tx; + struct tm tmx; + long orig_tzoff, tzoff; + ptr given_tzoff; + + tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec)); + tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min)); + tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour)); + tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday)); + tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1; + tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year)); + + given_tzoff = INITVECTIT(dtvec, dtvec_tzoff); + if (given_tzoff == Sfalse) + orig_tzoff = 0; + else + orig_tzoff = (long)UNFIX(given_tzoff); + + tmx.tm_isdst = -1; /* have mktime determine the DST status */ + if ((tx = mktime(&tmx)) == (time_t)-1) return Sfalse; + + /* mktime may have normalized some values, set wday and yday */ + INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec); + INITVECTIT(dtvec, dtvec_min) = Sinteger(tmx.tm_min); + INITVECTIT(dtvec, dtvec_hour) = Sinteger(tmx.tm_hour); + INITVECTIT(dtvec, dtvec_mday) = Sinteger(tmx.tm_mday); + INITVECTIT(dtvec, dtvec_mon) = Sinteger(tmx.tm_mon + 1); + INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year); + INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday); + INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday); + + tzoff = adjust_time_zone(dtvec, &tmx, given_tzoff); + + if (tzoff != orig_tzoff) tx = tx - orig_tzoff + tzoff; + + return Scons(S_integer_time_t(tx), Svector_ref(dtvec, dtvec_nsec)); +} + +static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) { + ptr tz_name = Sfalse; + long use_tzoff, tzoff; + +#ifdef WIN32 + { + TIME_ZONE_INFORMATION tz; + wchar_t *w_tzname; + + /* The ...ForYear() function is available on Windows Vista and later: */ + GetTimeZoneInformationForYear(tmxp->tm_year, NULL, &tz); + + if (tmxp->tm_isdst) { + tzoff = (tz.Bias + tz.DaylightBias) * -60; + w_tzname = tz.DaylightName; + } else { + tzoff = (tz.Bias + tz.StandardBias) * -60; + w_tzname = tz.StandardName; + } + + if (given_tzoff == Sfalse) { + char *name = Swide_to_utf8(w_tzname); + tz_name = Sstring_utf8(name, -1); + free(name); + } + } +#else + tzoff = tmxp->tm_gmtoff; + if (given_tzoff == Sfalse) { +# if defined(__linux__) || defined(SOLARIS) + /* Linux and Solaris set `tzname`: */ + tz_name = Sstring_utf8(tzname[tmxp->tm_isdst], -1); +# else + /* BSD variants add `tm_zone` in `struct tm`: */ + tz_name = Sstring_utf8(tmxp->tm_zone, -1); +# endif + } +#endif + + if (given_tzoff == Sfalse) + use_tzoff = tzoff; + else + use_tzoff = (long)UNFIX(given_tzoff); + + INITVECTIT(dtvec, dtvec_isdst) = ((given_tzoff == Sfalse) ? Sboolean(tmxp->tm_isdst) : Sfalse); + INITVECTIT(dtvec, dtvec_tzoff) = FIX(use_tzoff); + INITVECTIT(dtvec, dtvec_tzname) = tz_name; + + return tzoff; +} + +/******** old real-time and cpu-time support ********/ + +ptr S_cputime(void) { + struct timespec tp; + + S_gettime(time_process, &tp); + return S_add(S_mul(S_integer_time_t(tp.tv_sec), FIX(1000)), + Sinteger((tp.tv_nsec + 500000) / 1000000)); +} + +ptr S_realtime(void) { + struct timespec tp; + time_t sec; I32 nsec; + + S_gettime(time_monotonic, &tp); + + sec = tp.tv_sec - starting_mono_tp.tv_sec; + nsec = tp.tv_nsec - starting_mono_tp.tv_nsec; + if (nsec < 0) { + sec -= 1; + nsec += 1000000000; + } + return S_add(S_mul(S_integer_time_t(sec), FIX(1000)), + Sinteger((nsec + 500000) / 1000000)); +} + +/******** initialization ********/ + +void S_stats_init(void) { +#ifdef WIN32 + /* Use GetSystemTimePreciseAsFileTime when available (Windows 8 and later). */ + HMODULE h = LoadLibraryW(L"kernel32.dll"); + if (h != NULL) { + GetSystemTimeAsFileTime_t proc = (GetSystemTimeAsFileTime_t)GetProcAddress(h, "GetSystemTimePreciseAsFileTime"); + if (proc != NULL) + s_GetSystemTimeAsFileTime = proc; + else + FreeLibrary(h); + } +#endif + S_gettime(time_monotonic, &starting_mono_tp); +} diff --git a/c/symbol.c b/c/symbol.c new file mode 100644 index 0000000..0e1c2c6 --- /dev/null +++ b/c/symbol.c @@ -0,0 +1,28 @@ +/* symbol.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +ptr S_symbol_value(ptr sym) { + if (SYMVAL(sym) == sunbound) + S_error1("","~s is not bound", sym); + return SYMVAL(sym); +} + +void S_set_symbol_value(ptr sym, ptr val) { + SETSYMVAL(sym, val); + SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : S_G.nonprocedure_code); +} diff --git a/c/system.h b/c/system.h new file mode 100644 index 0000000..868708b --- /dev/null +++ b/c/system.h @@ -0,0 +1,47 @@ +/* system.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "scheme.h" +#include "equates.h" +#ifdef FEATURE_WINDOWS +#ifdef __MINGW32__ +# undef WINVER +# undef _WIN32_WINNT +#endif +#define WINVER 0x0601 // Windows 7 +#define _WIN32_WINNT WINVER +#include +#endif + +#include "version.h" +#include +#include + +#include "thread.h" + +#include "types.h" + +#include "compress-io.h" + +#ifndef EXTERN +#define EXTERN extern +#endif +#include "globals.h" + +#include "externs.h" + +#include "segment.h" + diff --git a/c/thread.c b/c/thread.c new file mode 100644 index 0000000..e836aee --- /dev/null +++ b/c/thread.c @@ -0,0 +1,470 @@ +/* thread.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +/* locally defined functions */ +#ifdef PTHREADS +static s_thread_rv_t start_thread(void *tc); +static IBOOL destroy_thread(ptr tc); +#endif + +void S_thread_init(void) { + if (S_boot_time) { + S_protect(&S_G.threadno); + S_G.threadno = FIX(0); + +#ifdef PTHREADS + /* this is also reset in scheme.c after heap restoration */ + s_thread_mutex_init(&S_tc_mutex.pmutex); + S_tc_mutex.owner = s_thread_self(); + S_tc_mutex.count = 0; + s_thread_cond_init(&S_collect_cond); + S_tc_mutex_depth = 0; +#endif /* PTHREADS */ + } +} + +/* this needs to be reworked. currently, S_create_thread_object is + called from main to create the base thread, from fork_thread when + there is already an active current thread, and from S_activate_thread + when there is no current thread. we have to avoid thread-local + allocation in at least the latter case, so we call vector_in and + cons_in and arrange for S_thread to use find_room rather than + thread_find_room. scheme.c does part of the initialization of the + base thread (e.g., parameters, current input/output ports) in one + or more places. */ +ptr S_create_thread_object(const char *who, ptr p_tc) { + ptr thread, tc; + INT i; + + tc_mutex_acquire() + + if (S_threads == Snil) { + tc = (ptr)S_G.thread_context; + } else { /* clone parent */ + ptr p_v = PARAMETERS(p_tc); + iptr i, n = Svector_length(p_v); + /* use S_vector_in to avoid thread-local allocation */ + ptr v = S_vector_in(space_new, 0, n); + + tc = (ptr)malloc(size_tc); + if (tc == (ptr)0) + S_error(who, "unable to malloc thread data structure"); + memcpy((void *)tc, (void *)p_tc, size_tc); + + for (i = 0; i < n; i += 1) + INITVECTIT(v, i) = Svector_ref(p_v, i); + + PARAMETERS(tc) = v; + CODERANGESTOFLUSH(tc) = Snil; + } + + /* override nonclonable tc fields */ + THREADNO(tc) = S_G.threadno; + S_G.threadno = S_add(S_G.threadno, FIX(1)); + + CCHAIN(tc) = Snil; + + WINDERS(tc) = Snil; + STACKLINK(tc) = SYMVAL(S_G.null_continuation_id); + STACKCACHE(tc) = Snil; + + /* S_reset_scheme_stack initializes stack, size, esp, and sfp */ + S_reset_scheme_stack(tc, stack_slop); + FRAME(tc,0) = (ptr)&CODEIT(S_G.dummy_code_object,size_rp_header); + + /* S_reset_allocation_pointer initializes ap and eap */ + S_reset_allocation_pointer(tc); + RANDOMSEED(tc) = most_positive_fixnum < 0xffffffff ? most_positive_fixnum : 0xffffffff; + X(tc) = Y(tc) = U(tc) = V(tc) = W(tc) = FIX(0); + + TIMERTICKS(tc) = Sfalse; + DISABLECOUNT(tc) = Sfixnum(0); + SIGNALINTERRUPTPENDING(tc) = Sfalse; + SIGNALINTERRUPTQUEUE(tc) = S_allocate_scheme_signal_queue(); + KEYBOARDINTERRUPTPENDING(tc) = Sfalse; + + TARGETMACHINE(tc) = S_intern((const unsigned char *)MACHINE_TYPE); + + /* choosing not to clone virtual registers */ + for (i = 0 ; i < virtual_register_count ; i += 1) { + VIRTREG(tc, i) = FIX(0); + } + + DSTBV(tc) = SRCBV(tc) = Sfalse; + + /* S_thread had better not do thread-local allocation */ + thread = S_thread(tc); + + /* use S_cons_in to avoid thread-local allocation */ + S_threads = S_cons_in(space_new, 0, thread, S_threads); + S_nthreads += 1; + SETSYMVAL(S_G.active_threads_id, + FIX(UNFIX(SYMVAL(S_G.active_threads_id)) + 1)); + ACTIVE(tc) = 1; + + /* collect request is only thing that can be pending for new thread. + must do this after we're on the thread list in case the cons + adding us onto the thread list set collect-request-pending */ + SOMETHINGPENDING(tc) = SYMVAL(S_G.collect_request_pending_id); + + GUARDIANENTRIES(tc) = Snil; + + LZ4OUTBUFFER(tc) = NULL; + + tc_mutex_release() + + return thread; +} + +#ifdef PTHREADS +IBOOL Sactivate_thread(void) { /* create or reactivate current thread */ + ptr tc = get_thread_context(); + + if (tc == (ptr)0) { /* thread created by someone else */ + ptr thread; + + /* borrow base thread for now */ + thread = S_create_thread_object("Sactivate_thread", S_G.thread_context); + s_thread_setspecific(S_tc_key, (ptr)THREADTC(thread)); + return 1; + } else { + reactivate_thread(tc) + return 0; + } +} + +int S_activate_thread(void) { /* Like Sactivate_thread(), but returns a mode to revert the effect */ + ptr tc = get_thread_context(); + + if (tc == (ptr)0) { + Sactivate_thread(); + return unactivate_mode_destroy; + } else if (!ACTIVE(tc)) { + reactivate_thread(tc); + return unactivate_mode_deactivate; + } else + return unactivate_mode_noop; +} + +void S_unactivate_thread(int mode) { /* Reverts a previous S_activate_thread() effect */ + switch (mode) { + case unactivate_mode_deactivate: + Sdeactivate_thread(); + break; + case unactivate_mode_destroy: + Sdestroy_thread(); + break; + case unactivate_mode_noop: + default: + break; + } +} + +void Sdeactivate_thread(void) { /* deactivate current thread */ + ptr tc = get_thread_context(); + if (tc != (ptr)0) deactivate_thread(tc) +} + +int Sdestroy_thread(void) { /* destroy current thread */ + ptr tc = get_thread_context(); + if (tc != (ptr)0 && destroy_thread(tc)) { + s_thread_setspecific(S_tc_key, 0); + return 1; + } + return 0; +} + +static IBOOL destroy_thread(ptr tc) { + ptr *ls; IBOOL status; + + status = 0; + tc_mutex_acquire() + ls = &S_threads; + while (*ls != Snil) { + ptr thread = Scar(*ls); + if (THREADTC(thread) == (uptr)tc) { + *ls = Scdr(*ls); + S_nthreads -= 1; + + /* process remembered set before dropping allocation area */ + S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc)); + + /* process guardian entries */ + { + ptr target, ges, obj, next; seginfo *si; + target = S_G.guardians[0]; + for (ges = GUARDIANENTRIES(tc); ges != Snil; ges = next) { + obj = GUARDIANOBJ(ges); + next = GUARDIANNEXT(ges); + if (!IMMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) { + INITGUARDIANNEXT(ges) = target; + target = ges; + } + } + S_G.guardians[0] = target; + } + + /* deactivate thread */ + if (ACTIVE(tc)) { + SETSYMVAL(S_G.active_threads_id, + FIX(UNFIX(SYMVAL(S_G.active_threads_id)) - 1)); + if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id)) + && SYMVAL(S_G.active_threads_id) == FIX(0)) { + s_thread_cond_signal(&S_collect_cond); + } + } + + if (LZ4OUTBUFFER(tc) != NULL) free(LZ4OUTBUFFER(tc)); + if (SIGNALINTERRUPTQUEUE(tc) != NULL) free(SIGNALINTERRUPTQUEUE(tc)); + + free((void *)tc); + THREADTC(thread) = 0; /* mark it dead */ + status = 1; + break; + } + ls = &Scdr(*ls); + } + tc_mutex_release() + return status; +} + +ptr S_fork_thread(ptr thunk) { + ptr thread; + int status; + + /* pass the current thread's context as the parent thread */ + thread = S_create_thread_object("fork-thread", get_thread_context()); + CP(THREADTC(thread)) = thunk; + + if ((status = s_thread_create(start_thread, (void *)THREADTC(thread))) != 0) { + destroy_thread((ptr)THREADTC(thread)); + S_error1("fork-thread", "failed: ~a", S_strerror(status)); + } + + return thread; +} + +static s_thread_rv_t start_thread(p) void *p; { + ptr tc = (ptr)p; ptr cp; + + s_thread_setspecific(S_tc_key, tc); + + cp = CP(tc); + CP(tc) = Svoid; /* should hold calling code object, which we don't have */ + TRAP(tc) = (ptr)default_timer_ticks; + Scall0(cp); + /* caution: calling into Scheme may result into a collection, so we + can't access any Scheme objects, e.g., cp, after this point. But tc + is static, so we can access it. */ + + /* find and destroy our thread */ + destroy_thread(tc); + s_thread_setspecific(S_tc_key, (ptr)0); + + s_thread_return; +} + + +scheme_mutex_t *S_make_mutex() { + scheme_mutex_t *m; + + m = (scheme_mutex_t *)malloc(sizeof(scheme_mutex_t)); + + if (m == (scheme_mutex_t *)0) + S_error("make-mutex", "unable to malloc mutex"); + s_thread_mutex_init(&m->pmutex); + m->owner = s_thread_self(); + m->count = 0; + + return m; +} + +void S_mutex_free(scheme_mutex_t *m) { + s_thread_mutex_destroy(&m->pmutex); + free(m); +} + +void S_mutex_acquire(scheme_mutex_t *m) { + s_thread_t self = s_thread_self(); + iptr count; + INT status; + + if ((count = m->count) > 0 && s_thread_equal(m->owner, self)) { + if (count == most_positive_fixnum) + S_error1("mutex-acquire", "recursion limit exceeded for ~s", m); + m->count = count + 1; + return; + } + + if ((status = s_thread_mutex_lock(&m->pmutex)) != 0) + S_error1("mutex-acquire", "failed: ~a", S_strerror(status)); + m->owner = self; + m->count = 1; +} + +INT S_mutex_tryacquire(scheme_mutex_t *m) { + s_thread_t self = s_thread_self(); + iptr count; + INT status; + + if ((count = m->count) > 0 && s_thread_equal(m->owner, self)) { + if (count == most_positive_fixnum) + S_error1("mutex-acquire", "recursion limit exceeded for ~s", m); + m->count = count + 1; + return 0; + } + + status = s_thread_mutex_trylock(&m->pmutex); + if (status == 0) { + m->owner = self; + m->count = 1; + } else if (status != EBUSY) { + S_error1("mutex-acquire", "failed: ~a", S_strerror(status)); + } + return status; +} + +void S_mutex_release(scheme_mutex_t *m) { + s_thread_t self = s_thread_self(); + iptr count; + INT status; + + if ((count = m->count) == 0 || !s_thread_equal(m->owner, self)) + S_error1("mutex-release", "thread does not own mutex ~s", m); + + if ((m->count = count - 1) == 0) + if ((status = s_thread_mutex_unlock(&m->pmutex)) != 0) + S_error1("mutex-release", "failed: ~a", S_strerror(status)); +} + +s_thread_cond_t *S_make_condition() { + s_thread_cond_t *c; + + c = (s_thread_cond_t *)malloc(sizeof(s_thread_cond_t)); + if (c == (s_thread_cond_t *)0) + S_error("make-condition", "unable to malloc condition"); + s_thread_cond_init(c); + return c; +} + +void S_condition_free(s_thread_cond_t *c) { + s_thread_cond_destroy(c); + free(c); +} + +#ifdef FEATURE_WINDOWS + +static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) { + if (typeno == time_utc) { + struct timespec now; + S_gettime(time_utc, &now); + sec -= now.tv_sec; + nsec -= now.tv_nsec; + if (nsec < 0) { + sec -= 1; + nsec += 1000000000; + } + } + if (sec < 0) { + sec = 0; + nsec = 0; + } + if (SleepConditionVariableCS(cond, mutex, (DWORD)(sec*1000 + (nsec+500000)/1000000))) { + return 0; + } else if (GetLastError() == ERROR_TIMEOUT) { + return ETIMEDOUT; + } else { + return EINVAL; + } +} + +#else /* FEATURE_WINDOWS */ + +static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) { + struct timespec t; + if (typeno == time_duration) { + struct timespec now; + S_gettime(time_utc, &now); + t.tv_sec = (time_t)(now.tv_sec + sec); + t.tv_nsec = now.tv_nsec + nsec; + if (t.tv_nsec >= 1000000000) { + t.tv_sec += 1; + t.tv_nsec -= 1000000000; + } + } else { + t.tv_sec = sec; + t.tv_nsec = nsec; + } + return pthread_cond_timedwait(cond, mutex, &t); +} + +#endif /* FEATURE_WINDOWS */ + +#define Srecord_ref(x,i) (((ptr *)((uptr)(x)+record_data_disp))[i]) + +IBOOL S_condition_wait(s_thread_cond_t *c, scheme_mutex_t *m, ptr t) { + ptr tc = get_thread_context(); + s_thread_t self = s_thread_self(); + iptr count; + INT typeno; + I64 sec; + long nsec; + INT status; + + if ((count = m->count) == 0 || !s_thread_equal(m->owner, self)) + S_error1("condition-wait", "thread does not own mutex ~s", m); + + if (count != 1) + S_error1("condition-wait", "mutex ~s is recursively locked", m); + + if (t != Sfalse) { + /* Keep in sync with ts record in s/date.ss */ + typeno = Sinteger32_value(Srecord_ref(t,0)); + sec = Sinteger64_value(Scar(Srecord_ref(t,1))); + nsec = Sinteger32_value(Scdr(Srecord_ref(t,1))); + } else { + typeno = 0; + sec = 0; + nsec = 0; + } + + if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) { + deactivate_thread(tc) + } + + m->count = 0; + status = (t == Sfalse) ? s_thread_cond_wait(c, &m->pmutex) : + s_thread_cond_timedwait(c, &m->pmutex, typeno, sec, nsec); + m->owner = self; + m->count = 1; + + if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) { + reactivate_thread(tc) + } + + if (status == 0) { + return 1; + } else if (status == ETIMEDOUT) { + return 0; + } else { + S_error1("condition-wait", "failed: ~a", S_strerror(status)); + return 0; + } +} +#endif /* PTHREADS */ + diff --git a/c/thread.h b/c/thread.h new file mode 100644 index 0000000..1d4515e --- /dev/null +++ b/c/thread.h @@ -0,0 +1,91 @@ +/* thread.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#ifdef FEATURE_PTHREADS +#ifdef FEATURE_WINDOWS + +#include +#include + +/* learned from http://locklessinc.com/articles/pthreads_on_windows/ which + * Windows API types and functions to use to support mutexes and condition + * variables. there's much more information there if we ever need a more + * complete implementation of pthreads functionality. + */ + +typedef DWORD s_thread_t; +typedef DWORD s_thread_key_t; +typedef CRITICAL_SECTION s_thread_mutex_t; +typedef CONDITION_VARIABLE s_thread_cond_t; +typedef void s_thread_rv_t; +#define s_thread_return return +#define s_thread_self() GetCurrentThreadId() +#define s_thread_equal(t1, t2) ((t1) == (t2)) +/* CreateThread description says to use _beginthread if thread uses the C library */ +#define s_thread_create(start_routine, arg) (_beginthread(start_routine, 0, arg) == -1 ? EAGAIN : 0) +#define s_thread_key_create(key) ((*key = TlsAlloc()) == TLS_OUT_OF_INDEXES ? EAGAIN : 0) +#define s_thread_key_delete(key) (TlsFree(key) == 0 ? EINVAL : 0) +#define s_thread_getspecific(key) TlsGetValue(key) +#define s_thread_setspecific(key, value) (TlsSetValue(key, (void *)value) == 0 ? EINVAL : 0) +#define s_thread_mutex_init(mutex) InitializeCriticalSection(mutex) +#define s_thread_mutex_lock(mutex) (EnterCriticalSection(mutex), 0) +#define s_thread_mutex_unlock(mutex) (LeaveCriticalSection(mutex), 0) +#define s_thread_mutex_trylock(mutex) (TryEnterCriticalSection(mutex) ? 0 : EBUSY) +#define s_thread_mutex_destroy(mutex) (DeleteCriticalSection(mutex), 0) +#define s_thread_cond_init(cond) InitializeConditionVariable(cond) +#define s_thread_cond_signal(cond) (WakeConditionVariable(cond), 0) +#define s_thread_cond_broadcast(cond) (WakeAllConditionVariable(cond), 0) +#define s_thread_cond_wait(cond, mutex) (SleepConditionVariableCS(cond, mutex, INFINITE) == 0 ? EINVAL : 0) +#define s_thread_cond_destroy(cond) (0) + +#else /* FEATURE_WINDOWS */ + +#include + +typedef pthread_t s_thread_t; +typedef pthread_key_t s_thread_key_t; +typedef pthread_mutex_t s_thread_mutex_t; +typedef pthread_cond_t s_thread_cond_t; +typedef void *s_thread_rv_t; +#define s_thread_return return NULL +#define s_thread_self() pthread_self() +#define s_thread_equal(t1, t2) pthread_equal(t1, t2) +static inline int s_thread_create(void *(* start_routine)(void *), void *arg) { + pthread_attr_t attr; pthread_t thread; int status; + + pthread_attr_init(&attr); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + status = pthread_create(&thread, &attr, start_routine, arg); + pthread_attr_destroy(&attr); + return status; +} +#define s_thread_key_create(key) pthread_key_create(key, NULL) +#define s_thread_key_delete(key) pthread_key_delete(key) +#define s_thread_getspecific(key) pthread_getspecific(key) +#define s_thread_setspecific(key, value) pthread_setspecific(key, value) +#define s_thread_mutex_init(mutex) pthread_mutex_init(mutex, NULL) +#define s_thread_mutex_lock(mutex) pthread_mutex_lock(mutex) +#define s_thread_mutex_unlock(mutex) pthread_mutex_unlock(mutex) +#define s_thread_mutex_trylock(mutex) pthread_mutex_trylock(mutex) +#define s_thread_mutex_destroy(mutex) pthread_mutex_destroy(mutex) +#define s_thread_cond_init(cond) pthread_cond_init(cond, NULL) +#define s_thread_cond_signal(cond) pthread_cond_signal(cond) +#define s_thread_cond_broadcast(cond) pthread_cond_broadcast(cond) +#define s_thread_cond_wait(cond, mutex) pthread_cond_wait(cond, mutex) +#define s_thread_cond_destroy(cond) pthread_cond_destroy(cond) + +#endif /* FEATURE_WINDOWS */ +#endif /* FEATURE_PTHREADS */ diff --git a/c/types.h b/c/types.h new file mode 100644 index 0000000..227f6af --- /dev/null +++ b/c/types.h @@ -0,0 +1,381 @@ +/* types.h + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* C datatypes (mostly defined in equates.h or scheme.h) + * ptr: scheme object: (void *) on most platforms + * uptr: unsigned integer sizeof(uptr) == sizeof(ptr): typically unsigned long + * iptr: signed integer sizeof(uptr) == sizeof(ptr): typically long + * I8: 8-bit signed integer: typically char + * I16: 16-bit signed integer: typically short + * I32: 32-bit signed integer: typically int + * U32: 32-bit unsigned integer: typically unsigned int + * I64: 64-bit signed integer: typically long long + * U64: 64-bit unsigned integer: typically unsigned long long + * bigit: unsigned integer sizeof(bigit)*8 == bigit_bits + * bigit: unsigned integer sizeof(bigit)*8 == bigit_bits + */ + +#if (bigit_bits == 32) +typedef U32 bigit; +typedef U64 bigitbigit; +typedef I32 ibigit; +typedef I64 ibigitbigit; +#endif + +/* C signed/unsigned conventions: + * signed/unsigned distinction is felt in comparisons with zero, right + * shifts, multiplies, and divides. + * + * general philosophy is to avoid surprises by using signed quantities, + * with a few exceptions. + * + * use unsigned whenever shifting right. ANSI C >> is undefined for + * negative numbers. if arithmetic shift is desired, divide by the + * appropriate power of two and hope that the C compiler generates a + * shift instruction. + * + * cast to uptr for ptr address computations. this is really necessary + * only when shifting addresses, but we do it all the time since + * addresses are inherently unsigned values. + * + * however, use signed (usually iptr) for lengths and array indices. + * this allows base cases like i < 0 when working backward from the end + * to the front of an array. using uptr would give a slightly larger + * range in theory, but not in practice. + */ + +/* documentary names for ints and unsigned ints */ +typedef int INT; /* honest-to-goodness C int */ +typedef unsigned int UINT; /* honest-to-goodness C unsigned int */ +typedef int ITYPE; /* ptr types */ +typedef int ISPC; /* storage manager spaces */ +typedef int IGEN; /* storage manager generations */ +typedef int IDIRTYBYTE; /* storage manager dirty bytes */ +typedef int IBOOL; /* int used exclusively as a boolean */ +typedef int ICHAR; /* int used exclusively as a character */ +typedef int IFASLCODE; /* fasl type codes */ + +#if (BUFSIZ < 4096) +#define SBUFSIZ 4096 +#else +#define SBUFSIZ BUFSIZ +#endif + +/* inline allocation --- mutex required */ +/* find room allocates n bytes in space s and generation g into + * destination x, tagged with ty, punting to find_more_room if + * no space is left in the current segment. n is assumed to be + * an integral multiple of the object alignment. */ +#define find_room(s, g, t, n, x) {\ + ptr X = S_G.next_loc[g][s];\ + S_G.next_loc[g][s] = (ptr)((uptr)X + (n));\ + if ((S_G.bytes_left[g][s] -= (n)) < 0) X = S_find_more_room(s, g, n, X);\ + (x) = TYPE(X, t);\ +} + +/* thread-local inline allocation --- no mutex required */ +/* thread_find_room allocates n bytes in the local allocation area of + * the thread (hence space new, generation zero) into destination x, tagged + * with type t, punting to find_more_room if no space is left in the current + * allocation area. n is assumed to be an integral multiple of the object + * alignment. */ +#define thread_find_room(tc, t, n, x) {\ + ptr _tc = tc;\ + uptr _ap = (uptr)AP(_tc);\ + if ((uptr)n > ((uptr)EAP(_tc) - _ap)) {\ + (x) = S_get_more_room_help(_tc, _ap, t, n);\ + } else {\ + (x) = TYPE(_ap,t);\ + AP(_tc) = (ptr)(_ap + n);\ + }\ +} + +/* size of protected array used to store roots for the garbage collector */ +#define max_protected 100 + +#define build_ptr(s,o) ((ptr)(((uptr)(s) << segment_offset_bits) | (uptr)(o))) +#define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits) +#define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits) + +#define SPACE(p) SegmentSpace(ptr_get_segment(p)) +#define GENERATION(p) SegmentGeneration(ptr_get_segment(p)) + +#define ptr_align(size) (((size)+byte_alignment-1) & ~(byte_alignment-1)) + +typedef struct _seginfo { + unsigned char space; /* space the segment is in */ + unsigned char generation; /* generation the segment is in */ + unsigned char sorted; /* sorted indicator---possibly to be incorporated into space flags? */ + octet min_dirty_byte; /* dirty byte for full segment, effectively min(dirty_bytes) */ + uptr number; /* the segment number */ + struct _chunkinfo *chunk; /* the chunk this segment belongs to */ + struct _seginfo *next; /* pointer to the next seginfo (used in occupied_segments and unused_segs */ + struct _seginfo **dirty_prev; /* pointer to the next pointer on the previous seginfo in the DirtySegments list */ + struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */ + ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */ + octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ +} seginfo; + +typedef struct _chunkinfo { + void *addr; /* chunk starting address */ + iptr base; /* first segment */ + iptr bytes; /* size in bytes */ + iptr segs; /* size in segments */ + iptr nused_segs; /* number of segments currently in used use */ + struct _chunkinfo **prev; /* pointer to previous chunk's next */ + struct _chunkinfo *next; /* next chunk */ + struct _seginfo *unused_segs; /* list of unused segments */ + struct _seginfo sis[0]; /* one seginfo per segment */ +} chunkinfo; + +#ifdef segment_t2_bits +typedef struct _t1table { + seginfo *t1[1<>1)+to_g) +#define DIRTY_SEGMENT_LISTS DIRTY_SEGMENT_INDEX(static_generation, static_generation) + +#define DirtySegments(from_g, to_g) S_G.dirty_segments[DIRTY_SEGMENT_INDEX(from_g, to_g)] + +/* oblist */ + +typedef struct _bucket { + ptr sym; + struct _bucket *next; +} bucket; + +typedef struct _bucket_list { + struct _bucket *car; + struct _bucket_list *cdr; +} bucket_list; + +typedef struct _bucket_pointer_list { + struct _bucket **car; + struct _bucket_pointer_list *cdr; +} bucket_pointer_list; + +/* size macros for variable-sized objects */ + +#define size_vector(n) ptr_align(header_size_vector + (n)*ptr_bytes) +#define size_closure(n) ptr_align(header_size_closure + (n)*ptr_bytes) +#define size_string(n) ptr_align(header_size_string + (n)*string_char_bytes) +#define size_fxvector(n) ptr_align(header_size_fxvector + (n)*ptr_bytes) +#define size_bytevector(n) ptr_align(header_size_bytevector + (n)) +#define size_bignum(n) ptr_align(header_size_bignum + (n)*bigit_bytes) +#define size_code(n) ptr_align(header_size_code + (n)) +#define size_reloc_table(n) ptr_align(header_size_reloc_table + (n)*ptr_bytes) +#define size_record_inst(n) ptr_align(n) +#define unaligned_size_record_inst(n) (n) + +/* type tagging macros */ + +#define TYPE(x,type) ((ptr)((iptr)(x) - typemod + (type))) +#define UNTYPE(x,type) ((ptr)((iptr)(x) + typemod - (type))) +#define UNTYPE_ANY(x) ((ptr)(((iptr)(x) + (typemod - 1)) & ~(typemod - 1))) +#define TYPEBITS(x) ((iptr)(x) & (typemod - 1)) +#define TYPEFIELD(x) (*(ptr *)UNTYPE(x, type_typed_object)) + +#define FIX(x) Sfixnum(x) +#define UNFIX(x) Sfixnum_value(x) + +#define TYPEP(x,mask,type) (((iptr)(x) & (mask)) == (type)) + +/* reloc fields */ +#define RELOC_EXTENDED_FORMAT(x) ((x)&reloc_extended_format) +#define RELOC_TYPE(x) (((x)>>reloc_type_offset)&reloc_type_mask) +#define RELOC_CODE_OFFSET(x) (((x)>>reloc_code_offset_offset)&reloc_code_offset_mask) +#define RELOC_ITEM_OFFSET(x) (((x)>>reloc_item_offset_offset)&reloc_item_offset_mask) +#define MAKE_SHORT_RELOC(ty,co,io) (((ty)< +#define MAKE_NAN(x) { x = sqrt(-1.0); } +#ifndef PATH_MAX +# define PATH_MAX _MAX_PATH +#endif +typedef char *memcpy_t; +struct timespec; +#ifndef __MINGW32__ +# define _setjmp setjmp +# define _longjmp longjmp +# define ftruncate _chsize_s +#endif +#define LOCK_SH 1 +#define LOCK_EX 2 +#define LOCK_NB 4 +#define LOCK_UN 8 +#define FLOCK S_windows_flock +#define DIRMARKERP(c) ((c) == '/' || (c) == '\\') +#define CHDIR S_windows_chdir +#define CHMOD S_windows_chmod +#define CLOSE _close +#define DUP _dup +#define FILENO _fileno +#define FSTAT _fstat64 +#define GETCWD S_windows_getcwd +#define GETPID _getpid +#define HYPOT _hypot +#define LSEEK _lseeki64 +#define LSTAT S_windows_stat64 +#define OFF_T __int64 +#define OPEN S_windows_open +#define READ _read +#define RENAME S_windows_rename +#define RMDIR S_windows_rmdir +#define STAT S_windows_stat64 +#define STATBUF _stat64 +#define SYSTEM S_windows_system +#define UNLINK S_windows_unlink +#define WRITE _write +#define SECATIME(sb) (sb).st_atime +#define SECCTIME(sb) (sb).st_ctime +#define SECMTIME(sb) (sb).st_mtime +#define NSECATIME(sb) 0 +#define NSECCTIME(sb) 0 +#define NSECMTIME(sb) 0 +#define ICONV_INBUF_TYPE char ** +struct timespec; +#define UNUSED +#endif + +#if (machine_type == machine_type_i3ob || machine_type == machine_type_ti3ob || machine_type == machine_type_a6ob || machine_type == machine_type_ta6ob) +#if (machine_type == machine_type_ti3ob || machine_type == machine_type_ta6ob) +#define PTHREADS +#endif +#define NOBLOCK O_NONBLOCK +#define LOAD_SHARED_OBJECT +#define USE_MMAP +#define MMAP_HEAP +#define IEEE_DOUBLE +#define LITTLE_ENDIAN_IEEE_DOUBLE +#define LDEXP +#define ARCHYPERBOLIC +#define GETPAGESIZE() getpagesize() +typedef char *memcpy_t; +struct timespec; +#define MAKE_NAN(x) { x = 0.0; x = x / x; } +#define GETWD(x) getcwd((x),PATH_MAX) +typedef int tputsputcchar; +#define LOCKF +#define DIRMARKERP(c) ((c) == '/') +#ifndef DISABLE_X11 +#define LIBX11 "libX11.so" +#endif +#define SECATIME(sb) (sb).st_atimespec.tv_sec +#define SECCTIME(sb) (sb).st_ctimespec.tv_sec +#define SECMTIME(sb) (sb).st_mtimespec.tv_sec +#define NSECATIME(sb) (sb).st_atimespec.tv_nsec +#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec +#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec +#define ICONV_INBUF_TYPE char ** +#define UNUSED __attribute__((__unused__)) +#define USE_OSSP_UUID +#endif + +#if (machine_type == machine_type_i3osx || machine_type == machine_type_ti3osx || machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx) +#if (machine_type == machine_type_ti3osx || machine_type == machine_type_ta6osx) +#define PTHREADS +#endif +#if (machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx) +#ifndef NO_ROSETTA_CHECK +#define CHECK_FOR_ROSETTA +extern int is_rosetta; +#endif +#endif +#define MACOSX +#define NOBLOCK O_NONBLOCK +#define LOAD_SHARED_OBJECT +#define USE_MMAP +#define MMAP_HEAP +#define IEEE_DOUBLE +#define LITTLE_ENDIAN_IEEE_DOUBLE +#define LDEXP +#define ARCHYPERBOLIC +#define GETPAGESIZE() getpagesize() +typedef char *memcpy_t; +#define MAKE_NAN(x) { x = 0.0; x = x / x; } +#define GETWD(x) getcwd((x),PATH_MAX) +typedef int tputsputcchar; +#define LOCKF +#define DIRMARKERP(c) ((c) == '/') +#ifndef DISABLE_X11 +#define LIBX11 "/usr/X11R6/lib/libX11.dylib" +#endif +#define _DARWIN_USE_64_BIT_INODE +#define SECATIME(sb) (sb).st_atimespec.tv_sec +#define SECCTIME(sb) (sb).st_ctimespec.tv_sec +#define SECMTIME(sb) (sb).st_mtimespec.tv_sec +#define NSECATIME(sb) (sb).st_atimespec.tv_nsec +#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec +#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec +#define ICONV_INBUF_TYPE char ** +#define UNUSED __attribute__((__unused__)) +#endif + +#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx) +#if (machine_type == machine_type_ti3qnx) +#define PTHREADS +#endif +#define NOBLOCK O_NONBLOCK +#define LOAD_SHARED_OBJECT +#define USE_MMAP +#define MMAP_HEAP +#define IEEE_DOUBLE +#define LITTLE_ENDIAN_IEEE_DOUBLE +#define LDEXP +#define ARCHYPERBOLIC +#define GETPAGESIZE() getpagesize() +typedef char *memcpy_t; +#define MAKE_NAN(x) { x = 0.0; x = x / x; } +#define GETWD(x) getcwd((x),PATH_MAX) +typedef int tputsputcchar; +#define LOCKF +#define DIRMARKERP(c) ((c) == '/') +#define LSEEK lseek64 +#define OFF_T off64_t +#define _LARGEFILE64_SOURCE +#define SECATIME(sb) (sb).st_atime +#define SECCTIME(sb) (sb).st_ctime +#define SECMTIME(sb) (sb).st_mtime +#define NSECATIME(sb) 0 +#define NSECCTIME(sb) 0 +#define NSECMTIME(sb) 0 +#define ICONV_INBUF_TYPE char ** +#define NOFILE 256 +#define UNUSED +#endif + +#if (machine_type == machine_type_i3s2 || machine_type == machine_type_ti3s2 || machine_type == machine_type_a6s2 || machine_type == machine_type_ta6s2) +#if (machine_type == machine_type_ti3s2 || machine_type == machine_type_ta6s2) +#define PTHREADS +#endif +#define NOBLOCK O_NONBLOCK +#define LOAD_SHARED_OBJECT +#define USE_MMAP +#define MMAP_HEAP +#define IEEE_DOUBLE +#define LITTLE_ENDIAN_IEEE_DOUBLE +#define LDEXP +#define ARCHYPERBOLIC +#define LOG1P +#define DEFINE_MATHERR +#define GETPAGESIZE() getpagesize() +typedef char *memcpy_t; +#define MAKE_NAN(x) { x = 0.0; x = x / x; } +#define _setjmp setjmp +#define _longjmp longjmp +typedef char tputsputcchar; +#define LOCKF +#define DIRMARKERP(c) ((c) == '/') +#ifndef DISABLE_X11 +#define LIBX11 "libX11.so" +#endif +#define SECATIME(sb) (sb).st_atim.tv_sec +#define SECCTIME(sb) (sb).st_ctim.tv_sec +#define SECMTIME(sb) (sb).st_mtim.tv_sec +#define NSECATIME(sb) (sb).st_atim.tv_nsec +#define NSECCTIME(sb) (sb).st_ctim.tv_nsec +#define NSECMTIME(sb) (sb).st_mtim.tv_nsec +#define ICONV_INBUF_TYPE const char ** +#define UNUSED __attribute__((__unused__)) +#endif + +/* defaults */ + +#ifndef CHDIR +# define CHDIR chdir +#endif +#ifndef CHMOD +# define CHMOD chmod +#endif +#ifndef CLOSE +# define CLOSE close +#endif +#ifndef DUP +# define DUP dup +#endif +#ifndef FILENO +# define FILENO fileno +#endif +#ifndef FSTAT +# define FSTAT fstat +#endif +#ifndef GETPID +# define GETPID getpid +#endif +#ifndef HYPOT +# define HYPOT hypot +#endif +#ifndef OFF_T +# define OFF_T off_t +#endif +#ifndef LSEEK +# define LSEEK lseek +#endif +#ifndef LSTAT +# define LSTAT lstat +#endif +#ifndef OPEN +# define OPEN open +#endif +#ifndef READ +# define READ read +#endif +#ifndef RENAME +# define RENAME rename +#endif +#ifndef RMDIR +# define RMDIR rmdir +#endif +#ifndef STAT +# define STAT stat +#endif +#ifndef STATBUF +# define STATBUF stat +#endif +#ifndef SYSTEM +# define SYSTEM system +#endif +#ifndef UNLINK +# define UNLINK unlink +#endif +#ifndef WRITE +# define WRITE write +#endif diff --git a/c/vs.bat b/c/vs.bat new file mode 100644 index 0000000..997c6c8 --- /dev/null +++ b/c/vs.bat @@ -0,0 +1,70 @@ +@echo off +set Applications=%ProgramFiles(x86)% +if not "%Applications%" == "" goto win64 +set Applications=%ProgramFiles% +:win64 + +:: Set up Visual Studio command line environment variables given a +:: machine type, e.g., amd64 or x86. + +:: Visual Studio 2022 Enterprise +set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Enterprise\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2022 Professional +set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Professional\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2022 Community +set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Community\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2019 Enterprise +set BATDIR=%Applications%\Microsoft Visual Studio\2019\Enterprise\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2019 Professional +set BATDIR=%Applications%\Microsoft Visual Studio\2019\Professional\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2019 Community +set BATDIR=%Applications%\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2019 BuildTools +set BATDIR=%Applications%\Microsoft Visual Studio\2019\BuildTools\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2017 Enterprise +set BATDIR=%Applications%\Microsoft Visual Studio\2017\Enterprise\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2017 Professional +set BATDIR=%Applications%\Microsoft Visual Studio\2017\Professional\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2017 Community +set BATDIR=%Applications%\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2017 BuildTools +set BATDIR=%Applications%\Microsoft Visual Studio\2017\BuildTools\VC\Auxiliary\Build +if exist "%BATDIR%\vcvarsall.bat" goto found + +:: Visual Studio 2015 +set BATDIR=%VS140COMNTOOLS%..\..\VC +if exist "%BATDIR%\vcvarsall.bat" goto found + +echo Visual Studio 2022, 2019, 2017, or 2015 must be installed. +exit 1 + +:found + +:: Clear environment variables that we might otherwise inherit +set INCLUDE= +set LIB= +set LIBPATH= + +:: Visual Studio 2017's vcvarsall.bat changes the directory to %USERPROFILE%\Source if the directory exists. See https://developercommunity.visualstudio.com/content/problem/26780/vsdevcmdbat-changes-the-current-working-directory.html +set VSCMD_START_DIR=%CD% +"%BATDIR%\vcvarsall.bat" %1 diff --git a/c/windows.c b/c/windows.c new file mode 100644 index 0000000..35ba629 --- /dev/null +++ b/c/windows.c @@ -0,0 +1,506 @@ +/* windows.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* much of the following code courtesy of Bob Burger, burgerrg@sagian.com */ + +#include "system.h" +#include +#include +#include + +static ptr s_ErrorStringImp(DWORD dwMessageId, const char *lpcDefault); +static ptr s_ErrorString(DWORD dwMessageId); +static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid); +static ptr s_GetRegistry(wchar_t *s); +static void s_PutRegistry(wchar_t *s, wchar_t *val); +static void s_RemoveRegistry(wchar_t *s); + +void S_machine_init(void) { + Sregister_symbol("(com)CreateInstance", (void *)s_CreateInstance); + Sregister_symbol("(windows)GetRegistry", (void *)s_GetRegistry); + Sregister_symbol("(windows)PutRegistry", (void *)s_PutRegistry); + Sregister_symbol("(windows)RemoveRegistry", (void *)s_RemoveRegistry); + Sregister_symbol("(windows)ErrorString", (void *)s_ErrorString); +} + +INT S_getpagesize(void) { + SYSTEM_INFO si; + GetSystemInfo(&si); + return si.dwPageSize; +} + +void *S_ntdlopen(const char *path) { + wchar_t *pathw = Sutf8_to_wide(path); + void *r = (void *)LoadLibraryW(pathw); + free(pathw); + return r; +} + +void *S_ntdlsym(void *h, const char *s) { + return (void *)GetProcAddress(h, s); +} + +/* Initial version of S_ntdlerror courtesy of Bob Burger + * Modifications by James-Adam Renquinha Henri, jarhmander@gmail.com */ +ptr S_ntdlerror(void) { + return s_ErrorStringImp(GetLastError(), "unable to load library"); +} + +#ifdef FLUSHCACHE +oops, no S_flushcache_max_gap or S_doflush +#endif /* FLUSHCACHE */ + +static void SplitRegistryKey(char *who, wchar_t *wholekey, HKEY *key, wchar_t **subkey, wchar_t **last) { + wchar_t c, *s; + + /* Determine the base key */ + if (_wcsnicmp(wholekey, L"HKEY_CLASSES_ROOT\\", 18) == 0) { + *key = HKEY_CLASSES_ROOT; + *subkey = wholekey+18; + } else if (_wcsnicmp(wholekey, L"HKEY_CURRENT_USER\\", 18) == 0) { + *key = HKEY_CURRENT_USER; + *subkey = wholekey+18; + } else if (_wcsnicmp(wholekey, L"HKEY_LOCAL_MACHINE\\", 19) == 0) { + *key = HKEY_LOCAL_MACHINE; + *subkey = wholekey+19; + } else if (_wcsnicmp(wholekey, L"HKEY_USERS\\", 11) == 0) { + *key = HKEY_USERS; + *subkey = wholekey+11; + } else if (_wcsnicmp(wholekey, L"HKEY_CURRENT_CONFIG\\", 20) == 0) { + *key = HKEY_CURRENT_CONFIG; + *subkey = wholekey+20; + } else if (_wcsnicmp(wholekey, L"HKEY_DYN_DATA\\", 14) == 0) { + *key = HKEY_DYN_DATA; + *subkey = wholekey+14; + } else { + char *wholekey_utf8 = Swide_to_utf8(wholekey); + ptr wholekey_scheme = Sstring_utf8(wholekey_utf8, -1); + free(wholekey_utf8); + S_error1(who, "invalid registry key ~s", wholekey_scheme); + } + + for (*last = s = *subkey, c = *s; c != '\0'; c = *++s) + if (c == '\\') *last = s; +} + +static ptr s_GetRegistry(wchar_t *s) { + HKEY key, result; + wchar_t *subkey, *last; + DWORD rc, type, size; + ptr ans; + + SplitRegistryKey("get-registry", s, &key, &subkey, &last); + + /* open the key */ + if (last == subkey) { + rc = RegOpenKeyExW(key, L"", 0, KEY_QUERY_VALUE, &result); + } else { + *last = '\0'; /* Truncate subkey at backslash */ + rc = RegOpenKeyExW(key, subkey, 0, KEY_QUERY_VALUE, &result); + *last++ = '\\'; /* Restore backslash */ + } + if (rc != ERROR_SUCCESS) return Sfalse; + + /* Get the size of the value */ + rc = RegQueryValueExW(result, last, NULL, &type, NULL, &size); + if (rc != ERROR_SUCCESS) { + RegCloseKey(result); + return Sfalse; + } + + /* Allocate a Scheme bytevector of the proper size */ + ans = S_bytevector(size); + + /* Load up the bytevector */ + rc = RegQueryValueExW(result, last, NULL, &type, &BVIT(ans,0), &size); + RegCloseKey(result); + if (rc != ERROR_SUCCESS) return Sfalse; + + /* discard unwanted terminating null character, if present */ + if (((type == REG_SZ) || (type == REG_EXPAND_SZ)) && + (size >= 2) && + (*(wchar_t*)(&BVIT(ans, size-2)) == 0)) + BYTEVECTOR_TYPE(ans) = ((size-2) << bytevector_length_offset) | type_bytevector; + + return ans; +} + +static void s_PutRegistry(wchar_t *s, wchar_t *val) { + HKEY key, result; + wchar_t *subkey, *last; + DWORD rc, type; + size_t n = (wcslen(val) + 1) * sizeof(wchar_t); +#if (size_t_bits > 32) + if ((DWORD)n != n) { + char *s_utf8 = Swide_to_utf8(s); + ptr s_scheme = Sstring_utf8(s_utf8, -1); + free(s_utf8); + S_error2("put-registry!", "cannot set ~a (~a)", s_scheme, Sstring("too long")); + } +#endif + + SplitRegistryKey("put-registry!", s, &key, &subkey, &last); + + /* create/open the key */ + if (last == subkey) { + rc = RegCreateKeyExW(key, L"", 0, NULL, 0, KEY_SET_VALUE, NULL, &result, NULL); + } else { + *last = '\0'; /* Truncate subkey at backslash */ + rc = RegCreateKeyExW(key, subkey, 0, NULL, 0, KEY_SET_VALUE, NULL, &result, NULL); + *last++ = '\\'; /* Restore backslash */ + } + + if (rc == ERROR_SUCCESS) { + /* lookup type for key (if it exists), if not assume REG_SZ */ + if (ERROR_SUCCESS != RegQueryValueExW(result, last, NULL, &type, NULL, NULL)) + type = REG_SZ; + + /* set the value */ + rc = RegSetValueExW(result, last, 0, type, (const BYTE*)val, (DWORD)n); + RegCloseKey(result); + } + + if (rc != ERROR_SUCCESS) { + char *s_utf8 = Swide_to_utf8(s); + ptr s_scheme = Sstring_utf8(s_utf8, -1); + free(s_utf8); + S_error2("put-registry!", "cannot set ~a (~a)", s_scheme, + rc == ERROR_FILE_NOT_FOUND ? Sstring("not found") : s_ErrorString(rc)); + } +} + + +static void s_RemoveRegistry(wchar_t *s) { + HKEY key, result; + wchar_t *subkey, *last; + DWORD rc; + + SplitRegistryKey("remove-registry!", s, &key, &subkey, &last); + + /* open the key */ + if (last == subkey) { + rc = RegOpenKeyExW(key, L"", 0, KEY_ALL_ACCESS, &result); + } else { + *last = '\0'; /* Truncate subkey at backslash */ + rc = RegOpenKeyExW(key, subkey, 0, KEY_ALL_ACCESS, &result); + *last++ = '\\'; /* Restore backslash */ + } + if (rc == ERROR_SUCCESS) { + /* delete the value */ + rc = RegDeleteValueW(result, last); + if (rc == ERROR_FILE_NOT_FOUND) + /* value by given name not found; try deleting as key */ + rc = RegDeleteKeyW(result, last); + RegCloseKey(result); + } + + if (rc != ERROR_SUCCESS) { + char *s_utf8 = Swide_to_utf8(s); + ptr s_scheme = Sstring_utf8(s_utf8, -1); + free(s_utf8); + S_error2("remove-registry!", "cannot remove ~a (~a)", s_scheme, + rc == ERROR_FILE_NOT_FOUND ? Sstring("not found") : + rc == ERROR_ACCESS_DENIED ? Sstring("insufficient permission or subkeys exist") : + s_ErrorString(rc)); + } +} + +static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid) { + IUnknown *pIface; + HRESULT hr; + + hr = CoCreateInstance(pCLSID, + NULL, + CLSCTX_INPROC_SERVER, + iid, + (void **)&pIface); + if (SUCCEEDED(hr)) { + return (IUnknown *)pIface; + } else { + S_error1("", "unable to create instance: ~s", s_ErrorString(hr)); + return (IUnknown *)0 /* not reached */; + } +} + +static ptr s_ErrorString(DWORD dwMessageId) { + return s_ErrorStringImp(dwMessageId, NULL); +} + +static ptr s_ErrorStringImp(DWORD dwMessageId, const char *lpcDefault) { + wchar_t *lpMsgBuf; + DWORD len; + char *u8str; + ptr result; + + len = FormatMessageW(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, dwMessageId, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPWSTR)&lpMsgBuf, 0, NULL); + /* If FormatMessage fails... */ + if (len == 0) { + if (lpcDefault) { + /* ... use the default string if provided... */ + return Sstring_utf8(lpcDefault, -1); + } else { + /* ...otherwise, use the error code in hexadecimal. */ + char buf[(sizeof(dwMessageId) * 2) + 3]; + int n = snprintf(buf, sizeof(buf), "0x%x", dwMessageId); + if (n < sizeof(buf)) + return Sstring_utf8(buf, n); + else + return Sstring("??"); + } + } + /* Otherwise remove trailing newlines & returns and strip trailing period, if present. */ + while (len > 0) { + wchar_t c = lpMsgBuf[len - 1]; + if (c == L'\n' || c == '\r') + len--; + else if (c == L'.') { + len--; + break; + } + else break; + } + lpMsgBuf[len] = 0; + u8str = Swide_to_utf8(lpMsgBuf); + LocalFree(lpMsgBuf); + result = Sstring_utf8(u8str, -1); + free(u8str); + return result; +} + +ptr S_LastErrorString(void) { + return s_ErrorString(GetLastError()); +} + +#ifdef CHAFF +int S_windows_open_exclusive(char *who, char *path, int flags) { + HANDLE hfile; + int fd; + DWORD access = 0; + DWORD crdisp = 0; + + /* could implement this later with more difficulty */ + if ((flags & (O_TRUNC|O_CREAT)) == (O_TRUNC|O_CREAT)) + S_error("open_exclusive", "O_TRUNC|O_CREAT not supported"); + + if (flags & O_RDWR) access |= GENERIC_READ|GENERIC_WRITE; + if (flags & O_RDONLY) access |= GENERIC_READ; + if (flags & O_WRONLY) access |= GENERIC_WRITE; + + if (flags & O_CREAT) crdisp = OPEN_ALWAYS; + if (flags & O_TRUNC) crdisp = TRUNCATE_EXISTING; + + hfile = CreateFile(path, access, 0, (SECURITY_ATTRIBUTES *)0, + crdisp, FILE_ATTRIBUTE_NORMAL, (HANDLE)0); + if (hfile == INVALID_HANDLE_VALUE) + S_error1(who, "~a", s_ErrorString(GetLastError())); + + flags &= O_RDONLY|O_WRONLY|O_RDWR|O_APPEND; + fd = _open_osfhandle((long)hfile, flags); + if (fd == -1) S_error(who, "open_osfhandle failed"); + + return fd; +} +#endif + +#include + +/* primitive version of flock compatible with Windows 95/98/ME. A better + version could be implemented for Windows NT/2000/XP using LockFileEx. */ +int S_windows_flock(int fd, int operation) { + HANDLE hfile = (HANDLE)_get_osfhandle(fd); + + switch (operation) { + case LOCK_EX|LOCK_NB: + if (LockFile(hfile, 0, 0, 0x0fffffff, 0)) return 0; + errno = EWOULDBLOCK; + return -1; + case LOCK_EX: + while (LockFile(hfile, 0, 0, 0x0fffffff, 0) == 0) Sleep(10); + return 0; + case LOCK_SH: + case LOCK_SH|LOCK_NB: + S_error("flock", "shared locks unsupported"); + return -1; + case LOCK_UN: + case LOCK_UN|LOCK_NB: + UnlockFile(hfile, 0, 0, 0x0fffffff, 0); + return 0; + default: + errno = EINVAL; + return -1; + } +} + +int S_windows_chdir(const char *pathname) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _chdir(pathname); + else + return _wchdir(wpathname); +} + +int S_windows_chmod(const char *pathname, int mode) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _chmod(pathname, mode); + else + return _wchmod(wpathname, mode); +} + +int S_windows_mkdir(const char *pathname) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _mkdir(pathname); + else + return _wmkdir(wpathname); +} + +int S_windows_open(const char *pathname, int flags, int mode) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _open(pathname,flags, mode); + else + return _wopen(wpathname,flags,mode); +} + +int S_windows_rename(const char *oldpathname, const char *newpathname) { + wchar_t woldpathname[PATH_MAX], wnewpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,oldpathname,-1,woldpathname,PATH_MAX) == 0 || + MultiByteToWideChar(CP_UTF8,0,newpathname,-1,wnewpathname,PATH_MAX) == 0) + return rename(oldpathname, newpathname); + else + return _wrename(woldpathname, wnewpathname); +} + +int S_windows_rmdir(const char *pathname) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _rmdir(pathname); + else { + int rc; + if (!(rc = _wrmdir(wpathname))) { + // Spin loop until Windows deletes the directory. + int n; + for (n = 1000; n > 0; n--) { + if (_wrmdir(wpathname) && (errno == ENOENT)) break; + } + return 0; + } + return rc; + } +} + +int S_windows_stat64(const char *pathname, struct STATBUF *buffer) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _stat64(pathname, buffer); + else + return _wstat64(wpathname, buffer); +} + +int S_windows_system(const char *command) { + wchar_t wcommand[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,command,-1,wcommand,PATH_MAX) == 0) + return system(command); + else + return _wsystem(wcommand); +} + +int S_windows_unlink(const char *pathname) { + wchar_t wpathname[PATH_MAX]; + if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) + return _unlink(pathname); + else { + int rc; + if (!(rc = _wunlink(wpathname))) { + // Spin loop until Windows deletes the file. + int n; + for (n = 1000; n > 0; n--) { + if (_wunlink(wpathname) && (errno == ENOENT)) break; + } + return 0; + } + return rc; + } +} + +char *S_windows_getcwd(char *buffer, int maxlen) { + wchar_t wbuffer[PATH_MAX]; + if (_wgetcwd(wbuffer, PATH_MAX) == NULL) return NULL; + if (WideCharToMultiByte(CP_UTF8,0,wbuffer,-1,buffer,PATH_MAX,NULL,NULL) == 0) { + switch (GetLastError()) { + case ERROR_INSUFFICIENT_BUFFER: + errno = ERANGE; + break; + default: + errno = EINVAL; + break; + } + return NULL; + } else + return buffer; +} + +char *Swide_to_utf8(const wchar_t *arg) { + int len = WideCharToMultiByte(CP_UTF8, 0, arg, -1, NULL, 0, NULL, NULL); + if (0 == len) return NULL; + char* arg8 = (char*)malloc(len * sizeof(char)); + if (0 == WideCharToMultiByte(CP_UTF8, 0, arg, -1, arg8, len, NULL, NULL)) { + free(arg8); + return NULL; + } + return arg8; +} + +wchar_t *Sutf8_to_wide(const char *arg) { + int len = MultiByteToWideChar(CP_UTF8, 0, arg, -1, NULL, 0); + if (0 == len) return NULL; + wchar_t* argw = (wchar_t*)malloc(len * sizeof(wchar_t)); + if (0 == MultiByteToWideChar(CP_UTF8, 0, arg, -1, argw, len)) { + free(argw); + return NULL; + } + return argw; +} + +char *Sgetenv(const char *name) { + wchar_t* wname; + DWORD n; + wchar_t buffer[256]; + wname = Sutf8_to_wide(name); + if (NULL == wname) return NULL; + n = GetEnvironmentVariableW(wname, buffer, 256); + if (n == 0) { + free(wname); + return NULL; + } else if (n <= 256) { + free(wname); + return Swide_to_utf8(buffer); + } else { + wchar_t* value = (wchar_t*)malloc(n * sizeof(wchar_t)); + if (0 == GetEnvironmentVariableW(wname, value, n)) { + free(wname); + free(value); + return NULL; + } else { + char* result = Swide_to_utf8(value); + free(wname); + free(value); + return result; + } + } +} diff --git a/checkin b/checkin new file mode 100755 index 0000000..ef77340 --- /dev/null +++ b/checkin @@ -0,0 +1,344 @@ +#! /bin/csh -f + +# checkin +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +if ($#argv != 1) then + echo "Usage: checkin " + exit 1 +endif + +# set M to machine type and W to workarea name +set W = $1 +if (!(-d $W)) then + echo "Workarea ./$W not found." + exit 1 +endif + +set M = $W/boot/*/. +if ($status || $#M != 1) then + echo "Cannot determine machine type." + exit 1 +endif + +set M = $M:h +set M = $M:t + +onintr error + +# This shell script checks sources and binaries in from a workarea to +# the release directory. Invoke with the name of a machine type and +# an optional workarea name. The workarea name defaults to the machine +# type. + +set BACKUPDIR = $cwd:h/backup +if (!(-d $BACKUPDIR)) then + echo "creating backup directory $BACKUPDIR" + mkdir $BACKUPDIR || goto error +endif + +echo -n "have you updated $W/LOG? [y]: " +set RESPONSE = $< +if ("$RESPONSE" != "y" && "$RESPONSE" != "") goto error + +if (-e $W/scheme.1.in) then + cmp scheme.1.in $W/scheme.1.in >& /dev/null + if ($status != 0) then + echo -n "Did you update the date in $W/scheme.1.in? [y]: " + set RESPONSE = $< + if ("$RESPONSE" != "y" && "$RESPONSE" != "") goto error + endif +endif + +set tmpsdirs = (. c mats s examples unicode makefiles csug release_notes wininstall bintar rpm pkg) +set sdirs = () +foreach x ($tmpsdirs) + if (!(-e $x)) then + echo "ERROR: ./$x does not exist" + goto error + endif + if (!(-d $x)) then + echo "ERROR: ./$x is not a directory" + goto error + endif + test -d $W/$x && set sdirs = ($sdirs $x) +end + +set tmpbdirs = (bin/$M boot/$M) +set bdirs = () +foreach x ($tmpbdirs) + if ((-e $x) && !(-d $x)) then + echo "ERROR: ./$x is not a directory" + goto error + endif + test -d $W/$x && set bdirs = ($bdirs $x) +end + +echo '*** running "make clean" in source directories ***' +foreach x ($sdirs) + switch ($x) + case .: + case unicode: + case unicode/UNIDATA: + case makefiles: + case csug: + case release_notes: + breaksw + case c: + case s: + case mats: + case benchmarks: + case examples: + case wininstall: + case bintar: + case rpm: + case pkg: + (cd $W/$x; make clean >& /dev/null) + breaksw + default: + echo "checkin error: unexpected sdir $x" + goto error + endsw +end + +set ignorefiles = () + +set tmpsfiles = () +foreach x ($sdirs) + set y = `(cd $W; find $x/* -type f -print -o -type d -prune)` + set tmpsfiles = ($tmpsfiles $y) +end + +set sfiles = () +foreach x ($tmpsfiles) + if ("$x" == "./Makefile" || "$x" == "./Mf-install" || "$x" == "./Mf-boot" || "$x" == "c/config.h" || "$x" == "c/Mf-config") then + set ignorefiles = ($ignorefiles $x) + else + cmp $W/$x $x >& /dev/null + if ($status == 0) then + set ignorefiles = ($ignorefiles $x) + else + set sfiles = ($sfiles $x) + endif + endif +end + +if ($#sfiles == 0) echo "*** no source files found in ./$W ***" + +set tmpbfiles = () +foreach x ($bdirs) + set y = `(cd $W; find $x/* -type f -print -o -type d -prune)` + set tmpbfiles = ($tmpbfiles $y) +end + +set bfiles = () +foreach x ($tmpbfiles) + cmp $W/$x $x >& /dev/null + if ($status == 0) then + set ignorefiles = ($ignorefiles $x) + else + set bfiles = ($bfiles $x) + endif +end + +if ($#bfiles == 0) echo "*** no binary files found in ./$W ***" + +if ($#sfiles == 0 && $#bfiles == 0) goto delete + +set tmpsfiles = ($sfiles) +set sfiles = () +foreach x ($tmpsfiles) + if ($x:h == ".") then + set xpretty = $x:t + else + set xpretty = $x + endif + if (-e $x) then + set comment = "" + else + set comment = " new" + endif + echo -n "check in$comment source file $W/$xpretty? [y]: " + set RESPONSE = $< + if ("$RESPONSE" == "" || "$RESPONSE" == "y") set sfiles = ($sfiles $x) +end + +set tmpbfiles = ($bfiles) +set bfiles = () +foreach x ($tmpbfiles) + if (-e $x) then + set comment = "" + else + set comment = " new" + endif + echo -n "check in$comment binary file $W/$x? [y]: " + set RESPONSE = $< + if ("$RESPONSE" == "" || "$RESPONSE" == "y") set bfiles = ($bfiles $x) +end + +set RESPONSE = "" +while ("$RESPONSE" != "y") + echo -n "proceed with check in? (y/n): " + set RESPONSE = $< + if ("$RESPONSE" == "n") exit 0 +end + +set oldsfiles = () +foreach x ($sfiles) + if (-e $x) set oldsfiles = ($oldsfiles $x) +end +if ($#oldsfiles != 0) then + echo "backing up old versions of source files" + if (!(-f $BACKUPDIR/seqno)) then + set seqno = 0 + else + set seqno = `cat $BACKUPDIR/seqno` + endif + set backuproot = $BACKUPDIR/$seqno + @ seqno = $seqno + 1 + echo $seqno > $BACKUPDIR/seqno + echo "backup directory is $backuproot" + mkdir $backuproot || goto error + set n = 4 + echo -n " " + foreach x ($oldsfiles) + set i = `echo "$x" | wc -c` + @ n = $n + $i + 1 + if ($n > 78) then + echo "" + echo -n " " + @ n = $i + 4 + endif + echo -n "$x " + set y = $backuproot/$x:h + if (!(-d $y)) then + mkdir -p $y || goto error + endif + rm -f $y/$x:t || goto error + mv $x $y || goto error + gzip $y/$x:t || goto error + end + echo "" +endif + +set oldbfiles = () +foreach x ($bfiles) + if (-e $x) set oldbfiles = ($oldbfiles $x) +end +if ($#oldbfiles != 0) then + echo "deleting old versions of binary files" + set n = 4 + echo -n " " + foreach x ($oldbfiles) + set i = `echo "$x" | wc -c` + @ n = $n + $i + 1 + if ($n > 78) then + echo "" + echo -n " " + @ n = $i + 4 + endif + echo -n "$x " + rm -f $x || goto error + end + echo "" +endif + +if ($#sfiles != 0) then + echo "moving new source files to release directory" + set n = 4 + echo -n " " + foreach x ($sfiles) + set i = `echo "$x" | wc -c` + @ n = $n + $i + 1 + if ($n > 78) then + echo "" + echo -n " " + @ n = $i + 4 + endif + echo -n "$x " + mv $W/$x $x || goto error + end + echo "" +endif + +if ($#bfiles != 0) then + echo "moving new binary files to release directory" + set n = 4 + echo -n " " + foreach x ($bfiles) + set i = `echo "$x" | wc -c` + @ n = $n + $i + 1 + if ($n > 78) then + echo "" + echo -n " " + @ n = $i + 4 + endif + echo -n "$x " + if (!(-e $x:h)) mkdir -p $x:h || goto error + mv $W/$x $x || goto error + end + echo "" +endif + +delete: + +set tmpfiles = `(cd $W; find . -name zlib -prune -o -name lz4 -prune -o -type f -print)` +set files = () +foreach x ($tmpfiles) + set files = ($x $files) + set tmpignorefiles = ($ignorefiles) + while ($#tmpignorefiles) + if ($x == ./$tmpignorefiles[1] || $x == $tmpignorefiles[1]) then + shift files + break + endif + shift tmpignorefiles + end +end + +if ($#files == 0) then + set delete = "y" +else + set delete = "n" + echo "*** new or modified files remain in ./$W" + set n = 4 + echo -n " " + foreach x ($files) + set i = `echo "$x" | wc -c` + @ n = $n + $i + 1 + if ($n > 78) then + echo "" + echo -n " " + @ n = $i + 4 + endif + echo -n "$x " + end + echo "" +endif + +echo -n "delete ./$W? [$delete]: " +set RESPONSE = $< +if ("$RESPONSE" == "") set RESPONSE = $delete +if ("$RESPONSE" == "y") then + rm -rf $W || goto error +endif + +exit 0 + +error: + +echo "" +echo "quitting (error occurred)." +exit 1 diff --git a/configure b/configure new file mode 100755 index 0000000..b82a610 --- /dev/null +++ b/configure @@ -0,0 +1,547 @@ +#! /bin/sh + +# configure +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +machs=""; last=""; sep0=""; sep1=""; sep2=""; sep3=""; sep4=" and "; +for fn in boot/*/scheme.boot ; do + machs=$machs$sep0$last + last=`echo $fn | sed -e 's/boot\/\(.*\)\/scheme.boot/\1/'` + sep0=$sep1; sep1=", "; sep2=$sep3; sep3=$sep4; sep4=", and " +done +machs=$machs$sep2$last + +m="" +w="" +threads=no +temproot="" +help=no +gzipmanpages=yes +installowner="" +installgroup="" +installbin="" +installlib="" +installman="" +installdoc="" +installcsug="" +installreleasenotes="" +installschemename="scheme" +installpetitename="petite" +installscriptname="scheme-script" +disablex11=no +disablecurses=no +: ${CC:="gcc"} +: ${CPPFLAGS:=""} +: ${CFLAGS:=""} +: ${LD:="ld"} +: ${LDFLAGS:=""} +: ${AR:="ar"} +: ${ARFLAGS:="rc"} +: ${RANLIB:="ranlib"} +: ${WINDRES:="windres"} +zlibInc=-I../zlib +LZ4Inc=-I../lz4/lib +zlibDep=../zlib/libz.a +LZ4Dep=../lz4/lib/liblz4.a +zlibLib=../zlib/libz.a +LZ4Lib=../lz4/lib/liblz4.a +zlibHeaderDep="../zlib/zconf.h ../zlib/zlib.h" +LZ4HeaderDep="../lz4/lib/lz4.h ../lz4/lib/lz4frame.h" +Kernel=KernelO +installkerneltarget=installkernelobj +installzlibtarget= +installlz4target= + +# On WSL, set OS to "Windows_NT" to create a Windows +# build instead of a Linux (on Windows) build: +if [ "$OS" = "Windows_NT" ] ; then + CONFIG_UNAME="CYGWIN_NT-" +else + CONFIG_UNAME=`uname` +fi + +case "${CONFIG_UNAME}" in + Linux) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3le + m64=a6le + tm32=ti3le + tm64=ta6le + elif uname -a | grep -i power > /dev/null 2>&1 ; then + m32=ppc32le + m64="" + tm32=tppc32le + tm64="" + fi + installprefix=/usr + installmansuffix=share/man + ;; + QNX) + if uname -a | egrep 'x86' > /dev/null 2>&1 ; then + m32=i3qnx + tm32=ti3qnx + fi + installprefix=/usr/local + installmansuffix=man + ;; + FreeBSD) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3fb + m64=a6fb + tm32=ti3fb + tm64=ta6fb + fi + installprefix=/usr/local + installmansuffix=man + ;; + OpenBSD) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3ob + m64=a6ob + tm32=ti3ob + tm64=ta6ob + fi + installprefix=/usr/local + installmansuffix=man + ;; + NetBSD) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3nb + m64=a6nb + tm32=ti3nb + tm64=ta6nb + fi + installprefix=/usr + installmansuffix=share/man + gzipmanpages=no + ;; + Darwin) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3osx + m64=a6osx + tm32=ti3osx + tm64=ta6osx + fi + installprefix=/usr/local + installmansuffix=share/man + ;; + SunOS) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3s2 + m64=a6s2 + tm32=ti3s2 + tm64=ta6s2 + installprefix=/usr + installmansuffix=share/man + gzipmanpages=no + fi + ;; + CYGWIN_NT-*) + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3nt + m64=a6nt + tm32=ti3nt + tm64=ta6nt + installprefix=/usr/local + installmansuffix=share/man + fi + ;; +esac + +threads="" +bits="" + +while [ $# != 0 ] ; do + case $1 in + -m=*) + m=`echo $1 | sed -e 's/^-m=//'` + ;; + --machine=*) + m=`echo $1 | sed -e 's/^--machine=//'` + ;; + --threads) + threads=yes + ;; + --64) + bits=64 + ;; + --32) + bits=32 + ;; + --installprefix=*) + installprefix=`echo $1 | sed -e 's/^--installprefix=//'` + ;; + --installlib=*) + installlib=`echo $1 | sed -e 's/^--installlib=//'` + ;; + --installbin=*) + installbin=`echo $1 | sed -e 's/^--installbin=//'` + ;; + --installman=*) + installman=`echo $1 | sed -e 's/^--installman=//'` + ;; + --installdoc=*) + installdoc=`echo $1 | sed -e 's/^--installdoc=//'` + ;; + --installcsug=*) + installcsug=`echo $1 | sed -e 's/^--installcsug=//'` + ;; + --installreleasenotes=*) + installreleasenotes=`echo $1 | sed -e 's/^--installreleasenotes=//'` + ;; + --installowner=*) + installowner=`echo $1 | sed -e 's/^--installowner=//'` + ;; + --installgroup=*) + installgroup=`echo $1 | sed -e 's/^--installgroup=//'` + ;; + --installschemename=*) + installschemename=`echo $1 | sed -e 's/^--installschemename=//'` + ;; + --installpetitename=*) + installpetitename=`echo $1 | sed -e 's/^--installpetitename=//'` + ;; + --installscriptname=*) + installscriptname=`echo $1 | sed -e 's/^--installscriptname=//'` + ;; + --toolprefix=*) + toolprefix=`echo $1 | sed -e 's/^--toolprefix=//'` + CC="${toolprefix}${CC}" + LD="${toolprefix}${LD}" + AR="${toolprefix}${AR}" + RANLIB="${toolprefix}${RANLIB}" + WINDRES="${toolprefix}${WINDRES}" + ;; + --gzip-man-pages) + gzipmanpages=yes + ;; + --nogzip-man-pages) + gzipmanpages=no + ;; + --temproot=*) + temproot=`echo $1 | sed -e 's/^--temproot=//'` + ;; + --workarea=*) + w=`echo $1 | sed -e 's/^--workarea=//'` + ;; + --help) + help=yes + ;; + --disable-x11) + disablex11=yes + ;; + --disable-curses) + disablecurses=yes + ;; + --libkernel) + Kernel=KernelLib + installkerneltarget=installkernellib + if [ "$zlibInc" != "" ]; then + installzlibtarget=installzlib + fi + if [ "$LZ4Inc" != "" ]; then + installlz4target=installlz4 + fi + ;; + --kernelobj) + Kernel=KernelO + installkerneltarget=installkernelobj + installzlibtarget= + installlz4target= + ;; + CC=*) + CC=`echo $1 | sed -e 's/^CC=//'` + ;; + CPPFLAGS=*) + CPPFLAGS=`echo $1 | sed -e 's/^CPPFLAGS=//'` + ;; + CFLAGS=*) + CFLAGS=`echo $1 | sed -e 's/^CFLAGS=//'` + ;; + LD=*) + LD=`echo $1 | sed -e 's/^LD=//'` + ;; + LDFLAGS=*) + LDFLAGS=`echo $1 | sed -e 's/^LDFLAGS=//'` + ;; + AR=*) + AR=`echo $1 | sed -e 's/^AR=//'` + ;; + ARFLAGS=*) + ARFLAGS=`echo $1 | sed -e 's/^ARFLAGS=//'` + ;; + RANLIB=*) + RANLIB=`echo $1 | sed -e 's/^RANLIB=//'` + ;; + WINDRES=*) + WINDRES=`echo $1 | sed -e 's/^WINDRES=//'` + ;; + ZLIB=*) + zlibLib=`echo $1 | sed -e 's/^ZLIB=//'` + zlibInc= + zlibDep= + zlibHeaderDep= + installzlibtarget= + ;; + LZ4=*) + LZ4Lib=`echo $1 | sed -e 's/^LZ4=//'` + LZ4Inc= + LZ4Dep= + LZ4HeaderDep= + installlz4target= + ;; + *) + echo "option '$1' unrecognized or missing an argument; try $0 --help" + exit 1 + ;; + esac + shift +done + +if [ "$bits" = "" ] ; then + if uname -a | egrep 'amd64|x86_64' > /dev/null 2>&1 ; then + bits=64 + else + bits=32 + fi +fi + +if [ "$threads" = "" ] ; then + threads=no +fi + +if [ "$m" = "" ] ; then + if [ $bits = 64 ] ; then + if [ $threads = yes ] ; then m=$tm64 ; else m=$m64 ; fi + else + if [ $threads = yes ] ; then m=$tm32 ; else m=$m32 ; fi + fi +fi + +if [ "$w" = "" ] ; then + w=$m +fi + +if [ "$installbin" = "" ] ; then + installbin=$installprefix/bin +fi + +if [ "$installlib" = "" ] ; then + installlib=$installprefix/lib +fi + +if [ "$installman" = "" ] ; then + installman=$installprefix/$installmansuffix +fi + +if [ "$installdoc" = "" ] ; then + installdoc=$installprefix/share/doc +fi + +if [ "$installcsug" = "" ] ; then + installcsug=$installdoc/csug9.5 +fi + +if [ "$installreleasenotes" = "" ] ; then + installreleasenotes=$installdoc/csv9 +fi + +if [ "$disablex11" = "no" ] ; then + if [ $m = a6osx ] || [ $m = ta6osx ] ; then + if [ ! -d /opt/X11/include/ ] ; then + disablex11=yes + fi + fi +fi + +if [ "$help" = "yes" ]; then + echo "Purpose:" + echo " $0 determines the machine type and constructs a custom Makefile" + echo " and Mf-install, taking into account the options below." + echo "" + echo "Options (defaults shown in parens):" + echo " --machine= explicitly specify machine type ($m)" + echo " -m= same as --machine ($m)" + echo " --threads specify threaded version ($threads)" + echo " --32|--64 specify 32/64-bit version ($bits)" + echo " --disable-x11 disable X11 support" + echo " --disable-curses disable [n]curses support" + echo " --libkernel build libkernel.a instead of kernel.o" + echo " --kernelobj build kernel.o (the default)" + echo " --installprefix= final installation root ($installprefix)" + echo " --installbin= bin directory ($installbin)" + echo " --installlib= lib directory ($installlib)" + echo " --installman= manpage directory ($installman)" + echo " --installdoc= documentation root ($installdoc)" + echo " --installcsug= guide directory ($installcsug)" + # abbreviate "release notes" to fit default help in 80 cols: + echo " --installreleasenotes= notes directory ($installreleasenotes)" + echo " --temproot= staging root ($temproot)" + echo " --installowner= install with owner ($installowner)" + echo " --installgroup= install with group ($installgroup)" + echo " --installschemename= install scheme as ($installschemename)" + echo " --installpetitename= install petite as ($installpetitename)" + echo " --installscriptname= install scheme-script as ($installscriptname)" + echo " --toolprefix= prefix tool (compiler, linker, ...) names" + echo " --[no]gzip-man-pages compress manual pages ($gzipmanpages)" + echo " --workarea= build directory ($w)" + echo " CC= C compiler" + echo " CPPFLAGS= additional C preprocessor flags ($CPPFLAGS)" + echo " CFLAGS= additional C compiler flags ($CFLAGS)" + echo " LD= linker" + echo " LDFLAGS= additional linker flags ($LDFLAGS)" + echo " AR= archiver" + echo " ARFLAGS= archiver flags" + echo " RANLIB= archive indexer" + echo " WINDRES= resource compiler" + echo " ZLIB= link to instead of own zlib" + echo " LZ4= link to instead of own LZ4" + echo "" + echo "Available machine types: $machs" + echo "" + echo "Examples:" + echo " $0 --machine=i3le" + echo "" + echo " set machine-type to i3le rather than to determined type" + echo "" + echo " $0 --threads --installprefix=/usr/local" + echo "" + echo " specify threaded version and set installation directory to /usr/local." + echo "" + echo " $0 --installprefix=/usr/local --temproot=/tmp" + echo "" + echo " declare the final destination to be /usr/local but staging area" + echo " to be /tmp/usr/local. Make will record the final destination in the" + echo " installed manual pages but actually install the system and manual" + echo " pages in the staging area." + echo "" + exit 0 +fi + +if [ "$m" = "" -o ! -f boot/$m/scheme.boot ] ; then + echo "no suitable machine type found" + echo "try rerunning as $0 -m=" + echo "available machine types: $machs" + exit 1 +fi + +if [ -d '.git' ] && command -v git >/dev/null 2>&1 ; then + git submodule init && git submodule update || exit 1 +else + if [ ! -f 'nanopass/nanopass.ss' ] ; then + rmdir nanopass > /dev/null 2>&1 + (curl -L -o v1.9.2.tar.gz https://github.com/nanopass/nanopass-framework-scheme/archive/v1.9.2.tar.gz && tar -zxf v1.9.2.tar.gz && mv nanopass-framework-scheme-1.9.2 nanopass && rm v1.9.2.tar.gz) || exit 1 + fi + + if [ "${zlibDep}" != "" ] ; then + if [ ! -f 'zlib/configure' ] ; then + rmdir zlib > /dev/null 2>&1 + (curl -L -o v1.2.12.tar.gz https://github.com/madler/zlib/archive/v1.2.12.tar.gz && tar -xzf v1.2.12.tar.gz && mv zlib-1.2.12 zlib && rm v1.2.12.tar.gz) || exit 1 + fi + fi + + if [ "${LZ4Dep}" != "" ] ; then + if [ ! -f 'lz4/lib/Makefile' ] ; then + rmdir lz4 > /dev/null 2>&1 + (curl -L -o v1.9.3.tar.gz https://github.com/lz4/lz4/archive/v1.9.3.tar.gz && tar -xzf v1.9.3.tar.gz && mv lz4-1.9.3 lz4 && rm v1.9.3.tar.gz) || exit 1 + fi + fi + + if [ ! -f 'stex/Mf-stex' ] ; then + rmdir stex > /dev/null 2>&1 + (curl -L -o v1.2.2.tar.gz https://github.com/dybvig/stex/archive/v1.2.2.tar.gz && tar -zxf v1.2.2.tar.gz && mv stex-1.2.2 stex && rm v1.2.2.tar.gz) || exit 1 + fi +fi + +./workarea $m $w + +sed -e 's/$(m)/'$m'/g'\ + -e 's/$(workarea)/'$w'/g'\ + makefiles/Makefile.in > Makefile + +sed -e 's/$(m)/'$m'/g'\ + -e "s;^installdir=.*\$;installdir=$installcsug;"\ + makefiles//Makefile-csug.in > csug/Makefile + +sed -e 's/$(m)/'$m'/g'\ + -e "s;^installdir=.*\$;installdir=$installreleasenotes;"\ + makefiles//Makefile-release_notes.in > release_notes/Makefile + +cat makefiles/Makefile-workarea.in > $w/Makefile + +sed -e 's/$(m)/'$m'/g'\ + -e 's/$(workarea)/'$w'/g'\ + makefiles/Mf-boot.in > $w/Mf-boot + +sed -e "s;^m=none\$;m=$m;"\ + -e "s;^InstallBin=.*\$;InstallBin=$installbin;"\ + -e "s;^InstallLib=.*\$;InstallLib=$installlib;"\ + -e "s;^InstallMan=.*\$;InstallMan=$installman/man1;"\ + -e "s;^InstallOwner=.*\$;InstallOwner=$installowner;"\ + -e "s;^InstallGroup=.*\$;InstallGroup=$installgroup;"\ + -e "s;^TempRoot=.*;TempRoot=$temproot;"\ + -e "s;^GzipManPages=.*$;GzipManPages=$gzipmanpages;"\ + -e "s;^InstallSchemeName=.*$;InstallSchemeName=$installschemename;"\ + -e "s;^InstallPetiteName=.*$;InstallPetiteName=$installpetitename;"\ + -e "s;^InstallScriptName=.*$;InstallScriptName=$installscriptname;"\ + -e "s;^InstallKernelTarget=.*$;InstallKernelTarget=$installkerneltarget;"\ + -e "s;^InstallZlibTarget=.*$;InstallZlibTarget=$installzlibtarget;"\ + -e "s;^InstallLZ4Target=.*$;InstallLZ4Target=$installlz4target;"\ + makefiles/Mf-install.in > $w/Mf-install + +cat > $w/c/config.h << END +#define SCHEME_SCRIPT "$installscriptname" +#ifndef WIN32 +#define DEFAULT_HEAP_PATH "$installlib/csv%v/%m" +#endif +END + +if [ "$disablex11" = "yes" ]; then + echo '#define DISABLE_X11' >> $w/c/config.h +fi + +cursesLib=-lcurses +ncursesLib=-lncurses + +if [ "$disablecurses" = "yes" ]; then + echo '#define DISABLE_CURSES' >> $w/c/config.h + cursesLib= + ncursesLib= +fi + +cat > $w/c/Mf-config << END +CC=$CC +CPPFLAGS=$CPPFLAGS +CFLAGS=$CFLAGS +LD=$LD +LDFLAGS=$LDFLAGS +AR=$AR +ARFLAGS=$ARFLAGS +RANLIB=$RANLIB +WINDRES=$WINDRES +cursesLib=$cursesLib +ncursesLib=$ncursesLib +zlibInc=$zlibInc +LZ4Inc=$LZ4Inc +zlibDep=$zlibDep +LZ4Dep=$LZ4Dep +zlibLib=$zlibLib +LZ4Lib=$LZ4Lib +zlibHeaderDep=$zlibHeaderDep +LZ4HeaderDep=$LZ4HeaderDep +Kernel=\${${Kernel}} +KernelLinkDeps=\${${Kernel}LinkDeps} +KernelLinkLibs=\${${Kernel}LinkLibs} +END diff --git a/csug/bibliography.stex b/csug/bibliography.stex new file mode 100644 index 0000000..03a9d9e --- /dev/null +++ b/csug/bibliography.stex @@ -0,0 +1,20 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\ifhtml +\chapter{Bibliography} +\input{csug.bbl} +\else +\bibliographystyle{tspl} +\bibliography{csug} +\fi diff --git a/csug/binding.stex b/csug/binding.stex new file mode 100644 index 0000000..6150d64 --- /dev/null +++ b/csug/binding.stex @@ -0,0 +1,594 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Binding Forms\label{CHPTBINDING}} + +This chapter describes {\ChezScheme} extensions to the set of Revised$^6$ +Report binding forms. +See Chapter~\ref{TSPL:CHPTBINDING} of {\TSPLFOUR} or the Revised$^6$ Report +for a description of standard binding forms. + +\section{Definitions\label{SECTDEFINITIONS}} + +A \index{definitions}definition in Revised$^6$ Report Scheme is a +\index{\scheme{define}}\index{variable definition}variable definition, +\index{\scheme{define-syntax}}\index{keyword definition}keyword +definition, or derived definition, i.e., a syntactic extension that +expands into a definition. +In addition, the forms within a +\index{\scheme{begin}}\scheme{begin} +expression appearing after a sequence +of definitions is spliced onto the end of the sequence of definitions +so that definitions at the front of the \scheme{begin} expression +are treated as if they were part of the outer sequence of definitions. +A \index{\scheme{let-syntax}}\scheme{let-syntax} or +\index{\scheme{letrec-syntax}}\scheme{letrec-syntax} form +is treated similarly, so that definitions at the front of the body +are treated as if they were part of the outer sequence of definitions, +albeit scoped where the bindings of the \scheme{let-syntax} or +\scheme{letrec-syntax} form are visible. + +{\ChezScheme} extends the set of definitions to include +\index{modules}\index{\scheme{module}}\scheme{module} forms, +\index{\scheme{import}}\scheme{import} forms, +\index{\scheme{import-only}}\scheme{import-only} forms, +\index{\scheme{meta}}\scheme{meta} definitions, and +\index{\scheme{alias}}\scheme{alias} forms, although the +\scheme{module}, \scheme{import}, \scheme{import-only}, +\scheme{meta}, and \scheme{alias} keywords are not available +in a library or RNRS top-level program unless the +\scheme{scheme} library is included in the library or +top-level programs imports. +These forms are described in Chapter~\ref{CHPTSYNTAX}. + +In Revised$^6$ Report Scheme, definitions can appear at the front of +a \scheme{lambda} or similar body (e.g., a \scheme{let} or \scheme{letrec} +body), at the front of a library body, or intermixed with expressions +within an RNRS top-level program body. +In {\ChezScheme}, definitions may also be used in the +interactive top-level, i.e., they can be intermixed with expressions in +the REPL or in program text to be loaded from a file +via \index{\scheme{load}}\scheme{load} (Section~\ref{SECTMISCCOMPILEEVAL}). +The Revised$^6$ Report does not mandate the existence nor specify the +semantics of an interactive top-level, nor of a \scheme{load} +procedure. + +The macro expander uses the same two-pass algorithm for expanding +top-level \scheme{begin} expressions as it uses for a \scheme{lambda}, +\scheme{library}, or top-level program body. +(This algorithm is described in Section~\ref{TSPL:SECTSYNTAXDEFINITIONS} of +{\TSPLFOUR}.) As a result, + +\schemedisplay +(begin + (define-syntax a (identifier-syntax 3)) + (define x a)) +\endschemedisplay + +and + +\schemedisplay +(begin + (define x a) + (define-syntax a (identifier-syntax 3))) +\endschemedisplay + +both result in the giving \scheme{x} the value 3, +even though an unbound variable reference to \scheme{a} would result if +the two forms within the latter \scheme{begin} expression were run +independently at top level. + +Similarly, the \scheme{begin} form produced by a use of + +\schemedisplay +(define-syntax define-constant + (syntax-rules () + [(_ x e) + (begin + (define t e) + (define-syntax x (identifier-syntax t)))])) +\endschemedisplay + +and the \scheme{begin} form produced by a use of + +\schemedisplay +(define-syntax define-constant + (syntax-rules () + [(_ x e) + (begin + (define-syntax x (identifier-syntax t)) + (define t e))])) +\endschemedisplay + +are equivalent. + +The Revised$^6$ Report specifies that internal variable definitions be +treated like \scheme{letrec*}, while earlier reports required internal +variable definitions to be treated like \scheme{letrec}. +By default, {\ChezScheme} implements the Revised$^6$ Report semantics for +internal variable definitions, as for all other things, but this behavior +may be overridden via the \scheme{internal-defines-as-letrec*} parameter. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{internal-defines-as-letrec*}{\categorythreadparameter}{internal-defines-as-letrec*} +\listlibraries +\endentryheader + +\noindent +When this parameter is set to \scheme{#t} (the default), internal variable +definitions are evaluated using \scheme{letrec*} semantics. +It may be set to \scheme{#f} to revert to the \scheme{letrec} semantics +for internal variable definitions, for backward compatibility. + + +\section{Multiple-value Definitions} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{define-values}{\categorysyntax}{(define-values \var{formals} \var{expr})} +\listlibraries +\endnoskipentryheader + +A \scheme{define-values} form is a definition and can appear anywhere +other definitions can appear. +It is like a \scheme{define} form but permits an arbitrary formals list +(like \scheme{lambda}) on the left-hand side. +It evaluates \var{expr} and binds the variables appearing in \var{formals} +to the resulting values, in the same manner as the formal parameters of a +procedure are bound to its arguments. + +\schemedisplay +(let () + (define-values (x y) (values 1 2)) + (list x y)) ;=> (1 2) +(let () + (define-values (x y . z) (values 1 2 3 4)) + (list x y z)) ;=> (1 2 (3 4)) +\endschemedisplay + +A \scheme{define-values} form expands into a sequence of definitions, the +first for a hidden temporary bound to a data structure holding the values +returned by \var{expr} and the remainder binding each of the formals to +the corresponding value or list of values, extracted from the data +structure via a reference to the temporary. +Because the temporary must be defined before the other variables are +defined, this works for internal \scheme{define-values} forms only if +\scheme{internal-defines-as-letrec*} is set to the default value +\scheme{#t}. + + +\section{Recursive Bindings} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{rec}{\categorysyntax}{(rec \var{var} \var{expr})} +\returns value of \var{expr} +\listlibraries +\endnoskipentryheader + +\noindent +The syntactic form \scheme{rec} creates a \index{recursive object}recursive object from \var{expr} by +establishing a binding of \var{var} within \var{expr} to the value of \var{expr}. +In essence, it is a special case of \scheme{letrec} for self-recursive objects. + +This form is useful for creating recursive objects (especially procedures) +that do not depend on external variables for the recursion, which are +sometimes undesirable because the external bindings can change. +For example, a recursive procedure defined at top level depends on the value +of the top-level variable given as its name. +If the value of this variable should change, the meaning of the procedure +itself would change. +If the procedure is defined instead with \scheme{rec}, its meaning is independent +of the variable to which it is bound. + +\schemedisplay +(map (rec sum + (lambda (x) + (if (= x 0) + 0 + (+ x (sum (- x 1)))))) + '(0 1 2 3 4 5)) ;=> (0 1 3 6 10 15) + +(define cycle + (rec self + (list (lambda () self)))) + +(eq? ((car cycle)) cycle) ;=> #t +\endschemedisplay + +\noindent +The definition below expands \scheme{rec} in terms of \scheme{letrec}. + +\schemedisplay +(define-syntax rec + (syntax-rules () + [(_ x e) (letrec ((x e)) x)])) +\endschemedisplay + +\section{Fluid Bindings} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{fluid-let}{\categorysyntax}{(fluid-let ((\var{var} \var{expr}) \dots) \var{body_1} \var{body_2} \dots)} +\returns the values of the body \scheme{\var{body_1} \var{body_2} \dots} +\listlibraries +\endentryheader + +\noindent +\index{fluid binding}\index{assignments}The syntactic form \scheme{fluid-let} +provides a way to temporarily assign values to a set of variables. +The new values are in effect only during the evaluation of the +body of the \scheme{fluid-let} expression. +The scopes of the variables are not determined by \scheme{fluid-let}; as with +\scheme{set!}, the variables must be bound at top level or by an enclosing +\scheme{lambda} or other binding form. +It is possible, therefore, to control the scope of a variable with +\scheme{lambda} or \scheme{let} while establishing a temporary +value with \scheme{fluid-let}. + +Although it is similar in appearance to \scheme{let}, its operation is more +like that of \scheme{set!}. +Each \var{var} is assigned, as with \scheme{set!}, to the value of the +corresponding \var{expr} within the body \scheme{\var{body_1} \var{body_2} \dots}. +Should the body +exit normally or by invoking a continuation made outside of the body +(see \scheme{call/cc}), the values in effect before the bindings were changed +are restored. +Should control return back to the body by the invocation of a continuation +created within the body, the bindings are changed once again to the values +in effect when the body last exited. + +Fluid bindings are most useful for +maintaining variables that must be shared by a group of procedures. +Upon entry to the group of procedures, the shared variables are fluidly +bound to a new set of initial values so that on exit the original values +are restored automatically. +In this way, the group of procedures itself can be reentrant; it may call +itself directly or indirectly without affecting the values of its shared +variables. + +\index{special bindings (in Lisp)}Fluid bindings are similar to +\emph{special} bindings in Common Lisp~\cite{Steele:common}, except that +(1) there is a single namespace for both lexical and fluid bindings, and +(2) the scope of a fluidly bound variable is not necessarily global. + +\schemedisplay +(let ([x 3]) + (+ (fluid-let ([x 5]) + x) + x)) ;=> 8 + +(let ([x 'a]) + (letrec ([f (lambda (y) (cons x y))]) + (fluid-let ([x 'b]) + (f 'c)))) ;=> (b . c) + +(let ([x 'a]) + (call/cc + (lambda (k) + (fluid-let ([x 'b]) + (letrec ([f (lambda (y) (k '*))]) + (f '*))))) + x) ;=> a +\endschemedisplay + + +\noindent +\scheme{fluid-let} may be defined in terms of \scheme{dynamic-wind} as follows. + +\schemedisplay\label{defn:fluid-let} +(define-syntax fluid-let + (lambda (x) + (syntax-case x () + [(_ () b1 b2 ...) #'(let () b1 b2 ...)] + [(_ ((x e) ...) b1 b2 ...) + (andmap identifier? #'(x ...)) + (with-syntax ([(y ...) (generate-temporaries #'(x ...))]) + #'(let ([y e] ...) + (let ([swap (lambda () + (let ([t x]) (set! x y) (set! y t)) + ...)]) + (dynamic-wind swap (lambda () b1 b2 ...) swap))))]))) +\endschemedisplay + + +\section{Top-Level Bindings\label{SECTBINDINGTOPLEVEL}} + +The procedures described in this section allow the direct manipulation +of \index{top-level values}top-level bindings for variables +and keywords. +They are intended primarily to support the definition of interpreters +or compilers for Scheme in Scheme but may be used to access or alter +top-level bindings anywhere within a program whether at top level or not. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{define-top-level-value}{\categoryprocedure}{(define-top-level-value \var{symbol} \var{obj})} +\formdef{define-top-level-value}{\categoryprocedure}{(define-top-level-value \var{symbol} \var{obj} \var{env})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{define-top-level-value} is used to establish a binding +for the variable named by \var{symbol} to the value \var{obj} +in the environment \var{env}. +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +An exception is raised with condition type \scheme{&assertion} if +\var{env} is not mutable. + +A call to \scheme{define-top-level-value} is similar to a top-level +\index{\scheme{define}}\scheme{define} form, except that a call to +\scheme{define-top-level-value} need not occur at top-level and +the variable for which the binding is to be established can be +determined at run time, as can the environment. + +\schemedisplay +(begin + (define-top-level-value 'xyz "hi") + xyz) ;=> "hi" + +(let ([var 'xyz]) + (define-top-level-value var "mom") + (list var xyz)) ;=> (xyz "mom") +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-top-level-value!}{\categoryprocedure}{(set-top-level-value! \var{symbol} \var{obj})} +\formdef{set-top-level-value!}{\categoryprocedure}{(set-top-level-value! \var{symbol} \var{obj} \var{env})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\index{assignments}\scheme{set-top-level-value!} assigns +the variable named by \var{symbol} to the value \var{obj} +in the environment \var{env}. +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +An exception is raised with condition type \scheme{&assertion} if the +identifier named by \var{symbol} is not defined as a variable in \var{env} +or if the variable or environment is not mutable. + +\scheme{set-top-level-value!} is similar to +\index{\scheme{set!}}\scheme{set!} when \scheme{set!} +is used on top-level variables except that the variable to be assigned +can be determined at run time, as can the environment. + +\schemedisplay +(let ([v (let ([cons list]) + (set-top-level-value! 'cons +) + (cons 3 4))]) + (list v (cons 3 4))) ;=> ((3 4) 7) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{top-level-value}{\categoryprocedure}{(top-level-value \var{symbol})} +\formdef{top-level-value}{\categoryprocedure}{(top-level-value \var{symbol} \var{env})} +\returns the top-level value of the variable named by \var{symbol} in \var{env} +\listlibraries +\endentryheader + +\noindent +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +An exception is raised with condition type \scheme{&assertion} if the +identifier named by \var{symbol} is not defined as a variable in \var{env}. + +\scheme{top-level-value} is similar to a top-level variable reference +except that the variable to be referenced can be determined at run time, +as can the environment. + +\schemedisplay +(let ([cons +]) + (list (cons 3 4) + ((top-level-value 'cons) 3 4))) ;=> (7 (3 . 4)) + +(define e (copy-environment (scheme-environment))) +(define-top-level-value 'pi 3.14 e) +(top-level-value 'pi e) ;=> 3.14 +(set-top-level-value! 'pi 3.1416 e) +(top-level-value 'pi e) ;=> 3.1416 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{top-level-bound?}{\categoryprocedure}{(top-level-bound? \var{symbol})} +\formdef{top-level-bound?}{\categoryprocedure}{(top-level-bound? \var{symbol} \var{env})} +\returns \scheme{#t} if \var{symbol} is defined as a variable in \var{env}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +This predicate is useful in an interpreter to check for the existence of +a top-level binding before requesting the value with +\scheme{top-level-value}. + +\schemedisplay +(top-level-bound? 'xyz) ;=> #f + +(begin + (define-top-level-value 'xyz 3) + (top-level-bound? 'xyz)) ;=> #t + +(define e (copy-environment (interaction-environment))) +(define-top-level-value 'pi 3.14 e) +(top-level-bound? 'pi) ;=> #f +(top-level-bound? 'pi e) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{top-level-mutable?}{\categoryprocedure}{(top-level-mutable? \var{symbol})} +\formdef{top-level-mutable?}{\categoryprocedure}{(top-level-mutable? \var{symbol} \var{env})} +\returns \scheme{#t} if \var{symbol} is mutable in \var{env}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +This predicate is useful in an interpreter to check whether a variable +can be assigned before assigning it with +\scheme{set-top-level-value!}. + +\schemedisplay +(define xyz 3) +(top-level-mutable? 'xyz) ;=> #t +(set-top-level-value! 'xyz 4) +(top-level-value 'xyz) ;=> 4 + +(define e (copy-environment (interaction-environment) #f)) +(top-level-mutable? 'xyz e) ;=> #f +(set-top-level-value! 'xyz e) ;=> \var{exception: xyz is immutable} +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{define-top-level-syntax}{\categoryprocedure}{(define-top-level-syntax \var{symbol} \var{obj})} +\formdef{define-top-level-syntax}{\categoryprocedure}{(define-top-level-syntax \var{symbol} \var{obj} \var{env})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{define-top-level-syntax} is used to establish a top-level binding +for the identifier named by \var{symbol} to the value of \var{obj} +in the environment \var{env}. +The value must be a procedure, the result of a call to +\scheme{make-variable-transformer}, or the result of a call to +\scheme{top-level-syntax}. +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +An exception is raised with condition type \scheme{&assertion} if +\var{env} is not mutable. + +A call to \scheme{define-top-level-syntax} is similar to a top-level +\index{\scheme{define-syntax}}\scheme{define-syntax} form, except that a call to +\scheme{define-top-level-syntax} need not occur at top-level and +the identifier for which the binding is to be established can be +determined at run time, as can the environment. + +\schemedisplay +(define-top-level-syntax 'let1 + (syntax-rules () + [(_ x e b1 b2 ...) (let ([x e]) b1 b2 ...)])) +(let1 a 3 (+ a 1)) ;=> 4 +\endschemedisplay + +\scheme{define-top-level-syntax} can also be used to attach +to an identifier arbitrary compile-time bindings obtained +via \scheme{top-level-syntax}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{top-level-syntax}{\categoryprocedure}{(top-level-syntax \var{symbol})} +\formdef{top-level-syntax}{\categoryprocedure}{(top-level-syntax \var{symbol} \var{env})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{top-level-syntax} is used to retrieve the transformer, compile-time +value, or other compile-time binding to which +the identifier named by \var{symbol} is bound in the environment \var{env}. +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). +All identifiers bound in an environment have compile-time bindings, including +variables. + +An exception is raised with condition type \scheme{&assertion} if the +identifier named by \var{symbol} is not defined as a keyword in \var{env}. + +\schemedisplay +(define-top-level-syntax 'also-let (top-level-syntax 'let)) +(also-let ([x 3] [y 4]) (+ x y)) ;=> 7 + +(define foo 17) +(define-top-level-syntax 'also-foo (top-level-syntax 'foo)) +also-foo ;=> 17 +(set! also-foo 23) +also-foo ;=> 23 +foo ;=> 23 +\endschemedisplay + +The effect of the last example can be had more clearly with \scheme{alias}: + +\schemedisplay +(define foo 17) +(alias also-foo foo) +also-foo ;=> 17 +(set! also-foo 23) +also-foo ;=> 23 +foo ;=> 23 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{top-level-syntax?}{\categoryprocedure}{(top-level-syntax? \var{symbol})} +\formdef{top-level-syntax?}{\categoryprocedure}{(top-level-syntax? \var{symbol} \var{env})} +\returns \scheme{#t} if \var{symbol} is bound as a keyword in \var{env}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +If \var{env} is not provided, it defaults to the +value of \scheme{interaction-environment}, i.e., the +top-level evaluation environment +(Section~\ref{SECTMISCENVIRONMENTS}). + +All identifiers bound in an environment have compile-time bindings, including +variables, so this predicate amounts to a bound check, but is more general +than \scheme{top-level-bound?}, which returns true only for bound variables. + +\schemedisplay +(define xyz 'hello) +(top-level-syntax? 'cons) ;=> #t +(top-level-syntax? 'lambda) ;=> #t +(top-level-syntax? 'hello) ;=> #t + +(top-level-syntax? 'cons (scheme-environment)) ;=> #t +(top-level-syntax? 'lambda (scheme-environment)) ;=> #t +(top-level-syntax? 'hello (scheme-environment)) ;=> #f +\endschemedisplay diff --git a/csug/canned/about.html b/csug/canned/about.html new file mode 100644 index 0000000..e1f3f4e --- /dev/null +++ b/csug/canned/about.html @@ -0,0 +1,37 @@ + + +About CSUG9 + + + + +

+The printed version of this book was created with LaTeX from extended +LaTeX sources with the help of a preprocessor written in Scheme. +The preprocessor handles extensions for incorporating arbitrary +verbatim Scheme code and various other features not directly supported +by LaTeX. +

+ +

+The HTML version was created from the preprocessed sources for the +printed version by a separate Scheme program that performs a LaTeX to +HTML conversion. +In addition to the extended LaTeX source files, this program takes as +input the .aux and .bbl files produced by a complete LaTeX/BibTeX run +of the document in order to support labels and page references in the +text, summary of forms, and index. +As it runs, the program produces a .haux file containing urls for the +labels, bibliographic entries, and index entries; as with LaTeX, a +second run of the program is needed to achieve proper +cross-referencing. +

+ +

+Most of the images and certain mathematical formulas included in the +HTML version were produced with the help of LaTeX, dvips, ghostscript, +and various programs from the netpbm library. +

+ + + diff --git a/csug/canned/cisco-logo-large.png b/csug/canned/cisco-logo-large.png new file mode 100644 index 0000000..47c6b3d Binary files /dev/null and b/csug/canned/cisco-logo-large.png differ diff --git a/csug/canned/cisco-logo-orig.png b/csug/canned/cisco-logo-orig.png new file mode 100644 index 0000000..3a058ca Binary files /dev/null and b/csug/canned/cisco-logo-orig.png differ diff --git a/csug/canned/cisco-logo.png b/csug/canned/cisco-logo.png new file mode 100644 index 0000000..52bfb89 Binary files /dev/null and b/csug/canned/cisco-logo.png differ diff --git a/csug/canned/copyright.html b/csug/canned/copyright.html new file mode 100644 index 0000000..8328131 --- /dev/null +++ b/csug/canned/copyright.html @@ -0,0 +1,25 @@ + + +Copyright Notice + + + + + + +

+Cisco and the Cisco logo are trademarks or registered trademarks +of Cisco and/or its affiliates in the U.S. and other countries. To +view a list of Cisco trademarks, go to this URL: +http://www.cisco.com/go/trademarks. Third-party trademarks mentioned +are the property of their respective owners. The use of the word +partner does not imply a partnership relationship between Cisco and +any other company. (1110R) +

+ + + diff --git a/csug/canned/csug.css b/csug/canned/csug.css new file mode 120000 index 0000000..69b665c --- /dev/null +++ b/csug/canned/csug.css @@ -0,0 +1 @@ +../csug.css \ No newline at end of file diff --git a/csug/canned/fatfibhtml-orig.png b/csug/canned/fatfibhtml-orig.png new file mode 100644 index 0000000..e646158 Binary files /dev/null and b/csug/canned/fatfibhtml-orig.png differ diff --git a/csug/canned/fatfibhtml.png b/csug/canned/fatfibhtml.png new file mode 100644 index 0000000..e646158 Binary files /dev/null and b/csug/canned/fatfibhtml.png differ diff --git a/csug/canned/profilehtml-orig.png b/csug/canned/profilehtml-orig.png new file mode 100644 index 0000000..e480610 Binary files /dev/null and b/csug/canned/profilehtml-orig.png differ diff --git a/csug/canned/profilehtml.png b/csug/canned/profilehtml.png new file mode 100644 index 0000000..e480610 Binary files /dev/null and b/csug/canned/profilehtml.png differ diff --git a/csug/canned/profview.png b/csug/canned/profview.png new file mode 100644 index 0000000..562b78b Binary files /dev/null and b/csug/canned/profview.png differ diff --git a/csug/compat.stex b/csug/compat.stex new file mode 100644 index 0000000..86505d2 --- /dev/null +++ b/csug/compat.stex @@ -0,0 +1,821 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Compatibility Features\label{CHPTCOMPAT}} + +This chapter describes several items that are included with current +versions of {\ChezScheme} primarily for compatibility with older +versions of the system. + +Section~\ref{SECTCOMPATHASHTABLES} describes a hash-table interface +that has since been replaced by the R6RS hashtable interface. +Section~\ref{SECTCOMPATEXTENDSYNTAX} +describes \scheme{extend-syntax} macros. +These features are supported directly by current versions of {\ChezScheme}, +but support may be dropped in future versions. +New programs should use the standard mechanisms described +in \emph{The Scheme Programming Language, 4th Edition}~\cite{Dybvig:tspl4} +instead. + +Section~\ref{SECTCOMPATSTRUCTURES} describes a mechanism for defining +record-like structures as vectors instead of new unique types. +New programs should use \scheme{define-record}, which is described +in Section~\ref{SECTCSV7RECORDS}, instead. + +Section~\ref{SECTCOMPATOTHER} +describes a compatibility file distributed with +{\ChezScheme} that contains definitions for forms and procedures no +longer supported directly by {\ChezScheme}. + +% undocumented: +% application-expander not bothering... +% constant-expander not bothering... +% variable-expander not bothering... +% syntax-match? not bothering... +% extend-syntax/code not bothering... + + +\section{Hash Tables\label{SECTCOMPATHASHTABLES}} + +The hash table procedures here are obviated by the new hash table procedures +listed in Section~\ref{SECTMISCHASHTABLES}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-hash-table}{\categoryprocedure}{(make-hash-table)} +\formdef{make-hash-table}{\categoryprocedure}{(make-hash-table \var{weak?})} +\returns a new hash table +\listlibraries +\endentryheader + +If \var{weak?} is provided and is non-false, the hash +table is a weak hash table, which means that it does not protect +keys from the garbage collector. +Keys reclaimed by the garbage collector are removed from the table, +and their associated values are dropped the next time the table +is modified, if not sooner. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hash-table?}{\categoryprocedure}{(hash-table? \var{obj})} +\returns \scheme{#t} if \var{obj} is a hash table, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{put-hash-table!}{\categoryprocedure}{(put-hash-table! \var{ht} \var{k} \var{v})} +\returns unspecified +\listlibraries +\endentryheader + +\var{ht} must be a hash table. +\var{k} and \var{v} may be any Scheme values. + +\scheme{put-hash-table!} associates the value +\var{v} with the key \var{k} in \var{ht}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-hash-table}{\categoryprocedure}{(get-hash-table \var{ht} \var{k} \var{d})} +\returns see below +\listlibraries +\endentryheader + +\scheme{get-hash-table} returns the value +associated with \var{k} in \var{ht}. +If no value is associated with \var{k} in \var{ht}, +\scheme{get-hash-table} returns \var{d}. + +Key comparisons are performed with \var{eq?}. + +Because objects may be moved by the garbage collector, \scheme{get-hash-table} +may need to rehash some objects and therefore cause side effects in the +hash table. +Thus, it is not safe to perform concurrent accesses of the same hash table +from multiple threads using \scheme{get-hash-table}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{remove-hash-table!}{\categoryprocedure}{(remove-hash-table! \var{ht} \var{k})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{remove-hash-table!} drops any association +for \var{k} from \var{ht}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hash-table-map}{\categoryprocedure}{(hash-table-map \var{ht} \var{p})} +\returns see below +\listlibraries +\endentryheader + +\scheme{hash-table-map} applies \var{p} to each key, value association +in \var{ht}, in no particular order, and returns a list of the resulting +values, again in no particular order. +\var{p} should accept two arguments, a key and a value. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hash-table-for-each}{\categoryprocedure}{(hash-table-for-each \var{ht} \var{p})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{hash-table-for-each} applies \var{p} to each key, value +association in \var{ht}, in no particular order. +Unlike \scheme{hash-table-map}, it does not create a list of the values; +instead, it's value is unspecified. +\var{p} should accept two arguments, a key and a value. + + +\section{Extend-Syntax Macros\label{SECTCOMPATEXTENDSYNTAX}} + +This section describes \scheme{extend-syntax}, a powerful yet easy to use +syntactic extension facility based on +\index{pattern matching}pattern matching~\cite{Kohlbecker:phd}. +Syntactic transformations written using +\scheme{extend-syntax} are similar to those written using a +\scheme{define-syntax} with \scheme{syntax-case}, except that the +transformations produced by \scheme{extend-syntax} do not automatically +respect lexical scoping. + +It is not typically possible to mix syntactic abstractions written using +\scheme{syntax-case} with those written using \scheme{extend-syntax} +seamlessly; it is generally preferable to use one or the other wherever +possible. +Support for \scheme{extend-syntax} within the \scheme{syntax-case} expander +is provided only as an aid to migrating to \scheme{syntax-case}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{extend-syntax}{\categorysyntax}{(extend-syntax (\var{name} \var{key} \dots) (\var{pat} \var{fender} \var{template}) \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +The identifier \var{name} is the name, or syntax keyword, for the +syntactic extension to be defined. +When the system expander processes any list expression whose car is +\var{name}, the syntactic transformation procedure generated by +\scheme{extend-syntax} is invoked on this expression. +The remaining identifiers \scheme{\var{key} \dots} are additional keywords to +be recognized within input expressions during expansion (such as +\scheme{else} in \scheme{cond} or \scheme{case}). + +Each clause after the list of keys consists of a pattern \var{pat}, an +optional \index{fenders}\var{fender}, +and a \var{template}. +The optional \var{fender} is omitted more often than not. +The \var{pat} specifies the syntax the input expression must have +for the clause to be chosen. +Identifiers within the pattern that are not keywords +(\emph{pattern variables}) are bound to corresponding pieces of the input expression. +If present, the \var{fender} is a Scheme expression that specifies +additional constraints on the input expression (accessed through the +pattern variables) that must be satisfied in order for the clause to +be chosen. +The \var{template} specifies what form the output takes, usually in +terms of the pattern variables. + +During expansion, the transformation procedure \scheme{extend-syntax} +generates attempts to match the input expression against each +pattern in the order the clauses are given. +If the input expression matches the pattern, the pattern variables are +bound to the corresponding pieces of the input expression and the +fender for the clause, if any, is evaluated. +If the fender returns a true value, the given expansion is performed. +If input does not match the pattern or if the fender returns a false +value, the transformation procedure tries the next clause. +An exception is raised with condition type \scheme{&assertion} if no clause can be chosen. + +Within the pattern, +\index{\scheme{...}~(ellipses)}\index{ellipses (~\scheme{...}~)}\emph{ellipsis} +(\scheme{...}) may be +used to specify zero or more occurrences +of the preceding pattern fragment, or prototype. +Similarly, ellipses may be used in the output to specify the construction +of zero or more expansion prototypes. +In this case, the expansion prototype must contain part of an input pattern +prototype. +The use of patterns, templates, ellipses within patterns and templates, +and fenders is illustrated in the following sequence of examples. + +The first example, defining \index{\scheme{rec}}\scheme{rec}, uses a single keyword, a single +clause with no fender, and no ellipses. + +\schemedisplay +(extend-syntax (rec) + [(rec id val) + (let ([id #f]) + (set! id val) + id)]) +\endschemedisplay + +The second example, defining \index{\scheme{when}}\scheme{when}, shows +the use of ellipses. + +\schemedisplay +(extend-syntax (when) + [(when test exp1 exp2 ...) + (if test (begin exp1 exp2 ...) #f)]) +\endschemedisplay + +The next example shows the definition of +\index{\scheme{let}}\scheme{let}. +The definition of \scheme{let} shows the use of multiple ellipses, employing +one for the identifier/value pairs and one for the expressions in the body. +It also shows that the prototype need not be a single identifier, and that +pieces of the prototype may be separated from one another in the template. + +\schemedisplay +(extend-syntax (let) + [(let ([x e] ...) b1 b2 ...) + ((lambda (x ...) b1 b2 ...) e ...)]) +\endschemedisplay + +The next example shows \index{\scheme{let*}}\scheme{let*}, whose syntax is the same as for +\scheme{let}, but which is defined recursively in terms of \scheme{let} with +two clauses (one for the base case, one for the recursion step) since +it must produce a nested structure. + +\schemedisplay +(extend-syntax (let*) + [(let* () b1 b2 ...) + (let () b1 b2 ...)] + [(let* ([x e] more ...) b1 b2 ...) + (let ([x e]) (let* (more ...) b1 b2 ...))]) +\endschemedisplay + +The first pattern/template pair matches any \scheme{let*} expression with no +identifier/value pairs and maps it into the equivalent \scheme{begin} expression. +This is the base case. +The second pattern/template pair matches any \scheme{let*} expression with one +or more identifier/value pairs and transforms it into a \scheme{let} expression +binding the first pair whose body is a \scheme{let*} expression binding the +remaining pairs. +This is the recursion step, which will eventually lead us to the base case +because we remove one identifier/value pair at each step. +Notice that the second pattern uses the pattern variable \scheme{more} for the +second and later identifier/value pairs; this makes the pattern and template +less cluttered and makes it clear that only the first identifier/value pair +is dealt with explicitly. + +The definition for \index{\scheme{and}}\scheme{and} requires three clauses. +The first clause is necessary to recognize \scheme{(and)}, and the second +two define all other \scheme{and} forms recursively. + +\schemedisplay +(extend-syntax (and) + [(and) #t] + [(and x) x] + [(and x y ...) (if x (and y ...) #f)]) +\endschemedisplay + +The definition for \index{\scheme{cond}}\scheme{cond} requires four clauses. +As with \scheme{let*}, \scheme{cond} must be described recursively, partly because +it produces nested \scheme{if} expressions, and partly because one +ellipsis prototype would not be sufficient to describe all possible +\scheme{cond} clauses. +The definition of \scheme{cond} also requires that we specify \scheme{else} as a +keyword, in addition to \scheme{cond}. +Here is the definition: + +\schemedisplay +(extend-syntax (cond else) + [(cond) #f] + [(cond (else e1 e2 ...)) + (begin e1 e2 ...)] + [(cond (test) more ...) + (or test (cond more ...))] + [(cond (test e1 e2 ...) more ...) + (if test + (begin e1 e2 ...) + (cond more ...))]) +\endschemedisplay + +\noindent +Two of the clauses are base cases and two are recursion steps. +The first base case is an empty \scheme{cond}. +The value of \scheme{cond} in this case is unspecified, so the choice of +\scheme{#f} is somewhat arbitrary. +The second base case is a \scheme{cond} containing only an \scheme{else} clause; +this is transformed to the equivalent \scheme{begin} expression. +The two recursion steps differ in the number of expressions in the \scheme{cond} +clause. +The value of \scheme{cond} when the first true clause contains only the test +expression is the value of the test. +This is similar to what \scheme{or} does, so we expand the \scheme{cond} clause +into an \scheme{or} expression. +On the other hand, when there are expressions following the test expression, +the value of the last expression is returned, so we use \scheme{if} and +\scheme{begin}. + +To be absolutely correct about the syntax of \scheme{let}, we actually +must require that the bound identifiers in the input are symbols. +If we typed something like \scheme{(let ([3 x]) x)} we would not get an +error from \scheme{let} because it does not check to verify that the +objects in the identifier positions are symbols. +Instead, \scheme{lambda} may complain, or perhaps the system evaluator +long after expansion is complete. +This is where \index{fenders}fenders +are useful. + +\schemedisplay +(extend-syntax (let) + [(let ([x e] ...) b1 b2 ...) + (andmap symbol? '(x ...)) + ((lambda (x ...) b1 b2 ...) e ...)]) +\endschemedisplay + +\noindent +The \index{\scheme{andmap}}\scheme{andmap} of \scheme{symbol?} +over \scheme{'(x ...)} assures that each +bound identifier is a symbol. +A fender is simply a Scheme expression. +Within that expression, any quoted object is first expanded by the same +rules as the template part of the clause. +In this case, \scheme{'(x ...)} is expanded to the list of identifiers from +the identifier/value pairs. + +\scheme{extend-syntax} typically handles everything you need it for, but +some syntactic extension definitions require the ability to include the +result of evaluating an arbitrary Scheme expression. +This ability is provided by \scheme{with}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with}{\categorysyntax}{(with ((\var{pat} \var{expr}) \dots) \var{template})} +\returns processed \var{template} +\nolistlibraries +\endentryheader + +\noindent +\scheme{with} is valid only within an template inside of \scheme{extend-syntax}. +\scheme{with} patterns are the same as \scheme{extend-syntax} patterns, \scheme{with} +expressions are the same as \scheme{extend-syntax} fenders, and \scheme{with} +templates are the same as \scheme{extend-syntax} templates. + +\scheme{with} can be used to introduce new pattern identifiers bound to +expressions produced by arbitrary Scheme expressions within +\scheme{extend-syntax} templates. +That is, \scheme{with} allows an escape from the declarative style of +\scheme{extend-syntax} into the procedural style of full Scheme. + +One common use of \scheme{with} is the introduction of a temporary +identifier or list of temporary identifiers into a template. +\scheme{with} is also used to perform complex transformations that might +be clumsy or inefficient if performed within the \scheme{extend-syntax} +framework. + +For example, \scheme{or} requires the use of a temporary identifier. +We could define \scheme{or} as follows. + +\schemedisplay +(extend-syntax (or) + [(or) #f] + [(or x) x] + [(or x y ...) + (let ([temp x]) + (if temp temp (or y ...)))]) +\endschemedisplay + +\noindent +This would work until we placed an \scheme{or} expression within the scope +of an occurrence of \scheme{temp}, in which case strange things could happen, +since \scheme{extend-syntax} does not respect lexical scoping. +(This is one of the reasons that \scheme{define-syntax} is preferable to +\scheme{extend-syntax}.) + +\schemedisplay +(let ([temp #t]) + (or #f temp)) ;=> #f +\endschemedisplay + +\noindent +One solution is to use +\index{\scheme{gensym}}\scheme{gensym} and \scheme{with} to +create a temporary identifier, as follows. + +\schemedisplay +(extend-syntax (or) + [(or) #f] + [(or x) x] + [(or x y ...) + (with ([temp (gensym)]) + (let ([temp x]) + (if temp temp (or y ...))))]) +\endschemedisplay + +\noindent +Also, \scheme{with} can be used to combine elements of the input pattern +in ways not possible directly with \scheme{extend-syntax}, such as the +following \scheme{folding-plus} example. + +\schemedisplay +(extend-syntax (folding-plus) + [(folding-plus x y) + (and (number? 'x) (number? 'y)) + (with ([val (+ 'x 'y)]) + val)] + [(folding-plus x y) (+ x y)]) +\endschemedisplay + +\noindent +\scheme{folding-plus} collapses into the value of \scheme{(+ x y)} if both +\scheme{x} and \scheme{y} are numeric constants. +Otherwise, \scheme{folding-plus} is transformed into \scheme{(+ x y)} for +later evaluation. +The fender checks that the operands are numbers at expansion time, and +the \scheme{with} performs the evaluation. +As with fenders, expansion is performed only within a quoted expressions, +since \scheme{quote} sets the data apart from the remainder of the Scheme +expression. + +The example below binds a list of pattern variables to a list of +temporary symbols, taking advantage of the fact that \scheme{with} allows +us to bind patterns to expressions. +This list of temporaries helps us to implement the \scheme{sigma} syntactic +extension. +\scheme{sigma} is similar to \scheme{lambda}, except it assigns the identifiers +in the identifier list instead of creating new bindings. +It may be used to perform a series of assignments in parallel. + +\schemedisplay +(extend-syntax (sigma) + [(sigma (x ...) e1 e2 ...) + (with ([(t ...) (map (lambda (x) (gensym)) '(x ...))]) + (lambda (t ...) + (set! x t) ... + e1 e2 ...))]) + +(let ([x 'a] [y 'b]) + ((sigma (x y) (list x y)) y x)) ;=> (b a) +\endschemedisplay + + +The final example below uses \scheme{extend-syntax} to implement +\scheme{define-structure}, following a similar example using +\scheme{syntax-case} in Section~\ref{TSPL:SECTSYNTAXEXAMPLES} of +\emph{The Scheme Programming Language, 4th Edition}. + +The definition of \scheme{define-structure} makes use of two pattern/template +clauses. +Two clauses are needed to handle the optionality of the second subexpression. +The first clause matches the form without the second subexpression and +merely converts it into the equivalent form with the second subexpression +present, but empty. + +The definition also makes heavy use of \index{\scheme{with}}\scheme{with} to evaluate Scheme +expressions at expansion time. +The first four \scheme{with} clauses are used to manufacture the identifiers +that name the automatically defined procedures. +(The procedure \index{\scheme{format}}\scheme{format} is particularly useful here, but it could be +replaced with \scheme{string-append!}, using \scheme{symbol->string} as needed.) +The first two clauses yield single identifiers (for the constructor and +predicate), while the next two yield lists of identifiers (for the field +access and assignment procedures). +The fifth \scheme{with} clause (the final clause in the outer \scheme{with}) +is used to count the total length vector needed for each instance of +the structure, which must include room for the name and all of the fields. +The final \scheme{with} clause (the only clause in the inner \scheme{with}) +is used to create a list of vector indexes, one for each field (starting at +1, since the structure name occupies position 0). + +\schemedisplay +(extend-syntax (define-structure) + [(define-structure (name id1 ...)) + (define-structure (name id1 ...) ())] + [(define-structure (name id1 ...) ([id2 val] ...)) + (with ([constructor + (string->symbol (format "make-~a" 'name))] + [predicate + (string->symbol (format "~a?" 'name))] + [(access ...) + (map (lambda (x) + (string->symbol + (format "~a-~a" 'name x))) + '(id1 ... id2 ...))] + [(assign ...) + (map (lambda (x) + (string->symbol + (format "set-~a-~a!" 'name x))) + '(id1 ... id2 ...))] + [count (length '(name id1 ... id2 ...))]) + (with ([(index ...) + (let f ([i 1]) + (if (= i 'count) + '() + (cons i (f (+ i 1)))))]) + (begin + (define constructor + (lambda (id1 ...) + (let* ([id2 val] ...) + (vector 'name id1 ... id2 ...)))) + (define predicate + (lambda (obj) + (and (vector? obj) + (= (vector-length obj) count) + (eq? (vector-ref obj 0) 'name)))) + (define access + (lambda (obj) + (vector-ref obj index))) + ... + (define assign + (lambda (obj newval) + (vector-set! obj index newval))) + ...)))]) +\endschemedisplay + +\section{Structures\label{SECTCOMPATSTRUCTURES}} + +\index{structures}This section describes a mechanism, similar +to the record-defining mechanisms of Section~\ref{SECTCSV7RECORDS}, +that permits the creation of data structures +with fixed sets of named fields. +Unlike record types, structure types are not unique types, but are +instead implemented as vectors. +Specifically, a structure is implemented as a vector whose length is +one more than the number of fields and whose first element contains +the symbolic name of the structure. + +The representation of structures as vectors +simplifies reading and printing of structures somewhat as well +as extension of the structure definition facility. +It does, however, have some drawbacks. +One is that structures may be treated as ordinary vectors by mistake in +situations where doing so is inappropriate. +When dealing with both structures and vectors in a program, care must +be taken to look for the more specific structure type before checking +for the more generic vector type, e.g., in a series of \scheme{cond} +clauses. +A similar drawback is that structure instances are easily ``forged,'' either +intentionally or by accident. +It is also impossible to control how structures are printed and read. + +Structures are created via \scheme{define-structure}. +Each structure definition defines a constructor +procedure, a type predicate, an access procedure for each of its fields, +and an assignment procedure for each of its fields. +\scheme{define-structure} allows the programmer to control which fields +are arguments to the generated constructor procedure and which fields +are explicitly initialized by the constructor procedure. + +\scheme{define-structure} is simple +yet powerful enough for most applications, and it is easily +extended to handle many applications for which it is not sufficient. +The definition of \scheme{define-structure} given at the end of +this section can serve as a starting point for more complicated +variants. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{define-structure}{\categorysyntax}{(define-structure (\var{name} \var{id_1} \dots) ((\var{id_2} \var{expr}) \dots))} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +A \scheme{define-structure} form is a definition and may appear anywhere +and only where other definitions may appear. + +\scheme{define-structure} defines a new data structure, \var{name}, and +creates a set of procedures for creating and manipulating instances of +the structure. +The identifiers \scheme{\var{id_1} \dots} and \scheme{\var{id_2} \dots} +name the fields of the data structure. + +The following procedures are defined by \scheme{define-structure}: + +\begin{itemize} +\item +a constructor procedure whose name is \scheme{make-\var{name}}, + +\item +a type predicate whose name is \scheme{\var{name}?}, + +\item +an access procedure whose name is \scheme{\var{name}-\var{field}} +for each field name \scheme{\var{id_1} \dots} and +\scheme{\var{id_2} \dots}, and + +\item +an assignment procedure whose name is +\scheme{set-\var{name}-\var{field}!} +for each field name \scheme{\var{id_1} \dots} and \scheme{\var{id_2} \dots}. +\end{itemize} + +The fields named by the identifiers \scheme{\var{id_1} \dots} are +initialized by the arguments to the constructor procedure. +The fields named by the identifiers \scheme{\var{id_2} \dots} are initialized +explicitly to the values of the expressions \scheme{\var{expr} \dots}. +Each expression is evaluated within the scope of the identifiers +\scheme{\var{id_1} \dots} (bound to the corresponding field values) and any +of the identifiers \scheme{\var{id_2} \dots} (bound to the corresponding field +values) appearing before it (as if within a \scheme{let*}). + +To clarify, the constructor behaves as if defined as + +\schemedisplay +(define make-\var{name} + (lambda (\var{id_1} \dots) + (let* ([\var{id_2} \var{expr}] \dots) + \var{body}))) +\endschemedisplay + +\noindent +where \var{body} builds the structure from the values of the identifiers +\scheme{\var{id_1} \dots} and \scheme{\var{id_2} \dots}. + +If no fields other than those initialized by the arguments to the +constructor procedure are needed, the second subexpression, +\scheme{((\var{id_2} \var{expr}) \dots)}, may be omitted. + +\index{pares}\index{\scheme{make-pare}}The following simple example +demonstrates how pairs might be defined in Scheme if they did not +already exist. +Both fields are initialized by the arguments to the constructor +procedure. + +\schemedisplay +(define-structure (pare car cdr)) +(define p (make-pare 'a 'b)) + +(pare? p) ;=> #t +(pair? p) ;=> #f +(pare? '(a . b)) ;=> #f + +(pare-car p) ;=> a +(pare-cdr p) ;=> b + +(set-pare-cdr! p (make-pare 'b 'c)) + +(pare-car (pare-cdr p)) ;=> b +(pare-cdr (pare-cdr p)) ;=> c +\endschemedisplay + +The following example defines a handy string data structure, called a +\index{stretch strings}\emph{stretch-string}, that grows as needed. +This example uses a field explicitly initialized to a value that +depends on the value of the constructor argument fields. + +\schemedisplay +(define-structure (stretch-string length fill) + ([string (make-string length fill)])) + +(define stretch-string-ref + (lambda (s i) + (let ([n (stretch-string-length s)]) + (when (>= i n) (stretch-stretch-string! s (+ i 1) n)) + (string-ref (stretch-string-string s) i)))) + +(define stretch-string-set! + (lambda (s i c) + (let ([n (stretch-string-length s)]) + (when (>= i n) (stretch-stretch-string! s (+ i 1) n)) + (string-set! (stretch-string-string s) i c)))) + +(define stretch-string-fill! + (lambda (s c) + (string-fill! (stretch-string-string s) c) + (set-stretch-string-fill! s c))) + +(define stretch-stretch-string! + (lambda (s i n) + (set-stretch-string-length! s i) + (let ([str (stretch-string-string s)] + [fill (stretch-string-fill s)]) + (let ([xtra (make-string (- i n) fill)]) + (set-stretch-string-string! s + (string-append str xtra)))))) +\endschemedisplay + +\noindent +As often happens, most of the procedures defined automatically are +used only to define more specialized procedures, in this case the procedures +\scheme{stretch-string-ref} and \scheme{stretch-string-set!}. +\scheme{stretch-string-length} and \scheme{stretch-string-string} are +the only automatically defined procedures that are likely to be +called directly in code that uses stretch strings. + +\schemedisplay +(define ss (make-stretch-string 2 #\X)) + +(stretch-string-string ss) ;=> "XX" +(stretch-string-ref ss 3) ;=> #\X +(stretch-string-length ss) ;=> 4 +(stretch-string-string ss) ;=> "XXXX" + +(stretch-string-fill! ss #\@) +(stretch-string-string ss) ;=> "@@@@" +(stretch-string-ref ss 5) ;=> #\@ +(stretch-string-string ss) ;=> "@@@@@@" + +(stretch-string-set! ss 7 #\=) +(stretch-string-length ss) ;=> 8 +(stretch-string-string ss) ;=> "@@@@@@@=" +\endschemedisplay + + +Section~\ref{TSPL:SECTSYNTAXEXAMPLES} of {\TSPLFOUR} defines a simplified +variant of \scheme{define-structure} as an example of the use of +\index{\scheme{syntax-case}}\scheme{syntax-case}. +The definition given below implements the complete version. + +\scheme{define-structure} expands into a series of definitions for names +generated from the structure name and field names. +The generated identifiers are created with +\index{\scheme{datum->syntax}}\scheme{datum->syntax} to +make the identifiers visible where the \scheme{define-structure} +form appears. +Since a \scheme{define-structure} form expands into a \scheme{begin} +containing definitions, it is itself a definition and can be used +wherever definitions are valid. + +\schemedisplay +(define-syntax define-structure + (lambda (x) + (define gen-id + (lambda (template-id . args) + (datum->syntax template-id + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string + (syntax->datum x)))) + args)))))) + (syntax-case x () + ((_ (name field1 ...)) + (andmap identifier? #'(name field1 ...)) + #'(define-structure (name field1 ...) ())) + ((_ (name field1 ...) ((field2 init) ...)) + (andmap identifier? #'(name field1 ... field2 ...)) + (with-syntax + ((constructor (gen-id #'name "make-" #'name)) + (predicate (gen-id #'name #'name "?")) + ((access ...) + (map (lambda (x) (gen-id x #'name "-" x)) + #'(field1 ... field2 ...))) + ((assign ...) + (map (lambda (x) (gen-id x "set-" #'name "-" x "!")) + #'(field1 ... field2 ...))) + (structure-length + (+ (length #'(field1 ... field2 ...)) 1)) + ((index ...) + (let f ([i 1] [ids #'(field1 ... field2 ...)]) + (if (null? ids) + '() + (cons i (f (+ i 1) (cdr ids))))))) + #'(begin + (define constructor + (lambda (field1 ...) + (let* ([field2 init] ...) + (vector 'name field1 ... field2 ...)))) + (define predicate + (lambda (x) + (and (vector? x) + (#3%fx= (vector-length x) structure-length) + (eq? (vector-ref x 0) 'name)))) + (define access (lambda (x) (vector-ref x index))) + ... + (define assign + (lambda (x update) (vector-set! x index update))) + ...)))))) +\endschemedisplay + + +\section{Compatibility File\label{SECTCOMPATOTHER}} + +Current versions of {\ChezScheme} are distributed with a compatibility +file containing definitions of various syntactic forms and procedures +supported by earlier versions of {\ChezScheme} for which support has +since been dropped. +This file, \scheme{compat.ss}, is typically installed in the library +subdirectory of the {\ChezScheme} installation directory. + +In some cases, the forms and procedures found in \scheme{compat.ss} +have been dropped because they were infrequently used and easily +written directly in Scheme. +In other cases, the forms and procedures have been rendered obsolete by +improvements in the system. +In such cases, new code should be written to use the newer features, +and older code should be rewritten if possible to use the newer +features as well. diff --git a/csug/contents.stex b/csug/contents.stex new file mode 100644 index 0000000..b26d109 --- /dev/null +++ b/csug/contents.stex @@ -0,0 +1,25 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\iflatex +\begingroup +\baselineskip=15pt plus 1pt +\normalbaselineskip=\baselineskip +\renewcommand{\baselinestretch}{1.5} +\tableofcontents +\endgroup +\fi + +\ifhtml +\begin{contents} +\fi diff --git a/csug/control.stex b/csug/control.stex new file mode 100644 index 0000000..b0ab7d7 --- /dev/null +++ b/csug/control.stex @@ -0,0 +1,662 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Control Structures\label{CHPTCONTROL}} + +This chapter describes {\ChezScheme} extensions to the set of standard +control structures. +See Chapter~\ref{TSPL:CHPTCONTROL} of {\TSPLFOUR} or the Revised$^6$ Report +on Scheme for a description of standard control structures. + + +\section{Conditionals} + +%---------------------------------------------------------------------------- +\entryheader +\formdef{exclusive-cond}{\categorysyntax}{(exclusive-cond \var{clause_1} \var{clause_2} \dots)} +\returns see below +\listlibraries +\endentryheader + +\scheme{exclusive-cond} is a version of \scheme{cond} +(Section~\ref{TSPL:SECTCONDITIONALS} of {TSPLFOUR}) that differs +from \scheme{cond} in that the tests embedded within the clauses +are assumed to be exclusive in the sense that if one of the tests +is true, the others are not. +This allows the implementation to reorder clauses when profiling +information is available at expansion time (Section~\ref{SECTMISCPROFILE}). + +The \scheme{(\var{test})} form of clause is not supported. +The order chosen when profiling information is available is based +on the relative numbers of times the RHS of each clause is executed, +and \scheme{(\var{test})} has no RHS. +\scheme{(\var{test} => values)} is equivalent, albeit less concise. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{case}{\categorysyntax}{(case \var{expr_0} \var{clause_1} \var{clause_2} \dots)} +\returns see below +\listlibraries +\endentryheader + +\noindent +Each clause but the last must take one of the forms: + +\schemedisplay +((\var{key} \dots) \var{expr_1} \var{expr_2} \dots) +(\var{key} \var{expr_1} \var{expr_2} \dots) +\endschemedisplay + +\noindent +where each \var{key} is a datum distinct from the other keys. +The last clause may be in the above form or it may be an +\index{\scheme{else}}\scheme{else} clause of the form + +\schemedisplay +(else \var{expr_1} \var{expr_2} \dots) +\endschemedisplay + +\var{expr_0} is evaluated and the result is compared +(using \scheme{equal?}) against the keys of each clause in order. +If a clause containing a matching key is found, the +expressions \scheme{\var{expr_1} \var{expr_2} \dots} are evaluated in sequence +and the values of the last expression are returned. + +If none of the clauses contains a matching key and an \scheme{else} clause +is present, the expressions \scheme{\var{expr_1} \var{expr_2} \dots} of the +\scheme{else} clause are evaluated in sequence and the values of the last +expression are returned. + +If none of the clauses contains a matching key and no \scheme{else} clause +is present, the value or values are unspecified. + +The Revised$^6$ Report version of \scheme{case} does not support singleton +keys (the second of the first two clause forms above) and uses +\scheme{eqv?} rather than \scheme{equal?} as the comparison procedure. +Both versions are defined in terms of \scheme{exclusive-cond} so that +if profiling information is available at expansion time, the clauses will +be reordered to put those that are most frequently executed first. + +\schemedisplay +(let ([ls '(ii iv)]) + (case (car ls) + [i 1] + [ii 2] + [iii 3] + [(iiii iv) 4] + [else 'out-of-range])) ;=> 2 + +(define p + (lambda (x) + (case x + [("abc" "def") 'one] + [((a b c)) 'two] + [else #f]))) + +(p (string #\d #\e #\f)) ;=> one +(p '(a b c)) ;=> two +\endschemedisplay + + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{record-case}{\categorysyntax}{(record-case \var{expr} \var{clause_1} \var{clause_2} \dots)} +\returns see explanation +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{record-case} is a restricted form of \scheme{case} that supports the +destructuring of \index{records}\emph{records}, or \index{tagged lists}\emph{tagged lists}. +A record has as its first element a tag that determines what ``type'' +of record it is; the remaining elements are the fields of the record. + +Each clause but the last must take the form + +\schemedisplay +((\var{key} \dots) \var{formals} \var{body_1} \var{body_2} \dots) +\endschemedisplay + +\noindent +where each \var{key} is a datum distinct from the other keys. +The last clause may be in the above form or it may be an +\index{\scheme{else}}\scheme{else} clause of the form + +\schemedisplay +(else \var{body_1} \var{body_2} \dots) +\endschemedisplay + +\var{expr} must evaluate to a pair. +\var{expr} is evaluated and the car of its value is compared +(using \scheme{eqv?}) against the keys of each clause in order. +If a clause containing a matching key is found, the variables in +\var{formals} are bound to the remaining elements +of the list and the expressions +\scheme{\var{body_1} \var{body_2} \dots} are evaluated in sequence. +The value of the last expression is returned. +The effect is identical to the application of + +\schemedisplay +(lambda \var{formals} \var{body_1} \var{body_2} \dots) +\endschemedisplay + +\noindent +to the cdr of the list. + +If none of the clauses contains a matching key and an \scheme{else} clause +is present, the expressions \scheme{\var{body_1} \var{body_2} \dots} of the +\scheme{else} clause are evaluated in sequence and the value of the last +expression is returned. + +If none of the clauses contains a matching key and no \scheme{else} clause +is present, the value is unspecified. + + +\schemedisplay +(define calc + (lambda (x) + (record-case x + [(add) (x y) (+ x y)] + [(sub) (x y) (- x y)] + [(mul) (x y) (* x y)] + [(div) (x y) (/ x y)] + [else (assertion-violationf 'calc "invalid expression ~s" x)]))) + +(calc '(add 3 4)) ;=> 7 +(calc '(div 3 4)) ;=> 3/4 +\endschemedisplay + + +\section{Mapping and Folding} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{ormap}{\categoryprocedure}{(ormap \var{procedure} \var{list_1} \var{list_2} \dots)} +\returns see explanation +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{ormap} is identical to the Revised$^6$ Report \scheme{exists}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{andmap}{\categoryprocedure}{(andmap \var{procedure} \var{list_1} \var{list_2} \dots)} +\returns see explanation +\listlibraries +\endentryheader + +\noindent +\scheme{andmap} is identical to the Revised$^6$ Report \scheme{for-all}. + + +\section{Continuations} + +{\ChezScheme} supports one-shot continuations as well as the standard +multi-shot continuations obtainable via \scheme{call/cc}. +One-shot continuations are continuations that may be invoked at most +once, whether explicitly or implicitly. +They are obtained with \scheme{call/1cc}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{call/1cc}{\categoryprocedure}{(call/1cc \var{procedure})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\scheme{call/1cc} obtains its continuation and passes it to \var{procedure}, +which should accept one argument. +The continuation itself is represented by a procedure. +This procedure normally takes one argument but may take an arbitrary +number of arguments depending upon whether the context of the call +to \scheme{call/1cc} +expects multiple return values or not. +When this procedure is applied to a value or values, it returns the values +to the continuation of the \scheme{call/1cc} application. + +The continuation obtained by \scheme{call/1cc} is a +\index{one-shot continuations}``one-shot continuation.'' +A one-shot continuation should not be returned to multiple times, either +by invoking the continuation or returning normally from \var{procedure} more +than once. +A one-shot continuation is ``promoted'' into a normal (multishot) +continuation, however, if it is +still active when a +normal continuation is obtained by \scheme{call/cc}. +After a one-shot continuation is promoted into a multishot continuation, +it behaves exactly as if it had been obtained via \scheme{call/cc}. +This allows \scheme{call/cc} and \scheme{call/1cc} to be used together +transparently in many applications. + +One-shot continuations may be more efficient for some applications than +multishot continuations. +See the paper ``Representing control in the presence of one-shot +continuations''~\cite{Bruggeman:oneshots} for more information about +one-shot continuations, including how they are implemented in +{\ChezScheme}. + +The following examples highlight the similarities and differences +between one-shot and normal continuations. + +\schemedisplay +(define prod + ; compute the product of the elements of ls, bugging out + ; with no multiplications if a zero element is found + (lambda (ls) + (lambda (k) + (if (null? ls) + 1 + (if (= (car ls) 0) + (k 0) + (* (car ls) ((prod (cdr ls)) k))))))) + +(call/cc (prod '(1 2 3 4))) ;=> 24 +(call/1cc (prod '(1 2 3 4))) ;=> 24 + +(call/cc (prod '(1 2 3 4 0))) ;=> 0 +(call/1cc (prod '(1 2 3 4 0))) ;=> 0 + +(let ([k (call/cc (lambda (x) x))]) + (k (lambda (x) 0))) ;=> 0 + +(let ([k (call/1cc (lambda (x) x))]) + (k (lambda (x) 0))) ;=> \var{exception} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader\label{dynamic-wind} +\formdef{dynamic-wind}{\categoryprocedure}{(dynamic-wind \var{in} \var{body} \var{out})} +\formdef{dynamic-wind}{\categoryprocedure}{(dynamic-wind \var{critical?} \var{in} \var{body} \var{out})} +\returns values resulting from the application of \var{body} +\listlibraries +\endentryheader + +The first form is identical to the Revised$^6$ Report \scheme{dynamic-wind}. +When the optional \var{critical?} argument is present and non-false, +the \var{in} thunk is invoked in a critical section along with the code +that records that the body has been entered, and the \var{out} thunk is +invoked in a critical section along with the code that records +that the body has been exited. +Extreme caution must be taken with this form of \scheme{dynamic-wind}, +since an error or long-running computation can leave interrupts +and automatic garbage collection disabled. + +\section{Engines\label{SECTENGINES}} + +\index{engines}Engines are a high-level process abstraction supporting +\index{timed preemption}\emph{timed preemption}~\cite{Dybvig:engines,Haynes:abstracting}. +Engines may be used to simulate \index{multiprocessing}multiprocessing, implement operating +system kernels, and perform \index{nondeterministic computations}nondeterministic computations. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-engine}{\categoryprocedure}{(make-engine \var{thunk})} +\returns an engine +\listlibraries +\endentryheader + +An engine is created by passing a thunk (no argument procedure) +to \scheme{make-engine}. +The body of the thunk is the computation to be performed by the engine. +An engine itself is a procedure of three arguments: + +\begin{description} +\item[\var{ticks}:] +\index{ticks@\var{ticks}|see{engines}}a positive integer that specifies +the amount of \emph{fuel} to be given +to the engine. +An engine executes until this fuel runs out or until its computation +finishes. + +\item[\var{complete}:] +\index{complete@\var{complete}|see{engines}}a procedure of one or more +arguments that +specifies what to do if the computation finishes. +Its arguments are the amount of fuel left over and the +values produced by the computation. + +\item[\var{expire}:] +\index{expire@\var{expire}|see{engines}}a procedure of one argument that +specifies what to do if the fuel runs +out before the computation finishes. +Its argument is a new engine capable of continuing the computation +from the point of interruption. +\end{description} + +When an engine is applied to its arguments, it sets up a timer +to fire in \var{ticks} time units. +(See \scheme{set-timer} on page~\pageref{desc:set-timer}.) +If the engine computation completes before the timer expires, the +system invokes \var{complete}, passing +it the number of \var{ticks} left over and +the values produced by the computation. +If, on the other hand, the timer goes off before the engine computation +completes, the system creates a new engine from the continuation of +the interrupted computation and passes this engine to \var{expire}. +\var{complete} and \var{expire} are invoked in the continuation +of the engine invocation. + +An implementation of engines is given +in Section~\ref{TSPL:SECTEXENGINES}. +of {\TSPLFOUR}. + +Do not use the timer interrupt (see \index{\scheme{set-timer}}\scheme{set-timer}) and \index{engines}engines +at the same time, since engines are implemented in terms of the timer. + +The following example creates an engine from a trivial computation, +3, and gives the engine 10 ticks. + +\schemedisplay +(define eng + (make-engine + (lambda () 3))) + +(eng 10 + (lambda (ticks value) value) + (lambda (x) x)) ;=> 3 +\endschemedisplay + +It is often useful to pass \scheme{list} as the \var{complete} +procedure to an engine, causing an engine that completes to return a +list whose first element is the ticks remaining and whose remaining elements +are the values returned by the computation. + +\schemedisplay +(define eng + (make-engine + (lambda () 3))) + +(eng 10 + list + (lambda (x) x)) ;=> (9 3) +\endschemedisplay + +\noindent +In the example above, the value is 3 and there are 9 ticks left over, +i.e., it takes one unit of fuel to evaluate 3. +(The fuel amounts given here are for illustration only. +Your mileage may vary.) + +Typically, the engine computation does not finish in one try. +\index{\scheme{fibonacci}}The following example displays the use of an engine to +compute the 10th Fibonacci number in steps. + +\schemedisplay +(define fibonacci + (lambda (n) + (let fib ([i n]) + (cond + [(= i 0) 0] + [(= i 1) 1] + [else (+ (fib (- i 1)) + (fib (- i 2)))])))) + +(define eng + (make-engine + (lambda () + (fibonacci 10)))) + +(eng 50 + list + (lambda (new-eng) + (set! eng new-eng) + "expired")) ;=> "expired" + +(eng 50 + list + (lambda (new-eng) + (set! eng new-eng) + "expired")) ;=> "expired" + +(eng 50 + list + (lambda (new-eng) + (set! eng new-eng) + "expired")) ;=> "expired" + +(eng 50 + list + (lambda (new-eng) + (set! eng new-eng) + "expired")) ;=> (21 55) +\endschemedisplay + +\noindent +Each time the engine's fuel runs out, the \var{expire} procedure assigns +\scheme{eng} to the new engine. +The entire computation requires four blocks of 50 ticks to complete; of the +last 50 it uses all but 21. +Thus, the total amount of fuel used is 179 ticks. +This leads to the following procedure, \scheme{mileage}, which ``times'' a +computation using engines: + +\schemedisplay +(define mileage + (lambda (thunk) + (let loop ([eng (make-engine thunk)] [total-ticks 0]) + (eng 50 + (lambda (ticks . values) + (+ total-ticks (- 50 ticks))) + (lambda (new-eng) + (loop new-eng + (+ total-ticks 50))))))) + +(mileage (lambda () (fibonacci 10))) ;=> 179 +\endschemedisplay + +\noindent +The choice of 50 for the number of ticks to use each time is +arbitrary, of course. +It might make more sense to pass a much larger number, say 10000, +in order to reduce the number of times the computation is interrupted. + +The next procedure is similar to \scheme{mileage}, but it returns a list +of engines, one for each tick it takes to complete the computation. +Each of the engines in the list represents a ``snapshot'' of the +computation, analogous to a single frame of a moving picture. +\scheme{snapshot} might be useful for ``single stepping'' a computation. + +\schemedisplay +(define snapshot + (lambda (thunk) + (let again ([eng (make-engine thunk)]) + (cons eng + (eng 1 (lambda (t . v) '()) again))))) +\endschemedisplay + +\noindent +The recursion embedded in this procedure is rather strange. +The complete procedure performs the base case, returning the empty +list, and the expire procedure performs the recursion. + +The next procedure, \index{\scheme{round-robin}}\scheme{round-robin}, could be the basis for a simple +time-sharing \index{operating system}operating system. +\scheme{round-robin} maintains a queue of processes (a list of engines), +cycling through the queue in a \emph{round-robin} fashion, allowing each +process to run for a set amount of time. +\scheme{round-robin} returns a list of the values returned by the engine +computations in the order that the computations complete. +Each computation is assumed to produce exactly one value. + +\schemedisplay +(define round-robin + (lambda (engs) + (if (null? engs) + '() + ((car engs) + 1 + (lambda (ticks value) + (cons value (round-robin (cdr engs)))) + (lambda (eng) + (round-robin + (append (cdr engs) (list eng)))))))) +\endschemedisplay + +\noindent +Since the amount of fuel supplied each time, one tick, is constant, +the effect of \scheme{round-robin} is to return a list of the values sorted +from the quickest to complete to the slowest to complete. +Thus, when we call \scheme{round-robin} on a list of engines, each computing +one of the Fibonacci numbers, the output list is sorted with the earlier +Fibonacci numbers first, regardless of the order of the input list. + +\schemedisplay +(round-robin + (map (lambda (x) + (make-engine + (lambda () + (fibonacci x)))) + '(4 5 2 8 3 7 6 2))) ;=> (1 1 2 3 5 8 13 21) +\endschemedisplay + +More interesting things can happen if the amount of fuel varies +each time through the loop. +\index{nondeterministic computations}In this case, the computation would +be nondeterministic, i.e., the results would vary from call to call. + +The following syntactic form, \index{\scheme{por} (parallel-or)}\scheme{por} (parallel-or), returns the +first of its expressions to complete with a true value. +\scheme{por} is implemented with the procedure \scheme{first-true}, which is +similar to \scheme{round-robin} but quits when any of the engines +completes with a true value. +If all of the engines complete, but none with a true value, +\scheme{first-true} (and hence \scheme{por}) returns \scheme{#f}. +Also, although \scheme{first-true} passes a fixed amount of fuel to each +engine, it chooses the next engine to run at random, and is thus +nondeterministic. + +\schemedisplay +(define-syntax por + (syntax-rules () + [(_ x ...) + (first-true + (list (make-engine (lambda () x)) ...))])) + +(define first-true + (let ([pick + (lambda (ls) + (list-ref ls (random (length ls))))]) + (lambda (engs) + (if (null? engs) + #f + (let ([eng (pick engs)]) + (eng 1 + (lambda (ticks value) + (or value + (first-true + (remq eng engs)))) + (lambda (new-eng) + (first-true + (cons new-eng + (remq eng engs)))))))))) +\endschemedisplay + +\noindent +The list of engines is maintained with \scheme{pick}, which randomly +chooses an element of the list, and \scheme{remq}, which removes the +chosen engine from the list. +Since \scheme{por} is nondeterministic, subsequent uses with the same +expressions may not return the same values. + +\schemedisplay +(por 1 2 3) ;=> 2 +(por 1 2 3) ;=> 3 +(por 1 2 3) ;=> 2 +(por 1 2 3) ;=> 1 +\endschemedisplay + +\noindent +Furthermore, even if one of the expressions is an infinite loop, +\scheme{por} still finishes as long as one of the other expressions +completes and returns a true value. + +\schemedisplay +(por (let loop () (loop)) 2) ;=> 2 +\endschemedisplay + +\noindent +With \scheme{engine-return} and \scheme{engine-block}, it is possible to +terminate an engine explicitly. +\scheme{engine-return} causes the engine to complete, as if the +computation had finished. +Its arguments are passed to the \var{complete} procedure along with the +number of ticks remaining. +It is essentially a nonlocal exit from the engine. +Similarly, \scheme{engine-block} causes the engine to expire, as if the +timer had run out. +A new engine is made from the continuation of the call to \scheme{engine-block} +and passed to the \var{expire} procedure. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{engine-block}{\categoryprocedure}{(engine-block)} +\returns does not return +\listlibraries +\endentryheader + +\noindent +This causes a running engine to stop, create a new engine capable +of continuing the computation, and pass the new engine to the original +engine's third argument +(the expire procedure). +Any remaining fuel is forfeited. + +\schemedisplay +(define eng + (make-engine + (lambda () + (engine-block) + "completed"))) + +(eng 100 + (lambda (ticks value) value) + (lambda (x) + (set! eng x) + "expired")) ;=> "expired" + +(eng 100 + (lambda (ticks value) value) + (lambda (x) + (set! eng x) + "expired")) ;=> "completed" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{engine-return}{\categoryprocedure}{(engine-return \var{obj} \dots)} +\returns does not return +\listlibraries +\endentryheader + +\noindent +This causes a running engine to stop and pass control to the +engine's \var{complete} argument. +The first argument passed to the complete procedure is the amount of +fuel remaining, as usual, and +the remaining arguments are the objects \scheme{\var{obj} \dots} +passed to \scheme{engine-return}. + +\schemedisplay +(define eng + (make-engine + (lambda () + (reverse (engine-return 'a 'b 'c))))) + +(eng 100 + (lambda (ticks . values) values) + (lambda (new-eng) "expired")) ;=> (a b c) +\endschemedisplay diff --git a/csug/copyright.stex b/csug/copyright.stex new file mode 100644 index 0000000..ce703df --- /dev/null +++ b/csug/copyright.stex @@ -0,0 +1,37 @@ +% Copyright 2005-2018 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\iflatex +\thispagestyle{empty} + +\centerline{}\vfill + +\textbf{\copyright~2022 Cisco Systems, Inc.} + +Licensed under the Apache License Version 2.0\\ +http://www.apache.org/licenses/LICENSE-2.0 + +% NB: also update corresponding notice in csug.stex +Revised \revisiondate~for Chez Scheme Version 9.5.9. + +\medskip\noindent +Cisco and the Cisco logo are trademarks or registered trademarks +of Cisco and/or its affiliates in the U.S. and other countries. To +view a list of Cisco trademarks, go to this URL: +http://www.cisco.com/go/trademarks. Third-party trademarks mentioned +are the property of their respective owners. The use of the word +partner does not imply a partnership relationship between Cisco and +any other company. (1110R) + +\vspace{1in}\break +\fi diff --git a/csug/csug.bib b/csug/csug.bib new file mode 100644 index 0000000..3e3d5b7 --- /dev/null +++ b/csug/csug.bib @@ -0,0 +1,568 @@ +@string{p:popl83 = {Conference Record of the Tenth Annual {ACM} Symposium + on Principles of Programming Languages}} +@string{p:popl87 = {Conference Record of the Fourteenth Annual {ACM} Symposium + on Principles of Programming Languages}} +@string{p:popl88 = {Conference Record of the Fifteenth Annual {ACM} Symposium + on Principles of Programming Languages}} +@string{p:popl90 = {Conference Record of the Seventeenth Annual {ACM} Symposium + on Principles of Programming Languages}} +@string{p:popl91 = {Conference Record of the Eighteenth Annual {ACM} Symposium + on Principles of Programming Languages}} +@string{p:popl99 = {Conference Record of the 26th Annual {ACM} Symposium + on Principles of Programming Languages}} + +@string{p:ppopp90 = {Proceedings of the Second {ACM} {SIGPLAN} Symposium + on Principles and Practice of Parallel Programming}} + +@string{p:sigplan86 = {Proceedings of the {SIGPLAN} '86 Symposium + on Compiler Construction}} +@string{p:sigplan87 = {Proceedings of the {SIGPLAN} '87 Symposium + on Interpreters and Interpretive Techniques}} +@string{p:pldi88 = {Proceedings of the {SIGPLAN} '88 Conference + on Programming Language Design and Implementation}} +@string{p:pldi90 = {Proceedings of the {SIGPLAN} '90 Conference + on Programming Language Design and Implementation}} +@string{p:pldi93 = {Proceedings of the {SIGPLAN} '93 Conference + on Programming Language Design and Implementation}} +@string{p:pldi95 = "Proceedings of the ACM SIGPLAN '95 Conference on + Programming Language Design and Implementation"} +@string{p:pldi96 = {Proceedings of the {SIGPLAN} '96 Conference + on Programming Language Design and Implementation}} + +@string{p:iccl98 = {Proceedings of the {IEEE Computer Society} +1998 International Conference on Computer Languages}} + +@string{p:sehld83 = {Proceedings of the {ACM} Software Engineering Symposium + on High-Level Debugging}} + +@string{p:lisp80 = {Conference Record of the 1980 {Lisp} Conference}} +@string{p:lfp84 = {Proceedings of the 1984 {ACM} Conference on {Lisp} + and Functional Programming}} +@string{p:lfp86 = {Proceedings of the 1986 {ACM} Conference on {Lisp} + and Functional Programming}} +@string{p:lfp88 = {Proceedings of the 1988 {ACM} Conference on {Lisp} + and Functional Programming}} +@string{p:lfp90 = {Proceedings of the 1990 {ACM} Conference on {Lisp} + and Functional Programming}} +@string{p:lfp94 = {Proceedings of the 1994 {ACM} Conference on {Lisp} + and Functional Programming}} + +@string{p:lics86 = {Proceedings of the Symposium on Logic in Computer Science}} +@string{p:lics88 = {Proceedings of the Third Symposium on Logic + in Computer Science}} + +@string{j:cacm = {Communications of the {ACM}}} +@string{j:acm = {Journal of the {ACM}}} +@string{j:ipl = {Information Processing Letters}} +@string{j:cl = {Computer Languages}} +@string{j:lasc = {{Lisp} and Symbolic Computation}} +@string{j:hasc = {{Higher Order} and Symbolic Computation}} +@string{j:sn = {{SIGPLAN} Notices}} +@string{j:lp = {{LISP} Pointers}} +@string{j:tcs = {Theoretical Computer Science}} +@string{j:toplas = {{ACM} Transactions on Programming Languages and Systems}} + +@string{elsevier = {Elsevier Science Publishers}} +@string{iucs = {Indiana Computer Science Department}} + +@string{LNCS = {Springer-Verlag Lecture Notes in Computer Science}} + +@techreport{Sussman:scheme, +author = {Gerald J. Sussman and Guy L. {Steele Jr.}}, +title = {{Scheme}: An Interpreter for Extended Lambda Calculus}, +year = 1975, +month = may, +number = 349, +type = {MIT AI Memo}, +institution = {Massachusetts Institute of Technology}} + +@techreport{Steele:scheme, + author = {Guy L. {Steele Jr.} and Gerald J. Sussman}, + title = {The Revised Report on {Scheme}, a Dialect of {Lisp}}, + year = 1978, + month = jan, + number = 452, + type = {MIT AI Memo}, + institution = {Massachusetts Institute of Technology}} + +@book{Manis:schematics, +author = {Vincent S. Manis and James J. Little}, +title = {The Schematics of Computation}, +year = 1995, +publisher = {Prentice Hall}} + +@book{Springer:sap, +author = {George Springer and Daniel P. Friedman}, +title = {Scheme and the Art of Programming}, +year = 1989, +publisher = {MIT Press and McGraw-Hill}} + +@book{Friedman:lisper, +author = {Daniel P. Friedman and Matthias Felleisen}, +title = {The Little Schemer}, +year = 1996, +edition = {fourth}, +publisher = {MIT Press}} + +@book{Abelson:sicp1ed, +author = {Harold Abelson and Gerald J. Sussman with Julie Sussman}, +title = {Structure and Interpretation of Computer Programs}, +edition = {first}, +year = 1985, +publisher = {MIT Press and McGraw-Hill}} + +@book{Abelson:sicp, +author = {Harold Abelson and Gerald J. Sussman with Julie Sussman}, +title = {Structure and Interpretation of Computer Programs}, +year = 1996, +edition = {second}, +publisher = {MIT Press and McGraw-Hill}} + +@book{Steele:common, +author = {Guy L. {Steele Jr.}}, +title = {{Common} {Lisp}, the Language}, +publisher = {Digital Press}, +edition = {second}, +year = 1990} + +@article{Clinger:revised, +author = {William Clinger and + Jonathan Rees and + others}, +title = {The Revised$^4$ Report on the Algorithmic Language {Scheme}}, +journal = j:lp, +volume = 4, +number = 3, +year = 1991} + +@article{Kelsey:r5rs, +author = {Richard Kelsey and William Clinger and + Jonathan Rees and + others}, +title = {The Revised$^5$ Report on the Algorithmic Language {Scheme}}, +journal = j:hasc, +volume = 11, +number = 1, +year = 1999} + +@article{Dybvig:engines, +author = {R. Kent Dybvig and Robert Hieb}, +title = {Engines from Continuations}, +journal = j:cl, +volume = 14, +number = 2, +pages = {109--123}, +year = 1989} + +@article{Haynes:obtaining, +author = {Christopher T. Haynes and Daniel P. Friedman and Mitchell Wand}, +title = {Obtaining Coroutines with Continuations}, +journal = j:cl, +volume = 11, +number = {3/4}, +pages = {143--153}, +year = 1986} + +@article{Haynes:abstracting, +author = {Christopher T. Haynes and Daniel P. Friedman}, +title = {Abstracting Timed Preemption with Engines}, +journal = j:cl, +volume = 12, +number = 2, +pages = {109--121}, +year = 1987} + +@inproceedings{Hieb:representing, +author = {Robert Hieb and + R. Kent Dybvig and + Carl Bruggeman}, +title = {Representing Control in the Presence of First-class Continuations}, +booktitle = p:pldi90, +pages = {66--77}, +month = jun, +year = 1990} + +@inproceedings{Bruggeman:oneshots, +author = {Carl Bruggeman and Oscar Waddell and R. Kent Dybvig}, +title = {Representing Control in the Presence of One-Shot Continuations}, +booktitle = p:pldi96, +pages = {99--107}, +month = may, +year = 1996 +} + +@manual{IEEE:1178, +title = {{IEEE} Standard for the {Scheme} Programming Language}, +note = {IEEE Std 1178-1990}, +organization = {{IEEE} Computer Society}, +month = may, +year = 1991} + +@book{Kernighan:c, +author = {Brian W. Kernighan and Dennis M. Ritchie}, +title = {The {C} Programming Language}, +edition = {second}, +publisher = {Prentice Hall}, +year = 1988} + +@article{Naur:revised, +author = {Peter Naur and others}, +title = {Revised Report on the Algorithmic Language {ALGOL} 60}, +journal = j:cacm, +volume = 6, +number = 1, +pages = {1--17}, +month = jan, +year = 1963} + +@inproceedings{Daniel:prolog-fft, +author = {Sam M. Daniel}, +title = {Efficient recursive {FFT} implementation in {Prolog}}, +booktitle = {Proceedings of the Second +International Conference on the Practical Application of Prolog}, +pages = {175--185}, +year = 1994} + +@inproceedings{Wand:continuation-based, +author = {Mitchell Wand}, +title = {Continuation-Based Multiprocessing}, +booktitle = p:lisp80, +month = aug, +pages = {19--28}, +year = 1980} + +@article{Robinson:unification, +author = {J. A. Robinson}, +title = {A Machine-Oriented Logic based on the Resolution Principle}, +journal = j:acm, +volume = 12, +number = 1, +pages = {23--41}, +year = 1965} + +@techreport{Plaisted:sets, +author = {David A. Plaisted}, +title = {Constructs for Sets, Quantifiers, and Rewrite Rules in {Lisp}}, +year = 1984, +month = jun, +number = {UIUCDCS-R-84-1176}, +institution = {University of Illinois at Urbana-Champaign Department +of Computer Science}} + +@book{Clocksin:prolog, +author = {William F. Clocksin and Christopher S. Mellish}, +title = {Programming in {Prolog}}, +publisher = {Springer-Verlag}, +edition = {second}, +year = 1984} + +@incollection(Friedman:devils, +author = {Daniel P. Friedman and Christopher T. Haynes + and Eugene E. Kohlbecker}, +title = {Programming with Continuations}, +year = 1984, +booktitle = {Program Transformation and Programming Environments}, +editor = {P. Pepper}, +publisher = {Springer-Verlag}, +pages = {263--274}) + +@article{Naur:algol, +author = {Peter Naur and others}, +title = {Revised Report on the Algorithmic Language {ALGOL} 60}, +journal = j:cacm, +volume = 6, +number = 1, +pages = {1--17}, +month = jan, +year = 1963} + +@inproceedings{Dybvig:guardians, +author = {R. Kent Dybvig and Carl Bruggeman and David Eby}, +title = {Guardians in a generation-based garbage collector}, +booktitle = p:pldi93, +pages = "207-216", +month = jun, +year = 1993} + +@article{Dybvig:lambdastar, +author = {R. Kent Dybvig and Robert Hieb}, +title = {A New Approach to Procedures with Variable Arity}, +journal = j:lasc, +volume = 3, +number = 3, +pages = {229--244}, +month = sep, +year = 1990} + +@article{Dybvig:syntactic, +author = {R. Kent Dybvig and Robert Hieb and Carl Bruggeman}, +title = {Syntactic Abstraction in {Scheme}}, +journal = j:lasc, +volume = 5, +number = 4, +pages = {295--326}, +year = 1993} + +@inproceedings{Ashley:mvalues, +author = {J. Michael Ashley and R. Kent Dybvig}, +title = {An efficient implementation of multiple return values in {Scheme}}, +booktitle = p:lfp94, +pages = {140-149}, +month = jun, +year = 1994} + +@manual{Dybvig:cssm, +author = {R. Kent Dybvig}, +title = {{Chez Scheme} System Manual, Rev. 3.0}, +organization = {Cadence Research Systems}, +address = {Bloomington, Indiana}, +month = "December", +year = 1995} + +@Book{Briggs:dft, + author = "William Briggs and Van Emden Henson", + title = "The {DFT}: {An} Owner's Manual for the Discrete Fourier Transform", + publisher = "Society for Industrial and Applied Mathematics", + year = "1995", + address = "Philadelphia"} + +@book{Dybvig:tspl4, +author = {R. Kent Dybvig}, +title = {The Scheme Programming Language}, +year = 2009, +edition = {4th}, +publisher = {MIT Press}} + +@phdthesis{Kohlbecker:phd, +author = {Eugene Kohlbecker}, +title = {Syntactic Extensions in the Programming Language {Lisp}}, +school = {Indiana University}, +address = {Bloomington}, +month = aug, +year = 1986} + +@article{Dybvig:expansion:jour, +author = {R. Kent Dybvig and Daniel P. Friedman and Christopher T. Haynes}, +title = {Expansion-Passing Style: A General Macro Mechanism}, +journal = j:lasc, +volume = 1, +number = 1, +pages = {53--75}, +year = 1988} + +@techreport{Dybvig:destination, +author = {R. Kent Dybvig and Robert Hieb and Tom Butler}, +title = {Destination-driven code generation}, +institution = iucs, +number = 302, +month = feb, +year = 1990} + +@techreport{Dybvig:syntax-case, +author = {R. Kent Dybvig}, +title = {Writing hygienic macros in Scheme with syntax-case}, +institution = iucs, +number = 356, +month = jun, +year = 1992} + +@techreport{Dybvig:sm, +author = {R. Kent Dybvig and David Eby and Carl Bruggeman}, +title = {Don't stop the {BiBOP}: Flexible and efficient storage +management for dynamically-typed languages}, +institution = iucs, +number = 400, +month = "March", +year = 1994} + +@phdthesis{Dybvig:phd, +author = {R. Kent Dybvig}, +title = {Three Implementation Models for Scheme}, +school = {University of North Carolina}, +address = {Chapel Hill}, +month = apr, +year = 1987} + +@inproceedings{Burger:regalloc, +author = {Robert G. Burger and + Oscar Waddell and + R. Kent Dybvig}, +title = {Register Allocation Using Lazy Saves, Eager Restores, + and Greedy Shuffling}, +booktitle = p:pldi95, +pages = {130--138}, +month = jun, +year = 1995} + +@InProceedings{Burger:floatprinting, + author = "Robert G. Burger and R. Kent Dybvig", + title = "Printing Floating-Point Numbers Quickly and Accurately", + booktitle = p:pldi96, + pages = "108--116", + month = may, + year = 1996, +} + +@InProceedings{burger:pdrtc, + author = "Robert G. Burger and R. Kent Dybvig", + title = "An Infrastructure for Profile-Driven Dynamic Recompilation", + booktitle = p:iccl98, + pages = "240--251", + month = may, + year = 1998 +} + +@inproceedings{waddell:modules, + author = {Oscar Waddell and R. Kent Dybvig}, + title = {Extending the scope of syntactic abstraction}, + booktitle = p:popl99, + pages = "203--213", + month = jan, + year = 1999, +} + +@InProceedings{waddell:sas97, + author = "Oscar Waddell and R. Kent Dybvig", + title = "Fast and Effective Procedure Inlining", + booktitle = "Fourth International Symposium on Static Analysis", + year = "1997", + series = lncs, + volume = "1302", + pages = "35--52", + publisher = "Springer-Verlag" +} + +@InProceedings{bawden:pepm99, + author = {Alan Bawden}, + title = {Quasiquotation in LISP}, + booktitle = {O. Danvy, Ed., University of Aarhus, Dept. of Computer Science}, + year = {1999}, + pages = {88--99} +} + +@article{Waddell:fixing-letrec, +author = {Oscar Waddell and Dipanwita Sarkar and R. Kent Dybvig}, +title = {Fixing Letrec: A Faithful Yet Efficient Implementation of {Scheme}'s +Recursive Binding Construct}, +journal = {Higher-order and symbolic computation}, +volume = 18, +number = "3/4", +pages = {299--326}, +year = 2005, +texturl = "http://www.cs.indiana.edu/~dyb/pubs/fixing-letrec.pdf", +abstracturl = "http://www.cs.indiana.edu/~dyb/pubs/fixing-letrec-abstract.html", +biburl = "http://www.cs.indiana.edu/~dyb/pubs/fixing-letrec.bib", +annote = {Describes how Chez Scheme handles {\tt letrec} expressions + efficiently and with full enforcement of the revised + report's restriction preventing evaluation of left-hand-side + variable references and assignments before the righ-hand + sides have been evaluated.}} + +@inproceedings{Dybvig:hocs, + author = {R. Kent Dybvig}, + title = {The Development of {Chez Scheme}}, + booktitle = {Proceedings of the Eleventh {ACM SIGPLAN} International + Conference on Functional Programming}, + pages = {1--12}, + month = sep, + year = 2006, + texturl = "http://www.cs.indiana.edu/~dyb/pubs/hocs.pdf", + biburl = "http://www.cs.indiana.edu/~dyb/pubs/hocs.bib", + annote = {A brief history of Chez Scheme's development} +} + +@Misc{r6rs, + author = {Michael Sperber and R. Kent + Dybvig and Matthew Flatt and Anton van Straaten (eds.)}, + title = {Revised${}^6$ Report on the Algorithmic Language {Scheme}}, + month = "September", + year = 2007, + url = "http://www.r6rs.org/" +} + +@Misc{r6rslibs, + author = {Michael Sperber and R. Kent + Dybvig and Matthew Flatt and Anton van Straaten (eds.)}, + title = {Revised${}^6$ Report on the Algorithmic Language {Scheme}---Standard Libraries}, + month = "September", + year = 2007, + url = "http://www.r6rs.org/" +} + +@Misc{r6rsapps, + author = {Michael Sperber and R. Kent + Dybvig and Matthew Flatt and Anton van Straaten (eds.)}, + title = {Revised${}^6$ Report on the Algorithmic Language {Scheme}---Non-normative Appendices}, + month = "September", + year = 2007, + url = "http://www.r6rs.org/" +} + +@inproceedings{adams:equal, +author = {Michael Adams and R. Kent Dybvig}, +title = {Efficient Nondestructive Equality Checking for Trees and Graphs}, +booktitle = {Proceedings of the 13th {ACM SIGPLAN} International + Conference on Functional Programming}, +pages = {179--188}, +month = sep, +year = 2008} + +@inproceedings{ghuloum:eq-hash-tables, + title={Generation-friendly eq hash tables}, + author = {Abdulaziz Ghuloum and R. Kent Dybvig}, + booktitle={2007 Workshop on Scheme and Functional Programming}, + year = 2007, + url = "http://sfp2007.ift.ulaval.ca/programme.html", + pages={27--35} +} + +@inproceedings{Dybvig:mitchfest-threads, + title={A {Scheme} for native threads}, + author = {R. Kent Dybvig}, + booktitle={Symposium in Honor of Mitchell Wand}, + url = "https://web.archive.org/web/20170626072601/http://www.ccs.neu.edu/events/wand-symposium/talks/mitchfest-09-dybvig.pdf", + month = aug, + year = 2009 +} + +@inproceedings{Ghuloum:fixing-letrec, + title={Fixing letrec (reloaded)}, + author = {Abdulaziz Ghuloum and R. Kent Dybvig}, + booktitle={2009 Workshop on Scheme and Functional Programming}, + url = "http://www.schemeworkshop.org/2009/", + month = aug, + year = 2009, +} + +@inproceedings{Ghuloum:libraries, + title = {Implicit phasing for {R6RS} libraries}, + author = {Abdulaziz Ghuloum and R. Kent Dybvig}, + booktitle = {\it Proceedings of the 12th ACM SIGPLAN International + Conference on Functional Programming}, + pages = {303--314}, + url = {http://doi.acm.org/10.1145/1291220.1291197}, + year = {2007} +} + +@phdthesis{ghuloum:phd, + author = {Ghuloum, Abdulaziz}, + note = {Adviser-Dybvig, R. Kent}, + title = {Implicit phasing for library dependencies}, + year = {2008}, + isbn = {978-1-109-02767-9}, + order_no = {AAI3344623}, + publisher = {Indiana University}, + address = {Indianapolis, IN, USA}, + school = {Indiana University} +} + +@inproceedings{Hayes:ephemerons, + author = {Barry Hayes}, + title = {Ephemerons: a New Finalization Mechanism}, + booktitle = {\it Proceedings of the 12th ACM SIGPLAN + Conference on Object-Oriented Languages, Programming, Systems, + and Applications}, + pages = {176--183}, + url = {https://doi.org/10.1145/263700.263733}, + year = {1997} +} diff --git a/csug/csug.css b/csug/csug.css new file mode 100644 index 0000000..083ce26 --- /dev/null +++ b/csug/csug.css @@ -0,0 +1,35 @@ +BODY {background-color: #FFFFFF} + +a:link, a:active, a:visited { color:#005568; text-decoration:underline } +a:hover { color:white; text-decoration:underline; background:#005568 } + +a.plain:link, a.plain:active, a.plain:visited { color:#005568; text-decoration:none } +a.plain:hover { color:white; text-decoration:none; background:#005568 } + +a.toc:link, a.toc:active, a.toc:visited {font-family: sans-serif; color:#005568; text-decoration:none} +a.toc:hover {font-family: sans-serif; color:white; text-decoration:none; background:#005568} + +a.image:link, a.image:active, a.image:visited, a.image:hover { + color: #005568; + background: #FFFFFF; +} + +ul.tocchapter { list-style: none; } +ul.tocsection { list-style: circle; color: #C41230 } + +hr.copyright { width: 50% } + +input.default { background: #ffffff; color: #000000; vertical-align: middle} + +h1, h2, h3, h4 {font-family: sans-serif; color: #005568} +h1 {font-size: 2em} +h2 {margin-top: 30px; font-size: 1.5em} +h3 {margin-top: 30px; font-size: 1.17em} +h1, h2, h3, h4 {font-weight: bold} + +.title { font-family: sans-serif; font-weight: bold; font-size: 2.5em; color: #005568; white-space: nowrap} + +.formdef { color: #005568 } + +table.indent {margin-left: 20px} + diff --git a/csug/csug.stex b/csug/csug.stex new file mode 100644 index 0000000..3a33548 --- /dev/null +++ b/csug/csug.stex @@ -0,0 +1,155 @@ +% Copyright 2005-2018 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\documentclass{csug8} +\chapterpicturesfalse + +% \let\cleardoublepage=\relax\includeonly{threads} + +\usepackage{scheme} + +\schemeinit +(case-sensitive #t) +\endschemeinit + +\def\revisiondate{April 2022} + +% Just don't care about small overflows, most of the time: +\iflatex +\hfuzz=16.0pt +\fi + +\iflatex +\usepackage{graphicx} +\usepackage{color} +\definecolor{formdefcolor}{gray}{.8} +\fi + +\iflatex +\usepackage{makeidx} +% \ifdraft \usepackage{showidx} \fi +\ifdraft\setlength\overfullrule{5pt}\else\setlength\overfullrule{0pt}\fi +\tolerance=1000 +\makeindex +\fi + +% also fix Revised date and version in copyright.stex +\ifhtml +\def\copyrightnotice{\raw{
+

+Chez Scheme Version 9 User's Guide
+Copyright © 2022 Cisco Systems, Inc.
+Licensed under the Apache License Version 2.0 +(full copyright notice.).
+Revised} \revisiondate\raw{ for Chez Scheme Version 9.5.9
+about this book + +}} +\documenttitle[csug.css]{Chez Scheme Version 9 User's Guide} +\fi + + +\newcommand{\ChezScheme}{\textsl{Chez~Scheme}} +\newcommand{\PetiteChezScheme}{\textsl{Petite~Chez~Scheme}} +\newcommand{\TSPLFOUR}{\emph{The Scheme Programming Language, 4th Edition}} +\iflatex +\newcommand{\dash}{\raise.5ex\hbox to 1em{\leaders\hrule\hfil}} +\fi +\ifhtml +\newcommand{\dash}{---} +\fi + +\iflatex +\font\titlefont=cmbxsl10 at 18pt +\font\subtitlefont=cmbxsl10 at 15pt +\fi + +% \iflatex +% \setlength{\pdfpagewidth}{6in} +% \setlength{\pdfpageheight}{9in} +% \fi + + +\begin{document} + +\iflatex +\parskip=4pt +\parindent=0pt +\fi + +\frontmatter + +\ifhtml +\raw{\raw{ + + +

Chez Scheme Version 9
User's Guide
}} +\fi + +\include{title} +\include{copyright} +\include{contents} +\include{preface} +% +\mainmatter +\include{intro} +\include{use} +\include{debug} +\include{foreign} +\include{binding} +\include{control} +\include{objects} +\include{numeric} +\include{io} +\include{libraries} +\include{syntax} +\include{system} +\include{smgmt} +\include{expeditor} +\include{threads} +\include{compat} +% +\backmatter +\include{bibliography} +\include{summary} +% +\def\indexintrotext{% +This index is a unified index for this book and +\index{The Scheme Programming Language, 4th Edition@\emph{The Scheme Programming Language, 4th Edition}}\emph{The +Scheme Programming Language, 4th Edition} (TSPL4). +Page numbers prefixed by ``t'' refer the latter document. +Italicized page numbers refer to the primary description of a syntactic +form or procedure.} +% +\ifhtml +\chapter{Index} + +{\indexintrotext} + +All page numbers appearing here refer to the printed version of these +books and also serve as hypertext links to the corresponding locations +in the electronic versions of these books. + +\makeindex +\else +\begingroup\tolerance=2000 +\printindex +\endgroup +\fi +% +\ifhtml +\end{contents} +\copyrightnotice +\fi + +\end{document} diff --git a/csug/csug8.cls b/csug/csug8.cls new file mode 100644 index 0000000..0fdd1aa --- /dev/null +++ b/csug/csug8.cls @@ -0,0 +1,507 @@ +%%% csug8.cls +%%% Based on tspl4.cls +%%% Copyright (c) 1998 R, Kent Dybvig +%%% +%%% Permission is hereby granted, free of charge, to any person obtaining a +%%% copy of this software and associated documentation files (the "Software"), +%%% to deal in the Software without restriction, including without limitation +%%% the rights to use, copy, modify, merge, publish, distribute, sublicense, +%%% and/or sell copies of the Software, and to permit persons to whom the +%%% Software is furnished to do so, subject to the following conditions: +%%% +%%% The above copyright notice and this permission notice shall be included in +%%% all copies or substantial portions of the Software. +%%% +%%% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +%%% IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +%%% FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +%%% THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +%%% LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +%%% FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +%%% DEALINGS IN THE SOFTWARE. + +\NeedsTeXFormat{LaTeX2e} +\ProvidesClass{csug8}[2009/07/12 CSUG8] + +\newif\ifdropfolios\dropfoliosfalse + +\newif\if@openright +\newif\if@mainmatter \@mainmattertrue +\newif\ifchapterpictures \chapterpicturestrue +\newif\ifdraft\draftfalse +\newcommand{\@ptsize}{} + +%%% to support hypertext index entries +\def\hindex#1{\index} % ignore the label here---no links in printed version + +\newcommand{\hyperlink}[3][ref]{#3} +\newcommand{\href}[3][ref]{#3} +\newcommand{\hpageref}[3][ref]{#3} +\let\true@ref=\ref\renewcommand{\ref}[2][]{\true@ref{#2}} +\let\true@pageref=\pageref\renewcommand{\pageref}[2][]{\true@pageref{#2}} + +\newif\iflatex\latextrue +\newif\ifhtml\htmlfalse + +\newlength{\trimwidth} +\newlength{\trimheight} +\newlength{\gutterwidth} +\newlength{\edgewidth} + +% paperheight is total height of paper before trimming +% paperwidth is total width of paper before trimming +% trimwidth is amount that will be trimmed on outside (unbound) edge +% trimheight is amount that will be trimmed on both top and bottom +% gutterwidth is margin on the inside (bound) edge +% edgewidth is margin on all the outside (unbound) edges + +% text height will be paperheight - 2*trimheight - 2*edgeheight +% text width will be paperwidth - trimwidth - gutterwidth - edgewidth +% inside (bound) margin will be gutterwidth +% outside (unbound) margins will be edgewidth + +%%% options +\DeclareOption{crownquarto} +% lulu lies or their converter is broken and we shouldn't include the trim +% {\setlength\paperheight {25.235cm}% % 24.6cm + 2 * .125 +% \setlength\paperwidth {19.535cm}% % 18.9cm + .25in +% \setlength\gutterwidth{1.0in}% +% \setlength\edgewidth{1.0in}% +% \setlength\trimwidth{.25in}% +% \setlength\trimheight{.125in}} + {\setlength\paperheight {24.6cm}% + \setlength\paperwidth {18.9cm}% + \setlength\gutterwidth{1.0in}% + \setlength\edgewidth{1.0in}% + \setlength\trimwidth{0in}% + \setlength\trimheight{0in}} +\DeclareOption{tspl4size} + {\setlength\paperheight {9.25in}% + \setlength\paperwidth {7.0in}% + \setlength\gutterwidth{.875in}% % isn't this actually 1in? + \setlength\edgewidth{1.0in}% + \setlength\trimwidth{.125in}% + \setlength\trimheight{.125in}} +\DeclareOption{ninebysix} + {\setlength\paperheight {9.25in}% + \setlength\paperwidth {6.125in}% + \setlength\gutterwidth{.75in}% + \setlength\edgewidth{.75in}% + \setlength\trimwidth{.125in}% + \setlength\trimheight{.125in}} +\DeclareOption{a4paper} + {\setlength\paperheight {297mm}% + \setlength\paperwidth {210mm}} +\DeclareOption{a5paper} + {\setlength\paperheight {210mm}% + \setlength\paperwidth {148mm}} +\DeclareOption{b5paper} + {\setlength\paperheight {250mm}% + \setlength\paperwidth {176mm}} +\DeclareOption{letterpaper} + {\setlength\paperheight {11in}% + \setlength\paperwidth {8.5in}} +\DeclareOption{legalpaper} + {\setlength\paperheight {14in}% + \setlength\paperwidth {8.5in}} +\DeclareOption{executivepaper} + {\setlength\paperheight {10.5in}% + \setlength\paperwidth {7.25in}} +\DeclareOption{landscape} + {\setlength\@tempdima {\paperheight}% + \setlength\paperheight {\paperwidth}% + \setlength\paperwidth {\@tempdima}} +\DeclareOption{10pt}{\renewcommand{\@ptsize}{0}} +\DeclareOption{11pt}{\renewcommand{\@ptsize}{1}} +\DeclareOption{12pt}{\renewcommand{\@ptsize}{2}} +\DeclareOption{oneside}{\@twosidefalse \@mparswitchfalse} +\DeclareOption{twoside}{\@twosidetrue \@mparswitchtrue} +\DeclareOption{draft}{\drafttrue} +\DeclareOption{final}{\draftfalse} +\DeclareOption{titlepage} + {\ClassError{proc}{Option `titlepage' is not supported}{}} +\DeclareOption{notitlepage}{\relax} +\DeclareOption{openright}{\@openrighttrue} +\DeclareOption{openany}{\@openrightfalse} +\DeclareOption{onecolumn}{\relax} +\DeclareOption{twocolumn} + {\ClassError{proc}{Option `twocolumn' is not supported}{}} +\DeclareOption{leqno}{\input{leqno.clo}} +\DeclareOption{fleqn}{\input{fleqn.clo}} +\ExecuteOptions{crownquarto,10pt,twoside,onecolumn,final,openright} +\ProcessOptions +\input{csug81\@ptsize.clo} + +\setlength\lineskip{1\p@} +\setlength\normallineskip{1\p@} +\renewcommand{\baselinestretch}{} +% block paragraphs: +\setlength\parskip{4\p@ \@plus \p@} +\setlength\parindent{0\p@} +\@lowpenalty 51 +\@medpenalty 151 +\@highpenalty 301 +\setcounter{topnumber}{2} +\renewcommand{\topfraction}{.7} +\setcounter{bottomnumber}{1} +\renewcommand{\bottomfraction}{.3} +\setcounter{totalnumber}{3} +\renewcommand{\textfraction}{.2} +\renewcommand{\floatpagefraction}{.5} +\setcounter{dbltopnumber}{2} +\renewcommand{\dbltopfraction}{.7} +\renewcommand{\dblfloatpagefraction}{.5} + +%%% headers and footers +\if@twoside + \def\ps@headings{% + \let\@oddfoot\@empty\let\@evenfoot\@empty + \def\@evenhead{\thepage\hfil\slshape\leftmark}% + \def\@oddhead{{\slshape\rightmark}\hfil\thepage}% + \def\chaptermark##1{% + \markboth{\if@mainmatter\thechapter.\ \fi##1}% + {\if@mainmatter\thechapter.\ \fi##1}} + \def\sectionmark##1{% + \markright{\thesection.\ ##1}}} +\else + \def\ps@headings{% + \let\@oddfoot\@empty + \def\@oddhead{{\slshape\rightmark}\hfil\thepage}% + \def\chaptermark##1{% + \markright{\if@mainmatter\@chapapp\ \thechapter.\fi\ ##1}}} +\fi +\newcommand*{\chaptermark}[1]{} +\setcounter{secnumdepth}{2} % must be at least two +\newcounter {chapter} +\newcounter {section}[chapter] +\newcounter{exercise}[section] +\renewcommand{\thechapter}{\arabic{chapter}} +\renewcommand{\thesection}{\thechapter.\arabic{section}} +\renewcommand{\theexercise}{\thechapter.\arabic{section}.\arabic{exercise}} +\newcommand{\@chapapp}{\chaptername} + +%%% illustrated chapter heads +\newlength{\chframesize} +\setlength{\chframesize}{\textwidth} +\addtolength{\chframesize}{-\fboxrule} +\addtolength{\chframesize}{-\fboxrule} +\newlength{\chpicsize} +\setlength{\chpicsize}{\chframesize} +\addtolength{\chpicsize}{-6pt} +\def\chpic#1{\begingroup% + \fboxsep=3pt + \fbox{\includegraphics[height=\chpicsize]{#1}}\endgroup} +%\def\chpic#1{\begingroup% +% \fboxsep=0pt +% \vbox{\noindent% +% \fbox{\vbox{\hbox to \chframesize{\hfil\vbox to \chframesize{\vfil% +% \includegraphics{#1}\vfil}\hfil}}}}\endgroup} + +%\def\picturechapterhead#1{ +% \thispagestyle{empty} +% \null\vfill\vfill +% {\LARGE\bfseries\hbox to \textwidth{\hfil CHAPTER \thechapter}} +% \vfill} + +\def\picturechapterhead#1{ + \thispagestyle{empty} + \vbox to 6pc{\null\vfill + {\Large\hbox to \textwidth{\hfil CHAPTER \thechapter}} + \hbox to \textwidth{\leaders\hrule\hfil}} + \vskip 10pt + {\titlefont\hbox to \textwidth{\hfil#1}} + \vfill\vfill\vfill\noindent + \chpic{pic/ch\thechapter} + \par\eject + \thispagestyle{empty} + \null + \vfill + \noindent + {\it \input{pic/ch\thechapter.tex}}\par\break + \thispagestyle{empty}} + +%%% document structure +\newcommand{\frontmatter}{\cleardoublepage + \@mainmatterfalse\pagenumbering{roman}} +\newcommand{\mainmatter}{\cleardoublepage + \@mainmattertrue\pagenumbering{arabic}} +\newcommand{\backmatter}{\if@openright\cleardoublepage\else\clearpage\fi + \@mainmatterfalse} +\def\chapter#1{ + \if@openright\cleardoublepage\else\clearpage\fi + \global\@topnum\z@ + \if@mainmatter + \refstepcounter{chapter}% + \typeout{\@chapapp\space\thechapter.}% + \addcontentsline{toc}{chapter}% + {\protect\numberline{\thechapter}#1}% + \else + \addcontentsline{toc}{chapter}{#1}% + \fi + \addtocontents{lof}{\protect\addvspace{10\p@}}% + \addtocontents{lot}{\protect\addvspace{10\p@}}% + \chaptermark{#1}% + \if@mainmatter + \ifchapterpictures + \picturechapterhead{#1}% + \else + \plainchapterhead{#1}% + \fi + \else + \plainchapterhead{#1}% + \fi + \@afterindentfalse + \@afterheading} +\def\plainchapterhead#1{% + \ifdropfolios\thispagestyle{plain}\else\thispagestyle{empty}\fi% + \vspace*{50\p@}% + {\parindent \z@ \raggedright \reset@font + \interlinepenalty\@M + \if@mainmatter + \titlefont\makebox[\hsize][l]{\thechapter. #1}\par\nobreak + \else + \titlefont\makebox[\hsize][l]{#1}\par\nobreak + \fi + \vskip 40\p@ + }} +\newcommand{\section}{\@startsection{section}{1}{\z@}% + {-3.5ex \@plus -1ex \@minus -.2ex}% + {2.3ex \@plus.2ex}% + {\reset@font\Large\bfseries}} + +%%% page layout +\setlength\leftmargini {2.5em} +\setlength\leftmarginii {2.2em} +\setlength\leftmarginiii {1.87em} +\setlength\leftmarginiv {1.7em} +\setlength\leftmarginv {1em} +\setlength\leftmarginvi {1em} +\setlength\leftmargin {\leftmargini} +\setlength \labelsep {.5em} +\setlength \labelwidth{\leftmargini} +\addtolength\labelwidth{-\labelsep} +\@beginparpenalty -\@lowpenalty +\@endparpenalty -\@lowpenalty +\@itempenalty -\@lowpenalty +\renewcommand{\theenumi}{\arabic{enumi}} +\renewcommand{\theenumii}{\alph{enumii}} +\renewcommand{\theenumiii}{\roman{enumiii}} +\renewcommand{\theenumiv}{\Alph{enumiv}} +\newcommand{\labelenumi}{\theenumi.} +\newcommand{\labelenumii}{(\theenumii)} +\newcommand{\labelenumiii}{\theenumiii.} +\newcommand{\labelenumiv}{\theenumiv.} +\renewcommand{\p@enumii}{\theenumi} +\renewcommand{\p@enumiii}{\theenumi(\theenumii)} +\renewcommand{\p@enumiv}{\p@enumiii\theenumiii} +\newcommand{\labelitemi}{$\m@th\bullet$} +\newcommand{\labelitemii}{\normalfont\bfseries --} +\newcommand{\labelitemiii}{$\m@th\ast$} +\newcommand{\labelitemiv}{$\m@th\cdot$} + +\setlength\arraycolsep{5\p@} +\setlength\tabcolsep{3\p@} +\setlength\arrayrulewidth{.4\p@} +\setlength\doublerulesep{2\p@} +\setlength\tabbingsep{\labelsep} +\skip\@mpfootins = \skip\footins +\setlength\fboxsep{3\p@} +\setlength\fboxrule{.4\p@} + +\DeclareOldFontCommand{\rm}{\normalfont\rmfamily}{\mathrm} +\DeclareOldFontCommand{\sf}{\normalfont\sffamily}{\mathsf} +\DeclareOldFontCommand{\tt}{\normalfont\ttfamily}{\mathtt} +\DeclareOldFontCommand{\bf}{\normalfont\bfseries}{\mathbf} +\DeclareOldFontCommand{\it}{\normalfont\itshape}{\mathit} +\DeclareOldFontCommand{\sl}{\normalfont\slshape}{\@nomath\sl} +\DeclareOldFontCommand{\sc}{\normalfont\scshape}{\@nomath\sc} +\DeclareRobustCommand*{\cal}{\@fontswitch{\relax}{\mathcal}} +\DeclareRobustCommand*{\mit}{\@fontswitch{\relax}{\mathnormal}} + +%%% table of contents +\newcommand{\@pnumwidth}{1.55em} +\newcommand{\@tocrmarg} {2.55em} +\newcommand{\@dotsep}{4.5} +\setcounter{tocdepth}{2} +\newcommand*{\l@chapter}[2]{% + \addpenalty{-\@highpenalty}% + \vskip 3pt \@plus4\p@ + \setlength\@tempdima{1.5em}% + \begingroup + \parindent \z@ \rightskip \@pnumwidth + \parfillskip -\@pnumwidth + \leavevmode \bfseries + \advance\leftskip\@tempdima + \hskip -\leftskip + #1\nobreak\hfil \nobreak\hbox to\@pnumwidth{\hss #2}\par + \penalty\@highpenalty + \endgroup} +% \newcommand*{\l@section} {\@dottedtocline{1}{1.5em}{2.3em}} +\newcommand*{\l@section}[2]{% + \vskip \z@ \@plus2\p@ + {\leftskip 1.5em\relax \rightskip \@tocrmarg \parfillskip -\rightskip + \parindent 1.5em\relax\@afterindenttrue + \interlinepenalty\@M + \leavevmode + \@tempdima 2.3em\relax + \advance\leftskip \@tempdima \null\nobreak\hskip -\leftskip + {#1}\nobreak\hfil \nobreak\hbox to\@pnumwidth{\hss #2}\par}} +\newcommand{\tableofcontents}{% + \if@openright\cleardoublepage\else\clearpage\fi + \ifdropfolios\thispagestyle{plain}\else\thispagestyle{empty}\fi% + \global\@topnum\z@ + \chaptermark{\contentsname}% + \plainchapterhead{\contentsname}% + \@starttoc{toc}} + +%%% bibliography +\newdimen\bibindent \bibindent=1.5em +\newcommand{\newblock}{} +\newenvironment{thebibliography}[1] + {\chapter{References} + \list{\@biblabel{\arabic{enumiv}}}% + {\settowidth\labelwidth{\@biblabel{#1}}% + \leftmargin\labelwidth + \advance\leftmargin\labelsep + \usecounter{enumiv}% + \let\p@enumiv\@empty + \renewcommand{\theenumiv}{\arabic{enumiv}}}% + \renewcommand{\newblock}{\hskip .11em \@plus.33em \@minus.07em}% + \sloppy\clubpenalty4000\widowpenalty4000% + \sfcode`\.=\@m} + {\def\@noitemerr + {\@latex@warning{Empty `thebibliography' environment}}% + \endlist} + +%%% index +\newenvironment{theindex} + {\if@openright\cleardoublepage\else\clearpage\fi + \begingroup\raggedright\schemeindexsize\footnotesize + \columnseprule \z@ + \columnsep 35\p@ + \twocolumn[\plainchapterhead{\indexname}]% + \addcontentsline{toc}{chapter}{\indexname}% + \chaptermark{\indexname}% + \ifdropfolios\thispagestyle{plain}\else\thispagestyle{empty}\fi\parindent\z@ + \indexintrotext\medskip + \parskip\z@ \@plus .3\p@\relax + \let\item\@idxitem} + {\clearpage\endgroup} +\newcommand{\@idxitem} {\par\hangindent 40\p@} +\newcommand{\subitem} {\par\hangindent 40\p@ \hspace*{20\p@}} +\newcommand{\subsubitem}{\par\hangindent 40\p@ \hspace*{30\p@}} +\newcommand{\indexspace}{\par \vskip 10\p@ \@plus5\p@ \@minus3\p@\relax} + +%%% latex.ltx redefinitions +%% leave padding page blank (no header) +\def\cleardoublepage{\clearpage\if@twoside \ifodd\c@page\else + {\pagestyle{empty}\hbox{}\newpage\if@twocolumn\hbox{}\newpage\fi}\fi\fi} +%% change section headers to "1.1. foo" instead of "1.1 foo" +\def\@seccntformat#1{\csname the#1\endcsname. } +%% change numbered table of contents lines to "1.1. foo" instead of "1.1 foo" +\def\numberline#1{#1. } + +\newenvironment{description} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\descriptionlabel}} + {\endlist} +\newcommand*\descriptionlabel[1]{\hspace\labelsep #1} + +\def\itemvdots{\item[] \mbox{\vdots}} + +\def\parheader#1 {\medskip\noindent{\bf #1.}~~} + +\newenvironment{grammar} + {\begingroup + \def\orbar{\hbox to 2em{\hfil}$\vert$\hbox to .75em{\hfil}} + \def\longis{ $\longrightarrow$\hbox to .75em{\hfil}} + \penalty-100\vskip 6pt plus 1pt\parindent=0pt\interlinepenalty=5000} + {\penalty-200\vskip6pt plus 1pt\endgroup} + +\def\bar{$\vert$} +\def\ang#1{$\langle${\small\rm{}#1}$\rangle$} +\def\kstar{\raise.5ex\hbox{\scheme{*}}} +\def\kplus{\raise.5ex\hbox{\scheme{+}}} + +% for fft example in examples.stex +\def\W#1{W_{\!\!#1}} +\def\fftcases#1{\left\{\,\vcenter{\m@th\baselineskip=18pt + \ialign{$##\hfil$&\quad##\hfil\crcr#1\crcr}}\right.} + +%%% adapted from old tspl macros.tex +%%% argument #1 is the \label{anslab} inserted by tspl4-prep +\def\exercise#1{ + \vskip 9pt plus 1pt minus 1pt\refstepcounter{exercise}\noindent + {\bf Exercise \arabic{chapter}.\arabic{section}.\arabic{exercise}.#1~}} + +\newcounter{alphacount} +\def\alphalabel{\textit{\alph{alphacount}}.} +\newenvironment{alphalist} + {\begingroup\let\beforeschemedisplay=\relax\let\afterschemedisplay=\relax + \begin{list}{\alphalabel}{\usecounter{alphacount}\itemsep=0pt\parsep=0pt% + \topsep=0pt}} + {\end{list}\endgroup} + +\newdimen\formdefwidth\formdefwidth=\textwidth\advance\formdefwidth by -2.5pt +\def\entryheader{\par\penalty-200\vskip15pt plus 6pt\noskipentryheader} +\def\noskipentryheader{\vbox\bgroup\parskip=0pt + \def\formdef##1##2{\par\begingroup\fboxsep=0pt\@@line{\colorbox{formdefcolor}{\hbox to \textwidth{\strut##2\hfil{\small\bf{##1}}}}\hss}\endgroup} + \def\returns{\par\noindent{\small\bf returns:} } + \def\libraries{\par\noindent{\small\bf libraries:} }} +\def\endnoskipentryheader\par{\egroup\nobreak\vskip6pt plus 1pt\relax} +\let\endentryheader=\endnoskipentryheader +\def\categorysyntax{syntax} +\def\categoryprocedure{procedure} +\def\categorythreadparameter{thread parameter} +\def\categoryglobalparameter{global parameter} +\def\categorymodule{module} +\def\categoryftype{ftype} + +\newwrite\forms +\openout\forms=\jobname.rfm +% \formsummary{sort key}{type}{form}{label} +\def\formsummary{\begingroup\@sanitize\addsummary} +\def\addsummary#1#2#3#4{\endgroup + \edef\formhead{\write\forms}% + \edef\formentry{{"#1" \string\sfentry{#3}{#2}{\string\pageref{#4}}}}% + \expandafter\formhead\formentry} +\def\sfentry#1#2#3{\par + \hbox to \hsize{% + \hbox to 24pc{#1\ \hfil}% + \hbox to 5pc{#2\ \hfil}% + \hfil #3}} +\newenvironment{thesummary} + {\begingroup\schemesummarysize\small\bigskip + \sfentry{{\slshape Form}}{{\slshape Category}}{{\slshape Page}} + \kern3pt\hrule\kern3pt} + {\endgroup} + +\newwrite\answers +\openout\answers=\jobname.ans +\def\answer{\begingroup\@sanitize\addanswer} +\long\def\addanswer#1#2{\endgroup + \edef\anshead{\write\answers}% + \edef\ansentry{{\string\ansentry{#1}{#2}}}% + \expandafter\anshead\ansentry} +\def\theanswers{\begingroup + \long\def\ansentry##1##2{\par\vskip 9pt plus 3pt minus 1pt\noindent\textbf{Exercise~\ref{##2}.~}(page~\pageref{##2})\par\nobreak\vspace{6pt}##1} + \immediate\closeout\answers + \input \jobname.ans + \endgroup} + +%%% final set up +\newcommand{\contentsname}{Contents} +\newcommand{\bibname}{References} +\newcommand{\indexname}{Index} +\newcommand{\chaptername}{Chapter} +\newcommand{\today}{\ifcase\month\or + January\or February\or March\or April\or May\or June\or + July\or August\or September\or October\or November\or December\fi + \space\number\day, \number\year} +\setlength\columnsep{10\p@} +\setlength\columnseprule{0\p@} +\pagestyle{headings} +\pagenumbering{arabic} + +\if@twoside\else\raggedbottom\fi +\endinput diff --git a/csug/csug8.hcls b/csug/csug8.hcls new file mode 100644 index 0000000..707a84b --- /dev/null +++ b/csug/csug8.hcls @@ -0,0 +1,191 @@ +%%% csug8.hcls +%%% Based on tspl4.hcls +%%% Copyright (c) 1998 R, Kent Dybvig +%%% +%%% Permission is hereby granted, free of charge, to any person obtaining a +%%% copy of this software and associated documentation files (the "Software"), +%%% to deal in the Software without restriction, including without limitation +%%% the rights to use, copy, modify, merge, publish, distribute, sublicense, +%%% and/or sell copies of the Software, and to permit persons to whom the +%%% Software is furnished to do so, subject to the following conditions: +%%% +%%% The above copyright notice and this permission notice shall be included in +%%% all copies or substantial portions of the Software. +%%% +%%% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +%%% IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +%%% FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +%%% THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +%%% LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +%%% FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +%%% DEALINGS IN THE SOFTWARE. + +\newif\iflatex\latexfalse +\newif\ifhtml\htmltrue + +\newif\ifdraft\draftfalse % define to prevent confusion in tspl.stex + +%%% \frontmatter, \mainmatter, \backmatter +\newif\ifmainmatter \mainmattertrue +\newcommand{\frontmatter}{\mainmatterfalse} +\newcommand{\mainmatter}{\setcounter{chapter}{0}\mainmattertrue} +\newcommand{\backmatter}{\mainmatterfalse} + +\newif\ifchapterpictures\chapterpicturestrue + +% we \let\label=\nolable within toc entries to avoid inserting +% labels that belong with the labeled entity, not the toc +\def\nolabel#1{} + +%%% \chapter +\newcounter{chapter} +\def\chpic#1#2{\raw{}\\\emph{#2}} +\newcommand{\chapter}[1]{ +\endchapter +\begingroup\renewcommand{\label}[1]{}\openhtmlfile{#1}\endgroup +\ifmainmatter +\refstepcounter{chapter} +\edef\templabel{\genlab}\label{\templabel} +\ifchapterpictures + \input{hebert/new/ch\thechapter} +\fi +\raw{

}Chapter \thechapter. #1\raw{

} +\begin{divertoutput}[0] +\raw{
  • }\textbf{\hpageref[toc]{\templabel}{Chapter \thechapter. {\let\label=\nolabel #1}}} +\raw{
      } +\end{divertoutput} +\renewcommand{\endchapter}{\begin{divertoutput}[0] +\raw{

    } +\end{divertoutput} +\copyrightnotice +\closehtmlfile\renewcommand{\endchapter}{}} +\else +\edef\templabel{\genlab}\label{\templabel} +\raw{

    }#1\raw{

    } +\begin{divertoutput}[0] +\raw{
  • }\textbf{\hpageref[toc]{\templabel}{{\let\label=\nolabel #1}}}\raw{

    } +\end{divertoutput} +\renewcommand{\endchapter}{\copyrightnotice + \closehtmlfile\renewcommand{\endchapter}{}} +\fi +} +\newcommand{\endchapter}{} +\newcommand{\copyrightnotice}{} + +%%% \section +\newcounter{section}[chapter] +\renewcommand{\thesection}{\thechapter.\arabic{section}} +\newcommand{\section}[1]{ +\raw{

    }\refstepcounter{section}\edef\templabel{\genlab}% + \label{\templabel}Section \thesection. #1\raw{

    } +\begin{divertoutput}[0] +\raw{
  • }\textbf{\hpageref[toc]{\templabel}{Section \thesection. {\let\label=\nolabel #1}}} +\end{divertoutput} +} + +%%% \subsection +\newcounter{subsection}[section] +\renewcommand{\thesubsection}{\thesection.\arabic{subsection}} +\newcommand{\subsection}[1]{ +\raw{

    }Subsection \refstepcounter{subsection}\thesubsection. #1\raw{

    } +} + +%%% \exercise +\newcounter{exercise}[section] +\renewcommand{\theexercise}{\thesection.\arabic{exercise}} +\newcommand{\exercise}{ +\raw{

    }Exercise \refstepcounter{exercise}\theexercise\raw{

    } +} + +%%% alphalist +\newcounter{alphalist} +\def\alphalist{\begingroup\setcounter{alphalist}{0} + \def\endalphalistitem{}% + \renewcommand{\item}{\endalphalistitem + \def\endalphalistiem{\raw{}}% + \stepcounter{alphalist}% + \raw{}\textit{~~\alph{alphalist}}.\raw{}} + \raw{}} +\def\endalphalist{\endalphalistitem\raw{
    }\endgroup} + +%%% define our own (compact) description environment +\def\description{\begingroup + \renewcommand{\item}[1][]{\raw{
    }##1\raw{
    }}\raw{
    }} +\def\enddescription{\raw{
    }\endgroup} + + +%%% table of contents +% do \endchapter as a favor to \chapter +\newenvironment{contents} + {\raw{

    }Table of Contents\raw{

    }\raw{
      }} + {\endchapter\raw{
    }} + +%%% summary of forms +\def\sfentry#1#2#3{\raw{}#1\raw{}% + \raw{}#2\raw{}% + \raw{}#3\raw{}}% +\newenvironment{thesummary} + {\raw{}% + \raw{}% + \raw{}} + {\raw{
    FormCategoryPage
    }} + +%%% index +\newcommand{\see}[2]{\emph{see} #1} +\newenvironment{theindex} + {\begingroup\newcommand{\itemindent}{\raw{   }} + \def\indexbreak{\def\indexbreak{\raw{
    }}} + \renewcommand{\item}{\indexbreak} + \newcommand{\subitem}{\raw{
    }\itemindent} + \newcommand{\subsubitem}{\raw{
    }\itemindent\itemindent}} + {\par\endgroup} + +%%% answers +\def\answer#1#2{} +\def\ansentry#1#2{\par\bigskip\noindent\textbf{Exercise~\ref{#2}.~}(page~\pageref{#2})\\ #1} +\def\theanswers{\begingroup + \ifhtml\begingroup\def\hardspaces{}\fi + \input{\jobname.ans} + \ifhtml\endgroup\fi + \endgroup} + +%%%% TSPL/CSSM specific +\def\longcode{} +\def\noskip{} +\def\copyright{©} +\def\itemvdots{\vdots} + +\def\parheader#1 {\medskip\noindent{\bf #1.}~~} + +%%% grammar support +\newenvironment{grammar} + {\begingroup + \def\orbar{\raw{|}} + \def\longis{\raw{}$\longrightarrow$\raw{}} + \def\\{\raw{}} + \raw{
    }} + {\raw{
    }\endgroup} + +\def\bar{\raw{|}} +\def\kplus{\raw{+}} +\def\kstar{\raw{*}} +\def\ang#1{\raw{<}#1\raw{>}} + +\def\entryheader{\noskipentryheader} +\def\noskipentryheader{\def\entrybreak{\def\entrybreak{\raw{
    }}}} +\def\endentryheader{\endnoskipentryheader} +\def\endnoskipentryheader{\par} +\def\formdef#1#2{\entrybreak\raw{}{\bf #1}: #2\raw{}} +\def\formsummary#1#2#3#4{} +\def\returns{\\\textbf{returns: }} +\def\libraries{\\\textbf{libraries: }} +\def\categorysyntax{syntax} +\def\categoryprocedure{procedure} +\def\categorythreadparameter{thread parameter} +\def\categoryglobalparameter{global parameter} +\def\categorymodule{module} +\def\categoryftype{ftype} + +%%% hyperlink support +\newcommand{\hyperlink}[3][]{\raw{}#3\raw{}} + diff --git a/csug/csug810.clo b/csug/csug810.clo new file mode 100644 index 0000000..7960b83 --- /dev/null +++ b/csug/csug810.clo @@ -0,0 +1,119 @@ +\ProvidesFile{tspl10.clo}[1995/06/18 v0.1] +\renewcommand{\normalsize}{% + \@setfontsize\normalsize\@xpt{12pt plus .5pt}% + \abovedisplayskip 6\p@ \@plus.6\p@ + \abovedisplayshortskip \z@ + \belowdisplayshortskip 3\p@ \@plus.3\p@ + \belowdisplayskip \abovedisplayskip + \let\@listi\@listI} +\normalsize +\newcommand{\small}{% + \@setfontsize\small\@ixpt{11pt plus .5pt}% + \abovedisplayskip 5\p@ \@plus.5\p@ \@minus4\p@ + \abovedisplayshortskip \z@ + \belowdisplayshortskip 2.5\p@ \@plus.25\p@ + \def\@listi{\leftmargin\leftmargini + \topsep 3\p@ \@plus.3\p@ + \parsep 3\p@ \@plus.3\p@ + \itemsep \z@}% + \belowdisplayskip \abovedisplayskip +} +\newcommand{\footnotesize}{% + \@setfontsize\footnotesize\@viiipt{9.5}% + \abovedisplayskip 6\p@ \@plus2\p@ \@minus4\p@ + \abovedisplayshortskip \z@ \@plus\p@ + \belowdisplayshortskip 3\p@ \@plus\p@ \@minus2\p@ + \def\@listi{\leftmargin\leftmargini + \topsep 3\p@ \@plus.3\p@ + \parsep 3\p@ \@plus.3\p@ + \itemsep \z@}% + \belowdisplayskip \abovedisplayskip +} +\newcommand{\scriptsize}{\@setfontsize\scriptsize\@viipt\@viiipt} +\newcommand{\tiny}{\@setfontsize\tiny\@vpt\@vipt} +\newcommand{\large}{\@setfontsize\large\@xiipt{14}} +\newcommand{\Large}{\@setfontsize\Large\@xivpt{18}} +\newcommand{\LARGE}{\@setfontsize\LARGE\@xviipt{22}} +\newcommand{\huge}{\@setfontsize\huge\@xxpt{25}} +\newcommand{\Huge}{\@setfontsize\Huge\@xxvpt{30}} +\setlength\parindent{15\p@} +\setlength\headheight{12\p@} +\setlength\headsep {.25in} +\setlength\topskip {10\p@} +\setlength\footskip{.35in} +\setlength\maxdepth{.5\topskip} +\setlength\@maxdepth\maxdepth +\if@twoside % see notes on heights, widths, and margins in cls file + \setlength\oddsidemargin {\gutterwidth} + \addtolength\oddsidemargin {-1.0in} % default hoffset + \setlength\evensidemargin {\edgewidth} + \addtolength\evensidemargin {\trimwidth} + \addtolength\evensidemargin {-1.0in} % default hoffset + \setlength\textwidth {\paperwidth} + \addtolength\textwidth {-\trimwidth} + \addtolength\textwidth {-\gutterwidth} + \addtolength\textwidth {-\edgewidth} + \setlength\textheight {\paperheight} + \addtolength\textheight {-2\trimheight} + \addtolength\textheight {-2\edgewidth} +\else + \figurethisoutlaterifneeded +\fi +\ifdim \marginparwidth >2in + \setlength\marginparwidth{2in} +\fi +\@settopoint\oddsidemargin +\@settopoint\evensidemargin +\@settopoint\marginparwidth +\setlength\marginparsep{7\p@} +\setlength\marginparpush{5\p@} +\setlength\topmargin{\paperheight} +\addtolength\topmargin{-2in} +\addtolength\topmargin{-\headheight} +\addtolength\topmargin{-\headsep} +\addtolength\topmargin{-\textheight} +\addtolength\topmargin{-\footskip} % this might be wrong! +\addtolength\topmargin{-.5\topmargin} +\@settopoint\topmargin +\setlength\footnotesep{6.65\p@} +\setlength{\skip\footins}{9\p@ \@plus 4\p@ \@minus 2\p@} +\setlength\floatsep {12\p@ \@plus 2\p@ \@minus 2\p@} +\setlength\textfloatsep{20\p@ \@plus 2\p@ \@minus 4\p@} +\setlength\intextsep {12\p@ \@plus 2\p@ \@minus 2\p@} +\setlength\dblfloatsep {12\p@ \@plus 2\p@ \@minus 2\p@} +\setlength\dbltextfloatsep{20\p@ \@plus 2\p@ \@minus 4\p@} +\setlength\@fptop{0\p@ \@plus 1fil} +\setlength\@fpsep{8\p@ \@plus 2fil} +\setlength\@fpbot{0\p@ \@plus 1fil} +\setlength\@dblfptop{0\p@ \@plus 1fil} +\setlength\@dblfpsep{8\p@ \@plus 2fil} +\setlength\@dblfpbot{0\p@ \@plus 1fil} +\setlength\partopsep{2\p@ \@plus 1\p@ \@minus 1\p@} +\def\@listI{\leftmargin\leftmargini + \parsep 3\p@ \@plus.3\p@ + \topsep 3\p@ \@plus.3\p@ + \itemsep \z@} +\let\@listi\@listI +\@listi +\def\@listii {\leftmargin\leftmarginii + \labelwidth\leftmarginii + \advance\labelwidth-\labelsep + \topsep 3\p@ \@plus.3\p@ + \parsep 3\p@ \@plus.3\p@ + \itemsep \z@} +\def\@listiii{\leftmargin\leftmarginiii + \labelwidth\leftmarginiii + \advance\labelwidth-\labelsep + \topsep 2\p@ \@plus.2\p@ + \parsep 2\p@ \@plus.2\p@ + \itemsep \z@} +\def\@listiv {\leftmargin\leftmarginiv + \labelwidth\leftmarginiv + \advance\labelwidth-\labelsep} +\def\@listv {\leftmargin\leftmarginv + \labelwidth\leftmarginv + \advance\labelwidth-\labelsep} +\def\@listvi {\leftmargin\leftmarginvi + \labelwidth\leftmarginvi + \advance\labelwidth-\labelsep} +\endinput diff --git a/csug/debug.stex b/csug/debug.stex new file mode 100644 index 0000000..006b762 --- /dev/null +++ b/csug/debug.stex @@ -0,0 +1,1571 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Debugging\label{CHPTDEBUG}} + +{\ChezScheme} has several features that support debugging. +In addition to providing error messages when fully type-checked code is +run, {\ChezScheme} also permits tracing of procedure calls, interruption +of any computation, redefinition of exception and interrupt handlers, +and inspection of any object, including the continuations of exceptions and +interrupts. + +Programmers new to Scheme or {\ChezScheme}, and even more experienced +Scheme programmers, might want to consult +the tutorial ``How to Debug Chez Scheme Programs.'' +HTML and PDF versions +% of the tutorial +are available at +\hyperlink{http://www.cs.indiana.edu/chezscheme/debug/}{http://www.cs.indiana.edu/chezscheme/debug/}. + + +\section{Tracing\label{SECTDEBUGTRACING}} + +Tracing is one of the most useful mechanisms for debugging Scheme programs. +{\ChezScheme} permits any primitive or user-defined procedure to be traced. +The trace package prints the arguments and return values for each +traced procedure with a compact indentation mechanism that shows the +nesting depth of calls. +The distinction between tail calls and nontail calls is reflected +properly by an increase in indentation for nontail calls only. +For nesting depths of 10 or greater, a number in brackets is used in +place of indentation to signify nesting depth. + +This section covers the mechanisms for tracing procedures and +controlling trace output. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-lambda}{\categorysyntax}{(trace-lambda \var{name} \var{formals} \var{body_1} \var{body_2} \dots)} +\returns a traced procedure +\listlibraries +\endentryheader + +\noindent +\index{\scheme{lambda}}A \scheme{trace-lambda} expression is equivalent to a +\scheme{lambda} expression with the same formals and body +except that trace information is printed to the trace output port whenever +the procedure is invoked, using \var{name} to identify the procedure. +The trace information shows the value of the arguments passed to the +procedure and the values returned by the procedure, with indentation to +show the nesting of calls. + +The traced procedure \index{\scheme{half}}\scheme{half} defined below +returns the integer quotient of its argument and 2. + +\schemedisplay +(define half + (trace-lambda half (x) + (cond + [(zero? x) 0] + [(odd? x) (half (- x 1))] + [(even? x) (+ (half (- x 1)) 1)]))) +\endschemedisplay + +\noindent +A trace of the call \scheme{(half 5)}, which returns 2, is shown below. + +\schemedisplay +|(half 5) +|(half 4) +| (half 3) +| (half 2) +| |(half 1) +| |(half 0) +| |0 +| 1 +|2 +\endschemedisplay + +\noindent +This example highlights the proper treatment of tail and nontail calls +by the trace package. +Since \scheme{half} tail calls itself when its argument is odd, the call +\scheme{(half 4)} appears at the same level of indentation as the call +\scheme{(half 5)}. +Furthermore, since the return values of \scheme{(half 5)} and +\scheme{(half 4)} are necessarily the same, only one return value is +shown for both calls. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-case-lambda}{\categorysyntax}{(trace-case-lambda \var{name} \var{clause} \dots)} +\returns a traced procedure +\listlibraries +\endentryheader + +\noindent +\index{\scheme{case-lambda}}A \scheme{trace-case-lambda} expression is +equivalent to a \scheme{case-lambda} expression with the same clauses +except that trace information is printed to the trace output port whenever +the procedure is invoked, using \var{name} to identify the procedure. +The trace information shows the value of the arguments passed to the +procedure and the values returned by the procedure, with indentation to +show the nesting of calls. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-let}{\categorysyntax}{(trace-let \var{name} ((\var{var} \var{expr}) \dots) \var{body_1} \var{body_2} \dots)} +\returns the values of the body \scheme{\var{body_1} \var{body_2} \dots} +\listlibraries +\endentryheader + +\noindent +\index{\scheme{let}}A \scheme{trace-let} expression is equivalent to a +named \scheme{let} expression with the same name, bindings, and body +except that trace information is printed to the trace output port on +entry or reentry (via invocation of the procedure bound to \scheme{name}) +into the \scheme{trace-let} expression. + +A \scheme{trace-let} expression of the form + +\schemedisplay +(trace-let \var{name} ([\var{var} \var{expr}] \dots) + \var{body_1} \var{body_2} \dots) +\endschemedisplay + +\noindent +can be rewritten in terms of \scheme{trace-lambda} as follows: + +\schemedisplay +((letrec ([\var{name} + (trace-lambda \var{name} (\var{var} \dots) + \var{body_1} \var{body_2} \dots)]) + \var{name}) + \var{expr} \dots) +\endschemedisplay + +\noindent +\scheme{trace-let} may be used to trace ordinary \scheme{let} expressions +as well as \scheme{let} expressions as long as the name inserted along +with the \scheme{trace-let} keyword in place of \scheme{let} does not +appear free within the body of the \scheme{let} expression. +It is also sometimes useful to insert a \scheme{trace-let} expression +into a program simply to display the value of an arbitrary expression +at the current trace indentation. +For example, a call to the following variant of \scheme{half} + +\schemedisplay +(define half + (trace-lambda half (x) + (cond + [(zero? x) 0] + [(odd? x) (half (trace-let decr-value () (- x 1)))] + [(even? x) (+ (half (- x 1)) 1)]))) +\endschemedisplay + +\noindent +with argument 5 results in the trace: + +\schemedisplay +|(half 5) +| (decr-value) +| 4 +|(half 4) +| (half 3) +| |(decr-value) +| |2 +| (half 2) +| |(half 1) +| | (decr-value) +| | 0 +| |(half 0) +| 1 +|2 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-do}{\categorysyntax}{(trace-do ((\var{var} \var{init} \var{update}) \dots) (\var{test} \var{result} \dots) \var{expr} \dots)} +\returns the values of the last \var{result} expression +\listlibraries +\endentryheader + +\noindent +\index{\scheme{do}}A \scheme{trace-do} expression is equivalent to a +\scheme{do} expression with the same subforms, +except that trace information is printed to the trace output port, +showing the values of \scheme{\var{var} \dots} and each iteration and +the final value of the loop on termination. +For example, the expression + +\schemedisplay +(trace-do ([old '(a b c) (cdr old)] + [new '() (cons (car old) new)]) + ((null? old) new)) +\endschemedisplay + +produces the trace + +\schemedisplay +|(do (a b c) ()) +|(do (b c) (a)) +|(do (c) (b a)) +|(do () (c b a)) +|(c b a) +\endschemedisplay + +and returns \scheme{(c b a)}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace}{\categorysyntax}{(trace \var{var_1} \var{var_2} \dots)} +\returns a list of \scheme{\var{var_1} \var{var_2} \dots} +\formdef{trace}{\categorysyntax}{(trace)} +\returns a list of all currently traced top-level variables +\listlibraries +\endentryheader + +\noindent +In the first form, \scheme{trace} reassigns the top-level values of +\scheme{\var{var_1} \var{var_2} \dots}, whose values must be procedures, +to equivalent procedures that display trace information in the manner +of \scheme{trace-lambda}. + +\scheme{trace} works by encapsulating the old value of each var in a +traced procedure. +It could be defined approximately as follows. (The actual version +records and returns information about traced variables.) + +\schemedisplay +(define-syntax trace + (syntax-rules () + [(_ var ...) + (begin + (set-top-level-value! 'var + (let ([p (top-level-value 'var)]) + (trace-lambda var args (apply p args)))) + ...)])) +\endschemedisplay + +Tracing for a procedure traced in this manner may be disabled via +\scheme{untrace} (see below), an assignment of the corresponding +variable to a different, untraced value, or a subsequent use of +\scheme{trace} for the same variable. +Because the value is traced and not the binding, however, a traced +value obtained before tracing is disabled and retained after tracing is +disabled will remain traced. + +\scheme{trace} without subexpressions evaluates to a list of all +currently traced variables. +A variable is currently traced if it has been traced and +not subsequently untraced or assigned to a different value. + +The following transcript demonstrates the use of \scheme{trace} in +an interactive session. + +\schemedisplay +> (define half + (lambda (x) + (cond + [(zero? x) 0] + [(odd? x) (half (- x 1))] + [(even? x) (+ (half (- x 1)) 1)]))) +> (half 5) +2 +> (trace half) +(half) +> (half 5) +|(half 5) +|(half 4) +| (half 3) +| (half 2) +| |(half 1) +| |(half 0) +| |0 +| 1 +|2 +2 +> (define traced-half half) +> (untrace half) +(half) +> (half 2) +1 +> (traced-half 2) +|(half 2) +|1 +1 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{untrace}{\categorysyntax}{(untrace \var{var_1} \var{var_2} \dots)} +\formdef{untrace}{\categorysyntax}{(untrace)} +\returns a list of untraced variables +\listlibraries +\endentryheader + +\noindent +\scheme{untrace} restores the original (pre-\scheme{trace}) top-level values +of each currently traced variable in +\scheme{\var{var_1} \var{var_2} \dots}, +effectively disabling the tracing of the values of these variables. +Any variable in \scheme{\var{var_1} \var{var_2} \dots} that is not +currently traced is ignored. +If \scheme{untrace} is called without arguments, the values of all +currently traced variables are restored. + +The following transcript demonstrates the use of \scheme{trace} and +\scheme{untrace} in an interactive session to debug an incorrect +procedure definition. + +\schemedisplay +> (define square-minus-one + (lambda (x) + (- (* x x) 2))) +> (square-minus-one 3) +7 +> (trace square-minus-one * -) +(square-minus-one * -) +> (square-minus-one 3) +|(square-minus-one 3) +| (* 3 3) +| 9 +|(- 9 2) +|7 +7 +> (define square-minus-one + (lambda (x) + (- (* x x) 1))) ; change the 2 to 1 +> (trace) +(- *) +> (square-minus-one 3) +|(* 3 3) +|9 +|(- 9 1) +|8 +8 +> (untrace square-minus-one) +() +> (untrace * -) +(- *) +> (square-minus-one 3) +8 +\endschemedisplay + +\noindent +The first call to \scheme{square-minus-one} indicates there is an error, +the second (traced) call indicates the step at which the error occurs, +the third call demonstrates that the fix works, +and the fourth call demonstrates that +\scheme{untrace} does not wipe out the fix. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-output-port}{\categorythreadparameter}{trace-output-port} +\listlibraries +\endentryheader + +\noindent +\scheme{trace-output-port} is a parameter that determines the +output port to which tracing information is sent. +When called with no arguments, \scheme{trace-output-port} returns the +current trace output port. +When called with one argument, which must be a textual output port, +\scheme{trace-output-port} changes the value of the current +trace output port. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-print}{\categorythreadparameter}{trace-print} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{trace-print} must be a procedure of two arguments, +an object and an output port. +The trace package uses the value of \scheme{trace-print} to print the +arguments and return values for each call to a traced procedure. +\scheme{trace-print} is set to \scheme{pretty-print} by default. + +The trace package sets +\index{\scheme{pretty-initial-indent}}\scheme{pretty-initial-indent} +to an appropriate value for the current nesting level before calling +the value of \scheme{trace-print} so that multiline output can be +indented properly. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-define}{\categorysyntax}{(trace-define \var{var} \var{expr})} +\formdef{trace-define}{\categorysyntax}{(trace-define (\var{var} . \var{idspec}) \var{body_1} \var{body_2} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{trace-define} is a convenient shorthand for defining variables bound +to traced procedures of the same name. +The first form is equivalent to + +\schemedisplay +(define \var{var} + (let ([x \var{expr}]) + (trace-lambda \var{var} args + (apply x args)))) +\endschemedisplay + +\noindent +and the second is equivalent to + +\schemedisplay +(define \var{var} + (trace-lambda \var{var} \var{idspec} + \var{body_1} \var{body_2} \dots)) +\endschemedisplay + +\noindent +In the former case, \var{expr} must evaluate to a procedure. + +\schemedisplay +> (let () + (trace-define plus + (lambda (x y) + (+ x y))) + (list (plus 3 4) (+ 5 6))) +|(plus 3 4) +|7 +(7 11) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{trace-define-syntax}{\categorysyntax}{(trace-define-syntax \var{keyword} \var{expr})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{trace-define-syntax} traces the input and output to the +transformer value of \var{expr}, stripped of the contextual +information used by the expander to maintain lexical scoping. + +\schemedisplay +> (trace-define-syntax let* + (syntax-rules () + [(_ () b1 b2 ...) + (let () b1 b2 ...)] + [(_ ((x e) m ...) b1 b2 ...) + (let ((x e)) + (let* (m ...) b1 b2 ...))])) +> (let* ([x 3] [y (+ x x)]) (list x y)) +|(let* (let* [(x 3) (y (+ x x))] [list x y])) +|(let ([x 3]) (let* ([y (+ x x)]) (list x y))) +|(let* (let* [(y (+ x x))] [list x y])) +|(let ([y (+ x x)]) (let* () (list x y))) +|(let* (let* () [list x y])) +|(let () (list x y)) +(3 6) +\endschemedisplay + +\noindent +Without contextual information, the displayed forms are more readable +but less precise, since different identifiers with the same name are +indistinguishable, as shown in the example below. + +\schemedisplay +> (let ([x 0]) + (trace-define-syntax a + (syntax-rules () + [(_ y) (eq? x y)])) + (let ([x 1]) + (a x))) +|(a (a x)) +|(eq? x x) +#f +\endschemedisplay + + +\section{The Interactive Debugger\label{SECTDEBUGINTERACTIVE}} + +The interactive debugger is entered as a result of +a call to the procedure \scheme{debug} after an exception is handled +by the default exception handler. +It can also be entered directly from the default exception handler, for +serious or non-warning conditions, if the parameter +\scheme{debug-on-exception} is true. + +Within the debugger, the command ``?'' lists the debugger command options. +These include commands to: + +\begin{itemize} +\item inspect the raise continuation, +\item display the condition, +\item inspect the condition, and +\item exit the debugger. +\end{itemize} + +The raise continuation is the continuation encapsulated within the +condition, if any. +The standard exception reporting procedures and forms \scheme{assert}, +\scheme{assertion-violation}, and \scheme{error} as well as the +{\ChezScheme} procedures \scheme{assertion-violationf}, \scheme{errorf}, +and \scheme{syntax-error} all raise exceptions with conditions that +encapsulate the continuations of their calls, allowing the programmer to +inspect the frames of pending calls at the point of a violation, error, or +failed assertion. + +A variant of the interactive debugger, the break handler, is entered as +the result of a keyboard interrupt handled by the default +keyboard-interrupt handler or an explicit call to the procedure +\scheme{break} handled by the default break handler. +Again, the command ``?'' lists the command options. +These include commands to: + +\begin{itemize} +\item exit the break handler and continue, +\item reset to the current caf\'e, +\item abort the entire Scheme session, +\item enter a new caf\'e, +\item inspect the current continuation, and +\item display program statistics (run time and memory usage). +\end{itemize} + +\noindent +It is also usually possible to exit from the debugger or break handler by +typing the end-of-file character (``control-D'' under Unix, ``control-Z'' +under Windows). + + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{debug}{\categoryprocedure}{(debug)} +\returns does not return +\listlibraries +\endentryheader + +\noindent +When the default exception handler receives a serious or non-warning +condition, it displays the condition and resets to the current caf\'e. +Before it resets, it saves the condition in the parameter +\scheme{debug-condition}. +The \scheme{debug} procedure may be used to inspect the condition. +Whenever one of the built-in error-reporting mechanisms is used to +raise an exception, the continuation at the point where the +exception was raised can be inspected as well. +More generally, \scheme{debug} allows the continuation contained +within any continuation condition created by +\scheme{make-continuation-condition} to be inspected. + +If the parameter \scheme{debug-on-exception} is set to \scheme{#t}, +the default exception handler enters the debugger directly for all +serious and non-warning conditions, delaying its reset until after +the debugger exits. +The \index{\scheme{--debug-on-exception} command-line option}\scheme{--debug-on-exception} +command-line option may be used to set \scheme{debug-on-exception} to +\scheme{#t} from the command line, which is particularly useful when +debugging scripts or top-level programs run via the +\index{\scheme{--script} command-line option}\scheme{--script} or +\index{\scheme{--program} command-line option}\scheme{--program} +command-line options. + + + +\section{The Interactive Inspector\label{SECTDEBUGINSPECTOR}} + +The \index{inspector}inspector may be called directly via the procedure \scheme{inspect} or +indirectly from the debugger. +It allows the programmer to examine circular objects, objects such as +ports and procedures that do not have a reader syntax, and objects such +as continuations and variables that are not directly accessible by the +programmer, as well as ordinary printable Scheme objects. + +The primary intent of the inspector is examination, not alteration, of +objects. +The values of \index{assignable variables}assignable variables may be changed from within the +inspector, however. +Assignable variables are generally limited to those for which +assignments occur in the source program. +It is also possible to invoke arbitrary procedures +(including mutation procedures such as \scheme{set-car!}) on an object. +No mechanism is provided for altering objects that are inherently +immutable, e.g., nonassignable variables, procedures, and bignums, since +doing so can violate assumptions made by the compiler and run-time +system. + +The user is presented with a prompt line that includes a printed +representation of the current object, abbreviated if necessary to +fit on the line. +Various commands are provided for displaying objects and moving around +inside of objects. +On-line descriptions of the command options are provided. +The command ``?'' displays commands that apply specifically to the +current object. +The command ``??'' displays commands that are always applicable. +The command ``h'' provides a brief description of how to use the +inspector. +The end-of-file character or the command ``q'' exits the inspector. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{inspect}{\categoryprocedure}{(inspect \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Invokes the inspector on \var{obj}, as described above. +The commands recognized by the inspector are listed below, categorized +by the type of the current object. + + +\def\Itype#1 {\bigskip\noindent\textbf{#1 commands}\nobreak\medskip\nobreak} +\def\Icmd#1{\medskip\noindent #1} + +\Itype{Generally applicable} + +\Icmd{\scheme{help} or \scheme{h}} displays a brief description of how to use the +inspector. + +\Icmd{\scheme{?}} displays commands applicable to the current type of +object. + +\Icmd{\scheme{??}} displays the generally applicable commands. + +\Icmd{\scheme{print} or \scheme{p}} prints the current object (using \scheme{pretty-print}). + +\Icmd{\scheme{write} or \scheme{w}} writes the current object (using \scheme{write}). + +\Icmd{\scheme{size}} writes the size in bytes occupied by the current object +(determined via \index{\scheme{compute-size}}\scheme{compute-size}), +including any objects accessible from the current object except those +for which the size was previously requested during the same interactive +inspector session. + +\Icmd{\scheme{find} \var{expr} [ \var{g} ]} evaluates \var{expr}, which should evaluate +to a procedure of one argument, and searches +(via \index{\scheme{make-object-finder}}\scheme{make-object-finder}) +for the first occurrence +of an object within the current object for which the predicate returns +a true value, treating immediate values (e.g., fixnums), values in +generations older than \var{g}, and values already visited during the +search as leaves. +If \var{g} is not unspecified, it defaults to the current maximum +generation, i.e., the value of \scheme{collect-maximum-generation}. +If specified, \var{g} must be an exact nonnegative integer less than or +equal to the current maximum generation or the symbol \scheme{static} +representing the static generation. +If such an object is found, the inspector's focus moves to that object +as if through a series of steps that lead from the current object to the +located object, so that the \scheme{up} command can be used to determine +where the object was found relative to the original object. + +\Icmd{\scheme{find-next}} repeats the last \scheme{find}, locating an +occurrence not previously found, if any. + +\Icmd{\scheme{up} or \scheme{u} \var{n}} returns to the \var{nth} previous level. +Used to move outwards in the structure of the inspected object. +\var{n} defaults to 1. + +\Icmd{\scheme{top} or \scheme{t}} returns to the outermost level of the inspected +object. + +\Icmd{\scheme{forward} or \scheme{f}} moves to the \var{nth} next expression. +Used to move from one element to another of an object containing +a sequence of elements, such as a list, vector, record, frame, or closure. +\var{n} defaults to 1. + +\Icmd{\scheme{back} or \scheme{b}} moves to the \var{nth} previous expression. +Used to move from one element to another of an object containing +a sequence of elements, such as a list, vector, record, frame, or closure. +\var{n} defaults to 1. + +\Icmd{\scheme{=>} \var{expr}} sends the current object to the procedure value +of \var{expr}. +\var{expr} may begin on the current or following line and may +span multiple lines. + +\Icmd{\scheme{file} \var{path}} opens the source file at the specified path for +listing. +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories +searched for source files. + +\Icmd{\scheme{list} \var{line} \var{count}} lists \var{count} lines of the +current source file (see \scheme{file}) starting at \var{line}. +\var{line} defaults to the end of the previous set of lines listed and +\var{count} defaults to ten or the number of lines previously listed. +If \var{line} is negative, listing begins \var{line} lines before the +previous set of lines listed. + +\Icmd{\scheme{files}} shows the currently open source files. + +\Icmd{\scheme{mark} or \scheme{m} \var{m}} marks the current location with the +symbolic mark \var{m}. +If \var{m} is not specified, the current location is marked with +a unique default mark. + +\Icmd{\scheme{goto} or \scheme{g} \var{m}} returns to the location marked \var{m}. +If \var{m} is not specified, the inspector returns to the location +marked with the default mark. + +\Icmd{\scheme{new-cafe} or \scheme{n}} enters a new read-eval-print loop +(caf\'e), giving access to the normal top-level environment. + +\Icmd{\scheme{quit} or \scheme{q}} exits from the inspector. + +\Icmd{\scheme{reset} or \scheme{r}} resets to the current caf\'e. + +\Icmd{\scheme{abort} or \scheme{a} \var{x}} aborts from Scheme with exit +status \var{x}, which defaults to -1. + + +\Itype{Continuation} + +\Icmd{\scheme{show-frames} or \scheme{sf}} shows the next \var{n} frames. +If \var{n} is not specified, all frames are displayed. + +\Icmd{\scheme{depth}} displays the number of frames in the continuation. + +\Icmd{\scheme{down} or \scheme{d} \var{n}} move to the \var{nth} frame down in the +continuation. +\var{n} defaults to 1. + +\Icmd{\scheme{show} or \scheme{s}} shows the continuation (next frame) and, +if available, the calling procedure source, the pending call source, +the closure, and the frame and free-variable values. +Source is available only if generation of inspector information +was enabled during compilation of the corresponding lambda +expression. + +\Icmd{\scheme{show-local} or \scheme{sl}} is like \scheme{show} or~\scheme{s} +except that free variable values are not shown. (If present, free variable +values can be found by inspecting the closure.) + +\Icmd{\scheme{length} or \scheme{l}} displays the number of elements +in the topmost frame of the continuation. + +\Icmd{\scheme{ref} or \scheme{r}} moves to the \var{nth} or named +frame element. \var{n} defaults to 0. +If multiple elements have the same name, only one is +accessible by name, and the others must be accessed by number. + +\Icmd{\scheme{code} or \scheme{c}} moves to the source for the calling procedure. + +\Icmd{\scheme{call}} moves to the source for the pending call. + +\Icmd{\scheme{file}} opens the source file containing the pending call, +if known. +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the list of source directories searched for source files +identified by relative path names. + +For absolute pathnames starting with a \scheme{/} (or \scheme{\} or a +directory specifier under Windows), the inspector tries the absolute +pathname first, then looks for the last (filename) component of the path in +the list of source directories. +For pathnames starting with \scheme{./} (or \scheme{.\} under Windows) +or \scheme{../} (or \scheme{..\} under Windows), the inspector looks in +\scheme{"."} or \scheme{".."} first, as appropriate, then for the entire +\scheme{.}- or \scheme{..}-prefixed +pathname in the source directories, then for the last (filename) +component in the source directories. +For other (relative) pathnames, the inspector looks for the entire +relative pathname in the list of source directories, then the last +(filename) component in the list of source directories. + +If a file by the same name as but different contents from the original +source file is found during this process, it will be skipped over. +This typically happens because the file has been modified since it was +compiled. +Pass an explicit filename argument to force opening of a particular file +(see the generally applicable commands above). + + + +\Icmd{\scheme{eval} or \scheme{e} \var{expr}} evaluates the expression +\var{expr} in an environment containing bindings for the elements of +the frame. Within the evaluated expression, the value of each frame +element \var{n} is accessible via the variable \scheme{%\var{n}}. +Named elements are accessible via their names as well. Names are +available only if generation of inspector information was enabled +during compilation of the corresponding lambda expression. + +\Icmd{\scheme{set!} or \scheme{!} \var{n} \var{e}} sets the value of the \var{nth} frame +element to \var{e}, if the frame element corresponds to +an assignable variable. +\var{n} defaults to 0. + + + +\Itype{Procedure} + +\Icmd{\scheme{show} or \scheme{s}} shows the source and free variables of the +procedure. +Source is available only if generation of inspector information +was enabled during compilation of the corresponding lambda +expression. + +\Icmd{\scheme{code} or \scheme{c}} moves to the source for the procedure. + +\Icmd{\scheme{file}} opens the file containing the procedure's source code, +if known. +See the description of the continuation \scheme{file} entry above for more +information. + +\Icmd{\scheme{length} or \scheme{l}} displays the number of free variables +whose values are recorded in the procedure object. + +\Icmd{\scheme{ref} or \scheme{r}} moves to the \var{nth} or named +free variable. \var{n} defaults to 0. +If multiple free variables have the same name, only one is +accessible by name, and the others must be accessed by number. + +\Icmd{\scheme{set!} or \scheme{!} \var{n} \var{e}} sets the value of the \var{nth} free variable +to \var{e}, if the variable is assignable. +\var{n} defaults to 0. + +\Icmd{\scheme{eval} or \scheme{e} \var{expr}} evaluates the expression +\var{expr} in an environment containing bindings for the free variables +of the procedure. +Within the evaluated expression, the value of each free variable +\var{n} is accessible via the variable \scheme{%\var{n}}. +Named free variables are accessible via their names as well. +Names are available only if generation of inspector information was +enabled during compilation of the corresponding lambda expression. + + +\Itype{Pair (list)} + +\Icmd{\scheme{show} or \scheme{s} \var{n}} shows the first \var{n} elements of the list. +If \var{n} is not specified, all elements are displayed. + +\Icmd{\scheme{length} or \scheme{l}} displays the list length. + +\Icmd{\scheme{car}} moves to the object in the car of the current object. + +\Icmd{\scheme{cdr}} moves to the object in the cdr. + +\Icmd{\scheme{ref} or \scheme{r} \var{n}} moves to the \var{nth} element of the list. +\var{n} defaults to 0. + +\Icmd{\scheme{tail} \var{n}} moves to the \var{nth} cdr of the list. +\var{n} defaults to 1. + + +\Itype{Vector, Bytevector, and Fxvector} + +\Icmd{\scheme{show} or \scheme{s} \var{n}} shows the first \var{n} elements of the vector. +If \var{n} is not specified, all elements are displayed. + +\Icmd{\scheme{length} or \scheme{l}} displays the vector length. + +\Icmd{\scheme{ref} or \scheme{r} \var{n}} moves to the \var{nth} element of the vector. +\var{n} defaults to 0. + + +\Itype{String} + +\Icmd{\scheme{show} or \scheme{s} \var{n}} shows the first \var{n} elements of the string. +If \var{n} is not specified, all elements are displayed. + +\Icmd{\scheme{length} or \scheme{l}} displays the string length. + +\Icmd{\scheme{ref} or \scheme{r} \var{n}} moves to the \var{nth} element of the string. +\var{n} defaults to 0. + +\Icmd{\scheme{unicode} \var{n}} displays the first \var{n} elements of the string +as hexadecimal Unicode scalar values. + +\Icmd{\scheme{ascii} \var{n}} displays the first \var{n} elements of the string +as hexadecimal ASCII values, using \scheme{--} to denote characters whose Unicode +scalar values are not in the ASCII range. + + +\Itype{Symbol} + +\Icmd{\scheme{show} or \scheme{s}} shows the fields of the symbol. + +\Icmd{\scheme{value} or \scheme{v}} moves to the top-level value of the symbol. + +\Icmd{\scheme{name} or \scheme{n}} moves to the name of the symbol. + +\Icmd{\scheme{property-list} or \scheme{pl}} moves to the property list +of the symbol. + +\Icmd{\scheme{ref} or \scheme{r} \var{n}} moves to the \var{nth} field of the symbol. +Field 0 is the top-level value of the symbol, field 1 +is the symbol's name, and field 2 is its property list. +\var{n} defaults to 0. + + +% in subset-mode system also value-slot, system-property-list, and symbol-hash + + +\Itype{Character} + +\Icmd{\scheme{unicode}} displays the hexadecimal Unicode scalar value for +the character. + +\Icmd{\scheme{ascii}} displays the hexadecimal ASCII code for the character, +using \scheme{--} to denote characters whose Unicode scalar values are not +in the ASCII range. + + +\Itype{Box} + +\Icmd{\scheme{show} or \scheme{s}} shows the contents of the box. + +\Icmd{\scheme{unbox} or \scheme{ref} or \scheme{r}} moves to the boxed object. + + +\Itype{Port} + +\Icmd{\scheme{show} or \scheme{s}} shows the fields of the port, including +the input and output size, index, and buffer fields. + +\Icmd{\scheme{name}} moves to the port's name. + +\Icmd{\scheme{handler}} moves to the port's handler. + +\Icmd{\scheme{output-buffer} or \scheme{ob}} moves to the port's output buffer. + +\Icmd{\scheme{input-buffer} or \scheme{ib}} moves to the port's input buffer. + +% \Icmd{\scheme{info}} moves to the port's info. + + +\Itype{Record} + +\Icmd{\scheme{show} or \scheme{s}} shows the contents of the record. + +\Icmd{\scheme{fields}} moves to the list of field names +of the record. + +\Icmd{\scheme{name}} moves to the name of the record. + +\Icmd{\scheme{rtd}} moves to the record-type descriptor of the record. + +\Icmd{\scheme{ref} or \scheme{r} \var{name}} moves to the named field of the +record, if accessible. + +\Icmd{\scheme{set!} or \scheme{!} \var{name} \var{value}} sets the value +of the named field of the record, if mutable. + + +\Itype{Transport Link Cell (TLC)} + +\Icmd{\scheme{show} or \scheme{s}} shows the fields of the TLC. + +\Icmd{\scheme{keyval}} moves to the keyval of the TLC. + +\Icmd{\scheme{tconc}} moves to the tconc of the TLC. + +\Icmd{\scheme{next}} moves to the next link of the TLC. + +\Icmd{\scheme{ref} or \scheme{r} \var{n}} moves to the \var{nth} field of the symbol. +Field 0 is the keyval, field 1 the tconc, and field 2 the next link. +\var{n} defaults to 0. + + +\section{The Object Inspector\label{SECTDEBUGOBJECTINSPECTOR}} + +A facility for noninteractive inspection is also provided +to allow construction of different inspection interfaces. +Like the interactive facility, it allows objects to be examined in +ways not ordinarily possible. +The noninteractive system follows a simple, object-oriented protocol. +Ordinary Scheme objects are encapsulated in procedures, or inspector +objects, that take symbolic messages and return either information +about the encapsulated object or new inspector objects that encapsulate +pieces of the object. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{inspect/object}{\categoryprocedure}{(inspect/object \var{object})} +\returns an inspector object procedure +\listlibraries +\endentryheader + +\noindent +\scheme{inspect/object} is used to turn an ordinary Scheme object into an +inspector object. +All inspector objects accept the messages \scheme{type}, \scheme{print}, +\scheme{write}, and \scheme{size}. +The \scheme{type} message returns a symbolic representation of the type of +the object. +The \scheme{print} and \scheme{write} messages must be accompanied by a port +parameter. +They cause a representation of the object to be written to the port, +using the Scheme procedures \scheme{pretty-print} and \scheme{write}. +The \scheme{size} message returns a fixnum representing the size +in bytes occupied by the object, including any objects accessible +from the current object except those for which the size was already +requested via an inspector object derived from the argument of the +same \scheme{inspect/object} call. + +All inspector objects except for variable inspector objects accept +the message \scheme{value}, which returns the actual object encapsulated +in the inspector object. + +\schemedisplay +(define x (inspect/object '(1 2 3))) +(x 'type) ;=> pair +(define p (open-output-string)) +(x 'write p) +(get-output-string p) ;=> "(1 2 3)" +(x 'length) ;=> (proper 3) +(define y (x 'car)) +(y 'type) ;=> simple +(y 'value) ;=> 1 +\endschemedisplay + +\def\instype#1{\bigskip\noindent\textbf{#1 inspector objects.}} + +\def\insmsg#1#2{\medskip\noindent\scheme{(}\emph{#1-object} #2\scheme{)}} + +\instype{Pair} +Pair inspector objects contain Scheme pairs. + +\insmsg{pair}{\scheme{'type}} +returns the symbol \scheme{pair}. + +\insmsg{pair}{\scheme{'car}} +returns an inspector object containing the ``car'' field of the pair. + +\insmsg{pair}{\scheme{'cdr}} +returns an inspector object containing the ``cdr'' field of the pair. + +\insmsg{pair}{\scheme{'length}} +returns a list of the form (\var{type} \var{count}). +The type field contains the symbol \scheme{proper}, the symbol \scheme{improper}, or +the symbol \scheme{circular}, depending on the structure of the list. +The count field contains the number of distinct pairs in the list. + +\instype{Box} +Box inspector objects contain {\ChezScheme} boxes. + +\insmsg{box}{\scheme{'type}} +returns the symbol \scheme{box}. + +\insmsg{box}{\scheme{'unbox}} +returns an inspector object containing the contents of the box. + +\instype{TLC} +Box inspector objects contain {\ChezScheme} boxes. + +\insmsg{tlc}{\scheme{'type}} +returns the symbol \scheme{tlc}. + +\insmsg{tlc}{\scheme{'keyval}} +returns an inspector object containing the TLC's keyval. + +\insmsg{tlc}{\scheme{'tconc}} +returns an inspector object containing the TLC's tconc. + +\insmsg{tlc}{\scheme{'next}} +returns an inspector object containing the TLC's next link. + +\instype{Vector, String, Bytevector, and Fxvector} +Vector (bytevector, string, fxvector) inspector objects contain Scheme +vectors (bytevectors, strings, fxvectors). + +\insmsg{vector}{\scheme{'type}} +returns the symbol \scheme{vector} (\scheme{string}, \scheme{bytevector}, \scheme{fxvector}). + +\insmsg{vector}{\scheme{'length}} +returns the number of elements in the vector or string. + +\insmsg{vector}{\scheme{'ref} \var{n}} +returns an inspector object containing the \var{nth} element of the +vector or string. + +\instype{Simple} +Simple inspector objects contain unstructured, unmodifiable objects. +These include numbers, booleans, the empty list, the end-of-file +object, and the void object. +They may be examined directly by asking for the \scheme{value} of the object. + +\insmsg{simple}{\scheme{'type}} +returns the symbol \scheme{simple}. + +\instype{Unbound} +Although unbound objects are not normally accessible to Scheme programs, +they may be encountered when inspecting variables. + +\insmsg{unbound}{\scheme{'type}} +returns the symbol \scheme{unbound}. + +\instype{Procedure} +Procedure inspector objects contain Scheme procedures. + +\insmsg{procedure}{\scheme{'type}} +returns the symbol \scheme{procedure}. + +\insmsg{procedure}{\scheme{'length}} +returns the number of free variables. + +\insmsg{procedure}{\scheme{'ref} \var{n}} +returns an inspector object containing the \var{nth} free variable of the +procedure. +See the description below of variable inspector objects. +\var{n} must be nonnegative and less than the length of the procedure. + +\insmsg{procedure}{\scheme{'eval} \var{expr}} +evaluates \var{expr} and returns its value. +The values of the procedure's free variables are bound within the +evaluated expression to +identifiers of the form \%$n$, where $n$ is the location number +displayed by the inspector. +The values of named variables are also bound to their names. + +\insmsg{procedure}{\scheme{'code}} +returns an inspector object containing the procedure's code object. +See the description below of code inspector objects. + + +\instype{Continuation} +Continuations created by \scheme{call/cc} are actually +procedures. +However, when inspecting such a procedure the underlying data structure +that embodies the continuation may be exposed. +A continuation structure contains the location at which computation is +to resume, the variable values necessary to perform the computation, +and a link to the next continuation. + +\insmsg{continuation}{\scheme{'type}} +returns the symbol \scheme{continuation}. + +\insmsg{continuation}{\scheme{'length}} +returns the number of free variables. + +\insmsg{continuation}{\scheme{'ref} \var{n}} +returns an inspector object containing the \var{nth} free variable of the +continuation. +See the description below of variable inspector objects. +\var{n} must be nonnegative and less than the length of the continuation. + +\insmsg{continuation}{\scheme{'eval} \var{expr}} +evaluates \var{expr} and returns its value. +The values of frame locations are bound within the +evaluated expression to +identifiers of the form \%$n$, where $n$ is the location number +displayed by the inspector. +The values of named locations are also bound to their names. + +\insmsg{continuation}{\scheme{'code}} +returns an inspector object containing the code object for the procedure +that was active when the current continuation frame was created. +See the description below of code inspector objects. + +\insmsg{continuation}{\scheme{'depth}} +returns the number of frames in the continuation. + +\insmsg{continuation}{\scheme{'link}} +returns an inspector object containing the next continuation frame. +The depth must be greater than 1. + +\insmsg{continuation}{\scheme{'link*} \var{n}} +returns an inspector object containing the \var{nth} continuation link. +\var{n} must be less than the depth. + +\insmsg{continuation}{\scheme{'source}} +returns an inspector object containing the source information attached +to the continuation (representing the source for the application that +resulted in the formation of the continuation) +or \scheme{#f} if no source information is attached. + +\insmsg{continuation}{\scheme{'source-object}} +returns an inspector object containing the source object for the +procedure application that resulted in the formation of the continuation +or \scheme{#f} if no source object is attached. + +\insmsg{continuation}{\scheme{'source-path}} +attempts to find the pathname of the file containing the source for +the procedure application that resulted in the formation of the continuation. +If successful, three values are returned to identify the file and position +of the application within the file: \var{path}, \var{line}, and \var{char}. +Two values, a file name and an absolute character position, are returned +if the file name is known but the named file cannot be found. +The search may be unsuccessful even if a file by the expected +name is found in the path if the file has been modified since the source +code was compiled. +If no file name is known, no values are returned. +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories +searched for source files identified by relative path names. + + +\instype{Code} +Code inspector objects contain {\ChezScheme} code objects. + +\insmsg{code}{\scheme{'type}} +returns the symbol \scheme{code}. + +\insmsg{code}{\scheme{'name}} +returns a string or \scheme{#f}. +The name associated with a code inspector object is the name of the +variable to which the procedure was originally bound or assigned. +Since the binding of a variable can be changed, this name association +may not always be accurate. +\scheme{#f} is returned if the inspector cannot determine a name for the +procedure. + +\insmsg{code}{\scheme{'source}} +returns an inspector object containing the source information attached +to the code object or \scheme{#f} if no source information is attached. + +\insmsg{continuation}{\scheme{'source-object}} +returns an inspector object containing the source object for the +code object or \scheme{#f} if no source object is attached. + +\insmsg{code}{\scheme{'source-path}} +attempts to find the pathname of the file containing the source for +the lambda expression that produced the code object. +If successful, three values are returned to identify the file and position +of the application within the file: \var{path}, \var{line}, and \var{char}. +Two values, a file name and an absolute character position, are returned +if the file name is known but the named file cannot be found. +The search may be unsuccessful even if a file by the expected +name is found in the path if the file has been modified since the source +code was compiled. +If no file name is known, no values are returned. +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories +searched for source files identified by relative path names. + +\insmsg{code}{\scheme{'free-count}} +returns the number of free variables in any procedure for which this is +the corresponding code. + + +\instype{Variable} +Variable inspector objects encapsulate variable bindings. +Although the actual underlying representation varies, the variable +inspector object provides a uniform interface. + +\insmsg{variable}{\scheme{'type}} +returns the symbol \scheme{variable}. + +\insmsg{variable}{\scheme{'name}} +returns a symbol or \scheme{#f}. +\scheme{#f} is returned if the name is not available or if the variable is a +compiler-generated temporary variable. +Variable names are not retained when the parameter +\scheme{generate-inspector-information} +(page~\ref{desc:generate-inspector-information}) +is false during compilation. + +\insmsg{variable}{\scheme{'ref}} +returns an inspector object containing the current value of the +variable. + +\insmsg{variable}{\scheme{'set!} \var{e}} +returns unspecified, after setting the current value of the +variable to \var{e}. +An exception is raised with condition type \scheme{&assertion} if the variable is not assignable. + +% \insmsg{variable}{\scheme{id}} returns compiler's internal data structure +% representing the variable, if available. + + +\instype{Port} +Port inspector objects contain ports. + +\insmsg{port}{\scheme{'type}} +returns the symbol \scheme{port}. + +\insmsg{port}{\scheme{'input?}} +returns \scheme{#t} if the port is an input port, \scheme{#f} otherwise. + +\insmsg{port}{\scheme{'output?}} +returns \scheme{#t} if the port is an output port, \scheme{#f} otherwise. + +\insmsg{port}{\scheme{'binary?}} +returns \scheme{#t} if the port is a binary port, \scheme{#f} otherwise. + +\insmsg{port}{\scheme{'closed?}} +returns \scheme{#t} if the port is closed, \scheme{#f} if the port is open. + +\insmsg{port}{\scheme{'name}} +returns an inspector object containing the port's name. + +\insmsg{port}{\scheme{'handler}} +returns a procedure inspector object encapsulating the port handler, +such as would be returned by \scheme{port-handler}. + +\insmsg{port}{\scheme{'output-size}} +returns the output buffer size as a fixnum if the port is an +output port (otherwise the value is unspecified). + +\insmsg{port}{\scheme{'output-index}} +returns the output buffer index as a fixnum if the port is an +output port (otherwise the value is unspecified). + +\insmsg{port}{\scheme{'output-buffer}} +returns an inspector object containing the string used for buffered +output. + +\insmsg{port}{\scheme{'input-size}} +returns the input buffer size as a fixnum if the port is an +input port (otherwise the value is unspecified). + +\insmsg{port}{\scheme{'input-index}} +returns the input buffer index as a fixnum if the port is an +input port (otherwise the value is unspecified). + +\insmsg{port}{\scheme{'input-buffer}} +returns an inspector object containing the string used for buffered +input. + +% \insmsg{port}{\scheme{'info}} +% returns an inspector object containing the port's info. + +\instype{Symbol} +Symbol inspector objects contain symbols. +These include gensyms. + +\insmsg{symbol}{\scheme{'type}} +returns the symbol \scheme{symbol}. + +\insmsg{symbol}{\scheme{'name}} +returns a string inspector object. +The string name associated with a symbol inspector object is the print +representation of a symbol, such as would be returned by the procedure +\scheme{symbol->string}. + +\insmsg{symbol}{\scheme{'gensym?}} +returns \scheme{#t} if the symbol is a gensym, \scheme{#f} otherwise. +Gensyms are created by \scheme{gensym}. + +\insmsg{symbol}{\scheme{'top-level-value}} +returns an inspector object containing the global value of the symbol. + +\insmsg{symbol}{\scheme{'property-list}} +returns an inspector object containing the property list for the +symbol. + +% also $top-level-value, system-property-list, and symbol-hash + + +\instype{Record} +Record inspector objects contain records. + +\insmsg{record}{\scheme{'type}} +returns the symbol \scheme{record}. + +\insmsg{record}{\scheme{'name}} +returns a string inspector object corresponding to the name of +the record type. + +\insmsg{record}{\scheme{'fields}} +returns an inspector object containing a list of the field names of +the record type. + +\insmsg{record}{\scheme{'length}} +returns the number of fields. + +\insmsg{record}{\scheme{'rtd}} +returns an inspector object containing the record-type descriptor of the +record type. + +\insmsg{record}{\scheme{'accessible?} \var{name}} +returns \scheme{#t} if the named field is accessible, \scheme{#f} otherwise. +A field may be inaccessible if optimized away by the compiler. + +\insmsg{record}{\scheme{'ref} \var{name}} +returns an inspector object containing the value of the named field. +An exception is raised with condition type \scheme{&assertion} if the named field is not accessible. + +\insmsg{record}{\scheme{'mutable?} \var{name}} +returns \scheme{#t} if the named field is mutable, \scheme{#f} otherwise. +A field is immutable if it is not declared mutable or if the compiler +optimizes away all assignments to the field. + +\insmsg{record}{\scheme{'set!} \var{name} \var{value}} +sets the value of the named field to \var{value}. +An exception is raised with condition type \scheme{&assertion} if the named field is not assignable. + +\section{Locating objects\label{SECTDEBUGLOCATINGOBJECTS}} + +\noskipentryheader +\formdef{make-object-finder}{\categoryprocedure}{(make-object-finder \var{pred})} +\formdef{make-object-finder}{\categoryprocedure}{(make-object-finder \var{pred} \var{g})} +\formdef{make-object-finder}{\categoryprocedure}{(make-object-finder \var{pred} \var{x} \var{g})} +\returns see below +\listlibraries +\endentryheader + +The procedure \scheme{make-object-finder} takes a predicate \var{pred} and two optional +arguments: a starting point \var{x} and a maximum generation \var{g}. +The starting point defaults to the value of the procedure \scheme{oblist}, +and the maximum generation defaults to the value of the parameter +\scheme{collect-maximum-generation}. +\scheme{make-object-finder} returns an object finder \var{p} that can be used to +search for objects satisfying \var{pred} within the starting-point object \var{x}. +Immediate objects and objects in generations older than \var{g} are treated +as leaves. +\var{p} is a procedure accepting no arguments. +If an object \var{y} satisfying \var{pred} can be found starting with \var{x}, +\var{p} returns a list whose first element is \var{y} and whose remaining +elements represent the path of objects from \var{x} to \var{y}, listed +in reverse order. +\var{p} can be invoked multiple times to find additional objects satisfying +the predicate, if any. +\var{p} returns \scheme{#f} if no more objects matching the predicate +can be found. + +\var{p} maintains internal state recording where it has been so it +can restart at the point of the last found object and not return +the same object twice. +The state can be several times the size of the starting-point object +\var{x} and all that is reachable from \var{x}. + +The interactive inspector provides a convenient interface to the object +finder in the form of \scheme{find} and \scheme{find-next} commands. + +Relocation tables for static code objects are discarded by default, which +prevents object finders from providing accurate results when static code +objects are involved. +That is, they will not find any objects pointed to directly from a code +object that has been promoted to the static generation. +If this is a problem, the command-line argument +\index{\scheme{--retain-static-relocation} command-line option}\scheme{--retain-static-relocation} +can be used to prevent the relocation tables from being discarded. + + +\section{Nested object size and composition\label{SECTDEBUGOBJECTSIZES}} + +The procedures \scheme{compute-size} and \scheme{compute-composition} can be +used to determine the size or composition of an object, including anything +reachable via pointers from the object. +Depending on the number of objects reachable from the object, the procedures +potentially allocate a large amount of memory. +In an application for which knowing the number, size, generation, and types +of all objects in the heap is sufficient, +\index{\scheme{object-counts}}\scheme{object-counts} is potentially much +more efficient. + +These procedures treat immediate objects such as fixnums, booleans, and +characters as zero-count, zero-byte leaves. + +By default, these procedures also treat static objects (those in the +initial heap) as zero-count, zero-byte leaves. +Both procedures accept an optional second argument that specifies the +maximum generation of interest, with the symbol \scheme{static} being +used to represent the static generation. + +Objects sometimes point to a great deal more than one might expect. +For example, if static data is included, the procedure value of +\scheme{(lambda (x) x)} points indirectly to the exception handling +subsystem (because of the argument-count check) and many other things +as a result of that. + +Relocation tables for static code objects are discarded by default, +which prevents these procedures from providing accurate results when +static code objects are involved. +That is, they will not find any objects pointed to directly from a code +object that has been promoted to the static generation. +If accurate sizes and compositions for static code objects are +required, the command-line argument +\index{\scheme{--retain-static-relocation} command-line option}\scheme{--retain-static-relocation} +can be used to prevent the relocation tables from being discarded. + +\entryheader +\formdef{compute-size}{\categoryprocedure}{(compute-size \var{object})} +\formdef{compute-size}{\categoryprocedure}{(compute-size \var{object} \var{generation})} +\returns see below +\listlibraries +\endentryheader + +\var{object} can be any object. +\var{generation} must be a fixnum between 0 and the value of +\scheme{collect-maximum-generation}, inclusive, or the symbol +\scheme{static}. +If \var{generation} is not supplied, it defaults to the value of +\scheme{collect-maximum-generation}. + +\scheme{compute-size} returns the amount of memory, in bytes, occupied by +\var{object} and anything reachable from \var{object} in any generation +less than or equal to \var{generation}. +Immediate values such as fixnums, booleans, and characters have zero size. + +The following examples are valid for machines with 32-bit pointers. + +\schemedisplay +(compute-size 0) ;=> 0 +(compute-size (cons 0 0)) ;=> 8 +(compute-size (cons (vector #t #f) 0)) ;=> 24 + +(compute-size + (let ([x (cons 0 0)]) + (set-car! x x) + (set-cdr! x x) + x)) ;=> 8 + +(define-record-type frob (fields x)) +(collect 1 1) ; force rtd into generation 1 +(compute-size + (let ([x (make-frob 0)]) + (cons x x)) + 0) ;=> 16 +\endschemedisplay + +\entryheader +\formdef{compute-composition}{\categoryprocedure}{(compute-composition \var{object})} +\formdef{compute-composition}{\categoryprocedure}{(compute-composition \var{object} \var{generation})} +\returns see below +\listlibraries +\endentryheader + +\var{object} can be any object. +\var{generation} must be a fixnum between 0 and the value of +\scheme{collect-maximum-generation}, inclusive, or the symbol +\scheme{static}. +If \var{generation} is not supplied, it defaults to the value of +\scheme{collect-maximum-generation}. + +\scheme{compute-composition} returns an association list representing +the composition of \var{object}, including anything reachable from it +in any generation less than or equal to \var{generation}. +The association list has the following structure: + +\schemedisplay +((\var{type} \var{count} . \var{bytes}) \dots) +\endschemedisplay + +\var{type} is either the name of a primitive type, represented as a +symbol, e.g., \scheme{pair}, or a record-type descriptor (rtd). +\var{count} and \var{bytes} are nonnegative fixnums. + +Immediate values such as fixnums, booleans, and characters are not +included in the composition. + +The following examples are valid for machines with 32-bit pointers. + +\schemedisplay +(compute-composition 0) ;=> () +(compute-composition (cons 0 0)) ;=> ((pair 1 . 8)) +(compute-composition + (cons (vector #t #f) 0)) ;=> ((pair 1 . 8) (vector 1 . 16)) + +(compute-composition + (let ([x (cons 0 0)]) + (set-car! x x) + (set-cdr! x x) + x)) ;=> ((pair 1 . 8) + +(define-record-type frob (fields x)) +(collect 1 1) ; force rtd into generation 1 +(compute-composition + (let ([x (make-frob 0)]) + (cons x x)) + 0) ;=> ((pair 1 . 8) + (# 1 . 8)) +\endschemedisplay diff --git a/csug/docond.ss b/csug/docond.ss new file mode 100644 index 0000000..46e7919 --- /dev/null +++ b/csug/docond.ss @@ -0,0 +1,24 @@ +(define docond-ht (make-eq-hashtable)) +(hashtable-set! docond-ht '&condition '()) +(define (docond expr) + (syntax-case expr (define-condition-type) + [(define-condition-type &name &parent make-name name? + (field-name field-accessor) ...) + (let ([pfields (hashtable-ref docond-ht #'&parent #f)]) + (unless pfields (error 'docond "unrecognized parent ~s" #'&parent)) + (printf "\\formdef{~s}{\\categorysyntax}{~s}\n" #'&name #'&name) + (let ([fields (append pfields #'(field-name ...))]) + (printf "\\formdef{~s}{\\categoryprocedure}{(~s~{ \\var{~s}~})}\n" + #'make-name #'make-name fields) + (hashtable-set! docond-ht #'&name fields)) + (printf "\\returns a condition of type \\scheme{~s}\n" #'&name) + (printf "\\formdef{~s}{\\categoryprocedure}{(~s \\var{obj})}\n" #'name? #'name?) + (printf "\\returns \\scheme{#t} if \\var{obj} is a condition of type \\scheme{~s}, \\scheme{#f} otherwise\n" + #'&name) + (for-each + (lambda (field get-field) + (printf "\\formdef{~s}{\\categoryprocedure}{(~s \\var{condition})}\n" get-field get-field) + (printf "\\returns the contents of \\var{condition}'s \\scheme{~s} field\n" field)) + #'(field-name ...) + #'(field-accessor ...)) + (printf "\\listlibraries\n"))])) diff --git a/csug/expeditor.stex b/csug/expeditor.stex new file mode 100644 index 0000000..2faecad --- /dev/null +++ b/csug/expeditor.stex @@ -0,0 +1,683 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Expression Editor\label{CHPTEXPEDITOR}} + +When the expression editor (expeditor) is enabled as described in +Section~\ref{SECTUSEEXPEDITOR}, it allows the user to edit expressions +entered into the system and move backwards and forwards through +a history of entered expressions. +This chapter describes a set of parameters that may be used to +control various aspects of the expression editor's behavior +(Section~\ref{SECTEXPEDITORPARAMS}), +a procedure for binding key sequences to editing commands +(Section~\ref{SECTEXPEDITORKEYBINDING}), +the built-in editing commands +(Section~\ref{SECTEXPEDITOREDITCMDS}), and mechanisms for creating new +editing commands (Section~\ref{SECTEXPEDITORNEWCMDS}). + +These mechanisms are available through the \scheme{expression-editor} module. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{expression-editor}{\categorymodule}{expression-editor} +\listlibraries +\endentryheader + +The \scheme{expression-editor} module exports a set of bindings for +parameters and other procedures that can be used to modify how the +expression editor interacts with the user, including the particular keys +used to invoke the various editing commands. + +\medskip +Basic use of the expression editor is described in Section~\ref{SECTUSEEXPEDITOR}. + +\xdef\cntl#1{\scheme{^#1}} + +\section{Expression Editor Parameters\label{SECTEXPEDITORPARAMS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{ee-auto-indent}{\categoryglobalparameter}{ee-auto-indent} +\nolistlibraries +\endnoskipentryheader + +The value of \scheme{ee-auto-indent} is a boolean value that determines +whether the expression editor indents expressions as they are entered. +Its default value is \scheme{#t}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-standard-indent}{\categoryglobalparameter}{ee-standard-indent} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-standard-indent} is a nonnegative fixnum +value that determines the amount (in single spaces) by which each +expression is indented relative to the enclosing expression, if +not aligned otherwise by one of the indenter's other heuristics, +when \scheme{ee-auto-indent} is true or when one of the indentation +commands is invoked explicitly. +It's default value is \scheme{2}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-auto-paren-balance}{\categoryglobalparameter}{ee-auto-paren-balance} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-auto-paren-balance} is a boolean value that determines +whether the expression editor automatically corrects a close +parenthesis or bracket, when typed, to match the corresponding open +parenthesis or bracket, if any. +Its default value is \scheme{#t}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-flash-parens}{\categoryglobalparameter}{ee-flash-parens} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-flash-parens} is a boolean value that determines +whether the expression editor briefly moves the cursor when an open +or close parenthesis or bracket is typed to the +matching close or open parenthesis or bracket (if any). +Its default value is \scheme{#t}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-paren-flash-delay}{\categoryglobalparameter}{ee-paren-flash-delay} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-paren-flash-delay} is a nonnegative fixnum +value that determines the amount of time (in milliseconds) that the +expression editor pauses when the cursor is moved to the matching +parenthesis or bracket, if any, when a parenthesis or bracket is +entered. +The value is ignored if the \scheme{ee-flash-parens} is false. +Its default value is \scheme{100}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-default-repeat}{\categoryglobalparameter}{ee-default-repeat} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-default-repeat} is a nonnegative fixnum +value that determines the number of times the next command is +repeated after the \scheme{ee-command-repeat} editing command +(bound to \scheme{Esc-^U} by default) is used and \emph{not} +followed by a sequence of digits. +It's default value is \scheme{4}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-noisy}{\categoryglobalparameter}{ee-noisy} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-noisy} is a boolean value that determines +whether the expression editor emits a beep (bell) when an error +occurs, such as an attempt to find the matching delimiter for a +non-delimiter character. +Its default value is \scheme{#f}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-history-limit}{\categoryglobalparameter}{ee-history-limit} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-history-limit} is a nonnegative fixnum value +that determines the number of history entries retained by the +expression editor during and across sessions. +Only the last \scheme{(ee-history-limit)} entries are retained. +% Its default value is \scheme{100}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-common-identifiers}{\categoryglobalparameter}{ee-common-identifiers} +\nolistlibraries +\endentryheader + +The value of \scheme{ee-common-identifiers} is list of symbols that +are considered common enough that they should appear early when +one of the incremental identifier-completion editing commands is +invoked. +Its default value contains a few dozen entries. +They are all more than a few characters long (under the theory that +users will most likely type short ones out fully) and all would +appear later than they likely should when incremental +identifier-completion is used. + + +\section{Key Binding\label{SECTEXPEDITORKEYBINDING}} + +Key bindings are established via \scheme{ee-bind-key}. +The default key bindings are described in Section~\ref{SECTEXPEDITOREDITCMDS}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-bind-key}{\categoryprocedure}{(ee-bind-key \var{key} \var{procedure})} +\nolistlibraries +\returns unspecified +\endentryheader + +The \scheme{ee-bind-key} procedure is used to add to or change the +set of key bindings recognized by the expression editor. + +The \var{key} must be a character or string; if it is a string, it +must have the following form. + +\begin{grammar} +\ang{key-string}\longis \scheme{"}\ang{key-char}\kplus\scheme{"} +\end{grammar} + +where + +\begin{grammar} +\ang{key-char}\longis \scheme{\\e} (specifying an escape character)\\ + \orbar \scheme{^\var{x}} (specifying control-\var{x})\\ + \orbar \scheme{\\^} (specifying caret)\\ + \orbar \scheme{\\\\} (specifying back slash)\\ + \orbar \scheme{plain char} (any character other than \scheme{\} or \scheme{^}) +\end{grammar} + +Note that each double-backslash in the syntax actually denotes just +one backslash in the string. + +For example, the \var{key} \scheme{"\\eX"} represents the two-character +sequence Escape-x, i.e., the ``escape'' key followed by the (capital) +``X'' key. +Similarly, they \var{key} \scheme{"\\e^X"} represents the two-character +sequence Escape-Control-x, i.e., the ``escape'' key followed by +Control-X. + +Character keys and string keys consisting of a single plain character +always represent a single keystroke. + +The \var{procedure} argument should normally be one of the built-in editing +commands described below. +It is also possible to define new editing commands with +\index{\scheme{ee-string-macro}}\scheme{ee-string-macro} +and \index{\scheme{ee-compose}}\scheme{ee-compose}. + + +\section{Editing Commands\label{SECTEXPEDITOREDITCMDS}} + +\xdef\editproc#1#2{\medskip {\bf command:} \index{\scheme{#1}}\scheme{#1}\\ + {\bf key(s):} #2\par{}} +\xdef\endeditproc{\par{}} + +\def\ECgroup#1 {\medskip\noindent{\bf #1}\par} + +The editing commands are grouped into sections according to usage. +Each is listed along with the default character sequence or sequences by +which it may be invoked. + +\ECgroup{Insertion commands} + +\editproc{ee-insert-self}{most printing characters} +Inserts the entered character into the entry. +\endeditproc + +\editproc{ee-insert-paren}{\scheme{(}, \scheme{)}, \scheme{[}, \scheme{]}} +Inserts the entered parenthesis or bracket into the entry. + +If the parameter +\index{\scheme{ee-auto-paren-balance}}\scheme{ee-auto-paren-balance} is +true, the editor corrects close delimiters if necessary to balance +existing open delimiters, when a matching open delimiter can be found. + +If the parameter \index{\scheme{ee-flash-parens}}\scheme{ee-flash-parens} +is true, the editor briefly moves the cursor to the matching delimiter, if +one can be found, pausing for an amount of time controlled by the +parameter \index{\scheme{ee-paren-flash-delay}}\scheme{ee-paren-flash-delay}. +If the matching delimiter is not presently displayed, the cursor is flashed +to the upper-left or lower-left corner of the displayed portion of the +entry, as appropriate. + +The behavior of this command is undefined if used for something other +than a parenthesis or bracket. +\endeditproc + +\editproc{ee-newline}{none} +Inserts a newline at the cursor position, moves to the next line, and +indents that line if the parameter +\index{\scheme{ee-auto-indent}}\scheme{ee-auto-indent} is true. +Does nothing if the entry is empty. +See also \scheme{ee-newline/accept}. +\endeditproc + +\editproc{ee-open-line}{\cntl{O}} +Inserts a newline at the cursor position and indents the next line, +but does not move to the next line. +\endeditproc + +\editproc{ee-yank-kill-buffer}{\cntl{Y}} +Inserts the contents of the kill buffer, which is set by the deletion +commands described below. +\endeditproc + +\editproc{ee-yank-selection}{\cntl{V}} +Inserts the contents of the window system's current selection or paste +buffer. +When running in a shell window under X Windows, this command requires that +the DISPLAY environment variable be set to the appropriate display. +\endeditproc + +% The following is no longer true, since auto-indent is disabled when +% the characters are coming fast enough that they are likely happening +% as the result of a paste operation. +% +% While it may be possible to insert the contents of the current selection +% or paste buffer via some other means, e.g., via the mouse or some +% OS-specific key combination, this command is preferable whenever the +% parameter \index{\scheme{ee-auto-indent}}\scheme{ee-auto-indent} is true +% for multi-line input that is already indented. + +\ECgroup{Cursor movement commands} + +\editproc{ee-backward-char}{leftarrow, \cntl{B}} +Moves the cursor left one character. +\endeditproc + +\editproc{ee-forward-char}{rightarrow, \cntl{F}} +Moves the cursor right one character. +\endeditproc + +\editproc{ee-next-line}{downarrow, \cntl{N}} +Moves the cursor down one line (and to the left if necessary so that +the cursor does not sit beyond the last possible position). +If the cursor is at the end of the current entry, and the current +entry has not been modified, this command behaves like +\index{\scheme{ee-history-fwd}}\scheme{ee-history-fwd}. +\endeditproc + +\editproc{ee-previous-line}{uparrow, \cntl{P}} +Moves the cursor up one line (and to the left if necessary so that +the cursor does not sit beyond the last possible position). +If the cursor is at the top of the current entry, and the current +entry has not been modified, this command behaves like +\index{\scheme{ee-history-bwd}}\scheme{ee-history-bwd}. +\endeditproc + +\editproc{ee-beginning-of-line}{home, \cntl{A}} +Moves the cursor to the first character of the current line. +\endeditproc + +\editproc{ee-end-of-line}{end, \cntl{E}} +Moves the cursor to the right of the last character of the current line. +\endeditproc + +\editproc{ee-beginning-of-entry}{escape-\scheme{<}} +Moves the cursor to the first character of the entry. +\endeditproc + +\editproc{ee-end-of-entry}{escape-\scheme{>}} +Moves the cursor to the right of the last character of the entry. +\endeditproc + +\editproc{ee-goto-matching-delimiter}{escape-\scheme{]}} +Moves the cursor to the matching delimiter. +Has no effect if the character under the cursor is not a parenthesis +or bracket or if no matching delimiter can be found. +\endeditproc + +\editproc{ee-flash-matching-delimiter}{\cntl{]}} +Moves the cursor briefly to the matching delimiter, if +one can be found, pausing for an amount of time controlled by the +parameter \index{\scheme{ee-paren-flash-delay}}\scheme{ee-paren-flash-delay}. +If the matching delimiter is not presently displayed, the cursor is flashed +to the upper-left or lower-left corner of the displayed portion of the +entry, as appropriate. +\endeditproc + +\editproc{ee-exchange-point-and-mark}{\cntl{X}-\cntl{X}} +Moves the cursor to the mark and leaves the mark at the old cursor +position. +(The mark can be set with \scheme{ee-set-mark}.) +\endeditproc + +\editproc{ee-forward-sexp}{escape-\cntl{F}} +Moves the cursor to the start of the next expression. +\endeditproc + +\editproc{ee-backward-sexp}{escape-\cntl{B}} +Moves the cursor to the start of the preceding expression. +\endeditproc + +\editproc{ee-forward-word}{escape-f, escape-\scheme{F}} +Moves the cursor to the end of the next word. +\endeditproc + +\editproc{ee-backward-word}{escape-b, escape-\scheme{B}} +Moves the cursor to the start of the preceding word. +\endeditproc + +\editproc{ee-forward-page}{pagedown, \cntl{X}-\scheme{]}} +Moves the cursor down one screen page. +\endeditproc + +\editproc{ee-backward-page}{pageup, \cntl{X}-\scheme{[}} +Moves the cursor up one screen page. +\endeditproc + + +\ECgroup{Deletion commands} + +\editproc{ee-delete-char}{delete} +Deletes the character under the cursor. + +See also \scheme{ee-eof/delete-char}. +\endeditproc + +\editproc{ee-backward-delete-char}{backspace (rubout), \cntl{H}} +Deletes the character to the left of the cursor. +\endeditproc + +\editproc{ee-delete-line}{\cntl{U}} +Deletes the contents of the current line, leaving behind an empty line. +When used on the first line of a multiline entry of which only the first line +is displayed, i.e., immediately after history movement, \scheme{ee-delete-line} +deletes the contents of the entire entry, like \scheme{ee-delete-entry} +(described below). +\endeditproc + +\editproc{ee-delete-to-eol}{\cntl{K}, escape-\scheme{K}} +If the cursor is at the end of a line, joins the line with the next +line, otherwise deletes from the cursor position to the end of the line. +\endeditproc + +\editproc{ee-delete-between-point-and-mark}{\cntl{W}} +Deletes text between the current cursor position and the mark. +(The mark can be set with \scheme{ee-set-mark}.) +\endeditproc + +\editproc{ee-delete-entry}{\cntl{G}} +Deletes the contents of the current entry. +\endeditproc + +\editproc{ee-reset-entry}{\cntl{C}} +Deletes the contents of the current entry and moves to the end of the +history. +\endeditproc + +\editproc{ee-delete-sexp}{escape-\cntl{K}, escape-delete} +Deletes the expression that starts under the cursor, or if +no expression starts under the cursor, deletes up to the next +expression. +\endeditproc + +\editproc{ee-backward-delete-sexp}{escape-backspace (escape-rubout), escape-\cntl{H}} +Deletes the expression to the left of the cursor. +\endeditproc + +\ECgroup{Identifier/filename completion commands} + +These commands perform either identifier or filename completion. +Identifier completion is performed outside of a string constant, and filename +completion is performed within a string constant. +(In determining whether the cursor is within a string constant, the +expression editor looks only at the current line and so can be fooled +by string constants that span multiple lines.) + +\editproc{ee-id-completion}{none} +Inserts the common prefix of possible completions of the identifier or +filename immediately to the left of the cursor. +Identifier completion is based on the identifiers +defined in the interaction environment. +When there is exactly one possible completion, the common prefix is the +completion. +This command has no effect if no filename or identifier prefix is +immediately the left of the cursor or if the possible completions have +no common prefix. +If run twice in succession, a list of possible completions is displayed. + +See also +\index{\scheme{ee-id-completion/indent}}\scheme{ee-id-completion/indent}. +\endeditproc + +\editproc{ee-next-id-completion}{\cntl{R}} +Inserts one of the possible completions of the identifier or filename +immediately to the left of the cursor. +Identifier completion is based on the identifiers +defined in the interaction environment. +If run twice or more in succession, this command cycles through all of +the possible completions. +The order is determined by the following heuristics: appearing first +are identifiers whose names appear in the list value of the parameter +\index{\scheme{ee-common-identifiers}}\scheme{ee-common-identifiers}; +appearing second are identifiers bound in the interaction environment +but not bound in the scheme-environment (i.e., identifiers defined by +the user), and appearing last are those in the scheme environment. +Within the set of matches appearing in the \scheme{ee-common-identifiers} +list, those listed earliest are shown first; the order is alphabetical +within the other two sets. + +See also +\index{\scheme{ee-next-id-completion/indent}}\scheme{ee-next-id-completion/indent}. +\endeditproc + +\ECgroup{History movement commands} + +\index{\scheme{--eehistory} command-line-option}% +The expression editor maintains a history of entries during each session. +It also saves the history across sessions unless this behavior is +disabled via the command-line argument ``\scheme{--eehistory off}.'' + +When moving from one history entry to another, only the first line of each +multi-line entry is displayed. +The redisplay command (which \cntl{L} is bound to by default) can be used +to display the entire entry. +It is also possible to move down one line at a time to expose just part of +the rest of the entry. + +\editproc{ee-history-bwd}{escape-uparrow, escape-\cntl{P}} +Moves to the preceding history entry +if the current entry is empty or has not been modified; +otherwise, has no effect. + +See also \scheme{ee-previous-line}. +\endeditproc + +\editproc{ee-history-fwd}{escape-downarrow, escape-\cntl{N}} +Moves to the next history entry +if the current entry is empty or has not been modified; +otherwise, has no effect. + +See also \scheme{ee-next-line}. +\endeditproc + +\editproc{ee-history-bwd-prefix}{escape-\scheme{p}} +Moves to the closest previous history entry, if any, that starts with +the sequence of characters that makes up the current entry. +May be used multiple times to search for same prefix. +\endeditproc + +\editproc{ee-history-fwd-prefix}{escape-\scheme{n}} +Moves to the closest following history entry, if any, that starts with +the sequence of characters that makes up the current entry. +May be used multiple times to search for same prefix. +\endeditproc + +\editproc{ee-history-bwd-contains}{escape-\scheme{P}} +Moves to the closest previous history entry, if any, that contains within +it the sequence of characters that makes up the current entry. +May be used multiple times to search for same content. +\endeditproc + +\editproc{ee-history-fwd-contains}{escape-\scheme{N}} +Moves to the closest following history entry, if any, that contains within +it the sequence of characters that makes up the current entry. +May be used multiple times to search for same content. +\endeditproc + + +\ECgroup{Indentation commands} + +\editproc{ee-indent}{escape-tab} +Re-indents the current line. + +See also \scheme{ee-next-id-completion/indent}. +\endeditproc + +\editproc{ee-indent-all}{escape-\scheme{q}, escape-\scheme{Q}, escape-\cntl{Q}} +Re-indents each line of the entire entry. +\endeditproc + + +\ECgroup{Miscellaneous commands} + +\editproc{ee-accept}{\cntl{J}} +Causes the expression editor to invoke the Scheme reader on the contents +of the entry. +If the read is successful, the expression is returned to the waiter; +otherwise, an error message is printed, the entry redisplayed, and the +cursor left (if possible) at the start of the invalid subform. + +See also \scheme{ee-newline/accept}. +\endeditproc + +\editproc{ee-eof}{none} +Causes end-of-file to be returned from the expression editor, +which in turn causes the waiter to exit. +Ignored unless entry is empty. + +See also \scheme{ee-eof/delete-char}. +\endeditproc + +\editproc{ee-redisplay}{\cntl{L}} +Redisplays the current expression. +If run twice in succession, clears the screen and redisplays the +expression at the top of the screen. +\endeditproc + +\editproc{ee-suspend-process}{\cntl{Z}} +Suspends the current process in shells that support job control. +\endeditproc + +\editproc{ee-set-mark}{\cntl{@}, \cntl{}space} +Sets the mark to the current cursor position. +\endeditproc + +\editproc{ee-command-repeat}{escape-\cntl{U}} +Repeats the next command $n$ times. +If the next character typed is a digit, $n$ is determined by reading +up the sequence of the digits typed and treating it as a decimal +number. +Otherwise, $n$ is the value of the parameter +\index{\scheme{ee-default-repeat}}\scheme{ee-default-repeat}. +\endeditproc + + +\ECgroup{Combination commands} + +\editproc{ee-newline/accept}{enter, \cntl{M}} +Behaves like \scheme{ee-accept} if run at the end (not including +whitespace) of an entry that starts with a balanced expression; +otherwise, behaves like \scheme{ee-newline}. +\endeditproc + +\editproc{ee-id-completion/indent}{tab} +Behaves like \scheme{ee-id-completion} if an identifier (outside +a string constant) or filename (within a string constant) appears +just to the left of the cursor and the last character of that +identifier or filename was just entered; +otherwise, behaves like \scheme{ee-indent}. + +If an existing identifier or filename, i.e., not one just typed, appears to the left +of the cursor, the first use of this command behaves like +\scheme{ee-newline}, the second consecutive use behaves like +\scheme{ee-id-completion}, and the third behaves like a second consecutive +use of \scheme{ee-id-completion}. +\endeditproc + +\editproc{ee-next-id-completion/indent}{none} +Behaves like \scheme{ee-next-id-completion} if an identifier (outside +a string constant) or filename (within a string constant) +appears just to the left of the cursor and the last character of that +identifier or identifier was just entered; +otherwise, behaves like \scheme{ee-indent}. +\endeditproc + +\editproc{ee-eof/delete-char}{\cntl{D}} +Behaves like \scheme{ee-delete-char} if the entry is nonempty; +otherwise, behaves like \scheme{ee-eof}. +If the entry is nonempty and this command is run twice or more in +succession, it does nothing once the entry becomes empty. +This is to prevent accidental exit from the waiter in cases where +the command is run repeatedly (perhaps with the help of a keyboard's +auto-repeat feature) to delete all of the characters in an entry. +\endeditproc + +\section{Creating New Editing Commands\label{SECTEXPEDITORNEWCMDS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{ee-string-macro}{\categoryprocedure}{(ee-string-macro \var{string})} +\nolistlibraries +\returns a new editing command +\endnoskipentryheader + +The new editing command produced inserts \var{string} before the current +cursor position. + +Two string macros are predefined: + +\begin{tabular}{ll} +\scheme{(ee-string-macro "(define ")} & ~~escape-d\\ +\scheme{(ee-string-macro "(lambda ")} & ~~escape-l +\end{tabular} + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ee-compose}{\categoryprocedure}{(ee-compose \var{ecmd} \dots)} +\nolistlibraries +\returns a new editing command +\endentryheader + +Each \var{ecmd} must be an editing command. + +The new editing command runs each of the editing commands +\scheme{\var{ecmd} \dots} in sequence. + +% this is of limited utility until we provide some +% inspection procedures, like point-pos and end-of-line? + +For example, the following expression binds \cntl{X}-p to an editing +command that behaves like \scheme{ee-history-bwd-prefix} but leaves the +cursor at the end of the expression rather than at the end of the first +line, causing the entire entry to be displayed. + +\schemedisplay +(let () + (import expression-editor) + (ee-bind-key "^Xp" + (ee-compose ee-history-bwd ee-end-of-entry))) +\endschemedisplay + +A command such as \scheme{ee-id-completion} that performs a different +action when run twice in succession will not recognize that it has been +run twice in succession if run as part of a composite command. + + diff --git a/csug/foreign.stex b/csug/foreign.stex new file mode 100644 index 0000000..e42c432 --- /dev/null +++ b/csug/foreign.stex @@ -0,0 +1,3873 @@ +% Copyright 2005-2018 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Foreign Interface\label{CHPTFOREIGN}} + + +{\ChezScheme} provides two ways to interact with ``foreign'' code, +i.e., code written in other languages. +The first is via subprocess creation and communication, which is +discussed in the Section~\ref{SECTFOREIGNSUBPROCESS}. +The second is via static or dynamic loading and invocation from Scheme +of procedures written in \index{C (programming language)}C and +invocation from C of procedures written in Scheme. +These mechanisms are discussed in Sections~\ref{SECTFOREIGNPROCEDURES} +through~\ref{SECTFOREIGNCONTINUATIONS}. + +The method for static loading of C object code is dependent upon which +machine you are running; see the installation instructions distributed +with {\ChezScheme}. + + +\section{Subprocess Communication\label{SECTFOREIGNSUBPROCESS}} + +Two procedures, \index{\scheme{system}}\scheme{system} and \index{\scheme{process}}\scheme{process}, are used to create +\index{creating subprocesses}subprocesses. +Both procedures accept a single string argument and create a +subprocess to execute the shell command contained in the string. +The \scheme{system} procedure waits for the process to exit before +returning, however, +while the \scheme{process} procedure returns immediately without +waiting for the process to exit. +The standard input and output files of a subprocess created by \scheme{system} +may be used to communicate with the user's console. +The standard +input and output files of a subprocess created by \scheme{process} may be used +to communicate with the Scheme process. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{system}{\categoryprocedure}{(system \var{command})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{command} must be a string. + +The \scheme{system} procedure creates a subprocess to perform the operation +specified by \var{command}. +The subprocess may communicate with the user through the same console +input and console output files used by the Scheme process. +After creating the subprocess, \scheme{system} waits for the process to exit +before returning. + +When the subprocess exits, \scheme{system} returns the exit code for the +subprocess, unless (on Unix-based systems) a signal caused the subprocess +to terminate, in which case \scheme{system} returns the negation of the +signal that caused the termination, e.g., -1 for \scheme{SIGHUP}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-process-ports}{\categoryprocedure}{(open-process-ports \var{command})} +\formdef{open-process-ports}{\categoryprocedure}{(open-process-ports \var{command} \var{b-mode})} +\formdef{open-process-ports}{\categoryprocedure}{(open-process-ports \var{command} \var{b-mode} \var{?transcoder})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{command} must be a string. +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure creates textual ports, each of whose +transcoder is \var{?transcoder}. +Otherwise, this procedure returns binary ports. +\var{b-mode} specifies the buffer mode used by each of the ports +returned by this procedure and defaults to \scheme{block}. +Buffer modes are described in Section~\ref{TSPL:SECTOPENINGFILES} of +{\TSPLFOUR}. + +\scheme{open-process-ports} creates a subprocess to perform the operation +specified by \var{command}. +Unlike \scheme{system}, \scheme{process} returns immediately after creating the +subprocess, i.e., without waiting for the subprocess to terminate. +It returns four values: + +\begin{enumerate} +\item +\var{to-stdin} is an output port to which Scheme can send output to the +subprocess through the subprocess's standard input file. + +\item +\var{from-stdout} is an input port from which Scheme can read input from +the subprocess through the subprocess's standard output file. + +\item +\var{from-stderr} is an input port from which Scheme can read input from +the subprocess through the subprocess's standard error file. + +\item +\var{process-id} is an integer identifying the created subprocess +provided by the host operating system. +\end{enumerate} + +\noindent +If the process exits or closes its standard output file descriptor, any +procedure that reads input from \var{from-stdout} will return an +end-of-file object. +Similarly, if the process exits or closes its standard error file +descriptor, any procedure that reads input from \var{from-stderr} will +return an end-of-file object. + +The predicate \index{\scheme{input-port-ready?}}\scheme{input-port-ready?} +may be used to detect whether input has been sent by the subprocess to +Scheme. + +It is sometimes necessary to force output to be sent immediately +to the subprocess by invoking \scheme{flush-output-port} on +\var{to-stdin}, since {\ChezScheme} buffers the output for efficiency. + +On UNIX systems, the \var{process-id} is the process identifier +for the shell created to execute \var{command}. +If \var{command} is used to invoke an executable file rather than +a shell command, it may be useful to prepend \var{command} with +the string \scheme{"exec "}, which causes the shell to load and execute +the named executable directly, without forking a new +process---the shell equivalent of a tail call. +This will reduce by one the number of subprocesses created and +cause \var{process-id} to reflect the process identifier for the +executable once the shell has transferred control. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{process}{\categoryprocedure}{(process \var{command})} +\returns see explanation +\listlibraries +\endentryheader + +\noindent +\var{command} must be a string. + +\scheme{process} is similar to \scheme{open-process-ports}, but less +general. +It does not return a port from which the subprocess's standard error output +can be read, and it always creates textual ports. +It returns a list of three values rather than the four separate values +of \scheme{open-process-ports}. +The returned list contains, in order: \var{from-stdout}, +\var{to-stdin}, and \var{process-id}, which correspond to the second, +first, and fourth return values of \scheme{open-process-ports}. + + +\def\foreigntype#1 {\medskip\noindent#1: } + +\section{Calling out of Scheme\label{SECTFOREIGNPROCEDURES}} + +{\ChezScheme}'s \index{foreign-procedure interface}foreign-procedure interface allows a Scheme program +to invoke +procedures written in \index{C (programming language)}C or in languages that obey the same +calling conventions as C. +Two steps are necessary before foreign procedures can be invoked from Scheme. +First, the foreign procedure must be compiled and loaded, +either statically or dynamically, +as described in Section~\ref{SECTFOREIGNACCESS}. +Then, access to the foreign procedure must be established in Scheme, +as described in this section. +Once access to a foreign procedure has been established it may be called as an +ordinary Scheme procedure. + +Since foreign procedures operate independently of the Scheme memory management +and exception handling system, great care must be taken when using them. +Although the foreign-procedure interface provides +type checking (at optimize levels less than 3) and +type conversion, the programmer must ensure that +the sharing of data between Scheme and foreign procedures is done safely by +specifying proper argument and result types. + +Scheme-callable wrappers for foreign procedures can also be created via +\scheme{ftype-ref} and function ftypes (Section~\ref{SECTFOREIGNDATA}). + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-procedure}{\categorysyntax}{(foreign-procedure \var{conv} \dots \var{entry-exp} (\var{param-type} \dots) \var{res-type})} +\returns a procedure +\listlibraries +\endentryheader + +\noindent +\var{entry-exp} must evaluate to a string representing a valid foreign +procedure entry point or an integer representing the address of the +foreign procedure. +The \var{param-types} and \var{res-type} must be symbols or +structured forms as described below. +When a \scheme{foreign-procedure} expression is evaluated, a Scheme procedure is +created that will invoke the foreign procedure specified by \var{entry-exp}. +When the procedure is called each argument is checked and converted according to +the specified \var{param-type} before it is passed to the foreign procedure. +The result of the foreign procedure call is converted as specified +by the \var{res-type}. +Multiple procedures may be created for the same \index{foreign entry}foreign entry. + +\label{page:conv-description}% +Each \var{conv} adjusts specifies the calling convention to be used. +A \scheme{#f} is allowed as \var{conv} to indicate the default calling convention +on the target machine (so the \scheme{#f} has no effect). +Three other conventions are currently supported under +Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only). +Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is +equivalent to specifying \scheme{#f} or no convention. +Finally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage +collection is allowed concurrent to a call of the foreign procedure. + +Use \scheme{__stdcall} to access most Windows API procedures. +Use \scheme{__cdecl} for Windows API varargs procedures, +for C library procedures, and for most other procedures. +Use \scheme{__com} to invoke COM interface methods; COM uses the +\scheme{__stdcall} convention but additionally performs the indirections +necessary to obtain the correct method from a COM instance. +The address of the COM instance must be passed as the first argument, +which should normally be declared as \scheme{iptr}. +For the \scheme{__com} interface only, \var{entry-exp} must evaluate +to the byte offset of the method in the COM vtable. +For example, + +\schemedisplay +(foreign-procedure __com 12 (iptr double-float) integer-32) +\endschemedisplay + +% MichaelL@frogware.com: +% [Minor point: It would be more impressive to use the three methods of IUnknown +% for your example since every COM interface must support them. See +% http://msdn.microsoft.com/library/default.asp?url=/library/en-us/com/html/33f1d7 +% 9a-33fc-4ce5-a372-e08bda378332.asp +% for details.] + +\noindent +creates an interface to a COM method at offset 12 in the vtable +encapsulated within the COM instance passed as the first argument, +with the second argument being a double float and the return +value being an integer. + +Use \scheme{__collect_safe} to declare that garbage collection is +allowed concurrent to the foreign procedure. The +\scheme{__collect_safe} declaration allows concurrent collection by +deactivating the current thread (see \scheme{fork-thread}) when the +foreign procedure is called, and the thread is activated again when +the foreign procedure returns. The \scheme{__collect_safe} declaration +is useful, for example, when calling a blocking I/O call to allow +other Scheme threads to run normally. Refrain from passing collectable memory to a +\scheme{__collect_safe} foreign procedure, or use \scheme{lock-object} +to lock the memory in place; see also \scheme{Sdeactivate_thread}. The +\scheme{__collect_safe} declaration has no effect on a non-threaded +version of the system. + +For example, calling the C \scheme{sleep} function with the default +convention will block other Scheme threads from performing a garbage +collection, but adding the \scheme{__collect_safe} declaration avoids that +problem: + +\schemedisplay +(define c-sleep + (foreign-procedure __collect_safe "sleep" (unsigned) unsigned)) +(c-sleep 10) \var{; sleeps for 10 seconds without blocking other threads} +\endschemedisplay + +\noindent +If a foreign procedure that is called with \scheme{__collect_safe} can +invoke callables, then each callable should also be declared with +\scheme{__collect_safe} so that the callable reactivates the thread. + + +Complete type checking and conversion is performed on the parameters +to a foreign procedure. +The types +\index{\scheme{scheme-object}}\scheme{scheme-object}, +\index{\scheme{string}}\scheme{string}, +\index{\scheme{wstring}}\scheme{wstring}, +\index{\scheme{u8*}}\scheme{u8*}, +\index{\scheme{u16*}}\scheme{u16*}, +\index{\scheme{u32*}}\scheme{u32*}, +\index{\scheme{utf-8}}\scheme{utf-8}, +\index{\scheme{utf-16le}}\scheme{utf-16le}, +\index{\scheme{utf-16be}}\scheme{utf-16be}, +\index{\scheme{utf-32le}}\scheme{utf-32le}, +and +\index{\scheme{utf-32be}}\scheme{utf-32be}, +must be used with caution, however, since they allow allocated +Scheme objects to be used in places the Scheme memory management system +cannot control. No problems will arise as long as such objects are not +retained in foreign variables or data structures while Scheme code is running, +and as long as they are not passed as arguments to a \scheme{__collect_safe} procedure, +since garbage collection can occur only while Scheme code is running +or when concurrent garbage collection is enabled. +Other parameter types are converted to equivalent foreign +representations and consequently they can be retained indefinitely in +foreign variables and data structures. + +For argument types \scheme{string}, \scheme{wstring}, +\index{\scheme{utf-8}}\scheme{utf-8}, +\index{\scheme{utf-16le}}\scheme{utf-16le}, +\index{\scheme{utf-16be}}\scheme{utf-16be}, +\index{\scheme{utf-32le}}\scheme{utf-32le}, and +\index{\scheme{utf-32be}}\scheme{utf-32be}, an argument is converted +to a fresh object that is passed to the foreign procedure. Since the +fresh object is not accessible for locking before the call, it can +never be treated correctly for a \scheme{__collect_safe} foreign +procedure, so those types are disallowed as argument types for +a \scheme{__collect_safe} foreign procedure. For analogous reasons, +those types are disallowed as the result of a \scheme{__collect_safe} +foreign callable. + +Following are the valid parameter types: + +\foreigntype{\scheme{integer-8}} +\index{\scheme{integer-8}}Exact integers from $-2^{7}$ through +$2^{8}-1$ are valid. +Integers in the range $2^{7}$ through $2^{8}-1$ are treated as +two's complement representations of negative numbers, e.g., +\scheme{#xff} is treated as $-1$. +The argument is passed to C as an integer of the appropriate size +(usually \scheme{signed char}). + +\foreigntype{\scheme{unsigned-8}} +\index{\scheme{unsigned-8}}Exact integers from $-2^{7}$ to +$2^{8}-1$ are valid. +Integers in the range $-2^{7}$ through $-1$ are treated as the +positive equivalents of their two's complement representation, +e.g., $-1$ is treated as \scheme{#xff}. +The argument is passed to C as an unsigned integer of the +appropriate size (usually \scheme{unsigned char}). + +\foreigntype{\scheme{integer-16}} +\index{\scheme{integer-16}}Exact integers from $-2^{15}$ through +$2^{16}-1$ are valid. +Integers in the range $2^{15}$ through $2^{16}-1$ are treated as +two's complement representations of negative numbers, e.g., +\scheme{#xffff} is treated as $-1$. +The argument is passed to C as an integer of the appropriate size +(usually \scheme{short}). + +\foreigntype{\scheme{unsigned-16}} +\index{\scheme{unsigned-16}}Exact integers from $-2^{15}$ to +$2^{16}-1$ are valid. +Integers in the range $-2^{15}$ through $-1$ are treated as the +positive equivalents of their two's complement representation, +e.g., $-1$ is treated as \scheme{#xffff}. +The argument is passed to C as an unsigned integer of the +appropriate size (usually \scheme{unsigned short}). + +\foreigntype{\scheme{integer-32}} +\index{\scheme{integer-32}}Exact integers from $-2^{31}$ through +$2^{32}-1$ are valid. +Integers in the range $2^{31}$ through $2^{32}-1$ are treated as +two's complement representations of negative numbers, e.g., +\scheme{#xffffffff} is treated as $-1$. +The argument is passed to C as an integer of the appropriate size +(usually \scheme{int}). + +\foreigntype{\scheme{unsigned-32}} +\index{\scheme{unsigned-32}}Exact integers from $-2^{31}$ to +$2^{32}-1$ are valid. +Integers in the range $-2^{31}$ through $-1$ are treated as the +positive equivalents of their two's complement representation, +e.g., $-1$ is treated as \scheme{#xffffffff}. +The argument is passed to C as an unsigned integer of the +appropriate size (usually \scheme{unsigned int}). + +\foreigntype{\scheme{integer-64}} +\index{\scheme{integer-64}}Exact integers from $-2^{63}$ through +$2^{64}-1$ are valid. +Integers in the range $2^{63}$ through $2^{64}-1$ are treated as +two's complement representations of negative numbers. +The argument is passed to C as an integer of the appropriate +size (usually \scheme{long long} or, on many 64-bit platforms, +\scheme{long}). + +\foreigntype{\scheme{unsigned-64}} +\index{\scheme{unsigned-64}}Exact integers from $-2^{63}$ through +$2^{64}-1$ are valid. +Integers in the range $-2^{63}$ through $-1$ are treated as the +positive equivalents of their two's complement representation, +The argument is passed to C as an integer of the appropriate +size (usually \scheme{unsigned long long} or, on many 64-bit +platforms, \scheme{long}). + +\foreigntype{\scheme{double-float}} +\index{\scheme{double-float}}Only Scheme flonums are valid---other +Scheme numeric types are not automatically converted. +The argument is passed to C as a double float. + +\foreigntype{\scheme{single-float}} +\index{\scheme{single-float}}Only Scheme flonums are valid---other +Scheme numeric types are not automatically converted. +The argument is passed to C as a single float. +Since {\ChezScheme} represents flonums in double-float format, the +parameter is first converted into single-float format. + +\foreigntype{\scheme{short}} +\index{\scheme{short}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{short}. + +\foreigntype{\scheme{unsigned-short}} +\index{\scheme{unsigned short}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{unsigned short}. + +\foreigntype{\scheme{int}} +\index{\scheme{int}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{int}. + +\foreigntype{\scheme{unsigned}} +\index{\scheme{unsigned}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{unsigned}. + +\foreigntype{\scheme{unsigned-int}} +\index{\scheme{unsigned-int}}This type is an alias \scheme{unsigned}. +fixed-size type above, depending on the size of a C \scheme{unsigned}. + +\foreigntype{\scheme{long}} +\index{\scheme{long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{long}. + +\foreigntype{\scheme{unsigned-long}} +\index{\scheme{unsigned long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{unsigned long}. + +\foreigntype{\scheme{long-long}} +\index{\scheme{long-long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of the nonstandard C type +\scheme{long long}. + +\foreigntype{\scheme{unsigned-long-long}} +\index{\scheme{unsigned-long-long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of the nonstandard C type +\scheme{unsigned long long}. + +\foreigntype{\scheme{ptrdiff_t}} +\index{\scheme{ptrdiff_t}}This type is an alias for the appropriate +fixed-size type above, depending on its definition in the host machine's +\scheme{stddef.h} include file. + +\foreigntype{\scheme{size_t}} +\index{\scheme{size_t}}This type is an alias for the appropriate unsigned +fixed-size type above, depending on its definition in the host machine's +\scheme{stddef.h} include file. + +\foreigntype{\scheme{ssize_t}} +\index{\scheme{ssize_t}}This type is an alias for the appropriate signed +fixed-size type above, depending on its definition in the host machine's +\scheme{stddef.h} include file. + +\foreigntype{\scheme{iptr}} +\index{\scheme{iptr}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C pointer. + +\foreigntype{\scheme{uptr}} +\index{\scheme{uptr}}This type is an alias for the appropriate +(unsigned) fixed-size type above, depending on the size of a C pointer. + +\foreigntype{\scheme{void*}} +\index{\scheme{void*}}This type is an alias for \scheme{uptr}. + +\foreigntype{\scheme{fixnum}} +\index{\scheme{fixnum}}This type is equivalent to \scheme{iptr}, +except only values in the fixnum range are valid. +Transmission of fixnums is slightly faster than transmission of +\scheme{iptr} values, but the fixnum range is smaller, so some +\scheme{iptr} values do not have a fixnum representation. + +\foreigntype{\scheme{boolean}} +\index{\scheme{boolean}}Any Scheme object may be passed as a boolean. +\scheme{#f} is converted to 0; all other objects are converted to 1. +The argument is passed to C as an \scheme{int}. + +\foreigntype{\scheme{char}} +\index{\scheme{char}}Only Scheme characters with Unicode scalar values +in the range 0 through 255 are valid \scheme{char} parameters. +The character is converted to its Unicode scalar value, as with +\scheme{char->integer}, and passed to C as an \scheme{unsigned char}. + +\foreigntype{\scheme{wchar_t}} +\index{\scheme{wchar_t}}Only Scheme characters are valid \scheme{wchar_t} parameters. +Under Windows and any other system where \scheme{wchar_t} holds only +16-bit values rather than full Unicode scalar values, only characters with +16-bit Unicode scalar values are valid. +On systems where \scheme{wchar_t} is a full 32-bit value, any Scheme +character is valid. +The character is converted to its Unicode scalar value, as with +\scheme{char->integer}, and passed to C as a \scheme{wchar_t}. + +\foreigntype{\scheme{wchar}} +\index{\scheme{wchar}}This type is an alias for \scheme{wchar_t}. + +\foreigntype{\scheme{double}} +\index{\scheme{double}}This type is an alias for \scheme{double-float}. + +\foreigntype{\scheme{float}} +\index{\scheme{float}}This type is an alias for \scheme{single-float}. + +\foreigntype{\scheme{scheme-object}} +\index{\scheme{scheme-object}}The argument is passed directly to the +foreign procedure; no conversion or type checking is performed. +This form of parameter passing should be used with discretion. +Scheme objects should not be preserved in foreign variables or data structures +since the memory management system may relocate them between foreign procedure +calls. + +\foreigntype{\scheme{ptr}} +\index{\scheme{ptr}}This type is an alias for \scheme{scheme-object}. + +\foreigntype{\scheme{u8*}} +\index{\scheme{u8*}}The argument must be a Scheme bytevector or +\scheme{#f}. +For \scheme{#f}, the null pointer (0) is passed to the foreign procedure. +For a bytevector, a pointer to the first byte of the bytevector's data +is passed. +If the C routine to which the data is passed requires the input to be +null-terminated, a null (0) byte must be included explicitly in the +bytevector. +The bytevector should not be retained in foreign variables or data +structures, since the memory management system may relocate or discard +them between foreign procedure calls, and use their storage for some +other purpose. + +\foreigntype{\scheme{u16*}} +\index{\scheme{u16*}}Arguments of this type are treated just like +arguments of type \scheme{u8*}. +If the C routine to which the data is passed requires the input to be +null-terminated, two null (0) bytes must be included explicitly in the +bytevector, aligned on a 16-bit boundary. + +\foreigntype{\scheme{u32*}} +\index{\scheme{u32*}}Arguments of this type are treated just like +arguments of type \scheme{u8*}. +If the C routine to which the data is passed requires the input to be +null-terminated, four null (0) bytes must be included explicitly in the +bytevector, aligned on a 32-bit boundary. + +\foreigntype{\scheme{utf-8}} +\index{\scheme{utf-8}}The argument must be a Scheme string or +\scheme{#f}. +For \scheme{#f}, the null pointer (0) is passed to the foreign procedure. +A string is converted into a bytevector, as if via \scheme{string->utf8}, +with an added null byte, and the address of the first byte of the +bytevector is passed to C. +The bytevector should not be retained in foreign variables or data +structures, since the memory management system may relocate or discard +them between foreign procedure calls and use their storage for some +other purpose. The \scheme{utf-8} argument type is not allowed for a +\scheme{__collect_safe} foreign procedure. + +\foreigntype{\scheme{utf-16le}} +\index{\scheme{utf-16le}}Arguments of this type are treated like arguments +of type \scheme{utf-8}, except they are converted as if via +\scheme{string->utf16} with endianness \scheme{little}, and they are +extended by two null bytes rather than one. + +\foreigntype{\scheme{utf-16be}} +\index{\scheme{utf-16be}}Arguments of this type are treated like arguments +of type \scheme{utf-8}, except they are converted as if via +\scheme{string->utf16} with endianness \scheme{big}, and they are +extended by two null bytes rather than one. + +\foreigntype{\scheme{utf-32le}} +\index{\scheme{utf-32le}}Arguments of this type are treated like arguments +of type \scheme{utf-8}, except they are converted as if via +\scheme{string->utf32} with endianness \scheme{little}, and they are +extended by four null bytes rather than one. + +\foreigntype{\scheme{utf-32be}} +\index{\scheme{utf-32be}}Arguments of this type are treated like arguments +of type \scheme{utf-8}, except they are converted as if via +\scheme{string->utf32} with endianness \scheme{big}, and they are +extended by four null bytes rather than one. + +\foreigntype{\scheme{string}} +\index{\scheme{string}}This type is an alias for \scheme{utf-8}. + +\foreigntype{\scheme{wstring}} +\index{\scheme{string}}This type is an alias for \scheme{utf-16le}, +\scheme{utf-16be}, \scheme{utf-32le}, or \scheme{utf-32be} as +appropriate depending on the size of a C \scheme{wchar_t} and +the endianness of the target machine. +For example, \scheme{wstring} is equivalent to \scheme{utf-16le} +under Windows running on Intel hardware. + +\foreigntype{\scheme{(* \var{ftype-name})}} +\index{ftype}This type allows a pointer to a foreign +type (ftype) to be passed. +The argument must be an ftype pointer of the type identified by +\var{ftype-name}, +and the actual argument is the address encapsulated in the +ftype pointer. +See Section~\ref{SECTFOREIGNDATA} for a description of +foreign types. + +\foreigntype{\scheme{(& \var{ftype-name})}} +\index{ftype}This type allows a foreign +type (ftype) to be passed as a value, but represented +on the Scheme side as a pointer to the foreign-type data. +That is, a \scheme{(& \var{ftype-name})} argument is represented on +the Scheme side the same as a \scheme{(* \var{ftype-name})} argument, +but a \scheme{(& \var{ftype-name})} argument is passed to the foreign procedure as the +content at the foreign pointer's address instead of as the +address. For example, if \var{ftype-name} identifies a \scheme{struct} type, +then \scheme{(& \var{ftype-name})} passes a struct argument instead of +a struct-pointer argument. The \var{ftype-name} cannot refer to an array type. + +\medskip\noindent +The result types are similar to the parameter types with the addition of a +\index{\scheme{void}}\scheme{void} type. +In general, the type conversions are the inverse of the parameter type +conversions. +No error checking is performed on return, since the system cannot determine +whether a foreign result is actually of the indicated type. +Particular caution should be exercised with the result types +\index{\scheme{scheme-object}}\scheme{scheme-object}, +\index{\scheme{double-float}}\scheme{double-float}, +\index{\scheme{double}}\scheme{double}, +\index{\scheme{single-float}}\scheme{single-float}, +\index{\scheme{float}}\scheme{float}, +and the types that result in the construction of bytevectors or strings, +since invalid +return values may lead to invalid memory references as well as incorrect +computations. +Following are the valid result types: + +\foreigntype{\scheme{void}} +\index{\scheme{void}}The result of the foreign procedure call is +ignored and an unspecified Scheme object is returned. +\scheme{void} should be used when foreign procedures are called for effect only. + +\foreigntype{\scheme{integer-8}} +\index{\scheme{integer-8}}The result is interpreted as a signed +8-bit integer and is converted to a Scheme exact integer. + +\foreigntype{\scheme{unsigned-8}} +\index{\scheme{unsigned-8}}The result is interpreted as an unsigned +8-bit integer and is converted to a Scheme nonnegative exact integer. + +\foreigntype{\scheme{integer-16}} +\index{\scheme{integer-16}}The result is interpreted as a signed +16-bit integer and is converted to a Scheme exact integer. + +\foreigntype{\scheme{unsigned-16}} +\index{\scheme{unsigned-16}}The result is interpreted as an unsigned +16-bit integer and is converted to a Scheme nonnegative exact integer. + +\foreigntype{\scheme{integer-32}} +\index{\scheme{integer-32}}The result is interpreted as a signed +32-bit integer and is converted to a Scheme exact integer. + +\foreigntype{\scheme{unsigned-32}} +\index{\scheme{unsigned-32}}The result is interpreted as an unsigned +32-bit integer and is converted to a Scheme nonnegative exact integer. + +\foreigntype{\scheme{integer-64}} +\index{\scheme{integer-64}}The result is interpreted as a signed +64-bit integer and is converted to a Scheme exact integer. + +\foreigntype{\scheme{unsigned-64}} +\index{\scheme{unsigned-64}}The result is interpreted as an unsigned +64-bit integer and is converted to a Scheme nonnegative exact integer. + +\foreigntype{\scheme{double-float}} +\index{\scheme{double-float}}The result is interpreted as a double float +and is translated into a {\ChezScheme} flonum. + +\foreigntype{\scheme{single-float}} +\index{\scheme{single-float}}The result is interpreted as a single float +and is translated into a {\ChezScheme} flonum. +Since {\ChezScheme} represents flonums in double-float format, the +result is first converted into double-float format. + +\foreigntype{\scheme{short}} +\index{\scheme{short}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{short}. + +\foreigntype{\scheme{unsigned-short}} +\index{\scheme{unsigned short}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{unsigned short}. + +\foreigntype{\scheme{int}} +\index{\scheme{int}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{int}. + +\foreigntype{\scheme{unsigned}} +\index{\scheme{unsigned}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{unsigned}. + +\foreigntype{\scheme{unsigned-int}} +\index{\scheme{unsigned-int}}This type is an alias \scheme{unsigned}. +fixed-size type above, depending on the size of a C \scheme{unsigned}. + +\foreigntype{\scheme{long}} +\index{\scheme{long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{long}. + +\foreigntype{\scheme{unsigned-long}} +\index{\scheme{unsigned long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C \scheme{unsigned long}. + +\foreigntype{\scheme{long-long}} +\index{\scheme{long-long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of the nonstandard C type +\scheme{long long}. + +\foreigntype{\scheme{unsigned-long-long}} +\index{\scheme{unsigned-long-long}}This type is an alias for the appropriate +fixed-size type above, depending on the size of the nonstandard C type +\scheme{unsigned long long}. + +\foreigntype{\scheme{ptrdiff_t}} +\index{\scheme{ptrdiff_t}}This type is an alias for the appropriate +fixed-size type above, depending on its definition in the host machine's +\scheme{stddef.h} include file. + +\foreigntype{\scheme{size_t}} +\index{\scheme{size_t}}This type is an alias for the appropriate unsigned +fixed-size type above, depending on its definition in the host machine's +\scheme{stddef.h} include file. + +\foreigntype{\scheme{ssize_t}} +\index{\scheme{ssize_t}}This type is an alias for the appropriate signed +fixed-size type above, depending on its definition in the host machine's +\scheme{stddef.h} include file. + +\foreigntype{\scheme{iptr}} +\index{\scheme{iptr}}This type is an alias for the appropriate +fixed-size type above, depending on the size of a C pointer. + +\foreigntype{\scheme{uptr}} +\index{\scheme{uptr}}This type is an alias for the appropriate +(unsigned) fixed-size type above, depending on the size of a C pointer. + +\foreigntype{\scheme{void*}} +\index{\scheme{void*}}This type is an alias for \scheme{uptr}. + +\foreigntype{\scheme{boolean}} +\index{\scheme{boolean}}This type converts a C \scheme{int} return value +into a Scheme boolean. +0 is converted to \scheme{#f}; all other values are converted to \scheme{#t}. + +\foreigntype{\scheme{char}} +\index{\scheme{char}}This type converts a C \scheme{unsigned char} return value +into a Scheme character, as if via \scheme{integer->char}. + +\foreigntype{\scheme{wchar_t}} +\index{\scheme{wchar_t}}This type converts a C \scheme{wchar_t} return value +into a Scheme character, as if via \scheme{integer->char}. +The \scheme{wchar_t} value must be a valid Unicode scalar value. + +\foreigntype{\scheme{wchar}} +\index{\scheme{wchar}}This type is an alias for \scheme{wchar_t}. + +\foreigntype{\scheme{double}} +\index{\scheme{double}}This type is an alias for \scheme{double-float}. + +\foreigntype{\scheme{float}} +\index{\scheme{float}}This type is an alias for \scheme{single-float}. + +\foreigntype{\scheme{scheme-object}} +\index{\scheme{scheme-object}}The result is assumed to be a valid Scheme +object, and no conversion is performed. +This type is inherently dangerous, since an invalid Scheme object can corrupt +the memory management system with unpredictable (but always unpleasant) results. +Since Scheme objects are actually typed pointers, even integers cannot +safely be returned as type \scheme{scheme-object} unless they were created by +the Scheme system. + +\foreigntype{\scheme{ptr}} +\index{\scheme{ptr}}This type is an alias for \scheme{scheme-object}. + +\foreigntype{\scheme{u8*}} +\index{\scheme{u8*}}The result is interpreted as a pointer to a +null-terminated sequence of 8-bit unsigned integers (bytes). +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of bytes is stored in a freshly allocated +bytevector of the appropriate length, and the bytevector is returned to +Scheme. + +\foreigntype{\scheme{u16*}} +\index{\scheme{u16*}}The result is interpreted as a pointer to a +null-terminated sequence of 16-bit unsigned integers. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of 16-bit integers is stored in a freshly allocated +bytevector of the appropriate length, and the bytevector is returned to +Scheme. +The null terminator must be a properly aligned 16-bit word, +i.e., two bytes of zero aligned on a 16-bit boundary. + +\foreigntype{\scheme{u32*}} +\index{\scheme{u16*}}The result is interpreted as a pointer to a +null-terminated sequence of 32-bit unsigned integers. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of 16-bit integers is stored in a freshly allocated +bytevector of the appropriate length, and the bytevector is returned to +Scheme. +The null terminator must be a properly aligned 32-bit word, +i.e., four bytes of zero aligned on a 32-bit boundary. + +\foreigntype{\scheme{utf-8}} +\index{\scheme{utf-8}}The result is interpreted as a pointer to a +null-terminated sequence of 8-bit unsigned character values. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of bytes is converted into a Scheme string, as if +via \scheme{utf8->string}, and the string is returned to Scheme. + +\foreigntype{\scheme{utf-16le}} +\index{\scheme{utf-16le}}The result is interpreted as a pointer to a +null-terminated sequence of 16-bit unsigned integers. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of integers is converted into a Scheme string, as if +via \scheme{utf16->string} with endianness \scheme{little}, +and the string is returned to Scheme. +A byte-order mark in the sequence of integers as treated as an ordinary +character value and does not affect the byte ordering. + +\foreigntype{\scheme{utf-16be}} +\index{\scheme{utf-16be}}The result is interpreted as a pointer to a +null-terminated sequence of 16-bit unsigned integers. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of integers is converted into a Scheme string, as if +via \scheme{utf16->string} with endianness \scheme{big}, +and the string is returned to Scheme. +A byte-order mark in the sequence of integers as treated as an ordinary +character value and does not affect the byte ordering. + +\foreigntype{\scheme{utf-32le}} +\index{\scheme{utf-32le}}The result is interpreted as a pointer to a +null-terminated sequence of 32-bit unsigned integers. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of integers is converted into a Scheme string, as if +via \scheme{utf32->string} with endianness \scheme{little}, +and the string is returned to Scheme. +A byte-order mark in the sequence of integers as treated as an ordinary +character value and does not affect the byte ordering. + +\foreigntype{\scheme{utf-32be}} +\index{\scheme{utf-32be}}The result is interpreted as a pointer to a +null-terminated sequence of 32-bit unsigned integers. +If the result is a null pointer, \scheme{#f} is returned. +Otherwise, the sequence of integers is converted into a Scheme string, as if +via \scheme{utf32->string} with endianness \scheme{big}, +and the string is returned to Scheme. +A byte-order mark in the sequence of integers as treated as an ordinary +character value and does not affect the byte ordering. + +\foreigntype{\scheme{string}} +\index{\scheme{string}}This type is an alias for \scheme{utf-8}. + +\foreigntype{\scheme{wstring}} +\index{\scheme{string}}This type is an alias for \scheme{utf-16le}, +\scheme{utf-16be}, \scheme{utf-32le}, or \scheme{utf-32be} as +appropriate depending on the size of a C \scheme{wchar_t} and +the endianness of the target machine. +For example, \scheme{wstring} is equivalent to \scheme{utf-16le} +under Windows running on Intel hardware. + +\foreigntype{\scheme{(* \var{ftype-name})}} +\index{ftype}The result is interpreted as the address of a foreign object +whose structure is described by the ftype identified by \var{ftype-name}, and a freshly allocated +ftype pointer encapsulating the address is returned. +See Section~\ref{SECTFOREIGNDATA} for a description of +foreign types. + +\foreigntype{\scheme{(& \var{ftype-name})}} +\index{ftype}The result is interpreted as a foreign object +whose structure is described by the ftype identified by \var{ftype-name}, where the foreign +procedure returns a \var{ftype-name} result, but the caller +must provide an extra \scheme{(* \var{ftype-name})} argument before +all other arguments to receive the result. An unspecified Scheme object +is returned when the foreign procedure is called, since the result +is instead written into storage referenced by the extra argument. + The \var{ftype-name} cannot refer to an array type. + +\medskip\noindent +Consider a C identity procedure: +\schemedisplay +int id(x) int x; { return x; } +\endschemedisplay + +\noindent +After a file containing this procedure has been compiled and loaded +(see Section~\ref{SECTFOREIGNACCESS}) it can be accessed as follows: + +\schemedisplay +(foreign-procedure "id" + (int) int) ;=> # +((foreign-procedure "id" + (int) int) + 1) ;=> 1 +(define int-id + (foreign-procedure "id" + (int) int)) +(int-id 1) ;=> 1 +\endschemedisplay + +\noindent +The \scheme{"id"} entry can also be interpreted as accepting and returning +a boolean: + +\schemedisplay +(define bool-id + (foreign-procedure "id" + (boolean) boolean)) +(bool-id #f) ;=> #f +(bool-id #t) ;=> #t +(bool-id 1) ;=> #t +\endschemedisplay + +\noindent +As the last example reveals, \scheme{bool-id} is actually a conversion procedure. +When a Scheme object is passed as type \scheme{boolean} it is converted to +0 or 1, and when it is returned it is converted to \scheme{#f} or \scheme{#t}. +As a result objects are converted to normalized boolean values. +The \scheme{"id"} entry can be used to create other conversion procedures by +varying the type specifications: + +\schemedisplay +(define int->bool + (foreign-procedure "id" + (int) boolean)) +(int->bool 0) ;=> #f +(int->bool 5) ;=> #t +(map (foreign-procedure "id" + (boolean) int) + '(#t #f)) ;=> (1 0) +(define void + (foreign-procedure "id" + (int) void)) +(void 10) ;=> \var{unspecified} +\endschemedisplay + +There are, of course, simpler and more efficient ways of accomplishing +these conversions directly in Scheme. + +A foreign entry is resolved when a +\index{\scheme{foreign-procedure}}\scheme{foreign-procedure} expression +is evaluated, rather than either when the code is loaded or each time +the procedure is invoked. +Thus, the following definition is always valid since the +\scheme{foreign-procedure} expression is not immediately evaluated: + +\schemedisplay +(define doit + (lambda () + ((foreign-procedure "doit" () void)))) +\endschemedisplay + +\noindent +\scheme{doit} should not be invoked, however, before an entry for +\scheme{"doit"} has been provided. +Similarly, an entry for \scheme{"doit"} must exist before the following code +is evaluated: + +\schemedisplay +(define doit + (foreign-procedure "doit" () void)) +\endschemedisplay + +\noindent +Although the second definition is more constraining on the load order +of foreign files, it is more efficient since the entry resolution need +be done only once. + +It is often useful to define a template to be used +in the creation of several foreign procedures with similar argument +types and return values. +For example, the following code creates two foreign procedures from +a single foreign procedure expression, by abstracting out the foreign +procedure name: + +\schemedisplay +(define double->double + (lambda (proc-name) + (foreign-procedure proc-name + (double) + double))) + +(define log10 (double->double "log10")) +(define gamma (double->double "gamma")) +\endschemedisplay + +\noindent +Both \scheme{"log10"} and \scheme{"gamma"} must be available as foreign +entries (see Section~\ref{SECTFOREIGNACCESS}) +before the corresponding definitions. +The use of foreign procedure templates can simplify the coding process +and reduce the amount of code generated when a large number of +foreign procedures are involved, e.g., when an entire library of +foreign procedures is imported into Scheme. + + +\section{Calling into Scheme\label{SECTFOREIGNCALLABLE}} + +Section~\ref{SECTFOREIGNPROCEDURES} describes the \scheme{foreign-procedure} +form, which permits Scheme code to invoke C~or C-compatible foreign +procedures. +This section describes the \scheme{foreign-callable} form, which permits +C~or C-compatible code to call Scheme procedures. +A more primitive mechanism for calling Scheme procedures from C is +described in Section~\ref{SECTFOREIGNCLIB}. + +As when calling foreign procedures from Scheme, +great care must be taken when sharing data between Scheme and +foreign code that calls Scheme to avoid corrupting Scheme's memory +management system. + +A foreign-callable wrapper for a Scheme procedure can also be created by +passing the procedure to \scheme{make-ftype-pointer} with an appropriate +function ftype (Section~\ref{SECTFOREIGNDATA}). + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-callable}{\categorysyntax}{(foreign-callable \var{conv} \dots \var{proc-exp} (\var{param-type} \dots) \var{res-type})} +\returns a code object +\listlibraries +\endentryheader + +\noindent +\var{proc-exp} must evaluate to a procedure, the Scheme procedure that +is to be invoked by foreign code. +The parameter and result types are as described for +\scheme{foreign-procedure} in Section~\ref{SECTFOREIGNPROCEDURES}, +except that the requirements and conversions are effectively reversed, +e.g., the conversions described for \scheme{foreign-procedure} +arguments are performed for \scheme{foreign-callable} return +values. +A \scheme{(& \var{ftype})} argument to the callable refers to an address +that is valid only during the dynamic extent of the callback invocation. +A \scheme{(& \var{ftype})} result type for a callable causes the Scheme +procedure to receive an extra \scheme{(& \var{ftype})} argument before +all others; the Scheme procedure should write a result into the extra +argument, and the direct result of the Scheme procedure is ignored. +Type checking is performed for result values but not argument values, +since the parameter +values are provided by the foreign code and must be assumed to be +correct. + +Each \var{conv} adjusts the calling convention to be used. +\scheme{foreign-callable} supports the same conventions as +\scheme{foreign-procedure} with the exception of \scheme{__com}. +The \scheme{__collect_safe} convention for a callable activates a +calling thread if the thread is not already activated, and +the thread's activation state is reverted when the callable +returns. If a calling thread is not currently registered with +the Scheme system, then reverting the thread's activation state implies +destroying the thread's registration (see \scheme{Sdestroy_thread}). + + +The value produced by \scheme{foreign-callable} is a Scheme code object, +which contains some header information as well as code that performs +the call to the encapsulated Scheme procedure. +The code object may be converted into a foreign-callable address via +\index{\scheme{foreign-callable-entry-point}}\scheme{foreign-callable-entry-point}, which returns an integer representing +the address of the entry point within the code object. +(The C-callable library function \scheme{Sforeign_callable_entry_point}, described in +Section~\ref{SECTFOREIGNCLIB}, may be used to obtain the entry point +as well.) +This is an implicit pointer into a Scheme object, and +in many cases, it is necessary to lock the code object +(using \index{\scheme{lock-object}}\scheme{lock-object}) +before converting it into an entry point +to prevent Scheme's storage management system from +relocating or destroying the code object, e.g., when the entry point is +registered as a callback and retained in the ``C'' side indefinitely. + +The following code creates a foreign-callable code object, locks +the code object, and returns the entry point. + +\schemedisplay +(let ([x (foreign-callable + (lambda (x y) (pretty-print (cons x (* y 2)))) + (string integer-32) + void)]) + (lock-object x) + (foreign-callable-entry-point x)) +\endschemedisplay + +\noindent +Unless the entry point is intended to be permanent, a pointer to the +code object returned by \scheme{foreign-callable} should be retained +so that it can be unlocked when no longer needed. + +Mixed use of \scheme{foreign-callable} and \scheme{foreign-procedure} +may result in nesting of foreign and Scheme calls, and this +results in some interesting considerations when continuations are +involved, directly or indirectly (as via the default exception handler). +See Section~\ref{SECTFOREIGNCONTINUATIONS} for a discussion of the +interaction between foreign calls and continuations. + +The following example demonstrates how the ``callback'' functions +required by many windowing systems might be defined in Scheme with the +use of \scheme{foreign-callable}. +Assume that the following C code has been compiled and loaded +(see Section~\ref{SECTFOREIGNACCESS}). + +\schemedisplay +#include + +typedef void (*CB)(char); + +CB callbacks[256]; + +void cb_init(void) { + int i; + + for (i = 0; i < 256; i += 1) + callbacks[i] = (CB)0; +} + +void register_callback(char c, CB cb) { + callbacks[c] = cb; +} + +void event_loop(void) { + CB f; char c; + + for (;;) { + c = getchar(); + if (c == EOF) break; + f = callbacks[c]; + if (f != (CB)0) f(c); + } +} +\endschemedisplay + +\noindent +Interfaces to these functions may be defined in Scheme as follows. + +\schemedisplay +(define cb-init + (foreign-procedure "cb_init" () void)) +(define register-callback + (foreign-procedure "register_callback" (char void*) void)) +(define event-loop + (foreign-procedure __collect_safe "event_loop" () void)) +\endschemedisplay + +\noindent +A callback for selected characters can then be defined. + +\schemedisplay +(define callback + (lambda (p) + (let ([code (foreign-callable __collect_safe p (char) void)]) + (lock-object code) + (foreign-callable-entry-point code)))) +(define ouch + (callback + (lambda (c) + (printf "Ouch! Hit by '~c'~%" c)))) +(define rats + (callback + (lambda (c) + (printf "Rats! Received '~c'~%" c)))) + +(cb-init) +(register-callback #\a ouch) +(register-callback #\c rats) +(register-callback #\e ouch) +\endschemedisplay + +\noindent +This sets up the following interaction. + +\schemedisplay +> (event-loop) +a +Ouch! Hit by 'a' +b +c +Rats! Received 'c' +d +e +Ouch! Hit by 'e' +\endschemedisplay + +\noindent +The \scheme{__collect_safe} declarations in this example ensure that +other threads can continue working while \scheme{event-loop} +blocks waiting for input. +A more well-behaved version of the example would save each code object +returned by \scheme{foreign-callable} and unlock it when it is no longer +registered as a callback. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-callable-entry-point}{\categoryprocedure}{(foreign-callable-entry-point \var{code})} +\returns the address of the foreign-callable entry point in \var{code} +\listlibraries +\endentryheader + +\noindent +\var{code} should be a code object produced by \scheme{foreign-callable}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-callable-code-object}{\categoryprocedure}{(foreign-callable-code-object \var{address})} +\returns the code object corresponding to the foreign-callable entry point \var{address} +\listlibraries +\endentryheader + +\noindent +\var{address} must be an exact integer and should be the address of the +entry point of a code object produced by \scheme{foreign-callable}. + + +\section{Continuations and Foreign Calls\label{SECTFOREIGNCONTINUATIONS}} + +\scheme{foreign-callable} and \scheme{foreign-procedure} allow arbitrary +nesting of foreign and Scheme calls. +Because other languages do not support the fully general first-class +continuations of Scheme, the interaction between continuations and +nested calls among Scheme and foreign procedures is problematic. +{\ChezScheme} handles this interaction in a general manner by trapping +attempts to return to \emph{stale} foreign contexts rather than by restricting +the use of continuations directly. +A foreign context is a foreign frame and return point corresponding to +a particular call from a foreign language, e.g., C, into Scheme. +A foreign context becomes stale after a normal return to the context or +after a return to some other foreign context beneath it on the control +stack. + +As a result of this treatment, Scheme continuations may be used to +throw control either upwards or downwards logically through any mix +of Scheme and foreign frames. +Furthermore, until some return to a foreign context is actually performed, +all return points remain valid. +In particular, this means that programs that use continuations +exclusively for nonlocal exits never attempt to return to a +stale foreign context. +(Nonlocal exits themselves are no problem and are implemented +by the C library function \scheme{longjmp} or the equivalent.) +Programs that use continuations more generally also function +properly as long as they never actually return to a stale foreign context, +even if control logically moves past stale foreign contexts via invocation +of continuations. + +One implication of this mechanism is that the C stack pointer is not +automatically restored to its base value when a continuation is used on +the Scheme side to perform a nonlocal exit. +If the program continues to run after the nonlocal exit, any further +build-up of the C stack will add to the existing build up, which might +result in a C stack overflow. +To avoid this situation, a program can arrange to set up a single C +call frame before obtaining the continuation and return to the C frame +after the nonlocal exit. +The procedure \scheme{with-exit-proc} below arranges to do this without +involving any C code. + +\schemedisplay +(define with-exit-proc + (lambda (p) + (define th (lambda () (call/cc p))) + (define-ftype ->ptr (function () ptr)) + (let ([fptr (make-ftype-pointer ->ptr th)]) + (let ([v ((ftype-ref ->ptr () fptr))]) + (unlock-object + (foreign-callable-code-object + (ftype-pointer-address fptr))) + v)))) +\endschemedisplay + +\scheme{with-exit-proc} behaves like \scheme{call/cc} except it resets +the C stack when the continuation is invoked. +To do this, it creates an ftype-pointer representing a foreign-callable +entry point for \scheme{th} and creates a Scheme-callable procedure for +that entry point. +This creates a wrapper for \scheme{th} that involves a C call. +When a call to the wrapper returns, either by explicit invocation of the +continuation passed to \scheme{p} or by a normal return from \scheme{p}, +the C stack is reset to its original value. + +\section{Foreign Data\label{SECTFOREIGNDATA}} + +The procedures described in this section directly create and manipulate +foreign data, i.e., data that resides outside of the Scheme heap. +With the exception of \scheme{foreign-alloc} and \scheme{foreign-sizeof}, +these procedures are inherently unsafe in the sense that they do not (and +cannot) check the validity of the addresses they are passed. +Improper use of these procedures can result in invalid memory references, +corrupted data, or system crashes. + +This section also describes a higher-level syntactic mechanism for +manipulating foreign data, including foreign structures, unions, +arrays, and bit fields. +The syntactic interface is safer than the procedural interface but +must still assume that the addresses it's given are appropriate for +the types of object being manipulated. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-alloc}{\categoryprocedure}{(foreign-alloc \var{n})} +\returns the address of a freshly allocated block of foreign data \var{n} bytes long +\listlibraries +\endentryheader + +\var{n} must be a positive fixnum. +The returned value is an exact integer and is guaranteed to be properly +aligned for any type of value according to the requirements of the +underlying hardware. +An exception is raised with condition type \scheme{&assertion} +if the block of foreign data cannot be allocated. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-free}{\categoryprocedure}{(foreign-free \var{address})} +\returns unspecified +\listlibraries +\endentryheader + +This procedure frees the block of storage to which \var{address} points. +\var{address} must be an exact integer in the range $-2^{w-1}$ through +$2^w-1$, where $w$ is the width in bits of a pointer, e.g., 64 for a +64-bit machine. +It should be an address returned by an earlier call to +\scheme{foreign-alloc} and not subsequently passed to +\scheme{foreign-free}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-ref}{\categoryprocedure}{(foreign-ref \var{type} \var{address} \var{offset})} +\returns see below +\listlibraries +\endentryheader + +\scheme{foreign-ref} extracts the value of type \var{type} +from the memory location at \var{offset} bytes offset from +\var{address}. + +\var{type} must be a symbol identifying the type of value +to be extracted. +The following types have machine-dependent sizes and correspond to the +like-named C types: + +\begin{itemize} +\item \scheme{short}, +\item \scheme{unsigned-short}, +\item \scheme{int}, +\item \scheme{unsigned}, +\item \scheme{unsigned-int}, +\item \scheme{long}, +\item \scheme{unsigned-long}, +\item \scheme{long-long}, +\item \scheme{unsigned-long-long}, +\item \scheme{ptrdiff_t}, +\item \scheme{size_t}, +\item \scheme{ssize_t}, +\item \scheme{char}, +\item \scheme{wchar_t}, +\item \scheme{float}, +\item \scheme{double}, and +\item \scheme{void*}. +\end{itemize} + +The types \scheme{long-long} and \scheme{unsigned-long-long} +correspond to the C types \scheme{long long} +and \scheme{unsigned long long}. +A value of type \scheme{char} is referenced as a single +byte and converted (as if via \scheme{integer->char}) +into a Scheme character. +A value of type \scheme{wchar_t} is converted (as if via +\scheme{integer->char}) into a Scheme character. +The value must be a valid Unicode scalar value. + +\scheme{wchar} is an alias for \scheme{wchar_t}. + +Several additional machine-dependent types are recognized: + +\begin{itemize} +\item \scheme{iptr}, +\item \scheme{uptr}, +\item \scheme{fixnum}, and +\item \scheme{boolean}. +\end{itemize} + +\scheme{uptr} is equivalent to \scheme{void*}; both are treated as +unsigned integers the size of a pointer. +\scheme{iptr} is treated as a signed integer the size of a pointer. +\scheme{fixnum} is treated as an \scheme{iptr}, but with a range limited +to the fixnum range. +\scheme{boolean} is treated as an \scheme{int}, with zero +converted to the Scheme value \scheme{#f} and all +other values converted to \scheme{#t}. + +Finally, several fixed-sized types are also supported: + +\begin{itemize} +\item \scheme{integer-8}, +\item \scheme{unsigned-8}, +\item \scheme{integer-16}, +\item \scheme{unsigned-16}, +\item \scheme{integer-32}, +\item \scheme{unsigned-32}, +\item \scheme{integer-64}, +\item \scheme{unsigned-64}, +\item \scheme{single-float}, and +\item \scheme{double-float}. +\end{itemize} + +\var{address} must be an exact integer in the range $-2^{w-1}$ through +$2^w-1$, where $w$ is the width in bits of a pointer, e.g., 64 for a +64-bit machine. +\var{offset} must be an exact fixnum. +The sum of \var{address} and \var{offset} should address a readable block +of memory large enough to hold a value of type \var{type}, within a block +of storage previously returned by \scheme{foreign-alloc} and not +subsequently freed by \scheme{foreign-free} or within a block of storage +obtained via some other mechanism, e.g., a foreign call. +For multiple-byte values, the native endianness of the machine is assumed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-set!}{\categoryprocedure}{(foreign-set! \var{type} \var{address} \var{offset} \var{value})} +\returns see below +\listlibraries +\endentryheader + +\scheme{foreign-set!} stores a representation of \var{value} as type +\var{type} \var{offset} bytes into the block of foreign data addressed by +\var{address}. + +\var{type} must be a symbol identifying the type of value +to be stored, one of those listed in the description of +\scheme{foreign-ref} above. +Scheme characters are converted to type \scheme{char} or \scheme{wchar_t} +as if via \scheme{char->integer}. +For type \scheme{boolean}, Scheme \scheme{#f} is converted to the +\scheme{int} 0, and any other Scheme object is converted to 1. + +\var{address} must be an exact integer in the range $-2^{w-1}$ through +$2^w-1$, where $w$ is the width in bits of a pointer, e.g., 64 for a +64-bit machine. +\var{offset} must be an exact fixnum. +The sum of \var{address} and \var{offset} should address a writable block +of memory large enough to hold a value of type \var{type}, within a block +of storage previously returned by \scheme{foreign-alloc} and not +subsequently freed by \scheme{foreign-free} or within a block of storage +obtained via some other mechanism, e.g., a foreign call. +\var{value} must be an appropriate value for \var{type}, e.g., +a floating-point number for the float types or an exact integer within +the appropriate range for the integer types. +For multiple-byte values, the native endianness of the machine is assumed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-sizeof}{\categoryprocedure}{(foreign-sizeof \var{type})} +\returns the size in bytes of \var{type} +\listlibraries +\endentryheader + +\var{type} must be one of the symbols listed in the description +of \scheme{foreign-ref} above. + + +%---------------------------------------------------------------------------- +\entryheader\label{defn:define-ftype} +\formdef{define-ftype}{\categorysyntax}{(define-ftype \var{ftype-name} \var{ftype})} +\formdef{define-ftype}{\categorysyntax}{(define-ftype (\var{ftype-name} \var{ftype}) \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\index{ftypes}% +\index{foreign types}% +A \scheme{define-ftype} form is a definition and can appear anywhere +other definitions can appear. +It establishes one or more foreign-type (ftype) bindings for the identifier +\var{ftype-name} or identifiers \scheme{\var{ftype-name} \dots} +to the foreign type represented \var{ftype} or the foreign types +represented by \scheme{\var{ftype} \dots}. +Each \var{ftype-name} can be used to access foreign objects with the +declared shape, and each can be used in the formation of other ftypes. + +An \var{ftype} must take one of the following forms: + +\schemedisplay +\var{ftype-name} +(struct (\var{field-name} \var{ftype}) \dots) +(union (\var{field-name} \var{ftype}) \dots) +(array \var{length} \var{ftype}) +(* \var{ftype}) +(bits (\var{field-name} \var{signedness} \var{bits}) \dots) +(function \var{conv} \dots (\var{ftype} \dots) \var{ftype}) +(packed \var{ftype}) +(unpacked \var{ftype}) +(endian \var{endianness} \var{ftype}) +\endschemedisplay + +where \var{length} is an exact nonnegative integer, +\var{bits} is an exact positive integer, +\var{field-name} is an identifier, +\var{conv} is \scheme{#f} or a string naming a valid convention +as described on page~\ref{page:conv-description}, +signedness is either \scheme{signed} or \scheme{unsigned}, and +endianness is one of \scheme{native}, \scheme{big}, or \scheme{little}. + +A restriction not reflected above is that +\scheme{function} ftypes cannot be used as the types of +field names or array elements. +That is, \index{function ftype}function ftypes are valid only at the +top level of an ftype, e.g,: + +\schemedisplay +(define-ftype bvcopy_t (function (u8* u8* size_t) void)) +\endschemedisplay + +or as the immediate sub-type of a pointer (\scheme{*}) ftype, as in the +following definitions, which are equivalent assuming the definition of +\scheme{bvcopy_t} above. + +\schemedisplay +(define-ftype A + (struct + [x int] + [f (* (function (u8* u8* size_t) void))])) + +(define-ftype A + (struct + [x int] + [f (* bvcopy_t)])) +\endschemedisplay + +That is, a function cannot be embedded within a struct, union, +or array, but a pointer to a function can be so embedded. + +The following definitions establish ftype bindings for \scheme{F}, +\scheme{A}, and \scheme{E}. + +\schemedisplay +(define-ftype F (function (wchar_t int) int)) + +(define-ftype A (array 10 wchar_t)) + +(define-ftype E + (struct + [a int] + [b double] + [c (array 25 + (struct + [a short] + [_ long] + [b A]))] + [d (endian big + (union + [v1 unsigned-32] + [v2 (bits + [hi unsigned 12] + [lo unsigned 20])]))] + [e (* A)] + [f (* F)])) +\endschemedisplay + +The ftype \scheme{F} describes the type of a foreign function that +takes two arguments, a wide character and an integer, and returns an +integer. +The ftype \scheme{A} is simply an array of 10 \scheme{wchar_t} values, +and its size will be 10 times the size of a single \scheme{wchar_t}. +The ftype \scheme{E} is a structure with six fields: an integer +\scheme{a}, a double-float \scheme{b}, an array \scheme{c}, a +union \scheme{d}, a pointer \scheme{e}, and a pointer \scheme{f}. +The array \scheme{c} is an array of 25 structs, each of which +contains a short integer, a long integer, and a \scheme{A} array. +The size of the \scheme{c} array will be 25 times the size of a +single \scheme{A} array, plus 25 times the space needed to store +each of the short and long integers. +The union \scheme{d} is either a 32-bit unsigned integer or +a 32-bit unsigned integer split into high (12 bits) and low (20 bits) +components. +The fields of a union overlap so that writing to one effectively +overlaps the other. +Thus, one can use the \scheme{d} union type to split apart an +unsigned integer by writing the integer into \scheme{v1} and reading +the pieces from \scheme{hi} and \scheme{lo}. +The pointer \scheme{e} points to an \scheme{A} array; it is not +itself an array, and its size is just the size of a single pointer. +Similarly, \scheme{f} points to a function, and its size is also +that of a single pointer. + +An underscore (~\scheme{_}~) can be used as the field name for one or +more fields of a \scheme{struct}, \scheme{union}, or \scheme{bits} ftype. +Such fields are included in the layout but are considered unnamed and +cannot be accessed via the ftype operators described below. +Thus, in the example above, the \scheme{long} field within the +\scheme{c} array is inaccessible. + +Non-underscore field names are handled symbolically, i.e., +they are treated as symbols rather than identifiers. +Each symbol must be unique (as a symbol) with respect to the other +field names within a single \scheme{struct}, \scheme{union}, +or \scheme{bits} ftype but need not be +unique with respect to field names in other \scheme{struct}, +\scheme{union}, or \scheme{bits} ftypes within the same +ftype. + +Each \var{ftype-name} in an \var{ftype} must either +(a) have been defined previously by \scheme{define-ftype}, +(b) be defined by the current \scheme{define-ftype}, +or +(c) be a base-type name, i.e., one of the type names supported by +\scheme{foreign-ref} and \scheme{foreign-set!}. +In case (b), any reference within one \var{ftype} to the +\var{ftype-name} of one of the earlier bindings is permissible, +but a reference to the \var{ftype-name} of the current or a +subsequent binding can appear only within a pointer field. + +For example, in: + +\schemedisplay +(define-ftype + [Qlist (struct + [head int] + [tail (* Qlist)])]) +\endschemedisplay + +the reference to \scheme{Qlist} is permissible since it appears +within a pointer field. +Similarly, in: + +\schemedisplay +(define-ftype + [Qfrob (struct + [head int] + [tail (* Qsnark)])] + [Qsnark (struct + [head int] + [xtra Qfrob] + [tail (* Qfrob)])]) +\endschemedisplay + +the mutually recursive references to \scheme{Qsnark} and \scheme{Qfrob} +are permissible. +In the following, however: + +\schemedisplay +(define-ftype + [Qfrob (struct + [head int] + [xtra Qfrob] + [tail (* Qsnark)])] + [Qsnark (struct + [head int] + [tail (* Qfrob)])]) +\endschemedisplay + +the reference to \scheme{Qfrob} within the \var{ftype} for \scheme{Qfrob} +is invalid, and in: + +\schemedisplay +(define-ftype + [Qfrob (struct + [head int] + [xtra Qsnark] + [tail (* Qsnark)])] + [Qsnark (struct + [head int] + [tail (* Qfrob)])]) +\endschemedisplay + +the reference to \scheme{Qsnark} is similarly invalid. + +By default, padding is inserted where appropriate to maintain +proper alignment of multiple-byte scalar values in an attempt to +mirror the target machine's C struct layout conventions, where +such layouts are adequately documented. +For packed ftypes (ftypes wrapped in a \scheme{packed} form with +no closer enclosing \scheme{unpacked} form), this padding is not +inserted. + +Multiple-byte scalar values are stored in memory using the +target machine's native ``endianness,'' e.g., \scheme{little} +on X86 and X86\_64-based platforms and \scheme{big} on +Sparc-based platforms. +Big-endian or little-endian representation can be forced via +the \scheme{endian} ftype with a \scheme{big} or \scheme{little} +\var{endianness} specifier. +The \scheme{native} specifier can be used to force a return +back to \scheme{native} representation. +Each \scheme{endian} form affects only ftypes nested syntactically +within it and not nested within a closer \scheme{endian} form. +The endianness of an ftype is fixed once it is defined. + +The total size $n$ of the fields within an ftype bits form must +be 8, 16, 24, 32, 40, 48, 56, or 64. padding must be added manually if needed. +In little-endian representation, the first field occupies +the low-order bits of the containing 8, 16, 24, 32, 40, 48, 56, or 64-bit word, +with each subsequent field just above the preceding field. +In big-endian representation, the first field occupies the +high-order bits, with each subsequent field just below the +preceding field. + +Two ftypes are considered equivalent only if defined by the +same \scheme{ftype} binding. +If two ftype definitions look identical but appear in two +parts of the same program, the ftypes are not identical, +and attempts to access one using the name of the other via +the operators described below will fail with a run-time +exception. + +Array bounds must always be constant. +If an array's length cannot be known until run time, the array +can be placed at the end of the ftype (and any containing ftype) +and declared to have size zero, as illustrated by the example below. + +\schemedisplay +(define-ftype Vec + (struct + [len int] + [data (array 0 double)])) +(define make-Vec + (lambda (n) + (let ([fptr (make-ftype-pointer Vec + (foreign-alloc + (+ (ftype-sizeof Vec) + (* (ftype-sizeof double) n))))]) + (ftype-set! Vec (len) fptr n) + fptr))) +(define x (make-Vec 100)) +(/ (- (ftype-pointer-address (ftype-&ref Vec (data 10) x)) + (ftype-pointer-address x) ;=> 10 + (ftype-sizeof int)) + (ftype-sizeof double)) +(foreign-free (ftype-pointer-address x)) +\endschemedisplay + +No array bounds checks are performed for zero-length arrays. +Only one variable-sized array can appear +in a single foreign object, but one can work around this by +treating the object as multiple individual objects. + +To avoid specifying the constant length of an array in more than +one place, a macro that binds both a variable to the size as +well as an ftype name to the ftype can be used. +For example, + +\schemedisplay +(define-syntax define-array + (syntax-rules () + [(_ array-name type size-name size) + (begin + (define size-name size) + (define-ftype array-name + (array size type)))])) +(define-array A int A-size 100) +A-size ;=> 100 +(ftype-pointer-ftype + (make-ftype-pointer A + (foreign-alloc (ftype-sizeof A)))) ;=> (array 100 int) +\endschemedisplay + +This technique can be used to define arbitrary ftypes with +arbitrary numbers of array fields. + +\label{page:ftype-subtyping}% +\index{ftype subtyping}% +A struct ftype is an implicit subtype of the type of the first field +of the struct. +Similarly, an array ftype is an implicit subtype of the type of its +elements. +Thus, the struct or array extends the type of first field or element +with additional fields or elements. +This allows an instance of the struct or array to be treated as an instance +of the type of its first field or element, without the need to use +\scheme{ftype-&ref} to allocate a new pointer to the field or element. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-sizeof}{\categorysyntax}{(ftype-sizeof \var{ftype-name})} +\returns the size in bytes of the ftype identified by \var{ftype-name} +\listlibraries +\endentryheader + +The size includes the sizes of any ftypes directly embedded within the +identified ftype but excludes those indirectly embedded via a pointer +ftype. +In the latter case, the size of the pointer is included. + +\var{ftype-name} must not be defined as a function ftype, since the size +of a function cannot generally be determined. + +% careful---B and C are used by ftype-&ref, etc., below +\schemedisplay +(define-ftype B + (struct + [b1 integer-32] + [b2 (array 10 integer-32)])) +(ftype-sizeof B) ;=> 44 + +(define-ftype C (* B)) +(ftype-sizeof C) ;=> 4 \var{; on 32-bit machines} +(ftype-sizeof C) ;=> 8 \var{; on 64-bit machines} + +(define-ftype BB + (struct + [bb1 B] + [bb2 (* B)])) +(- (ftype-sizeof BB) (ftype-sizeof void*)) ;=> 44 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader\label{desc:make-ftype-pointer} +\formdef{make-ftype-pointer}{\categorysyntax}{(make-ftype-pointer \var{ftype-name} \var{expr})} +\returns an ftype-pointer object +\listlibraries +\endentryheader + +If \var{ftype-name} does not describe a function ftype, \var{expr} +must evaluate to an \var{address} represented as an exact integer in +the appropriate range for the target machine. + +The ftype-pointer object returned by this procedure encapsulates the +address and is tagged with a representation of the type identified by +\var{ftype-name} to enable various forms of checking to be done by the +access routines described below. + +\schemedisplay +(make-ftype-pointer E #x80000000) ;=> # +\endschemedisplay + +The address will not typically be a constant, as shown. +Instead, it might instead come from a call to \scheme{foreign-alloc}, e.g.: + +\schemedisplay +(make-ftype-pointer E (foreign-alloc (ftype-sizeof E))) +\endschemedisplay + +It might also come from source outside of Scheme such as from a C +routine called from Scheme via the foreign-procedure interface. + +If \var{ftype-name} describes a \index{function ftype}function ftype, +\var{expr} must evaluate to an address, procedure, or string. +If it evaluates to address, the call behaves like any other call to +\scheme{make-ftype-pointer} with an address argument. + +If it evaluates to a procedure, a foreign-callable code object is +created for the procedure, as if via +\index{\scheme{foreign-callable}}\scheme{foreign-callable} +(Section~\ref{SECTFOREIGNCALLABLE}). +The address encapsulated in the resulting ftype-pointer object is the +address of the procedure's entry point. + +\schemedisplay +(define fact + (lambda (n) + (if (= n 0) 1 (fact (- n 1))))) +(define-ftype fact_t (function (int) int)) +(define fact-fptr (make-ftype-pointer fact_t fact)) +\endschemedisplay + +The resulting ftype pointer can be passed to a C routine, +if the argument is declared to be a pointer to the same ftype, and +the C routine can invoke the function pointer it receives as it +would any other function pointer. +Thus, \scheme{make-ftype-pointer} with a function ftype is an alternative +to \scheme{foreign-callable} for creating C-callable wrappers for Scheme +procedures. + +Since all Scheme objects, including code objects, can be relocated or +even reclaimed by the garbage collector the foreign-callable code object +is automatically locked, as if via \scheme{lock-object}, before it is +embedded in the ftype pointer. +The code object should be unlocked after its last use from C, +since locked objects take up space, cause fragmentation, and +increase the cost of collection. +Since the system cannot determine automatically when the last use +from C occurs, the program must explicitly unlock the code object, +which it can do by extracting the address from the ftype-pointer +converting the address (back) into a code object, and passing it +to \scheme{unlock-object}: + +\schemedisplay +(unlock-object + (foreign-callable-code-object + (ftype-pointer-address fact-fptr))) +\endschemedisplay + +Once unlocked, the ftype pointer should not be used again, unless +it is relocked, e.g., via: + +\schemedisplay +(lock-object + (foreign-callable-code-object + (ftype-pointer-address fact-fptr))) +\endschemedisplay + +A program can determine whether an object is already locked via +the \scheme{locked-object?} predicate. + +A \index{function ftype}function ftype can be also used with +\scheme{make-ftype-pointer} to create an ftype-pointer to a C function, +either by providing the address of the C function or its name, represented +as a string. +For example, with the following definition of \scheme{bvcopy_t}, + +\schemedisplay +(define-ftype bvcopy_t (function (u8* u8* size_t) void)) +\endschemedisplay + +the two definitions of \scheme{bvcopy-ftpr} below are equivalent. + +\schemedisplay +(define bvcopy-fptr (make-ftype-pointer bvcopy_t "memcpy")) +(define bvcopy-fptr (make-ftype-pointer bvcopy_t (foreign-entry "memcpy"))) +\endschemedisplay + +A library that defines \var{memcpy} must be loaded first via +\scheme{load-shared-object}, or \scheme{memcpy} must be registered +via one of the methods described in Section ~\ref{SECTFOREIGNACCESS}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-pointer?}{\categorysyntax}{(ftype-pointer? \var{obj})} +\returns \scheme{#t} if \var{obj} is an ftype pointer, otherwise \scheme{#f} +\formdef{ftype-pointer?}{\categorysyntax}{(ftype-pointer? \var{ftype-name} \var{obj})} +\returns \scheme{#t} if \var{obj} is an \var{ftype-name}, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\schemedisplay +(define-ftype Widget1 (struct [x int] [y int])) +(define-ftype Widget2 (struct [w Widget1] [b boolean])) + +(define x1 (make-ftype-pointer Widget1 #x80000000)) +(define x2 (make-ftype-pointer Widget2 #x80000000)) + +(ftype-pointer? x1) ;=> #t +(ftype-pointer? x2) ;=> #t + +(ftype-pointer? Widget1 x1) ;=> #t +(ftype-pointer? Widget1 x2) ;=> #t + +(ftype-pointer? Widget2 x1) ;=> #f +(ftype-pointer? Widget2 x2) ;=> #t + +(ftype-pointer? #x80000000) ;=> #f +(ftype-pointer? Widget1 #x80000000) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-pointer-address}{\categoryprocedure}{(ftype-pointer-address \var{fptr})} +\returns the address encapsulated within \var{fptr} +\listlibraries +\endentryheader + +\var{fptr} must be an ftype-pointer object. + +\schemedisplay +(define x (make-ftype-pointer E #x80000000)) +(ftype-pointer-address x) ;=> #x80000000 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-pointer=?}{\categorysyntax}{(ftype-pointer=? \var{fptr_1} \var{fptr_2})} +\returns \scheme{#t} if \var{fptr_1} and \var{fptr_2} have the same address, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\var{fptr_1} and \var{fptr_2} must be ftype-pointer objects. + +\scheme{ftype-pointer=?} might be defined as follows: + +\schemedisplay +(define ftype-pointer=? + (lambda (fptr1 fptr2) + (= (ftype-pointer-address fptr1) (ftype-pointer-address fptr2)))) +\endschemedisplay + +It is, however, guaranteed not to allocate bignums for the addresses +even if the addresses do not fit in fixnum range. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-pointer-null?}{\categorysyntax}{(ftype-pointer-null? \var{fptr})} +\returns \scheme{#t} if the address of \var{fptr} is $0$, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\var{fptr} must be an ftype-pointer object. + +\scheme{ftype-pointer-null?} might be defined as follows: + +\schemedisplay +(define ftype-pointer-null? + (lambda (fptr) + (= (ftype-pointer-address fptr) 0))) +\endschemedisplay + +It is, however, guaranteed not to allocate a bignum for the address +even if the address does not fit in fixnum range. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-&ref}{\categorysyntax}{(ftype-&ref \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-&ref}{\categorysyntax}{(ftype-&ref \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns an ftype-pointer object +\listlibraries +\endentryheader + +The ftype-pointer object returned by \scheme{ftype-&ref} +encapsulates the address of some object embedded directly or +indirectly within the foreign object pointed to by the value +of \var{fptr-expr}, offset by \var{index}, if present. +The value of \var{fptr-expr} must be +an ftype pointer (fptr) of the ftype identified by \var{ftype-name}, +and \var{index} must either be the identifier \scheme{*} or evaluate +to a fixnum, possibly negative. +The index is automatically scaled by the size of the ftype identified +by \var{ftype-name}, which allows the fptr to be treated as an array +of \var{ftype-name} objects and \var{index} as an index into that array. +An index of \scheme{*} or 0 is the same as no index. + +The sequence of accessors \scheme{\var{a} \dots} must specify a +valid path through the identified ftype. +For \scheme{struct}, \scheme{union}, and \scheme{bits} ftypes, +an accessor must be a valid field name for the ftype, while for +pointer and array ftypes, an accessor must be the identifier +\scheme{*} or evaluate to a fixnum index. +For array ftypes, an index must be nonnegative, and for array ftypes +with nonzero length, an index must also be less than the length. + +The examples below assume the definitions of \scheme{B} and \scheme{BB} +shown above in the description of \scheme{ftype-sizeof}. +Fixed addresses are shown for illustrative purposes and are assumed +to be valid, although addresses are generally determined +at run time via \scheme{foreign-alloc} or some other mechanism. + +\schemedisplay +(define x (make-ftype-pointer B #x80000000)) +(ftype-&ref B () x) ;=> # +(let ([idx 1]) ;=> # + (ftype-&ref B () x idx)) +(let ([idx -1]) ;=> # + (ftype-&ref B () x idx)) +(ftype-&ref B (b1) x) ;=> # +(ftype-&ref B (b2) x) ;=> # +(ftype-&ref B (b2 5) x) ;=> # +(let ([n 5]) (ftype-&ref B (b2 n) x)) ;=> # + +(ftype-&ref B (b1 b2) x) ;=> \var{syntax error} +(ftype-&ref B (b2 15) x) ;=> \var{run-time exception} + +(define y (make-ftype-pointer BB #x90000000)) +(ftype-set! BB (bb2) y x) +(ftype-&ref BB (bb1 b2) y) ;=> # +(ftype-&ref BB (bb2 * b2) y) ;=> # +(let ([idx 1]) ;=> # + (ftype-&ref BB (bb2 idx b2) y)) +\endschemedisplay + +With no accessors and no index, as in the first use of \scheme{ftype-&ref} +above, the returned \scheme{ftype-pointer} might be \scheme{eq?} to +the input. +Otherwise, the \scheme{ftype-pointer} is freshly allocated. + +%---------------------------------------------------------------------------- +\entryheader\label{defn:ftype-set!} +\formdef{ftype-set!}{\categorysyntax}{(ftype-set! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{val-expr})} +\formdef{ftype-set!}{\categorysyntax}{(ftype-set! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index} \var{val-expr})} +\returns unspecified +\formdef{ftype-ref}{\categorysyntax}{(ftype-ref \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-ref}{\categorysyntax}{(ftype-ref \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns an ftype-pointer object +\listlibraries +\endentryheader + +These forms are used to store values into or retrieve values from the +object pointed to by the value of \var{fptr-expr}, offset by +\var{index}, if present. +The value of \var{fptr-expr} must be +an ftype pointer (fptr) of the ftype identified by \var{ftype-name}, +and \var{index} must either be the identifier \scheme{*} or evaluate +to a fixnum, possibly negative. +The index is automatically scaled by the size of the ftype identified +by \var{ftype-name}, which allows the fptr to be treated as an array +of \var{ftype-name} objects and \var{index} as an index into that array. +An index of \scheme{*} or 0 is the same as no index. + +The sequence of accessors \scheme{\var{a} \dots} must specify a +valid path through the identified ftype. +For \scheme{struct}, \scheme{union}, and \scheme{bits} ftypes, +an accessor must be a valid field name for the ftype, while for +pointer and array ftypes, an accessor must be the identifier +\scheme{*} or evaluate to a fixnum index. +For array ftypes, an index must be nonnegative, and for array ftypes +with nonzero length, an index must also be less than the length. +The field or element specified by the sequence of accessors must be a scalar +field, e.g., a pointer field or a field containing a base type +such as an \scheme{int}, \scheme{char}, or \scheme{double}. + +For \scheme{ftype-set!}, \var{val-expr} must evaluate to a value +of the appropriate type for the specified field, e.g., an ftype +pointer of the appropriate type or an appropriate base-type value. + +For both signed and unsigned integer fields, values in the range +$-2^{w-1}$ through $2^{w}-1$ are accepted, where $w$ is the width in +bits of the integer field. +For signed integer fields, values in the range $2^{w-1}$ through $2^{w}-1$ +are treated as two's complement representations of the corresponding +negative numbers. +For unsigned integer fields, values in the range $-2^{w-1}$ through +$-1$ are similarly treated as two's complement representations of the +corresponding positive numbers. + +\scheme{char} and \scheme{wchar_t} (\scheme{wchar}) field values +are converted from (\scheme{ftype-set!}) or to (\scheme{ftype-ref}) +Scheme characters, as if with \scheme{char->integer} and +\scheme{integer->char}. +Characters stored by \scheme{ftype-set!} into a \scheme{char} +field must have Unicode scalar values in the range 0 through 255. +Under Windows and any other system where \scheme{wchar_t} +(\scheme{wchar}) is a 16-bit value, characters stored by +\scheme{ftype-set!} into a \scheme{whar_t} (\scheme{wchar}) +field must have Unicode scalar values in the range 0 through $2^{16}-1$. +On systems where \scheme{wchar_t} is a 32-bit value, any +character can be stored in a \scheme{wchar_t} (\scheme{wchar}) +field. + +The examples below assume that \scheme{B} and \scheme{C} have been +defined as shown in the description of \scheme{ftype-sizeof} above. + +\schemedisplay +(define b + (make-ftype-pointer B + (foreign-alloc + (* (ftype-sizeof B) 3)))) +(define c + (make-ftype-pointer C + (foreign-alloc (ftype-sizeof C)))) + +(ftype-set! B (b1) b 5) +(ftype-set! B (b1) b 1 6) +(ftype-set! B (b1) c 5) ;=> \var{exception: ftype mismatch} +(ftype-set! B (b2) b 0) ;=> \var{exception: not a scalar} +(ftype-set! B (b2 -1) b 0) ;=> \var{exception: invalid index} +(ftype-set! B (b2 0) b 50) +(ftype-set! B (b2 4) b 55) +(ftype-set! B (b2 10) b 55) ;=> \var{exception: invalid index} + +(ftype-set! C () c (ftype-&ref B () b 1)) + +(= (ftype-pointer-address (ftype-ref C () c)) ;=> #t + (+ (ftype-pointer-address b) (ftype-sizeof B))) +(= (ftype-pointer-address (ftype-&ref C (*) c)) ;=> #t + (+ (ftype-pointer-address b) (ftype-sizeof B))) +(= (ftype-pointer-address (ftype-&ref C (-1) c)) ;=> #t + (ftype-pointer-address b)) + +(ftype-ref C (-1 b1) c) ;=> 5 +(ftype-ref C (* b1) c) ;=> 6 +(ftype-ref C (-1 b2 0) c) ;=> 50 +(let ([i 4]) (ftype-ref C (-1 b2 i) c)) ;=> 55 + +(ftype-set! C (-1 b2 0) c 75) +(ftype-ref B (b2 0) b) ;=> 75 +(foreign-free (ftype-pointer-address c)) +(foreign-free (ftype-pointer-address b)) +\endschemedisplay + +A \index{function ftype}function ftype pointer can be converted into +a Scheme-callable procedure via \scheme{ftype-ref}. +Assuming that a library defining \var{memcpy} has been loaded via +\scheme{load-shared-object} or \scheme{memcpy} has been registered +via one of the methods described in Section ~\ref{SECTFOREIGNACCESS}, +A Scheme-callable \scheme{memcpy} can be defined as follows. + +\schemedisplay +(define-ftype bvcopy_t (function (u8* u8* size_t) void)) +(define bvcopy-fptr (make-ftype-pointer bvcopy_t "memcpy")) +(define bvcopy (ftype-ref bvcopy_t () bvcopy-fptr)) + +(define bv1 (make-bytevector 8 0)) +(define bv2 (make-bytevector 8 57)) +bv1 ;=> #vu8(0 0 0 0 0 0 0 0) +bv2 ;=> #vu8(57 57 57 57 57 57 57 57) +(bvcopy bv1 bv2 5) +bv1 ;=> #vu8(57 57 57 57 57 0 0 0) +\endschemedisplay + +An ftype pointer can also be obtained as a return value from a +C function declared to return a pointer to a function ftype. + +Thus, \scheme{ftype-ref} with a function ftype is an alternative to +\index{\scheme{foreign-procedure}}\scheme{foreign-procedure} +(Section~\ref{SECTFOREIGNPROCEDURES}) +for creating Scheme-callable wrappers for +C functions. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-pointer-ftype}{\categoryprocedure}{(ftype-pointer-ftype \var{fptr})} +\returns \var{fptr}'s ftype, represented as an s-expression +\listlibraries +\endentryheader + +\var{fptr} must be an ftype-pointer object. + +\schemedisplay +(define-ftype Q0 + (struct + [x int] + [y int])) +(define-ftype Q1 + (struct + [x double] + [y char] + [z (endian big + (bits + [_ unsigned 3] + [a unsigned 9] + [b unsigned 4]))] + [w (* Q0)])) +(define q1 (make-ftype-pointer Q1 0)) +(ftype-pointer-ftype q1) ;=> (struct + ;== [x double] + ;== [y char] + ;== [z (endian big + ;== (bits + ;== [_ unsigned 3] + ;== [a unsigned 9] + ;== [b unsigned 4]))] + ;== [w (* Q0)]) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ftype-pointer->sexpr}{\categoryprocedure}{(ftype-pointer->sexpr \var{fptr})} +\returns an s-expression representation of the object to which \var{fptr} points +\listlibraries +\endentryheader + +\var{fptr} must be an ftype-pointer object. + +For each unnamed field, i.e., each whose field name is an underscore, the +corresponding field value in the resulting s-expression is also an underscore. +Similarly, if a field is inaccessible, i.e., if its address is invalid, the +value is the symbol \scheme{invalid}. + +\schemedisplay +(define-ftype Frob + (struct + [p boolean] + [q char])) +(define-ftype Snurk + (struct + [a Frob] + [b (* Frob)] + [c (* Frob)] + [d (bits + [_ unsigned 15] + [dx signed 17])] + [e (array 5 double)])) +(define x + (make-ftype-pointer Snurk + (foreign-alloc (ftype-sizeof Snurk)))) +(ftype-set! Snurk (b) x + (make-ftype-pointer Frob + (foreign-alloc (ftype-sizeof Frob)))) +(ftype-set! Snurk (c) x + (make-ftype-pointer Frob 0)) +(ftype-set! Snurk (a p) x #t) +(ftype-set! Snurk (a q) x #\A) +(ftype-set! Snurk (b * p) x #f) +(ftype-set! Snurk (b * q) x #\B) +(ftype-set! Snurk (d dx) x -2500) +(do ([i 0 (fx+ i 1)]) + ((fx= i 5)) + (ftype-set! Snurk (e i) x (+ (* i 5.0) 3.0))) +(ftype-pointer->sexpr x) ;=> (struct + ;== [a (struct [p #t] [q #\A])] + ;== [b (* (struct [p #f] [q #\B]))] + ;== [c (* (struct [p invalid] [q invalid]))] + ;== [d (bits [_ _] [dx -2500])] + ;== [e (array 5 3.0 8.0 13.0 18.0 23.0)]) +\endschemedisplay + + + + +\section{Providing Access to Foreign Procedures\label{SECTFOREIGNACCESS}} + +Access to foreign procedures can be provided in several ways: + +\begin{itemize} +\item Foreign procedures may be loaded from +``shared objects'' using \scheme{load-shared-object}. + +\item A new {\ChezScheme} image can be built with additional foreign code +linked in. (Consult with the person who installed {\ChezScheme} at +your site for details.) +These entries are typically registered via +\scheme{Sforeign_symbol} or \scheme{Sregister_symbol}, +documented in Section~\ref{SECTFOREIGNCLIB}. + +\item Additional entries may be dynamically loaded or otherwise obtained +by foreign code. +These are also typically registered using +\scheme{Sforeign_symbol} or \scheme{Sregister_symbol}. + +\item The address of an entry, i.e., a function pointer, may be passed +into Scheme and used as the value of the entry expression in a +foreign-procedure expression. +This allows foreign entry points to be used even when they are not +registered by name. +\end{itemize} + +% \noindent +% \scheme{load-shared-object} is available on all platforms, including +% Sun Sparc systems running Solaris 2.0 (SunOS 5.X) or later, +% DEC Alpha systems running Digital Unix 2.X or later, +% SGI systems running IRIX 5.X or later, +% PowerPC systems running AIX 4.1 or later, +% HP PA-RISC systems running HP/UX 9.X or later, +% Intel-based Linux systems running kernel version 2.X or higher, +% Intel-based Windows~NT 3.51 or later, +% and Windows~95/98. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-entry?}{\categoryprocedure}{(foreign-entry? \var{entry-name})} +\returns \scheme{#t} if \var{entry-name} is an existing foreign procedure entry +point, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\var{entry-name} must be a string. +\scheme{foreign-entry?} may be used to determine if an entry exists for a foreign +procedure. + +The following examples assume that +a library that defines \var{strlen} has been loaded via +\scheme{load-shared-object} or that \scheme{strlen} has been registered +via one of the other methods described in this section. + +\schemedisplay +(foreign-entry? "strlen") ;=> #t +((foreign-procedure "strlen" + (string) size_t) + "hey!") ;=> 4 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-entry}{\categoryprocedure}{(foreign-entry \var{entry-name})} +\returns the address of \var{entry-name} as an exact integer +\listlibraries +\endentryheader + +\noindent +\var{entry-name} must be a string naming an existing foreign entry point. + +The following examples assume that +a library that defines \var{strlen} has been loaded via +\scheme{load-shared-object} or that \scheme{strlen} has been registered +via one of the other methods described in this section. + +\schemedisplay +(let ([addr (foreign-entry "strlen")]) + (and (integer? addr) (exact? addr))) ;=> #t + +(define-ftype strlen-type (function (string) size_t)) +(define strlen + (ftype-ref strlen-type () + (make-ftype-pointer strlen-type "strlen"))) +(strlen "hey!") ;=> 4 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{foreign-address-name}{\categoryprocedure}{(foreign-address-name \var{address})} +\returns the entry name corresponding to \var{address}, if known, otherwise \scheme{#f} +\listlibraries +\endentryheader + +The following examples assume that +a library that defines \var{strlen} has been loaded via +\scheme{load-shared-object} or that \scheme{strlen} has been registered +via one of the other methods described in this section. + +\schemedisplay +(foreign-address-name (foreign-entry "strlen")) ;=> "strlen" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{load-shared-object}{\categoryprocedure}{(load-shared-object \var{path})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{load-shared-object} loads the shared object named by \var{path}. +Shared objects may be system libraries or files created from ordinary +C programs. +All external symbols in the shared object, along with external symbols +available in other shared objects linked with the shared object, +are made available as foreign entries. + +This procedure is supported for most platforms upon which {\ChezScheme} +runs. + +If \var{path} does not begin with a ``.'' or ``/'', the shared +object is searched for in a default set of directories determined +by the system. + +On most Unix systems, \scheme{load-shared-object} is based on the +system routine \scheme{dlopen}. +%Under AIX, \scheme{load-shared-object} is based on the system routine +%\scheme{load}. +%Under HPUX, \scheme{load-shared-object} is based on the system routine +%\scheme{shl_load}. +Under Windows, \scheme{load-shared-object} is based on \scheme{LoadLibrary}. +Refer to the documentation for these routines and for the C compiler +and loader for precise rules for locating and building shared objects. + +\scheme{load-shared-object} can be used to access built-in C library +functions, such as \scheme{getenv}. +The name of the shared object varies from one system to another. +% On Sun Sparc systems running Solaris 2.X or higher +% running Digital Unix 2.X or higher, and SGI systems running IRIX 5.X +% or higher +On Linux systems: + +\schemedisplay +(load-shared-object "libc.so.6") +\endschemedisplay + +On Solaris, OpenSolaris, FreeBSD, NetBSD, and OpenBSD systems: + +\schemedisplay +(load-shared-object "libc.so") +\endschemedisplay + +On MacOS X systems: + +\schemedisplay +(load-shared-object "libc.dylib") +\endschemedisplay + +% \noindent +% On PA-RISC systems running HP/UX 9.X or later: +% +% \schemedisplay +% (load-shared-object "/lib/libc.sl") +% \endschemedisplay + +On Windows: + +\schemedisplay +(load-shared-object "msvcrt.dll") +\endschemedisplay + +Once the C library has been loaded, \scheme{getenv} should be available +as a foreign entry. + +\schemedisplay +(foreign-entry? "getenv") ;=> #t +\endschemedisplay + +\noindent +An equivalent Scheme procedure may be defined and +invoked as follows. + +\schemedisplay +(define getenv + (foreign-procedure "getenv" + (string) + string)) +(getenv "HOME") ;=> "/home/elmer/fudd" +(getenv "home") ;=> #f +\endschemedisplay + +\scheme{load-shared-object} can be used to access user-created +libraries as well. +Suppose the \index{C (programming language)}C file \scheme{"even.c"} +contains + +\schemedisplay +int even(n) int n; { return n == 0 || odd(n - 1); } +\endschemedisplay + +\noindent +and the C file \scheme{"odd.c"} contains + +\schemedisplay +int odd(n) int n; { return n != 0 && even(n - 1); } +\endschemedisplay + +\noindent +The files must be compiled and linked into a shared object before +they can be loaded. +How this is done depends upon the host system. +\noindent +On Linux, FreeBSD, OpenBSD, and OpenSolaris systems: + +\schemedisplay +(system "cc -fPIC -shared -o evenodd.so even.c odd.c") +\endschemedisplay + +Depending on the host configuration, the \scheme{-m32} or +\scheme{-m64} option might be needed to specify 32-bit +or 64-bit compilation as appropriate. + +On MacOS X (Intel or PowerPC) systems: + +\schemedisplay +(system "cc -dynamiclib -o evenodd.so even.c odd.c") +\endschemedisplay + +Depending on the host configuration, the \scheme{-m32} or +\scheme{-m64} option might be needed to specify 32-bit +or 64-bit compilation as appropriate. + +On 32-bit Sparc Solaris: + +\schemedisplay +(system "cc -KPIC -G -o evenodd.so even.c odd.c") +\endschemedisplay + +\noindent +On 64-bit Sparc Solaris: + +\schemedisplay +(system "cc -xarch=v9 -KPIC -G -o evenodd.so even.c odd.c") +\endschemedisplay + +%\noindent +%On DEC Alpha systems running Digital Unix 2.X or higher: +% +%\schemedisplay +%(system "cc -c even.c") +%(system "cc -c odd.c") +%(system "ld -o evenodd.so -shared even.o odd.o") +%\endschemedisplay +% +%\noindent +%On SGI systems running IRIX 5.X: +% +%\schemedisplay +%(system "cc -G -c even.c") +%(system "cc -G -c odd.c") +%(system "ld -o evenodd.so -shared even.o odd.o") +%\endschemedisplay +% +%\noindent +%On PA-RISC systems running HP/UX 9.X or later: +% +%\schemedisplay +%(system "cc -Ae +z -c even.c") +%(system "cc -Ae +z -c odd.c") +%(system "ld -b -o evenodd.so even.o odd.o") +%\endschemedisplay + +On Windows, we build a DLL (dynamic link library) file. +In order to make the compiler generate the appropriate entry +points, we alter \scheme{even.c} to read + +\schemedisplay +#ifdef WIN32 +#define EXPORT extern __declspec (dllexport) +#else +#define EXPORT extern +#endif + +EXPORT int even(n) int n; { return n == 0 || odd(n - 1); } +\endschemedisplay + +\noindent +and \scheme{odd.c} to read + +\schemedisplay +#ifdef WIN32 +#define EXPORT extern __declspec (dllexport) +#else +#define EXPORT extern +#endif + +EXPORT int odd(n) int n; { return n != 0 && even(n - 1); } +\endschemedisplay + +\noindent +We can then build the DLL as follows, giving +it the extension ``.so'' rather than ``.dll'' +for consistency with the other systems. + +\schemedisplay +(system "cl -c -DWIN32 even.c") +(system "cl -c -DWIN32 odd.c") +(system "link -dll -out:evenodd.so even.obj odd.obj") +\endschemedisplay + + +%On PowerPC systems running AIX 4.1 or higher, it is necessary to provide +%``.imp'' and ``.exp'' files on the command line. +%(See the documentation for \scheme{ld} for details). +%The ``.imp'' file lists imports, and the ``.exp'' file lists +%exports. +%Since we do not have any imports, the ``.imp'' can be empty. +%The ``.exp'' file should simply contain a list of the exported +%identifiers, one per line. +%We also need to provide an entry point, so we include an extra file +%\scheme{evenodd.c} that defines one. +% +%\schemedisplay +%(system "echo > evenodd.imp") +%(system "echo even > evenodd.exp; echo odd >> evenodd.exp") +%(system "echo 'void init(void) { return; }' > evenodd.c") +%(system "cc -c even.c") +%(system "cc -c odd.c") +%(system "cc -c evenodd.c") +%(system "ld -o evenodd.so -e init -bI:evenodd.imp -bE:evenodd.exp\\ +% evenodd.o even.o odd.o") +%\endschemedisplay +% +%\noindent +%(The \scheme{\\} in the last command should be omitted if the command +%is all on one line.) + +\medskip\noindent +The resulting ``.so'' file can be loaded into Scheme and \scheme{even} and +\scheme{odd} made available as foreign procedures: + +\schemedisplay +(load-shared-object "./evenodd.so") +(let ([odd (foreign-procedure "odd" + (integer-32) boolean)] + [even (foreign-procedure "even" + (integer-32) boolean)]) + (list (even 100) (odd 100))) ;=> (#t #f) +\endschemedisplay + +\noindent +The filename is given as \scheme{"./evenodd.so"} rather than simply +\scheme{"evenodd.so"}, because some systems look for shared libraries +in a standard set of system directories that does not include the +current directory. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{remove-foreign-entry}{\categoryprocedure}{(remove-foreign-entry \var{entry-name})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{remove-foreign-entry} blocks further access to the entry +specified by the string \var{entry-name}. +An exception is raised with condition type \scheme{&assertion} +if the entry does not exist. +Since access previously established by \scheme{foreign-procedure} is not affected, +\scheme{remove-foreign-entry} may be used to clean up after the desired interface +to a group of foreign procedures has been established. + +\scheme{remove-foreign-entry} can be used to remove entries registered using +\scheme{Sforeign_symbol} and \scheme{Sregister_symbol} but not +entries created as +a result of a call to \scheme{load-shared-object}. + + +\section{Using Other Foreign Languages\label{SECTFOREIGNOTHER}} + +Although the {\ChezScheme} foreign procedure interface is oriented primarily +toward procedures defined in C or available in C libraries, it +is possible to invoke procedures defined in other languages that follow C +calling conventions. +One source of difficulty may be the interpretation of names. +Since \index{Unix}Unix-based \index{C (programming language)}C compilers often prepend an underscore to external +names, +the foreign interface attempts to interpret entry names in +a manner consistent with the host C compiler. +Occasionally, such as for assembly coded files, this entry +name interpretation may not be desired. +It can be prevented by prefixing the entry name with an ``='' character. +For example, after loading an assembly file containing a procedure \scheme{"foo"} +one might have\index{\scheme{foreign-entry?}}: + +\schemedisplay +(foreign-entry? "foo") ;=> #f +(foreign-entry? "=foo") ;=> #t +\endschemedisplay + + +\section{C Library Routines\label{SECTFOREIGNCLIB}} + +Additional foreign interface support is provided via a set of +\index{C (programming language)}\index{C preprocessor macros}C +preprocessor macros and +\index{C-callable library functions}C-callable library functions. +Some of these routines allow C programs to examine, +allocate, and alter Scheme objects. +Others permit C functions to call Scheme procedures via a +more primitive interface than that defined in +Section~\ref{SECTFOREIGNCALLABLE}. +Still others permit the development of custom executable images +and use of the Scheme system as a subordinate program within +another program, e.g., for use as an extension language. + +C code that uses these routines must include the \scheme{"scheme.h"} +header file distributed with {\ChezScheme} and must be linked +(statically or dynamically) with the {\ChezScheme} kernel. +The header file contains definitions for the preprocessor macros and +\scheme{extern} declarations for the library functions. +The file is customized to the release of {\ChezScheme} and machine +type with which it is distributed; it +should be left unmodified to facilitate switching among {\ChezScheme} +releases, and the proper version of the header file should always be +used with C code compiled for use with a particular version of +{\ChezScheme}. +The version and machine type are defined in \scheme{"scheme.h"} +under the names \scheme{VERSION} and \scheme{MACHINE_TYPE}. + +The name of each routine begins with a capital \scheme{S}, e.g., +\scheme{Sfixnump}. +Many of the names are simple translations of the names of closely +related Scheme procedures, e.g., \scheme{Sstring_to_symbol} is the C +interface equivalent of \scheme{string->symbol}. +Most externally visible entries in the {\ChezScheme} executable that +are not documented here begin with capital \scheme{S} followed by an +underscore (\scheme{S_}); their use should be avoided. + +In addition to the various macros and external declarations given +in \scheme{scheme.h}, the header file also defines (\scheme{typedefs}) +several types used in the header file: + +\begin{itemize} +\item \scheme{ptr}: type of a Scheme value, + +\item \scheme{iptr}: a signed integer the same size as a Scheme value, and + +\item \scheme{uptr}: an unsigned integer the same size as a Scheme value. + +\item \scheme{string_char}: type of a single Scheme string element. + +\item \scheme{octet}: type of a single Scheme bytevector element (unsigned char). +\end{itemize} + +\noindent +These types may vary depending upon the platform, although \scheme{ptr} +is typically \scheme{void *}, \scheme{iptr} is typically \scheme{long} \scheme{int}, +and \scheme{uptr} is typically \scheme{unsigned} \scheme{long} \scheme{int}. + +Under Windows, defining \scheme{SCHEME_IMPORT} before including scheme.h +causes scheme.h to declare its entry points using +\scheme{extern} \scheme{declspec} \scheme{(dllimport)} rather than +\scheme{extern} \scheme{declspec} \scheme{(dllexport)} (the default). +Not defining \scheme{SCHEME_IMPORT} and instead defining \scheme{SCHEME_STATIC} +causes scheme.h to declare exports using just \scheme{extern}. +The static libraries distributed with Chez Scheme are built using +\scheme{SCHEME_STATIC}. + +The remainder of this section describes each of the C interface +routines in turn. +A declaration for each routine is given in ANSI C function prototype +notation to precisely specify the argument and result types. +Scheme objects have the C type \scheme{ptr}, which is defined in +\scheme{"scheme.h"}. +Where appropriate, C values are accepted as arguments or returned as +values in place of Scheme objects. + +The preprocessor macros may evaluate their arguments more than once +(or not at all), so care should be taken to ensure that this does not +cause problems. + +% these must be xdef, since their expansions contain \scheme{...} +\xdef\cconst#1#2{\noindent\index{\scheme{#2}}% +[macro] \scheme{#1} \scheme{#2}\\} + +\xdef\cmacro#1#2#3{\noindent\index{\scheme{#2}}% +[macro] \scheme{#1} \scheme{#2}\scheme{(#3)}\\} + +\xdef\cfunction#1#2#3{\noindent\index{\scheme{#2}}% +[func] \scheme{#1} \scheme{#2}\scheme{(#3)}\\} + +\parheader{Customization} +The functions described here are used to initialize the Scheme system, +build the Scheme heap, and run the Scheme system from a separate +program. + +\cfunction{char *}{Skernel_version}{void} +\cfunction{void}{Sscheme_init}{void (*\var{abnormal}_\var{exit})(void)} +\cfunction{void}{Sset_verbose}{int \var{v}} +\cfunction{void}{Sregister_boot_file}{const char *\var{name}} +\cfunction{void}{Sregister_boot_file_fd}{const char *\var{name}, int \var{fd}} +\cfunction{void}{Sbuild_heap}{const char *\var{exec}, void (*\var{custom}_\var{init})(void)} +\cfunction{void}{Senable_expeditor}{const char *\var{history}_\var{file}} +\cfunction{void}{Sretain_static_relocation}{void} +\cfunction{int}{Sscheme_start}{int \var{argc}, char *\var{argv}[]} +\cfunction{int}{Sscheme_script}{char *\var{scriptfile}, int \var{argc}, char *\var{argv}[]} +\cfunction{int}{Sscheme_program}{char *\var{programfile}, int \var{argc}, char *\var{argv}[]} +\cfunction{void}{Scompact_heap}{void} +\cfunction{void}{Sscheme_deinit}{void} + +\scheme{Skernel_version} returns a string representing the Scheme +version. +It should be compared against the value of the VERSION preprocessor +macro before any of the initialization functions listed above are +used to verify that the correct \scheme{"scheme.h"} header file has +been used. + +\scheme{Sscheme_init} causes the Scheme system to +initialize its static memory in preparation for boot file +registration. +The \scheme{\var{abnormal}_\var{exit}} parameter should be a (possibly null) +pointer to a C function +of no arguments that takes appropriate action if the initialization or +subsequent heap-building process fails. +If null, the default action is to call \scheme{exit(1)}. + +\scheme{Sset_verbose} sets verbose mode on for nonzero +values of \var{v} and off when \var{v} is zero. +In verbose mode, the system displays a trace of the search process +for subsequently registered boot files. + +\scheme{Sregister_boot_file} searches for +the named boot file and +register it for loading, while \scheme{Sregister_boot_file_fd} +provides a specific boot file as a file descriptor. +When only a boot file name is provided, the file is opened but not loaded until the heap is built via +\scheme{Sbuild_heap}. When a file descriptor is provided, the given file name +is used only for error reporting. +For the first boot file registered only, the system also +searches for the boot files upon which the named file +depends, either directly or indirectly. + +\scheme{Sbuild_heap} creates the Scheme heap from the registered boot +files. +\var{exec} is assumed to be the name of or path to the executable +image and is used when no boot files have been registered as +the base name for the boot-file search process. +\var{exec} may be null only if one or more boot files have +been registered. +\scheme{\var{custom}_\var{init}} must be a (possibly null) pointer to +a C function of no arguments; if non-null, it is called before any boot +files are loaded. + +\scheme{Sscheme_start} invokes the interactive startup procedure, i.e., +the value of the parameter \scheme{scheme-start}, with one Scheme +string argument for the first \var{argc} elements of \var{argv}, +not including \scheme{argv[0]}. +\scheme{Sscheme_script} similarly invokes the script startup +procedure, i.e., +the value of the parameter \scheme{scheme-script}, with one Scheme +string argument for \var{scriptfile} and the first \var{argc} elements +of \var{argv}, +not including \scheme{argv[0]}. +\scheme{Sscheme_program} similarly invokes the program startup +procedure, i.e., +the value of the parameter \scheme{scheme-program}, with one Scheme +string argument for \var{programfile} and the first \var{argc} elements +of \var{argv}, +not including \scheme{argv[0]}. + +\scheme{Senable_expeditor} enables the expression editor +(Section~\ref{SECTUSEEXPEDITOR}, Chapter~\ref{CHPTEXPEDITOR}), +which is disabled by default, +and determines the history file from which it restores and to +which it saves the history. +This procedure must be called after the heap is built, or +an error will result. +It must also be called before \scheme{Sscheme_start} in order +to be effective. +If the \scheme{\var{history}_\var{file}} argument is the null pointer, the +history is not restored or saved. +The preprocessor variable \scheme{FEATURE_EXPEDITOR} is defined +in \scheme{scheme.h} if support for the expression editor has +been compiled into the system. + +\scheme{Sretain_static_relocation} causes relocation information +to be retained for static generation code objects created by +heap compaction for the benefit of \scheme{compute-size} and +related procedures. + +\scheme{Scompact_heap} compacts the Scheme heap and places all objects +currently in the heap into a \emph{static} generation. +Objects in the static generation are never collected. +That is, they are never moved during collection and the storage used +for them is never reclaimed even if they become inaccessible. +\scheme{Scompact_heap} is called implicitly after any boot files have been +loaded. + +\scheme{Sscheme_deinit} closes any open files, tears down the Scheme heap, +and puts the Scheme system in an uninitialized state. + + +\parheader{Predicates} +The predicates described here correspond to the similarly named +Scheme predicates. +A trailing letter \scheme{p}, for ``predicate,'' is used in place of +the question mark that customarily appears at the end of a Scheme +predicate name. +Each predicate accepts a single Scheme object and returns a boolean +(C integer) value. + +\begin{flushleft} +\cmacro{int}{Sfixnump}{ptr \var{obj}} +\cmacro{int}{Scharp}{ptr \var{obj}} +\cmacro{int}{Snullp}{ptr \var{obj}} +\cmacro{int}{Seof_objectp}{ptr \var{obj}} +\cmacro{int}{Sbwp_objectp}{ptr \var{obj}} +\cmacro{int}{Sbooleanp}{ptr \var{obj}} +\cmacro{int}{Spairp}{ptr \var{obj}} +\cmacro{int}{Ssymbolp}{ptr \var{obj}} +\cmacro{int}{Sprocedurep}{ptr \var{obj}} +\cmacro{int}{Sflonump}{ptr \var{obj}} +\cmacro{int}{Svectorp}{ptr \var{obj}} +\cmacro{int}{Sbytevectorp}{ptr \var{obj}} +\cmacro{int}{Sfxvectorp}{ptr \var{obj}} +\cmacro{int}{Sstringp}{ptr \var{obj}} +\cmacro{int}{Sbignump}{ptr \var{obj}} +\cmacro{int}{Sboxp}{ptr \var{obj}} +\cmacro{int}{Sinexactnump}{ptr \var{obj}} +\cmacro{int}{Sexactnump}{ptr \var{obj}} +\cmacro{int}{Sratnump}{ptr \var{obj}} +\cmacro{int}{Sinputportp}{ptr \var{obj}} +\cmacro{int}{Soutputportp}{ptr \var{obj}} +\cmacro{int}{Srecordp}{ptr \var{obj}} +\end{flushleft} + +\parheader{Accessors} +Some of the accessors described here correspond to similarly named +Scheme procedures, while others are unique to this interface. +\scheme{Sfixnum_value}, \scheme{Schar_value}, \scheme{Sboolean_value}, +and \scheme{Sflonum_value} return the C equivalents of the given +Scheme value. + +\begin{flushleft} +\cmacro{iptr}{Sfixnum_value}{ptr \var{fixnum}} +\cmacro{uptr}{Schar_value}{ptr \var{character}} +\cmacro{int}{Sboolean_value}{ptr \var{obj}} +\cmacro{double}{Sflonum_value}{ptr \var{flonum}} +\end{flushleft} + +\noindent +\scheme{Sinteger_value} and \scheme{Sunsigned_value} are similar to +\scheme{Sfixnum_value}, except they accept not only fixnum arguments +but bignum arguments in the range of C integer or unsigned values. +\scheme{Sinteger_value} and \scheme{Sunsigned_value} accept the same +range of Scheme integer values. +They differ only in the result type, and so allow differing +interpretations of negative and large unsigned values. + +\begin{flushleft} +\cfunction{iptr}{Sinteger_value}{ptr \var{integer}} +\cmacro{uptr}{Sunsigned_value}{ptr \var{integer}} +\end{flushleft} + +\scheme{Sinteger32_value}, \scheme{Sunsigned32_value}, +\scheme{Sinteger64_value}, and \scheme{Sunsigned64_value} +accept signed or unsigned Scheme integers in the 32- +or 64-bit range and return integers of the appropriate +type for the machine type. + +\begin{flushleft} +\cfunction{<32-bit int type>}{Sinteger32_value}{ptr \var{integer}} +\cmacro{<32-bit unsigned type>}{Sunsigned32_value}{ptr \var{integer}} +\cfunction{<64-bit int type>}{Sinteger64_value}{ptr \var{integer}} +\cmacro{<64-bit unsigned type>}{Sunsigned64_value}{ptr \var{integer}} +\end{flushleft} + +\noindent +\scheme{Scar}, \scheme{Scdr}, \scheme{Ssymbol_to_string} (corresponding +to \scheme{symbol->string}), and \scheme{Sunbox} are identical to their +Scheme counterparts. + +\begin{flushleft} +\cmacro{ptr}{Scar}{ptr \var{pair}} +\cmacro{ptr}{Scdr}{ptr \var{pair}} +\cfunction{ptr}{Ssymbol_to_string}{ptr \var{sym}} +\cmacro{ptr}{Sunbox}{ptr \var{box}} +\end{flushleft} + +\noindent +\scheme{Sstring_length}, \scheme{Svector_length}, +\scheme{Sbytevector_length}, and +\scheme{Sfxvector_length} each return a C integer representing the length +(in elements) of the object. + +\begin{flushleft} +\cmacro{iptr}{Sstring_length}{ptr \var{str}} +\cmacro{iptr}{Svector_length}{ptr \var{vec}} +\cmacro{iptr}{Sbytevector_length}{ptr \var{bytevec}} +\cmacro{iptr}{Sfxvector_length}{ptr \var{fxvec}} +\end{flushleft} + +\noindent +\scheme{Sstring_ref}, \scheme{Svector_ref}, \scheme{Sbytevector_u8_ref}, +and \scheme{Sfxvector_ref} +correspond to their Scheme counterparts, except that the index arguments +are C integers, the return value for \scheme{Sstring_ref} is a C +character, and the return value for \scheme{Sbytevector_u8_ref} is an +octet (unsigned char). + +\begin{flushleft} +\cmacro{char}{Sstring_ref}{ptr \var{str}, iptr \var{i}} +\cmacro{ptr}{Svector_ref}{ptr \var{vec}, iptr \var{i}} +\cmacro{octet}{Sbytevector_u8_ref}{ptr \var{fxvec}, iptr \var{i}} +\cmacro{ptr}{Sfxvector_ref}{ptr \var{fxvec}, iptr \var{i}} +\end{flushleft} + +\noindent +A Scheme bytevector is represented as a length field followed by a +sequence of octets (unsignec chars). +\scheme{Sbytevector_data} returns a pointer to the start of the sequence +of octets. +Extreme care should be taken to stop dereferencing the pointer returned by +\scheme{Sbytevector_data} or to lock the bytevector into memory (see +\scheme{Slock_object} below) before any Scheme code is executed, +whether by calling into Scheme or returning to a Scheme caller. +The storage manager may otherwise relocate or discard the object into which +the pointer points and may copy other data over the object. + +\begin{flushleft} +\cmacro{octet *}{Sbytevector_data}{ptr \var{bytevec}} +\end{flushleft} + +\parheader{Mutators} +Changes to mutable objects that contain pointers, such as pairs and +vectors, must be tracked on behalf of the storage +manager, as described in one of the references~\cite{Dybvig:sm}. +The operations described here perform this tracking automatically +where necessary. + +\begin{flushleft} +\cfunction{void}{Sset_box}{ptr \var{box}, ptr \var{obj}} +\cfunction{void}{Sset_car}{ptr \var{pair}, ptr \var{obj}} +\cfunction{void}{Sset_cdr}{ptr \var{pair}, ptr \var{obj}} +\cmacro{void}{Sstring_set}{ptr \var{str}, iptr \var{i}, char \var{c}} +\cfunction{void}{Svector_set}{ptr \var{vec}, iptr \var{i}, ptr \var{obj}} +\cmacro{void}{Sbytevector_u8_set}{ptr \var{bytevec}, iptr \var{i}, octet \var{n}} +\cmacro{void}{Sfxvector_set}{ptr \var{fxvec}, iptr \var{i}, ptr \var{fixnum}} +\end{flushleft} + +\noindent +Some Scheme objects, such as procedures and numbers, +are not mutable, so no operators are provided for altering +the contents of those objects. + +\parheader{Constructors} +The constructors described here create Scheme objects. +Some objects, such as fixnums and the empty list, are +represented as immediate values that do not require any heap +allocation; others, such as pairs and vectors, are represented +as pointers to heap allocated objects. + +\scheme{Snil}, \scheme{Strue}, \scheme{Sfalse}, \scheme{Sbwp_object}, +\scheme{Seof_object}, and +\scheme{Svoid} +construct constant immediate values representing +the empty list (~\scheme{()}~), the boolean values (\scheme{#t} and +\scheme{#f}), the broken-weak-pointer object (\scheme{#!bwp}), +the eof object (\scheme{#!eof}), and the void object. + +\begin{flushleft} +\cconst{ptr}{Snil} +\cconst{ptr}{Strue} +\cconst{ptr}{Sfalse} +\cconst{ptr}{Sbwp_object} +\cconst{ptr}{Seof_object} +\cconst{ptr}{Svoid} +\end{flushleft} + +\noindent +Fixnums, characters, booleans, flonums, and strings may be created from +their C equivalents. + +\begin{flushleft} +\cmacro{ptr}{Sfixnum}{iptr \var{n}} +\cmacro{ptr}{Schar}{char \var{c}} +\cmacro{ptr}{Sboolean}{int \var{b}} +\cfunction{ptr}{Sflonum}{double x} +\cfunction{ptr}{Sstring}{const char *\var{s}} +\cfunction{ptr}{Sstring_of_length}{const char *\var{s}, iptr \var{n}} +\cfunction{ptr}{Sstring_utf8}{const char *\var{s}, iptr \var{n}}; +\end{flushleft} + +\noindent +\scheme{Sstring} creates a Scheme copy of the C string \var{s}, while +\scheme{Sstring_of_length} creates a Scheme string of length \var{n} +and copies the first \var{n} bytes from \var{s} +into the new Scheme string. + +If the C string is encoded in UTF-8, use \scheme{Sstring_utf8} +instead. Specify the number of bytes to convert as \var{n} or use $-1$ +to convert until the null terminator. + +It is possible to determine whether a C integer is within fixnum range +by comparing the fixnum value of a fixnum created from a C integer with +the C integer: + +\schemedisplay +#define fixnum_rangep(x) (Sfixnum_value(Sfixnum(x)) == x) +\endschemedisplay + +\noindent +\scheme{Sinteger} and \scheme{Sunsigned} may be used to create Scheme +integers whether they are in fixnum range or not. + +\begin{flushleft} +\cfunction{ptr}{Sinteger}{iptr \var{n}} +\cfunction{ptr}{Sunsigned}{uptr \var{n}} +\end{flushleft} + +\noindent +\scheme{Sinteger} and \scheme{Sunsigned} differ in their treatment of +negative C integer values as well as C unsigned integer values that would +appear negative if cast to integers. +\scheme{Sinteger} converts such values into negative Scheme values, +whereas \scheme{Sunsigned} converts such values into the appropriate +positive Scheme values. +For example, assuming a 32-bit, two's complement representation for +\scheme{iptrs}, \scheme{Sinteger(-1)} and \scheme{Sunsigned((iptr)0xffffffff)} +both evaluate to the Scheme integer \scheme{-1}, whereas +\scheme{Sunsigned(0xffffffff)} and \scheme{Sunsigned((uptr)-1)} +both evaluate to the Scheme integer +\scheme{#xffffffff} (\scheme{4294967295}). + +Whichever routine is used, \scheme{Sinteger_value} and +\scheme{Sunsigned_value} always reproduce the corresponding C +input value, thus the following are all equivalent to \var{x} +if \var{x} is an iptr. + +\schemedisplay +Sinteger_value(Sinteger(\var{x})) +(iptr)Sunsigned_value(Sinteger(\var{x})) +Sinteger_value(Sunsigned((uptr)\var{x})) +(iptr)Sunsigned_value(Sunsigned((uptr)\var{x})) +\endschemedisplay + +\noindent +Similarly, the following are all equivalent to \var{x} +if \var{x} is a uptr. + +\schemedisplay +(uptr)Sinteger_value(Sinteger((iptr)\var{x})) +Sunsigned_value(Sinteger((iptr)\var{x})) +(uptr)Sinteger_value(Sunsigned(\var{x})) +Sunsigned_value(Sunsigned(\var{x})) +\endschemedisplay + +\noindent +\scheme{Sinteger32}, \scheme{Sunsigned32}, \scheme{Sinteger64}, +and \scheme{Sunsigned64} are like the generic equivalents but +restrict their arguments to the 32- or 64-bit range. + +\begin{flushleft} +\cfunction{ptr}{Sinteger32}{<32-bit int type> \var{n}} +\cfunction{ptr}{Sunsigned32}{<32-bit unsigned type> \var{n}} +\cfunction{ptr}{Sinteger64}{<64-bit int type> \var{n}} +\cfunction{ptr}{Sunsigned64}{<64-bit unsigned type> \var{n}} +\end{flushleft} + +\noindent +\scheme{Scons} and \scheme{Sbox} are identical to their Scheme +counterparts. + +\begin{flushleft} +\cfunction{ptr}{Scons}{ptr \var{obj_1}, ptr \var{obj_2}} +\cfunction{ptr}{Sbox}{ptr \var{obj}} +\end{flushleft} + +\noindent +\scheme{Sstring_to_symbol} is similar to its Scheme counterpart, +\scheme{string->symbol}, except +that it takes a C string (character pointer) as input. + +\begin{flushleft} +\cfunction{ptr}{Sstring_to_symbol}{const char *\var{s}} +\end{flushleft} + +\noindent +\scheme{Smake_string}, \scheme{Smake_vector}, \scheme{Smake_bytevector}, +and \scheme{Smake_fxvector} are similar to their Scheme counterparts. + +\begin{flushleft} +\cfunction{ptr}{Smake_string}{iptr \var{n}, int \var{c}} +\cfunction{ptr}{Smake_vector}{iptr \var{n}, ptr \var{obj}} +\cfunction{ptr}{Smake_bytevector}{iptr \var{n}, int \var{fill}} +\cfunction{ptr}{Smake_fxvector}{iptr \var{n}, ptr \var{fixnum}} +\end{flushleft} + +\noindent +\scheme{Smake_uninitialized_string} is similar to the one-argument +\scheme{make-string}. + +\begin{flushleft} +\cfunction{ptr}{Smake_uninitialized_string}{iptr \var{n}} +\end{flushleft} + +\parheader{Windows-specific helper functions} +The following helper functions are provided on Windows only. + +\begin{flushleft} +\cfunction{char *}{Sgetenv}{const char *\var{name}} +\end{flushleft} + +\noindent +\scheme{Sgetenv} returns the UTF-8-encoded value of UTF-8-encoded +environment variable \var{name} if found and NULL otherwise. Call +\scheme{free} on the returned value when it is no longer needed. + +\begin{flushleft} +\cfunction{wchar_t *}{Sutf8_to_wide}{const char *\s} +\cfunction{char *}{Swide_to_utf8}{const wchar_t *\s} +\end{flushleft} + +\noindent +\scheme{Sutf8_to_wide} and \scheme{Swide_to_utf8} convert between +UTF-8-encoded and UTF-16LE-encoded null-terminated strings. Call +\scheme{free} on the returned value when it is no longer needed. + +\parheader{Accessing top-level values} +Top-level variable bindings may be accessed or assigned via +\scheme{Stop_level_value} and \scheme{Sset_top_level_value}. + +\begin{flushleft} +\cfunction{ptr}{Stop_level_value}{ptr \var{sym}} +\cfunction{void}{Sset_top_level_value}{ptr \var{sym}, ptr \var{obj}} +\end{flushleft} + +These procedures give fast access to the bindings in the original +interaction environment and do not reflect changes to the +\scheme{interaction-environment} parameter or top-level module imports. +To access the current interaction-environment binding for a symbol, it +is necessary to call the Scheme \scheme{top-level-value} and +\scheme{set-top-level-value!} procedures instead. + +\parheader{Locking Scheme objects} +The storage manager periodically relocates objects in order to reclaim +storage and compact the heap. +This relocation is completely transparent to Scheme programs, since all +pointers to a relocated object are updated to refer to the new +location of the object. +The storage manager cannot, however, update Scheme pointers that reside +outside of the Scheme heap. + +As a general rule, all pointers from C variables or data structures +to Scheme objects should be discarded before entry (or reentry) into +Scheme. +That is, if a C procedure receives an object from Scheme or obtains it +via the mechanisms described in this section, all pointers to the +object should be considered invalid once the C procedure calls into +Scheme or returns back to Scheme. +Dereferencing an invalid pointer or passing it back to Scheme can +have disastrous effects, including unrecoverable memory faults. +The foregoing does not apply to immediate objects, e.g., fixnums, +characters, booleans, or the empty list. +It does apply to all heap-allocated objects, including pairs, vectors, +strings, all numbers other than fixnums, ports, procedures, and records. + +In practice, the best way to ensure that C code does not retain +pointers to Scheme objects is to immediately convert the Scheme objects +into C equivalents, if possible. +In certain cases, it is not possible to do so, yet retention of the +Scheme object is essential to the design of the C portions of the +program. +In these cases, the object may be \emph{locked} via the library routine +\scheme{Slock_object} (or from Scheme, the equivalent procedure +\index{\scheme{lock-object}}\scheme{lock-object}). + +\begin{flushleft} +\cfunction{void}{Slock_object}{ptr \var{obj}} +\end{flushleft} + +\noindent +Locking an object prevents the storage manager from reclaiming or +relocating the object. +Locking should be used sparingly, as it introduces memory fragmentation +and increases storage management overhead. +Locking can also lead to accidental retention of storage if objects +are not unlocked. +Locking objects that have been made static via heap compaction +(see \index{\scheme{Scompact_heap}}\scheme{Scompact_heap} above) +is unnecessary but harmless. + +Objects may be unlocked via \scheme{Sunlock_object} +(\index{\scheme{unlock-object}}\scheme{unlock-object}). + +\begin{flushleft} +\cfunction{void}{Sunlock_object}{ptr \var{obj}} +\end{flushleft} + +\noindent +An object may be locked more than once by successive calls to +\scheme{Slock_object} or \scheme{lock-object}, in which case it must +be unlocked by an equal number of calls to +\scheme{Sunlock_object} or \scheme{unlock-object} before it is +truly unlocked. + +The function \scheme{Slocked_objectp} can be used to determine +if an object is locked. + +\begin{flushleft} +\cfunction{int}{Slocked_objectp}{ptr \var{obj}} +\end{flushleft} + +When a foreign procedure call is made into Scheme, a return address +pointing into the Scheme code object associated with the foreign +procedure is passed implicitly to the C routine. +The system therefore locks the code object before calls are +made from C back into Scheme and unlocks it upon return from +Scheme. +This locking is performed automatically; user +code should never need to lock such code objects. + +An object contained within a locked object, such as an object in the car +of a locked pair, need not also be locked unless a separate C pointer +to the object exists. + +\parheader{Registering foreign entry points} +Foreign entry points may be made visible to Scheme via +\scheme{Sforeign_symbol} or \scheme{Sregister_symbol}. + +\begin{flushleft} +\cfunction{void}{Sforeign_symbol}{const char *\var{name}, void *\var{addr}} +\cfunction{void}{Sregister_symbol}{const char *\var{name}, void *\var{addr}} +\end{flushleft} + +\noindent +External entry points in object files or shared objects loaded as a +result of a call to \scheme{load-shared-object} are automatically +made visible by the system. +Once a foreign entry point is made visible, it may be named in a +\scheme{foreign-procedure} expression to create a Scheme-callable +version of the entry point. +\scheme{Sforeign_symbol} and \scheme{Sregister_symbol} allow +programs to register nonexternal +entry points, entry points in code linked statically with {\ChezScheme}, +and entry points into code loaded directly from C, i.e., without +\scheme{load-shared-object}. +\scheme{Sforeign_symbol} and \scheme{Sregister_symbol} differ only in +that \scheme{Sforeign_symbol} raises an exception when an attempt is made +to register an existing name, whereas \scheme{Sregister_symbol} +permits existing names to be redefined. + +\parheader{Obtaining Scheme entry points} +\scheme{Sforeign_callable_entry_point} extracts the entry point from a code +object produced by \scheme{foreign-callable}, performing the same +operation as its Scheme counterpart, i.e., the Scheme procedure +\scheme{foreign-callable-entry-point}. + +\begin{flushleft} +\cmacro{(void (*) (void))}{Sforeign_callable_entry_point}{ptr \var{code}} +\end{flushleft} + +\noindent +This can be used to avoid converting the code object into an address +until just when it is needed, which may eliminate the need to lock +the code object in some circumstances, assuming that the code object +is not saved across any calls back into Scheme. + +The inverse translation can be made via \scheme{Sforeign_callable_code_object}. + +\begin{flushleft} +\cmacro{ptr}{Sforeign_callable_code_object}{(void (*addr)(void))} +\end{flushleft} + +\parheader{Low-level support for calls into Scheme} +Support for calling Scheme procedures from C is provided by the set of +routines documented below. +Calling a Scheme procedure that expects a small number of arguments +(0--3) involves the use of one of the following routines. + +\begin{flushleft} +\cfunction{ptr}{Scall0}{ptr \var{procedure}} +\cfunction{ptr}{Scall1}{ptr \var{procedure}, ptr \var{obj_1}} +\cfunction{ptr}{Scall2}{ptr \var{procedure}, ptr \var{obj_1}, ptr \var{obj_2}} +\cfunction{ptr}{Scall3}{ptr \var{procedure}, ptr \var{obj_1}, ptr \var{obj_2}, ptr \var{obj_3}} +\end{flushleft} + +\noindent +In each case, +the first argument, \var{procedure}, should be a Scheme procedure. +The remaining arguments, which should be Scheme objects, are +passed to the procedure. +The tools described earlier in this section may be used to convert +C datatypes into their Scheme equivalents. +A program that automatically generates conversion code from +declarations that are similar to \scheme{foreign-procedure} expressions +is distributed with {\ChezScheme}. +It can be found in the Scheme library directory on most systems in the +file \scheme{"foreign.ss"}. + +A Scheme procedure may be obtained in a number of ways. +For example, it may be received as an argument in a call +from Scheme into C, obtained via another call to Scheme, +extracted from a Scheme data structure, or obtained from the top-level +environment via \scheme{Stop_level_value}. + +A more general interface involving the following routines is available +for longer argument lists. + +\begin{flushleft} +\cfunction{void}{Sinitframe}{iptr \var{n}} +\cfunction{void}{Sput_arg}{iptr \var{i}, ptr \var{obj}} +\cfunction{ptr}{Scall}{ptr \var{procedure}, iptr \var{n}} +\end{flushleft} + +\noindent +A C procedure first calls \scheme{Sinitframe} with one argument, the +number of arguments to be passed to Scheme. +It then calls \scheme{Sput_arg} once for each argument (in any order), passing +\scheme{Sput_arg} the argument number (starting with \scheme{1}) and +the argument. +Finally, it calls \scheme{Scall} to perform the call, passing it +the Scheme procedure and the number of arguments (the same number as +in the call to \scheme{Sinitframe}). +Programmers should ensure a Scheme call initiated via +\scheme{Sinitframe} is completed via \scheme{Scall} before any other +calls to Scheme are made and before a return to Scheme is attempted. +If for any reason the call is not completed after \scheme{Sinitframe} +has been called, it may not be possible to return to Scheme. + +The following examples serve to illustrate both the simpler and more +general interfaces. + +\schemedisplay +/* a particularly silly way to multiply two floating-point numbers */ +double mul(double x, double y) { + ptr times = Stop_level_value(Sstring_to_symbol("*")); + + return Sflonum_value(Scall2(times, Sflonum(x), Sflonum(y))); +} +\endschemedisplay + +\schemedisplay +/* an equally silly way to call printf with five arguments */ + +/* it is best to define interfaces such as the one below to handle + * calls into Scheme to prevent accidental attempts to nest frame + * creation and to help ensure that initiated calls are completed + * as discussed above. Specialized versions tailored to particular + * C argument types may be defined as well, with embedded conversions + * to Scheme objects. */ +ptr Scall5(ptr p, ptr x1, ptr x2, ptr x3, ptr x4, ptr x5) { + Sinitframe(5); + Sput_arg(1, x1); + Sput_arg(2, x2); + Sput_arg(3, x3); + Sput_arg(4, x4); + Sput_arg(5, x5); + Scall(p, 5); +} + +static void dumpem(char *s, int a, double b, ptr c, char *d) { + printf(s, a, b, c, d); +} + +static void foo(int x, double y, ptr z, char *s) { + ptr ois, sip, read, expr, eval, c_dumpem; + char *sexpr = "(foreign-procedure \"dumpem\" (string integer-32\ + double-float scheme-object string) void)"; + + /* this series of statements is carefully crafted to avoid referencing + variables holding Scheme objects after calls into Scheme */ + ois = Stop_level_value(Sstring_to_symbol("open-input-string")); + sip = Scall1(ois, Sstring(sexpr)); + read = Stop_level_value(Sstring_to_symbol("read")); + expr = Scall1(read, sip); + eval = Stop_level_value(Sstring_to_symbol("eval")); + Sforeign_symbol("dumpem", (void *)dumpem); + c_dumpem = Scall1(eval, expr); + Scall5(c_dumpem, + Sstring("x = %d, y = %g, z = %x, s = %s\n"), + Sinteger(x), + Sflonum(y), + z, + Sstring(s)); +} +\endschemedisplay + +Calls from C to Scheme should not be made from C interrupt handlers. +When Scheme calls into C, the system saves the contents of certain +dedicated machine registers in a register save area. +When C then calls into Scheme, the registers are restored from the +register save area. +Because an interrupt can occur at any point in a computation, the +contents of the register save locations would typically contain invalid +information that would cause the Scheme system to fail to operate +properly. + +\parheader{Activating, deactivating, and destroying threads} +Three functions are provided by the threaded versions of Scheme to +allow C code to notify Scheme when a thread should be activated, +deactivated, or destroyed. + +\cfunction{int}{Sactivate_thread}{void} +\cfunction{void}{Sdeactivate_thread}{void} +\cfunction{int}{Sdestroy_thread}{void} + +A thread created via the Scheme procedure \scheme{fork-thread} starts +in the active state and need not be activated. +Any thread that has been deactivated, and any +thread created by some mechanism other than \scheme{fork-thread} must, +however, be activated before it can access Scheme data or execute +Scheme code. A foreign callable that is declared with \scheme{__collect_safe} +can activate a calling thread. +Otherwise, \scheme{Sactivate_thread} must be used to activate a thread. +It returns 1 the first time the thread is activated and 0 on each +subsequent call until the activation is destroyed with \scheme{Sdestroy_thread}. + +Since active threads operating in C code prevent the storage management +system from garbage collecting, +a thread should be deactivated via \scheme{Sdeactivate_thread} or +through a \scheme{foreign-procedure} \scheme{__collect_safe} declaration whenever +the thread may spend a significant amount of time in C code. +This is especially important whenever the thread calls a C library +function, like \scheme{read}, that may block indefinitely. +Once deactivated, the thread must not touch any Scheme data or +execute any Scheme code until it is reactivated, with one exception. +The exception is that the thread may access or even modify a locked +Scheme object, such as a locked string, that contains no pointers to +other, unlocked Scheme objects. +(Objects that are not locked may be relocated by the garbage collector +while the thread is inactive.) + +\scheme{Sdestroy_thread} is used to notify the Scheme system that the +thread is shut down and any thread-specific data can be released. + +\parheader{Low-level synchronization primitives} +The header file defines several preprocessor macros that can be +used to lock memory locations in a manner identical to the corresponding +ftype lock operations (sections ~\ref{SECTTHREADLOCKS} and +\ref{SECTTHREADLOCKEDINCRDECR}). + +\cmacro{void}{INITLOCK}{void *\var{addr}} +\cmacro{void}{SPINLOCK}{void *\var{addr}} +\cmacro{void}{UNLOCK}{void *\var{addr}} +\cmacro{void}{LOCKED_INCR}{void *\var{addr}, int *\var{ret}} +\cmacro{void}{LOCKED_DECR}{void *\var{addr}, int *\var{ret}} + +\scheme{LOCKED_INCR} and \scheme{LOCKED_DECR} set \var{ret} to a +nonzero (true) value if the incremented or decremented value is 0. +Otherwise they set \var{ret} to 0. + +\section{Example: Socket Operations\label{SECTFOREIGNSOCKETS}} + +\index{sockets}This section presents a simple socket interface that +employs a combination of Scheme and C code. +The C code defines a set of convenient low-level operating-system +interfaces that can be used in the higher-level Scheme code to open, +close, read from, and write to sockets. + +The C code (csocket.c) is given below, followed by the Scheme code +(socket.ss). +The code should require little or no modification to run on most Unix +systems and can be modified to work under Windows (using the Windows +\emph{WinSock} interface). + +A sample session demonstrating the socket interface follows the code. +See Section~\ref{SECTPORTEXAMPLES} for an example that demonstrates how +to use the same socket interface to build a process port that allows +transparent input from and output to a subprocess via a Scheme port. + +\parheader{C code} + +\schemedisplay +/* csocket.c */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* c_write attempts to write the entire buffer, pushing through + interrupts, socket delays, and partial-buffer writes */ +int c_write(int fd, char *buf, ssize_t start, ssize_t n) { + ssize_t i, m; + + buf += start; + m = n; + while (m > 0) { + if ((i = write(fd, buf, m)) < 0) { + if (errno != EAGAIN && errno != EINTR) + return i; + } else { + m -= i; + buf += i; + } + } + return n; +} + +/* c_read pushes through interrupts and socket delays */ +int c_read(int fd, char *buf, size_t start, size_t n) { + int i; + + buf += start; + for (;;) { + i = read(fd, buf, n); + if (i >= 0) return i; + if (errno != EAGAIN && errno != EINTR) return -1; + } +} + +/* bytes_ready(fd) returns true if there are bytes available + to be read from the socket identified by fd */ +int bytes_ready(int fd) { + int n; + + (void) ioctl(fd, FIONREAD, &n); + return n; +} + +/* socket support */ + +/* do_socket() creates a new AF_UNIX socket */ +int do_socket(void) { + + return socket(AF_UNIX, SOCK_STREAM, 0); +} + +/* do_bind(s, name) binds name to the socket s */ +int do_bind(int s, char *name) { + struct sockaddr_un sun; + int length; + + sun.sun_family = AF_UNIX; + (void) strcpy(sun.sun_path, name); + length = sizeof(sun.sun_family) + sizeof(sun.sun_path); + + return bind(s, (struct sockaddr*)(&sun), length); +} + +/* do_accept accepts a connection on socket s */ +int do_accept(int s) { + struct sockaddr_un sun; + socklen_t length; + + length = sizeof(sun.sun_family) + sizeof(sun.sun_path); + + return accept(s, (struct sockaddr*)(&sun), &length); +} + +/* do_connect initiates a socket connection */ +int do_connect(int s, char *name) { + struct sockaddr_un sun; + int length; + + sun.sun_family = AF_UNIX; + (void) strcpy(sun.sun_path, name); + length = sizeof(sun.sun_family) + sizeof(sun.sun_path); + + return connect(s, (struct sockaddr*)(&sun), length); +} + +/* get_error returns the operating system's error status */ +char* get_error(void) { + extern int errno; + return strerror(errno); +} +\endschemedisplay + +\parheader{Scheme code} + +\schemedisplay +;;; socket.ss + +;;; Requires csocket.so, built from csocket.c. +(load-shared-object "./csocket.so") + +;;; Requires from C library: +;;; close, dup, execl, fork, kill, listen, tmpnam, unlink +(case (machine-type) + [(i3le ti3le a6le ta6le) (load-shared-object "libc.so.6")] + [(i3osx ti3osx a6osx ta6osx) (load-shared-object "libc.dylib")] + [else (load-shared-object "libc.so")]) + +;;; basic C-library stuff + +(define close + (foreign-procedure "close" (int) + int)) + +(define dup + (foreign-procedure "dup" (int) + int)) + +(define execl4 + (let ((execl-help + (foreign-procedure "execl" + (string string string string void*) + int))) + (lambda (s1 s2 s3 s4) + (execl-help s1 s2 s3 s4 0)))) + +(define fork + (foreign-procedure "fork" () + int)) + +(define kill + (foreign-procedure "kill" (int int) + int)) + +(define listen + (foreign-procedure "listen" (int int) + int)) + +(define tmpnam + (foreign-procedure "tmpnam" (void*) + string)) + +(define unlink + (foreign-procedure "unlink" (string) + int)) + +;;; routines defined in csocket.c + +(define accept + (foreign-procedure "do_accept" (int) + int)) + +(define bytes-ready? + (foreign-procedure "bytes_ready" (int) + boolean)) + +(define bind + (foreign-procedure "do_bind" (int string) + int)) + +(define c-error + (foreign-procedure "get_error" () + string)) + +(define c-read + (foreign-procedure "c_read" (int u8* size_t size_t) + ssize_t)) + +(define c-write + (foreign-procedure "c_write" (int u8* size_t ssize_t) + ssize_t)) + +(define connect + (foreign-procedure "do_connect" (int string) + int)) + +(define socket + (foreign-procedure "do_socket" () + int)) + +;;; higher-level routines + +(define dodup + ; (dodup old new) closes old and dups new, then checks to + ; make sure that resulting fd is the same as old + (lambda (old new) + (check 'close (close old)) + (unless (= (dup new) old) + (error 'dodup + "couldn't set up child process io for fd ~s" old)))) + +(define dofork + ; (dofork child parent) forks a child process and invokes child + ; without arguments and parent with the child's pid + (lambda (child parent) + (let ([pid (fork)]) + (cond + [(= pid 0) (child)] + [(> pid 0) (parent pid)] + [else (error 'fork (c-error))])))) + +(define setup-server-socket + ; create a socket, bind it to name, and listen for connections + (lambda (name) + (let ([sock (check 'socket (socket))]) + (unlink name) + (check 'bind (bind sock name)) + (check 'listen (listen sock 1)) + sock))) + +(define setup-client-socket + ; create a socket and attempt to connect to server + (lambda (name) + (let ([sock (check 'socket (socket))]) + (check 'connect (connect sock name)) + sock))) + +(define accept-socket + ; accept a connection + (lambda (sock) + (check 'accept (accept sock)))) + +(define check + ; signal an error if status x is negative, using c-error to + ; obtain the operating-system's error message + (lambda (who x) + (if (< x 0) + (error who (c-error)) + x))) + +(define terminate-process + ; kill the process identified by pid + (lambda (pid) + (define sigterm 15) + (kill pid sigterm) + (void))) +\endschemedisplay + +\parheader{Sample session} + +\schemedisplay +> (define client-pid) +> (define client-socket) +> (let* ([server-socket-name (tmpnam 0)] + [server-socket (setup-server-socket server-socket-name)]) + ; fork a child, use it to exec a client Scheme process, and set + ; up server-side client-pid and client-socket variables. + (dofork ; child + (lambda () + ; the child establishes the socket input/output fds as + ; stdin and stdout, then starts a new Scheme session + (check 'close (close server-socket)) + (let ([sock (setup-client-socket server-socket-name)]) + (dodup 0 sock) + (dodup 1 sock)) + (check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" "exec scheme -q")) + (errorf 'client "returned!")) + (lambda (pid) ; parent + ; the parent waits for a connection from the client + (set! client-pid pid) + (set! client-socket (accept-socket server-socket)) + (check 'close (close server-socket))))) +> (define put ; procedure to send data to client + (lambda (x) + (let ([s (format "~s~%" x)]) + (c-write client-socket s (string-length s))) + (void))) +> (define get ; procedure to read data from client + (let ([buff (make-string 1024)]) + (lambda () + (let ([n (c-read client-socket buff (string-length buff))]) + (printf "client:~%~a~%server:~%" (substring buff 0 n)))))) +> (get) +server: +> (put '(let ([x 3]) x)) +> (get) +client: +3 +server: +> (terminate-process client-pid) +> (exit) +\endschemedisplay + diff --git a/csug/gifs/Makefile b/csug/gifs/Makefile new file mode 100644 index 0000000..4253ffd --- /dev/null +++ b/csug/gifs/Makefile @@ -0,0 +1,63 @@ +gifs = ghostRightarrow.gif + +# ch1.gif ch2.gif ch3.gif ch4.gif ch5.gif ch6.gif ch7.gif ch8.gif ch9.gif\ +# ch10.gif ch11.gif ch12.gif + +density=-r90x90 + +.SUFFIXES: +.SUFFIXES: .tex .gif .eps + +# translate ps file to ppm, crop to minimum background, and translate ppm +# to gif with white (background) transparent +# +.tex.gif: + echo | latex $* &&\ + dvips -f < $*.dvi |\ + gs -q -dNOPAUSE -dSAFER -sDEVICE=ppmraw -sOutputFile=-\ + ${density} - |\ + pnmcrop |\ + ppmtogif -transparent white > $*.gif + rm -f $*.dvi $*.log *.aux + test -f $*.gif && chmod 644 $*.gif + +# translate ps file to gif w/o transparent white background +.eps.gif: + cat $*.eps |\ + gs -q -dNOPAUSE -dSAFER -sDEVICE=ppmraw -sOutputFile=-\ + ${density} - |\ + pnmcrop |\ + ppmtogif > $*.gif + rm -f $*.dvi $*.log *.aux + test -f $*.gif && chmod 644 $*.gif + +all: ${gifs} + +# make ghostRightarrow.gif a completely transparent version of Rightarrow.ps +# +# translate ps to gif as above but w/o making white transparent, map black +# to white, convert to ppm, and convert back to gif with white transparent +# +# could skip intermediate conversion to gif if we could map black to white +# with some ppm tool +# +# it seems like should be able to replace last three steps with +# giftrans -g '#000000=#ffffff' -t '#ffffff' +# or at least +# giftrans -g '#000000=#ffffff' | giftrans -t '#ffffff' +# but giftrans changes only the first white color it sees, not all +# +ghostRightarrow.gif: Rightarrow.tex + echo | latex Rightarrow &&\ + dvips -f < Rightarrow.dvi |\ + gs -q -dNOPAUSE -dSAFER -sDEVICE=ppmraw -sOutputFile=-\ + ${density} - |\ + pnmcrop |\ + ppmtogif |\ + giftrans -g '#000000=#ffffff' |\ + giftopnm |\ + ppmtogif -transparent white > $*.gif + rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux + test -f $*.gif && chmod 644 $*.gif + +clean: ; rm -f *.gif Make.out diff --git a/csug/gifs/Rightarrow.tex b/csug/gifs/Rightarrow.tex new file mode 100644 index 0000000..dcaee3e --- /dev/null +++ b/csug/gifs/Rightarrow.tex @@ -0,0 +1,5 @@ +\documentclass[12pt]{article} +\begin{document} +\pagestyle{empty} +$\Rightarrow$ +\end{document} diff --git a/csug/gifs/ghostRightarrow.gif b/csug/gifs/ghostRightarrow.gif new file mode 100644 index 0000000..18271f8 Binary files /dev/null and b/csug/gifs/ghostRightarrow.gif differ diff --git a/csug/intro.stex b/csug/intro.stex new file mode 100644 index 0000000..1e41e49 --- /dev/null +++ b/csug/intro.stex @@ -0,0 +1,433 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Introduction} + +This book describes {\ChezScheme} extensions to the Revised$^6$ +Report on Scheme~\cite{r6rs} (R6RS). +It contains as well a concise summary of standard and {\ChezScheme} forms +and procedures, which gives the syntax of each form and the number and +types of arguments accepted by each procedure. +Details on standard R6RS features can be found in +\index{The Scheme Programming Language, 4th Edition@\emph{The Scheme Programming Language, 4th Edition}}\hyperlink{http://www.scheme.com/tspl4/}{\emph{The +Scheme Programming Language, 4th Edition}} (TSPL4)~\cite{Dybvig:tspl4} or +the Revised$^6$ Report on Scheme. +\emph{The Scheme Programming Language, 4th Edition} also contains an +extensive introduction to the Scheme language and numerous short and +extended examples. + +Most of this document also applies equally to \index{PetiteChezScheme@\PetiteChezScheme}{\PetiteChezScheme}, +which is fully compatible with the complete {\ChezScheme} system but uses +a high-speed interpreter in place of {\ChezScheme}'s +incremental native-code compiler. +Programs written for {\ChezScheme} run unchanged in +{\PetiteChezScheme} as long as they do not require the +compiler to be invoked. +In fact, {\PetiteChezScheme} is built from the same sources as +{\ChezScheme}, with all but the compiler sources included. +A detailed discussion of the impact of this distinction appears in +Section~\ref{SECTUSEAPPLICATIONS}. + +The remainder of this chapter covers +{\ChezScheme} extensions to Scheme syntax (Section~\ref{SECTINTROSYNTAX}), +notational conventions used in this book (Section~\ref{SECTINTRONOTATION}), +the use of parameters for system customization (Section~\ref{SECTINTROPARAMETERS}), +and where to look for more information on +{\ChezScheme} (Section~\ref{SECTINTROMOREINFO}). + +Chapter~\ref{CHPTUSE} describes how one uses {\ChezScheme} +for program development, scripting, and application delivery, plus +how to get the compiler to generate the most efficient code +possible. +Chapter~\ref{CHPTDEBUG} describes debugging and object inspection +facilities. +Chapter~\ref{CHPTFOREIGN} documents facilities for interacting with +separate processes or code written in other languages. +Chapter~\ref{CHPTBINDING} describes binding forms. +Chapter~\ref{CHPTCONTROL} documents control structures. +Chapter~\ref{CHPTOBJECTS} documents operations on nonnumeric objects, +while Chapter~\ref{CHPTNUMERIC} documents various numeric operations, +including efficient type-specific operations. +Chapter~\ref{CHPTIO} describes input/output operations and +generic ports, which allow the definition of ports with arbitrary +input/output semantics. +Chapter~\ref{CHPTLIBRARIES} discusses how R6RS libraries and top-level +programs are loaded into {\ChezScheme} along with various features for +controlling and tracking the loading process. +Chapter~\ref{CHPTSYNTAX} describes syntactic extension and modules. +Chapter~\ref{CHPTSYSTEM} describes system operations, such as operations +for interacting with the operating system and customizing +{\ChezScheme}'s user interface. +Chapter~\ref{CHPTSMGMT} describes how to invoke and control the storage +management system and documents guardians and weak pairs. +Chapter~\ref{CHPTEXPEDITOR} describes {\ChezScheme}'s expression +editor and how it can be customized. +Chapter~\ref{CHPTTHREADS} documents the procedures and syntactic forms +that comprise the interface to {\ChezScheme}'s native thread system. +Finally, Chapter~\ref{CHPTCOMPAT} describes various compatibility features. + +The back of this book contains a bibliography, +the summary of forms, and an index. +The page numbers appearing in the summary of forms and +the italicized page numbers appearing in the index indicate the +locations in the text where forms and procedures are formally defined. +The summary of forms and index includes entries from TSPL4, so that +they cover the entire set of {\ChezScheme} features. +A TSPL4 entry is marked by a ``t'' prefix on the page number. + +Online versions and errata for this book and for TSPL4 can be found at +\hyperlink{http://www.scheme.com}{www.scheme.com}. +% Printed versions of this book may be obtained from +% \hyperlink{http://www.lulu.com/product/paperback/chez-scheme-version-9-users-guide/6516800}{www.lulu.com}. + +\bigskip\noindent +\emph{Acknowledgments:} +Michael Adams, Mike Ashley, Carl Bruggeman, Bob Burger, Sam +Daniel, George Davidson, Matthew Flatt, Aziz Ghuloum, Bob Hieb, Andy Keep, and Oscar Waddell have +contributed substantially to the development of {\ChezScheme}. +{\ChezScheme}'s expression editor is based on a command-line editor for +Scheme developed from 1989 through 1994 by C.~David Boyer. +File compression is performed with the use of the lz4 compression +library developed by Yann Collet or the zlib compression library +developed by Jean-loup Gailly and Mark Adler. +Implementations of the list and vector sorting routines are based on +Olin Shiver's opportunistic merge-sort algorithm and implementation. +Michael Lenaghan provided a number of corrections for earlier drafts +of this book. +Many of the features documented in this book were suggested by +current {\ChezScheme} users, and numerous comments from users have also +led to improvements in the text. +Additional suggestions for improvements to {\ChezScheme} and to this +book are welcome. + +\section{Chez Scheme Syntax\label{SECTINTROSYNTAX}} + +{\ChezScheme} extends Scheme's syntax both at the object (datum) level +and at the level of syntactic forms. +At the object level, {\ChezScheme} supports additional representations for +symbols that contain nonstandard characters, +nondecimal numbers expressed in floating-point +and scientific notation, vectors with explicit lengths, +shared and cyclic structures, records, boxes, and more. +These extensions are described below. +Form-level extensions are described throughout the book and summarized +in the Summary of Forms, which also appears in the back of this book. + +{\ChezScheme} extends the syntax of identifiers in several ways. +First, the sequence of characters making up an identifier's name may +start with digits, periods, plus signs, and minus +signs as long as the sequence cannot be parsed as a number. +For example, \scheme{0abc}, \scheme{+++}, and \scheme{..} are all +valid identifiers in {\ChezScheme}. +Second, the single-character sequences \scheme{\schlbrace} and +\scheme{\schrbrace} are identifiers. +Third, identifiers containing arbitrary characters may be printed by +escaping them with \scheme{\} or with \scheme{|}. +\scheme{\} is used to escape a single character (except 'x', since +\scheme{\x} marks the start of a hex scalar value), +whereas \scheme{|} is used +to escape the group of characters that follow it up through the +matching \scheme{|}. +For example, \scheme{\||\|} is an identifier with a two-character +name consisting of the character \scheme{|} followed by the +character \scheme{\}, and \scheme{|hit me!|} is an identifier whose name +contains a space. + +In addition, gensyms (page~\ref{desc:gensym}) are printed with +\index{\scheme{#\schlbrace} (gensym prefix)}\scheme{#\schlbrace} and +\scheme{\schrbrace} brackets that enclose both the ``pretty'' and ``unique'' +names, e.g., \scheme{#\schlbrace\raw{{}}g1426 e5g1c94g642dssw-a\schrbrace}. +They may also be printed using the pretty name only with the prefix +\index{\scheme{#:} (gensym prefix)}\scheme{#:}, e.g., +\scheme{#:g1426}. + +Arbitrary radixes from two through 36 may be specified with the prefix +\index{#r (radix prefix)@\scheme{#\var{n}r} (radix prefix)}\scheme{#\var{n}r}, +where \var{n} is the radix. +Case is not significant, so \scheme{#\var{n}R} may be used as well. +Digit values from 10 through 35 are specified as either lower- or upper-case +alphabetic characters, just as for hexadecimal numbers. +For example, \scheme{#36rZZ} is $35\times36+35$, or $1295$. + +{\ChezScheme} also permits nondecimal numbers +to be printed in floating-point or scientific notation. +For example, \scheme{#o1.4} is equivalent to \scheme{1.5}, and +\scheme{#b1e10} is equivalent to \scheme{4.0}. +Digits take precedence over exponent specifiers, so that +\scheme{#x1e20} is simply the four-digit hexadecimal number equivalent +to \scheme{7712}. + +In addition to the standard named characters +\index{\scheme{#\alarm}}\scheme{#\alarm}, +\index{\scheme{#\backspace}}\scheme{#\backspace}, +\index{\scheme{#\delete}}\scheme{#\delete}, +\index{\scheme{#\esc}}\scheme{#\esc}, +\index{\scheme{#\linefeed}}\scheme{#\linefeed}, +\index{\scheme{#\newline}}\scheme{#\newline}, +\index{\scheme{#\page}}\scheme{#\page}, +\index{\scheme{#\return}}\scheme{#\return}, +\index{\scheme{#\space}}\scheme{#\space}, +and +\index{\scheme{#\tab}}\scheme{#\tab}, +{\ChezScheme} recognizes +\index{\scheme{#\bel}}\scheme{#\bel}, +\index{\scheme{#\ls}}\scheme{#\ls}, +\index{\scheme{#\nel}}\scheme{#\nel}, +\index{\scheme{#\nul}}\scheme{#\nul}, +\index{\scheme{#\rubout}}\scheme{#\rubout}, +and +\index{\scheme{#\vt}}\scheme{#\vt} (or \scheme{#\vtab}). +Characters whose scalar values are less than 256 may also be printed with +an octal syntax consisting of the prefix \scheme{#\} followed by a three +octal-digit sequence. +For example, \scheme{#\000} is equivalent to \scheme{#\nul}. + +{\ChezScheme}'s fxvectors, or fixnum vectors, are printed like vectors +but with the prefix \scheme{#vfx(} in place of \scheme{#(}. +Vectors, bytevectors, and fxvectors may be printed with an explicit length +prefix, and when the explicit length prefix is specified, duplicate +trailing elements may be omitted. +For example, +\index{\scheme{#(} (vector prefix)}\scheme{#(a b c)} may be printed as +\index{#( (vector prefix)@\scheme{#\var{n}(} (vector prefix)}\scheme{#3(a b c)}, +and a vector of length 100 containing all zeros may be printed as +\scheme{#100(0)}. + +{\ChezScheme}'s boxes are printed with a +\index{\scheme{#&} (box prefix)}\scheme{#&} prefix, e.g., +\scheme{#&17} is a box containing the integer \scheme{17}. + +Records are printed with the syntax +\index{\scheme{#[} (record prefix)}\scheme{#[\var{type-name} \var{field} \dots]}, +where the symbol \var{type-name} is the name of the record +type and \scheme{\var{field} \dots} are the printed +representations for the contents of the fields of the record. + +Shared and cyclic structure may be printed using the graph mark and +reference prefixes +\index{#= (graph mark)@\scheme{#\var{n}=} (graph mark)}\scheme{#\var{n}=} +and +\index{## (graph reference)@\scheme{#\var{n}#} (graph reference)}\scheme{#\var{n}#}. +\scheme{#\var{n}=} is used to mark an item in the input, and +\scheme{#\var{n}#} is used to refer to the item marked \var{n}. +For example, \scheme{'(#1=(a) . #1#)} is a pair whose car and cdr +contain the same list, and \scheme{#0=(a . #0#)} is a cyclic +list, i.e., its cdr is itself. + +A \scheme{$primitive} form (see page~\pageref{desc:hash-primitive}) may +be abbreviated in the same manner as a \scheme{quote} form, using the +\index{#% ($primitive)@\scheme{#%} (\scheme{$primitive})}\scheme{#%} prefix. +For example, +\scheme{#%car} is equivalent to \scheme{($primitive car)}, +\scheme{#2%car} to \scheme{($primitive 2 car)}, and +\scheme{#3%car} to \scheme{($primitive 3 car)}. + +{\ChezScheme}'s end-of-file object is printed \scheme{#!eof}. +If the end-of-file object appears outside of any datum within a file +being loaded, \scheme{load} will treat it as if it were a true +end of file and stop loading at that point. +Inserting \scheme{#!eof} into the middle of a file can thus be handy +when tracking down a load-time error. + +Broken pointers in weak pairs (see page~\pageref{desc:weak-cons}) are +represented by the \emph{broken weak pointer} object, which is +printed \scheme{#!bwp}. + +In addition to the standard delimiters (whitespace, open and close +parentheses, open and close brackets, double quotes, semi-colon, +and \scheme{#}), {\ChezScheme} also treats as delimiters +open and close braces, single quote, backward quote, and comma. + +Finally, {\ChezScheme} accepts \index{\scheme{#true}}\scheme{#true} and +\index{\scheme{#false}}\scheme{#false} as alternative spellings of the booleans +\scheme{#t} and \scheme{#f}. Like the external representation of numbers, case +is not significant; for example, \scheme{#T}, \scheme{#True} and \scheme{#TRUE} +are all equivalent. + +The {\ChezScheme} lexical extensions described above are disabled in an +input stream after an \scheme{#!r6rs} comment directive has been seen, +unless a \scheme{#!chezscheme} comment directive has been seen since. +Each library loaded implicitly via \scheme{import} and each RNRS top-level +program loaded via the \scheme{--program} command-line option, the +\scheme{scheme-script} command, or the \scheme{load-program} procedure is +treated as if it begins implicitly with an \scheme{#!r6rs} comment directive. + +The case of symbol and character names is normally significant, +as required by the Revised$^6$ Report. +Names are folded, as if by \scheme{string-foldcase}, following a +\scheme{#!fold-case} comment directive in the same input stream +unless a \scheme{#!no-fold-case} has been seen since. +Names are also folded if neither directive has been seen and the +parameter \scheme{case-sensitive} has been set to \scheme{#f}. + +The printer invoked by \scheme{write}, \scheme{put-datum}, +\scheme{pretty-print}, and the \scheme{format} \scheme{~s} +option always prints standard Revised$^6$ Report objects +using the standard syntax, unless a different behavior is +requested via the setting of one of the print parameters. +For example, it prints symbols in the extended identifier syntax +of Chez Scheme described above using hex scalar value escapes, +unless the parameter +\index{\scheme{print-extended-identifiers}}\scheme{print-extended-identifiers} is set to +true. +Similarly, it does not print the explicit length or suppress +duplicate trailing elements unless the parameter +\index{\scheme{print-vector-length}}\scheme{print-vector-length} is set to +true. + + +\section{Notational Conventions\label{SECTINTRONOTATION}} + +This book follows essentially the same notational conventions as +\emph{The Scheme Programming Language, 4th Edition}. +These conventions are repeated below, with notes specific to +{\ChezScheme}. + +When the value produced by a procedure or syntactic form is said to +be \index{unspecified}\emph{unspecified}, the form or procedure may +return any number of values, each of which may be any Scheme +object. +{\ChezScheme} usually returns a single, unique +\index{void object}\emph{void} object +(see \index{\scheme{void}}\scheme{void}) whenever +the result is unspecified; avoid counting on this behavior, however, +especially if your program may be ported to another Scheme implementation. +Printing of the void object is suppressed by {\ChezScheme}'s waiter +(read-evaluate-print loop). + +% following borrowed from TSPL4 +\index{exceptions}This book uses the words ``must'' and ``should'' to +describe program requirements, such as the requirement to provide an index +that is less than the length of the vector in a call to +\scheme{vector-ref}. +If the word ``must'' is used, it means that the requirement is enforced +by the implementation, i.e., an exception is raised, usually with +condition type \scheme{&assertion}. +If the word ``should'' is used, an exception may or may not be raised, +and if not, the behavior of the program is undefined. +\index{syntax violation}The phrase ``syntax violation'' is used to +describe a situation in which a program is malformed. +Syntax violations are detected prior to program execution. +When a syntax violation is detected, an exception of type \scheme{&syntax} +is raised and the program is not executed. + +Scheme objects are displayed in a \scheme{typewriter} typeface just +as they are to be typed at the keyboard. +This includes identifiers, constant objects, parenthesized Scheme +expressions, and whole programs. +An \emph{italic} typeface is used to set off syntax variables in +the descriptions of syntactic forms and arguments in the descriptions of +procedures. +Italics are also used to set off technical terms the first time they +appear. +The first letter of an identifier that is not ordinarily capitalized +is not capitalized when it appears at the beginning of a sentence. +The same is true for syntax variables written in italics. + +In the description of a syntactic form or procedure, a pattern shows +the syntactic form or the application of the procedure. +The syntax keyword or procedure name is given in typewriter font, +as are parentheses. +The remaining pieces of the syntax or arguments are shown in italics, +using names that imply the types of the expressions or arguments expected +by the syntactic form or procedure. +Ellipses are used to specify +zero or more occurrences of a subexpression or argument. + + +\section{Parameters\label{SECTINTROPARAMETERS}} + +\index{parameters}All {\ChezScheme} system customization is done via +\emph{parameters}. +A parameter is a procedure that encapsulates a hidden state variable. +When invoked without arguments, a parameter returns the value of +the encapsulated variable. +When invoked with one argument, the parameter changes the value +of the variable to the value of its argument. +A parameter may raise an exception if its argument is not appropriate, +or it may filter the argument in some way. + +New parameters may be created and used by programs running in +{\ChezScheme}. +Parameters are used rather than global variables for program customization +for two reasons: +First, unintentional redefinition of a customization variable can cause +unexpected problems, whereas unintentional redefinition of a +parameter simply makes the parameter inaccessible. +For example, a program that defines \scheme{*print-level*} for its own +purposes in early releases of {\ChezScheme} would have unexpected +effects on the printing of Scheme objects, whereas a program that +defines \index{\scheme{print-level}}\scheme{print-level} for its own +purposes simply loses the ability to alter the printer's behavior. +Of course, a program that invokes \scheme{print-level} by accident can +still affect the system in unintended ways, but such an occurrence is +less likely, and can only happen in an incorrect program. + +Second, invalid values for parameters can be detected and rejected +immediately when the ``assignment'' is made, rather than at the point +where the first use occurs, when it is too late to recover and +reinstate the old value. +For example, an assignment of \scheme{*print-level*} to $-1$ would not +have been caught until the first call to \scheme{write} or +\scheme{pretty-print}, whereas an attempted assignment of $-1$ to the +parameter \scheme{print-level}, i.e., \scheme{(print-level -1)}, is +flagged as an error immediately, before the change is actually made. + +Built-in system parameters are described in different sections +throughout this book and are listed along with other syntactic +forms and procedures in the Summary of Forms in the +back of this book. +Parameters marked ``thread parameters'' have per-thread values in threaded +versions of {\ChezScheme}, while the values of parameters marked ``global +parameters'' are shared by all threads. +Nonthreaded versions of {\ChezScheme} do not distinguish between +thread and global parameters. +See Sections~\ref{SECTPARAMETERS} and~\ref{SECTTHREADPARAMETERS} for +more information on creating and manipulating parameters. + + +\section{More Information\label{SECTINTROMOREINFO}} + +The articles and technical reports listed below document various +features of {\ChezScheme} and its implementation: + +\begin{itemize} +\item syntactic abstraction~\cite{Dybvig:expansion:jour,Dybvig:syntax-case,Dybvig:syntactic}, +\item modules~\cite{waddell:modules}, +\item libraries~\cite{Ghuloum:libraries}, +\item storage management~\cite{Dybvig:guardians,Dybvig:sm}, +\item threads~\cite{Dybvig:mitchfest-threads}, +\item multiple return values~\cite{Ashley:mvalues}, +\item optional arguments~\cite{Dybvig:lambdastar}, +\item continuations~\cite{Dybvig:phd,Hieb:representing,Bruggeman:oneshots}, +\item eq? hashtables~\cite{ghuloum:eq-hash-tables}, +\item internal definitions, \scheme{letrec}, and \scheme{letrec*}~\cite{Waddell:fixing-letrec,Ghuloum:fixing-letrec}, +\item \scheme{equal?}~\cite{adams:equal}, +\item engines~\cite{Dybvig:engines}, +\item floating-point printing~\cite{Burger:floatprinting}, +\item code generation~\cite{Dybvig:destination}, +\item register allocation~\cite{Burger:regalloc}, +\item procedure inlining~\cite{waddell:sas97}, +\item profiling~\cite{Burger:pdrtc}, +and +\item history of the implementation~\cite{Dybvig:hocs}. +\end{itemize} + +\noindent +Links to abstracts and electronic versions of these publications are +available at the url +\hyperlink{http://www.cs.indiana.edu/chezscheme/pubs/}{http://www.cs.indiana.edu/chezscheme/pubs/}. +% Additional resources, +% online versions of this book and of The Scheme Programming Language, +% 4th Edition, and links to various Scheme resources are available at +% \hyperlink{http://www.scheme.com}{www.scheme.com}. diff --git a/csug/io.stex b/csug/io.stex new file mode 100644 index 0000000..038a2ea --- /dev/null +++ b/csug/io.stex @@ -0,0 +1,4338 @@ +% Copyright 2005-2018 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Input/Output Operations\label{CHPTIO}} + +This chapter describes {\ChezScheme}'s generic port facility, +operations on ports, and various {\ChezScheme} extensions to the +standard set of input/output operations. +See Chapter~\ref{TSPL:CHPTIO} of {\TSPLFOUR} or the Revised$^6$ Report +on Scheme for a description of standard input/output operations. +Definitions of a few sample generic ports are given in +Section~\ref{SECTPORTEXAMPLES}. + +{\ChezScheme} closes file ports automatically after they become +inaccessible to the program or when the Scheme program exits, but it is +best to close ports explicitly whenever possible. + + +\section{Generic Ports} + +{\ChezScheme}'s ``\index{generic port}generic port'' facility +allows the programmer to add new types of textual ports with +arbitrary input/output semantics. +It may be used, for example, to define any of the built-in +Common Lisp~\cite{Steele:common} stream types, i.e., +\index{synonym streams}synonym streams, +\index{broadcast streams}broadcast streams, +\index{concatenated streams}concatenated streams, +\index{two-way streams}two-way streams, +\index{echo streams}echo streams, and +\index{string streams}string streams. +It may also be used to define more exotic ports, such as ports that +represent windows on a bit-mapped display or ports that represent +processes connected to the current process via pipes or sockets. + +Each port has an associated \emph{port handler}. +A port handler is a procedure that accepts messages in an +object-oriented style. +Each message corresponds to one of the low-level Scheme operations +on ports, such as \scheme{read-char} and \scheme{close-input-port} (but not +\scheme{read}, which is defined in terms of the lower-level operations). +Most of these operations simply call the handler immediately with +the corresponding message. + +Standard messages adhere to the following conventions: the message name is +the first argument to the handler. +It is always a symbol, and it is always the name of a primitive +Scheme operation on ports. +The additional arguments are the same as the arguments to the +primitive procedure and occur in the same order. +(The port argument to some of the primitive procedures is optional; +in the case of the messages passed to a handler, the port argument +is always supplied.) +The following messages are defined for built-in ports: + +\schemedisplay +block-read \var{port} \var{string} \var{count} +block-write \var{port} \var{string} \var{count} +char-ready? \var{port} +clear-input-port \var{port} +clear-output-port \var{port} +close-port \var{port} +file-position \var{port} +file-position \var{port} \var{position} +file-length \var{port} +flush-output-port \var{port} +peek-char \var{port} +port-name \var{port} +read-char \var{port} +unread-char \var{char} \var{port} +write-char \var{char} \var{port} +\endschemedisplay + +\noindent +Additional messages may be accepted by user-defined ports. + +{\ChezScheme} input and output is normally buffered for efficiency. +To support buffering, each input port contains an input buffer and +each output port contains an output buffer. +Bidirectional ports, ports that are both input ports and output +ports, contain both input and output buffers. +Input is not buffered if the input buffer is the empty string, +and output is not buffered if the output buffer is the empty +string. +In the case of unbuffered input and output, calls to \scheme{read-char}, +\scheme{write-char}, and similar messages cause the handler to be invoked +immediately with the corresponding message. +For buffered input and output, calls to these procedures cause the +buffer to be updated, and the handler is not called under normal +circumstances until the buffer becomes empty (for input) or full (for +output). +Handlers for buffered ports must \var{not} count +on the buffer being empty or full when \scheme{read-char}, \scheme{write-char}, and +similar messages are received, however, due to the possibility that (a) +the handler is invoked through some other mechanism, or (b) the +call to the handler is interrupted. + +In the presence of keyboard, timer, and other interrupts, it is +possible for a call to a port handler to be interrupted or for the +handler itself to be interrupted. +If the port is accessible outside of the interrupted code, there +is a possibility that the interrupt handler will cause input or +output to be performed on the port. +This is one reason, as stated above, that port handlers must not count +on the input buffer being empty or output buffer being full when a +\scheme{read-char}, \scheme{write-char}, or similar message is received. +In addition, port handlers may need to manipulate the buffers only +with interrupts disabled (using \scheme{with-interrupts-disabled}). + +Generic ports are created via one of the port construction +procedures \scheme{make-input-port}, +\scheme{make-output-port}, and \scheme{make-input/output-port} defined +later in this chapter. +Ports have seven accessible fields: + +\begin{description} +\item[\var{handler},] accessed with \scheme{port-handler}; +\item[\var{output-buffer},] accessed with \scheme{port-output-buffer}, +\item[\var{output-size},] accessed with \scheme{port-output-size}, +\item[\var{output-index},] accessed with \scheme{port-output-index}, +\item[\var{input-buffer},] accessed with \scheme{port-input-buffer}, +\item[\var{input-size},] accessed with \scheme{port-input-size}, and +\item[\var{input-index},] accessed with \scheme{port-input-index}. +\end{description} + +\noindent +The output-size and output-index fields are valid only for output +ports, and the input-size and input-index fields are valid only for +input ports. +The output and input size and index fields may be updated as well +using the corresponding ``\scheme{set-\var{field}!}'' procedure. + +A port's output size determines how much of the port's output buffer is +actually available for writing by \scheme{write-char}. +The output size is often the same as the string length of the port's +output buffer, but it can be set to less (but no less than zero) at the +discretion of the programmer. +The output index determines to which position in the port's +buffer the next character will be written. +The output index should be between $0$ and the output size, +inclusive. +If no output has occurred since the buffer was last flushed, the +output index should be $0$. +If the index is less than the size, \scheme{write-char} +stores its character argument into the specified character +position within the buffer and increments the index. +If the index is equal to the size, \scheme{write-char} leaves the fields of +the port unchanged and invokes the handler. + +A port's input size determines how much of the port's input buffer is +actually available for reading by \scheme{read-char}. +A port's input size and input index are constrained in the same manner +as output size and index, i.e., the input size must be between +$0$ and the string length of the input buffer (inclusive), and the input +index must be between $0$ and the input size (inclusive). +Often, the input size is less than the length of the input buffer +because there are fewer characters available to read than would fit +in the buffer. +The input index determines from which position in the input buffer the +next character will be read. +If the index is less than the size, \scheme{read-char} extracts the character +in this position, increments the index, and returns the character. +If the index is equal to the size, \scheme{read-char} leaves the fields of +the port unchanged and invokes the handler. + +The operation of \scheme{peek-char} is similar to that of \scheme{read-char}, except +that it does not increment the input index. +\scheme{unread-char} decrements the input index if it is greater than $0$, +otherwise it invokes the handler. +\scheme{char-ready?} returns \scheme{#t} if the input index is less than the input +size, otherwise it invokes the handler. + +Although the fields shown and discussed above are logically present in +a port, actual implementation details may differ. +The current {\ChezScheme} implementation uses a different representation +that allows \scheme{read-char}, \scheme{write-char}, and similar operations to be +open-coded with minimal overhead. +The access and assignment operators perform the conversion between the +actual representation and the one shown above. + +Port handlers receiving a message must return a value appropriate for +the corresponding operation. +For example, a handler receiving a \scheme{read-char} message must return a +character or eof object (if it returns). +For operations that return unspecified values, such as \scheme{close-port}, +the handler is not required to return any particular value. + +\section{File Options\label{SECTFILEOPTIONS}} + +The Revised$^6$ Report requires that the universe of a file-options +enumeration set must include \scheme{no-create}, \scheme{no-fail}, +and \scheme{no-truncate}, whose meanings are described within the +description of the \scheme{file-options} syntax in +Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR}. +{\ChezScheme} defines a number of additional file options: + +\begin{description} +\item[\var{compressed}:] +An output file should be compressed when written; and a compressed input +file should be decompressed when read. The compression format for output +is determined by the \index{\scheme{compress-format}}\scheme{compress-format} +parameter, while the compression format on input is inferred. +The compression level, which is relevant only for output, is determined +by the \index{\scheme{compress-level}}\scheme{compress-level} parameter. + +\item[\var{replace}:] +For output files only, replace (remove and recreate) the existing file if +it exists. + +\item[\var{exclusive}:] +For output files only, lock the file for exclusive access. +On some systems the lock is advisory, i.e., it inhibits access by +other processes only if they also attempt to open exclusively. + +\item[\var{append}:] +For output files only, position the output port at the end of the file +before each write so that output to the port is always appended to the +file. + +\item[\var{perm-set-user-id}:] +For newly created output files under Unix-based systems only, set +user-id bit. + +\item[\var{perm-set-group-id}:] +For newly created output files under Unix-based systems only, set +group-id bit. + +\item[\var{perm-sticky}:] +For newly created output files under Unix-based systems only, set +sticky bit. + +\item[\var{perm-no-user-read}:] +For newly created output files under Unix-based systems only, +do not set user read bit. +(User read bit is set by default, unless masked by the process umask.) + +\item[\var{perm-no-user-write}:] +For newly created output files under Unix-based systems only, +do not set user write bit. +(User write bit is set by default, unless masked by the process umask.) + +\item[\var{perm-user-execute}:] +For newly created output files under Unix-based systems only, +set user execute bit unless masked by process umask. +(User execute bit is not set by default.) + +\item[\var{perm-no-group-read}:] +For newly created output files under Unix-based systems only, +do not set group read bit. +(Group read bit is set by default, unless masked by the process umask.) + +\item[\var{perm-no-group-write}:] +For newly created output files under Unix-based systems only, +do not set group write bit. +(Group write bit is set by default, unless masked by the process umask.) + +\item[\var{perm-group-execute}:] +For newly created output files under Unix-based systems only, +set group execute bit unless masked by process umask. +(Group execute bit is not set by default.) + +\item[\var{perm-no-other-read}:] +For newly created output files under Unix-based systems only, +do not set other read bit. +(Other read bit is set by default, unless masked by the process umask.) + +\item[\var{perm-no-other-write}:] +For newly created output files under Unix-based systems only, +do not set other write bit. +(Other write bit is set by default, unless masked by the process umask.) + +\item[\var{perm-other-execute}:] +For newly created output files under Unix-based systems only, +set other execute bit unless masked by process umask. +(Other execute bit is not set by default.) +\end{description} + +\section{Transcoders\label{SECTTRANSCODERS}} + +The language of the Revised$^6$ Report provides three built-in codecs: +a latin-1 codec, a utf-8 codec, and a utf-16 codec. +{\ChezScheme} provides three additional codecs: a utf-16le codec, +utf-16be codec, and an ``iconv'' codec for non-Unicode character sets. +It also provides an alternative to the standard utf-16 codec that +defaults to little-endian format rather than the default big-endian +format. +This section describes these codecs, plus a \scheme{current-transcoder} +parameter that allows the programmer to determine the transcoder +used for a textual port whenever the transcoder is implicit, as for +\scheme{open-input-file} or \scheme{load}, along with the +predicate \scheme{transcoder?}, which should be standard but is not. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{utf-16-codec}{\categoryprocedure}{(utf-16-codec)} +\formdef{utf-16-codec}{\categoryprocedure}{(utf-16-codec \var{endianness})} +\formdef{utf-16le-codec}{\categoryprocedure}{(utf-16le-codec)} +\formdef{utf-16be-codec}{\categoryprocedure}{(utf-16be-codec)} +\returns a codec +\listlibraries +\endentryheader + +\var{endianness} must be the symbol \scheme{big} or the symbol +\scheme{little}. + +The codec returned by \scheme{utf-16-codec} can be used to create and +process data written UTF-16 format. +When called without the \var{endianness} argument or with \var{endianness} +\scheme{big}, \scheme{utf-16-codec} returns a codec for standard UTF-16 +data, i.e., one that defaults to big-endian format if no byte-order mark +(BOM) is found. + +When output is transcoded with a transcoder based on this codec, a BOM is +emitted just before the first character written, and each character is +written as a UTF-16 character in big-endian format. +For input, a BOM is looked for at the start of the +input and, if present, controls the byte order of the remaining +UTF-16 characters. +If no BOM is present, big-endian order is assumed. +For input-output ports, the BOM is not emitted if the file is +read before written, and a BOM is not looked for if the file is written +before read. + +For textual ports created via \scheme{transcoded-port}, a BOM written or +read via the transcoder appears at the beginning of the underlying data +stream or file only if the binary port passed to \scheme{transcoded-port} +is positioned at the start of the data stream or file. +When the transcoder can determine this is the case, it sets a flag that +causes \scheme{set-port-position!} to position the port beyond the BOM if +an attempt is made to reposition the port to the start of the data stream +or file, so that the BOM is preserved. + +When called with \var{endianness} \scheme{little}, \scheme{utf-16-codec} +returns a codec that defaults to the little-endian format both for reading +and for writing. +For output-only streams or input/output streams that are written before read, +the result is standard UTF-16, with a BOM that specifies little-endian +format followed by characters in little-endian byte order. +For input-only streams or input/output streams that are read before written, +this codec allows programs to read from input streams that either +begin with a BOM or are encoded in UTF-16LE format. +This is particularly useful for handling files that might have been +produced by older Windows applications that claim to produce UTF-16 files +but actually produce UTF-16LE files. + +The Revised$^6$ Report version of \scheme{utf-16-codec} lacks the +optional \var{endianness} argument. + +The codecs returned by \scheme{utf-16le-codec} and \scheme{utf-16be-codec} +are used to read and write data in the UTF-16LE and UTF-16BE formats, +i.e., UTF-16 with little-endian or big-endian byte order and no BOM. +For output, these codecs are useful for controlling whether and where +the BOM is emitted, since no BOM is emitted implicitly and a BOM +can be emitted explicitly as an ordinary character. +For input, these codecs are useful for processing files known to be +in little-endian or big-endian format with no BOM. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{iconv-codec}{\categoryprocedure}{(iconv-codec \var{code-page})} +\returns a codec +\listlibraries +\endentryheader + +\var{code-page} must be a string and should identify a codec accepted by +the \scheme{iconv} library installed on the target machine. +The codec returned by this procedure can be used to convert from the +non-Unicode single- and multiple-byte character sets supported by +\scheme{iconv}. +When used in the input direction, the codec converts byte sequences +into Scheme strings, and when used in the output direction, it converts +Scheme strings to byte sequences. + +The set of supported code pages depends on the version of +\scheme{iconv} available; consult the \scheme{iconv} documentation +or use the shell command \scheme{iconv --list} to obtain a list +of supported code pages. + +While the Windows operating system does not supply an \scheme{iconv} +library, it is possible to use \scheme{iconv-codec} on Windows systems by +supplying an \scheme{iconv} dynamic-link library (named \scheme{iconv.dll}, +\scheme{libiconv.dll}, or \scheme{libiconv-2.dll}) that provides +Posix-conformant \scheme{iconv_open}, \scheme{iconv}, and +\scheme{iconv_close} entry points either under those names or under the +alternative names \scheme{libiconv_open}, \scheme{libiconv}, and +\scheme{libiconv_close}. +The dll must be located in a standard location for dlls or in the +current directory of the process the first time \scheme{iconv-codec} +is called. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-transcoder}{\categorythreadparameter}{current-transcoder} +\listlibraries +\endentryheader + +The transcoder value of the \scheme{current-transcoder} parameter is used +whenever a textual file is opened with an implicit transcoder, e.g., by +\scheme{open-input-file} and other convenience I/O procedures, +\scheme{compile-file} \scheme{include}, \scheme{load}, and +\scheme{pretty-file}. +Its initial value is the value of the \scheme{native-transcoder} procedure. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{transcoder?}{\categoryprocedure}{(transcoder? \var{obj})} +\returns \scheme{#t} if \var{obj} is a transcoder, \scheme{#f} otherwise +\listlibraries +\endentryheader + + +\section{Port Operations\label{SECTPORTOPERATIONS}} + +The procedures used to create, access, and alter ports directly +are described in this section. +Also described are several nonstandard operations on ports. + +Unless otherwise specified, procedures requiring either input ports or +output ports as arguments accept input/output ports as well, i.e., an +input/output port is both an input port and an output port. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-input-port}{\categoryprocedure}{(make-input-port \var{handler} \var{input-buffer})} +\formdef{make-output-port}{\categoryprocedure}{(make-output-port \var{handler} \var{output-buffer})} +\formdef{make-input/output-port}{\categoryprocedure}{(make-input/output-port \var{handler} \var{input-buffer} \var{output-buffer})} +\returns a new textual port +\listlibraries +\endentryheader + +\noindent +\var{handler} must be a procedure, and +\var{input-buffer} and \var{output-buffer} must be strings. +Each procedure creates a \index{generic port}generic port. +The handler associated with the port is \var{handler}, the +input buffer is \var{input-buffer}, and the +output buffer is \var{output-buffer}. +For \scheme{make-input-port}, the output buffer is undefined, and for +\scheme{make-output-port}, the input buffer is undefined. + +The input size of an input or input/output port is initialized to the +string length of the input buffer, and the input index is set to $0$. +The output size and index of an output or input/output port are +initialized similarly. + +The length of an input or output buffer may be zero, in which case +buffering is effectively disabled. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-handler}{\categoryprocedure}{(port-handler \var{port})} +\returns a procedure +\listlibraries +\endentryheader + +\noindent +For generic ports, \scheme{port-handler} returns the handler passed to one +of the generic port creation procedures described above. +For ports created by \scheme{open-input-file} and similar procedures, +\scheme{port-handler} returns an internal handler that may be invoked in +the same manner as any other handler. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-input-buffer}{\categoryprocedure}{(port-input-buffer \var{input-port})} +\formdef{port-input-size}{\categoryprocedure}{(port-input-size \var{input-port})} +\formdef{port-input-index}{\categoryprocedure}{(port-input-index \var{input-port})} +\formdef{textual-port-input-buffer}{\categoryprocedure}{(textual-port-input-buffer \var{textual-input-port})} +\formdef{textual-port-input-size}{\categoryprocedure}{(textual-port-input-size \var{textual-input-port})} +\formdef{textual-port-input-index}{\categoryprocedure}{(textual-port-input-index \var{textual-input-port})} +\formdef{binary-port-input-buffer}{\categoryprocedure}{(binary-port-input-buffer \var{binary-input-port})} +\formdef{binary-port-input-size}{\categoryprocedure}{(binary-port-input-size \var{binary-input-port})} +\formdef{binary-port-input-index}{\categoryprocedure}{(binary-port-input-index \var{binary-input-port})} +\returns see below +\listlibraries +\endentryheader + +\noindent +These procedures return the input buffer, size, or index +of the input port. +The variants specialized to textual or binary ports are slightly +more efficient than their generic counterparts. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-port-input-index!}{\categoryprocedure}{(set-port-input-index! \var{input-port} \var{n})} +\formdef{set-port-input-size!}{\categoryprocedure}{(set-port-input-size! \var{input-port} \var{n})} +\formdef{set-port-input-buffer!}{\categoryprocedure}{(set-port-input-buffer! \var{input-port} \var{x})} +\formdef{set-textual-port-input-index!}{\categoryprocedure}{(set-textual-port-input-index! \var{textual-input-port} \var{n})} +\formdef{set-textual-port-input-size!}{\categoryprocedure}{(set-textual-port-input-size! \var{textual-input-port} \var{n})} +\formdef{set-textual-port-input-buffer!}{\categoryprocedure}{(set-textual-port-input-buffer! \var{textual-input-port} \var{string})} +\formdef{set-binary-port-input-index!}{\categoryprocedure}{(set-binary-port-input-index! \var{binary-input-port} \var{n})} +\formdef{set-binary-port-input-size!}{\categoryprocedure}{(set-binary-port-input-size! \var{binary-input-port} \var{n})} +\formdef{set-binary-port-input-buffer!}{\categoryprocedure}{(set-binary-port-input-buffer! \var{binary-input-port} \var{bytevector})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{set-port-input-index!} sets the input index field of +\var{input-port} to $n$, which must be a nonnegative integer less than +or equal to the port's input size. + +The procedure \scheme{set-port-input-size!} sets the input size field of +\var{input-port} to $n$, which must be a nonnegative integer less than +or equal to the string length of the port's input buffer. +It also sets the input index to $0$. + +The procedure \scheme{set-port-input-buffer!} sets the input buffer field of +\var{input-port} to $x$, which must be a string for textual ports and a +bytevector for binary ports. +It also sets the input size to the length of the string or bytevector +and the input index to $0$. + +The variants specialized to textual or binary ports are slightly +more efficient than their generic counterparts. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-input-count}{\categoryprocedure}{(port-input-count \var{input-port})} +\formdef{textual-port-input-count}{\categoryprocedure}{(textual-port-input-count \var{textual-input-port})} +\formdef{binary-port-input-count}{\categoryprocedure}{(binary-port-input-count \var{binary-input-port})} +\returns see below +\listlibraries +\endentryheader + +These procedures return an exact integer representing the number of +characters or bytes left to be read from the port's input buffer, i.e., +the difference between the buffer size and index. + +The variants specialized to textual or binary ports are slightly +more efficient than their generic counterpart. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-input-empty?}{\categoryprocedure}{(port-input-empty? \var{input-port})} +\returns \scheme{#t} if the port's input buffer contains no more data, otherwise \scheme{#f} +\listlibraries +\endentryheader + +This procedure determines whether the port's input count is zero without +computing or returning the actual count. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-output-buffer}{\categoryprocedure}{(port-output-buffer \var{output-port})} +\formdef{port-output-size}{\categoryprocedure}{(port-output-size \var{output-port})} +\formdef{port-output-index}{\categoryprocedure}{(port-output-index \var{output-port})} +\formdef{textual-port-output-buffer}{\categoryprocedure}{(textual-port-output-buffer \var{output-port})} +\formdef{textual-port-output-size}{\categoryprocedure}{(textual-port-output-size \var{output-port})} +\formdef{textual-port-output-index}{\categoryprocedure}{(textual-port-output-index \var{output-port})} +\formdef{binary-port-output-buffer}{\categoryprocedure}{(binary-port-output-buffer \var{output-port})} +\formdef{binary-port-output-size}{\categoryprocedure}{(binary-port-output-size \var{output-port})} +\formdef{binary-port-output-index}{\categoryprocedure}{(binary-port-output-index \var{output-port})} +\returns see below +\listlibraries +\endentryheader + +\noindent +These procedures return the output buffer, size, or index +of the output port. +The variants specialized to textual or binary ports are slightly +more efficient than their generic counterparts. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-port-output-index!}{\categoryprocedure}{(set-port-output-index! \var{output-port} \var{n})} +\formdef{set-port-output-size!}{\categoryprocedure}{(set-port-output-size! \var{output-port} \var{n})} +\formdef{set-port-output-buffer!}{\categoryprocedure}{(set-port-output-buffer! \var{output-port} \var{x})} +\formdef{set-textual-port-output-index!}{\categoryprocedure}{(set-textual-port-output-index! \var{textual-output-port} \var{n})} +\formdef{set-textual-port-output-size!}{\categoryprocedure}{(set-textual-port-output-size! \var{textual-output-port} \var{n})} +\formdef{set-textual-port-output-buffer!}{\categoryprocedure}{(set-textual-port-output-buffer! \var{textual-output-port} \var{string})} +\formdef{set-binary-port-output-index!}{\categoryprocedure}{(set-binary-port-output-index! \var{output-port} \var{n})} +\formdef{set-binary-port-output-size!}{\categoryprocedure}{(set-binary-port-output-size! \var{output-port} \var{n})} +\formdef{set-binary-port-output-buffer!}{\categoryprocedure}{(set-binary-port-output-buffer! \var{binary-output-port} \var{bytevector})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{set-port-output-index!} sets the output index field of +the output port to $n$, which must be a nonnegative integer less than +or equal to the port's output size. + +The procedure \scheme{set-port-output-size!} sets the output size field of +the output port to $n$, which must be a nonnegative integer less than +or equal to the string length of the port's output buffer. +It also sets the output index to $0$. + +The procedure \scheme{set-port-output-buffer!} sets the output buffer field of +\var{output-port} to $x$, which must be a string for textual ports and a +bytevector for binary ports. +It also sets the output size to the length of the string or bytevector +and the output index to $0$. + +The variants specialized to textual or binary ports are slightly +more efficient than their generic counterparts. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-output-count}{\categoryprocedure}{(port-output-count \var{output-port})} +\formdef{textual-port-output-count}{\categoryprocedure}{(textual-port-output-count \var{textual-output-port})} +\formdef{binary-port-output-count}{\categoryprocedure}{(binary-port-output-count \var{binary-output-port})} +\returns see below +\listlibraries +\endentryheader + +These procedures return an exact integer representing the amount of +space in characters or bytes available to be written in the +port's output buffer, i.e., the difference between the buffer size +and index. + +The variants specialized to textual or binary ports are slightly +more efficient than their generic counterpart. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-output-full?}{\categoryprocedure}{(port-output-full? \var{output-port})} +\returns \scheme{#t} if the port's input buffer has no more room, otherwise \scheme{#f} +\listlibraries +\endentryheader + +This procedure determines whether the port's output count is zero without +computing or returning the actual count. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mark-port-closed!}{\categoryprocedure}{(mark-port-closed! \var{port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +This procedure directly marks the port closed so that no further +input or output operations are allowed on it. +It is typically used by handlers upon receipt of a \scheme{close-port} +message. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-closed?}{\categoryprocedure}{(port-closed? \var{port})} +\returns \scheme{#t} if \var{port} is closed, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(let ([p (open-output-string)]) + (port-closed? p)) ;=> #f + +(let ([p (open-output-string)]) + (close-port p) + (port-closed? p)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader\label{desc:set-port-bol} +\formdef{set-port-bol!}{\categoryprocedure}{(set-port-bol! \var{output-port} \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +When \var{obj} is \scheme{#f}, the port's beginning-of-line (BOL) +flag is cleared; otherwise, the port's BOL flag is set. + +The BOL flag is consulted by \scheme{fresh-line} +(page~\pageref{desc:fresh-line}) to determine if it needs to emit a +newline. +This flag is maintained automatically for file output ports, string output +ports, and transcript ports. +The flag is set for newly created file and string output ports, except +for file output ports created with the \scheme{append} option, for which +the flag is reset. +The BOL flag is clear for newly created generic ports and never set +automatically, but may be set explicitly using \scheme{set-port-bol!}. +The port is always flushed immediately before the flag is consulted, so it +need not be maintained on a per-character basis for buffered ports. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-bol?}{\categoryprocedure}{(port-bol? \var{port})} +\returns \scheme{#t} if \var{port}'s BOL flag is set, \scheme{#f} otherwise +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-port-eof!}{\categoryprocedure}{(set-port-eof! \var{input-port} \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +When \var{obj} is not \scheme{#f}, \scheme{set-port-eof!} marks \var{input-port} +so that, once its buffer is empty, the port is treated as if it were at +eof even if more data is available in the underlying byte or character +stream. +Once this artificial eof has been read, the eof mark is cleared, making +any additional data in the stream available beyond the eof. +This feature can be used by a generic port to simulate a stream consisting +of multiple input files. + +When \var{obj} is \scheme{#f}, the eof mark is cleared. + +The following example assumes /dev/zero provides an infinite stream of +zero bytes. + +\schemedisplay +(define p + (parameterize ([file-buffer-size 3]) + (open-file-input-port "/dev/zero"))) +(set-port-eof! p #t) +(get-u8 p) ;=> #!eof +(get-u8 p) ;=> 0 +(set-port-eof! p #t) +(get-u8 p) ;=> 0 +(get-u8 p) ;=> 0 +(get-u8 p) ;=> #!eof +(get-u8 p) ;=> 0 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-name}{\categoryprocedure}{(port-name \var{port})} +\returns the name associated with \var{port} +\listlibraries +\endentryheader + +\noindent +The name may be any object but is usually a string or \scheme{#f} +(denoting no name). +For file ports, the name is typically a string naming the file. + +\schemedisplay +(let ([p (open-input-file "myfile.ss")]) + (port-name p)) ;=> "myfile.ss" + +(let ([p (open-output-string)]) + (port-name p)) ;=> "string" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-port-name!}{\categoryprocedure}{(set-port-name! \var{port} \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +This procedure sets \var{port}'s name to \var{obj}, which should be +a string or \scheme{#f} (denoting no name). + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-length}{\categoryprocedure}{(port-length \var{port})} +\formdef{file-length}{\categoryprocedure}{(file-length \var{port})} +\returns the length of the file or other object to which \var{port} refers +\formdef{port-has-port-length?}{\categoryprocedure}{(port-has-port-length? \var{port})} +\returns \scheme{#t} if the port supports \scheme{port-length}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +A port may allow the length of the underlying stream of characters or bytes +to be determined. +If so, the procedure \scheme{port-has-port-length?} returns +\scheme{#t} and \scheme{port-length} returns the current length. +For binary ports, the length is always an exact nonnegative integer byte +count. +For textual ports, the representation of a length is unspecified; it +may not be an exact nonnegative integer and, even if it is, it may not +represent either a byte or character count. +The length may be used at some later time to reset the length if the +port supports \scheme{set-port-length!}. +If \scheme{port-length} is called on a port that does not support it, +an exception with condition type \scheme{&assertion} is raised. + +File lengths beyond $2^{32}$ might not be reported property +for compressed files on 32-bit versions of the system. + +\scheme{file-length} is identical to \scheme{port-length}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-port-length!}{\categoryprocedure}{(set-port-length! \var{port} \var{len})} +\returns unspecified +\formdef{port-has-set-port-length!?}{\categoryprocedure}{(port-has-set-port-length!? \var{port})} +\returns \scheme{#t} if the port supports \scheme{set-port-length!}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +A port may allow the length of the underlying stream of characters or bytes +to be set, i.e., extended or truncated. +If so, the procedure \scheme{port-has-set-port-length!?} returns +\scheme{#t} and \scheme{set-port-length!} changes the length. +For binary ports, the length \var{len} must be an exact nonnegative integer byte +count. +For textual ports, the representation of a length is unspecified, as +described in the entry for \scheme{port-length} above, but \var{len} must be +an appropriate length for the textual port, which is usually guaranteed +to be the case only if it was obtained from a call to \scheme{port-length} +on the same port. +If \scheme{set-port-length!} is called on a port that does not support it, +an exception with condition type \scheme{&assertion} is raised. + +It is not possible to set the length of a port opened with compression +to an arbitrary position, and the result of an attempt to set the length +of a compressed file beyond $2^{32}$ on 32-bit versions of the system is +undefined. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-nonblocking?}{\categoryprocedure}{(port-nonblocking? \var{port})} +\returns \scheme{#t} if the port is in nonblocking mode, \scheme{#f} otherwise +\formdef{port-has-port-nonblocking??}{\categoryprocedure}{(port-has-port-nonblocking?? \var{port})} +\returns \scheme{#t} if the port supports \scheme{port-nonblocking?}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +A port may allow the nonblocking status of the port to be determined. +If so, the procedure \scheme{port-has-port-nonblocking??} returns +\scheme{#t} and \scheme{port-nonblocking?} returns a boolean value +reflecting whether the port is in nonblocking mode. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-port-nonblocking!}{\categoryprocedure}{(set-port-nonblocking! \var{port} \var{obj})} +\returns unspecified +\formdef{port-has-set-port-nonblocking!?}{\categoryprocedure}{(port-has-set-port-nonblocking!? \var{port})} +\returns \scheme{#t} if the port supports \scheme{set-port-nonblocking!}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +A port may allow reads or writes to be performed in a ``nonblocking'' fashion. +If so, the procedure \scheme{port-has-set-port-nonblocking!?} returns +\scheme{#t} and \scheme{set-port-nonblocking!} sets the port to nonblocking +mode (if \var{obj} is a true value) or blocking mode (if \var{obj} is \scheme{#f}). +If \scheme{set-port-nonblocking!} is called on a port that does not support it, +an exception with condition type \scheme{&assertion} is raised. + +Ports created by the standard Revised$^6$ port opening procedures are +initially set in blocking mode by default. +The same is true for most of the procedures described in this document. +A generic port based on a nonblocking source may be nonblocking +initially. +A port returned by \scheme{open-fd-input-port}, +\scheme{open-fd-output-port}, or \scheme{open-fd-input/output-port} +is initially in nonblocking mode if the file-descriptor passed in is in +nonblocking mode. +Similarly, a port returned by \scheme{standard-input-port}, +\scheme{standard-output-port}, or \scheme{standard-error-port} is +initially in nonblocking mode if the underlying stdin, stdout, +or stderr file descriptor is in nonblocking mode. + +Although \scheme{get-bytevector-some} and \scheme{get-string-some} normally +cannot return an empty bytevector or empty string, they can if the port +is in nonblocking mode and no input is available. +Also, \scheme{get-bytevector-some!} and \scheme{get-string-some!} +may not read any data if the port is in nonblocking mode and +no data is available. +Similarly, \scheme{put-bytevector-some} and \scheme{put-string-some} +may not write any data if the port is in nonblocking mode and +no room is available. + +Nonblocking mode is not supported under Windows. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-position}{\categoryprocedure}{(file-position \var{port})} +\formdef{file-position}{\categoryprocedure}{(file-position \var{port} \var{pos})} +\returns see below +\listlibraries +\endentryheader + +When the second argument is omitted, this procedure behaves like the R6RS +\scheme{port-position} procedure, and when present, like the R6RS +\scheme{set-port-position!} procedure. + +For compressed files opened with the \scheme{compressed} flag, +\scheme{file-position} returns the position in the +uncompressed stream of data. +Changing the position of a compressed input file opened with the +\scheme{compressed} flag generally requires rewinding and rereading the +file and might thus be slow. +The position of a compressed output file opened with the +\scheme{compressed} flag can be moved forward only; this is +accomplished by writing a (compressed) sequence of zeros. +File positions beyond $2^{32}$ might not be reported property +for compressed files on 32-bit versions of the system. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{clear-input-port}{\categoryprocedure}{(clear-input-port)} +\formdef{clear-input-port}{\categoryprocedure}{(clear-input-port \var{input-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +If \var{input-port} is not supplied, it defaults to the current input port. +This procedure discards any data in the buffer associated +with \var{input-port}. +This may be necessary, for example, to clear any type-ahead from the keyboard +in preparation for an urgent query. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{clear-output-port}{\categoryprocedure}{(clear-output-port)} +\formdef{clear-output-port}{\categoryprocedure}{(clear-output-port \var{output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +If \var{output-port} is not supplied, it defaults to the current output port. +This procedure discards any data in the buffer associated +with \var{output-port}. +This may be necessary, for example, to clear any pending output on an +interactive port in preparation for an urgent message. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{flush-output-port}{\categoryprocedure}{(flush-output-port)} +\formdef{flush-output-port}{\categoryprocedure}{(flush-output-port \var{output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +If \var{output-port} is not supplied, it defaults to the current output port. +This procedure forces any data in the buffer associated +with \var{output-port} to be printed immediately. +The console output port is automatically flushed after a newline and before +input from the console input port; all ports are automatically flushed when +they are closed. +\scheme{flush-output-port} may be necessary, however, to force a message +without a newline to be sent to the console output port or to force output +to appear on a file without delay. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-file-compressed!}{\categoryprocedure}{(port-file-compressed! \var{port})} +\returns unspecified +\listlibraries +\endentryheader + +\var{port} must be an input or an output port, but not an input/output port. +It must be a file port pointing to a regular file, i.e., a file on disk rather +than, e.g., a socket. +The port can be a binary or textual port. +If the port is an output port, subsequent output sent to the port +will be compressed. +If the port is an input port, subsequent input will be decompressed +if and only if the port is currently pointing at compressed data. +The compression format for output +is determined by the \index{\scheme{compress-format}}\scheme{compress-format} +parameter, while the compression format on input is inferred. +The compression level, which is relevant only for output, is determined +by the \index{\scheme{compress-level}}\scheme{compress-level} parameter. +This procedure has no effect if the port is already set for compression. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compress-format}{\categorythreadparameter}{compress-format} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{compress-format} determines the +compression algorithm and format used for output. Currently, +the possible values of the parameter are the symbols \scheme{lz4} (the default) +and \scheme{gzip}. + +The \scheme{lz4} format uses the LZ4 compression library developed by +Yann Collet. +It is therefore compatible with the \scheme{lz4} program, which +means that \scheme{lz4} may be used to uncompress files produced +by {\ChezScheme} and visa versa. + +The \scheme{gzip} format uses the zlib compression library developed by +Jean-loup Gailly and Mark Adler. +It is therefore compatible with the \scheme{gzip} program, which +means that \scheme{gzip} may be used to uncompress files produced +by {\ChezScheme} and visa versa. + +Reading \scheme{lz4}-compressed data tends to be much faster than reading +\scheme{gzip}-compressed data, while \scheme{gzip}-compressed data tends to +be significantly smaller. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compress-level}{\categorythreadparameter}{compress-level} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{compress-level} determines the amount of effort spent on +compression and is thus relevant only for output. +It can be set to one of the symbols \scheme{minimum}, \scheme{low}, +\scheme{medium}, \scheme{high}, or \scheme{maximum}, which are +listed in order from shortest to longest expected compression time +and least to greatest expected effectiveness. +Its default value is \scheme{medium}. + +\section{String Ports\label{SECTIOSTRINGPORTS}} + +String ports allow the creation and manipulation of strings via port +operations. +The procedure +\scheme{open-input-string} converts a string into a textual input port, +allowing the characters in the string to be read in sequence via input +operations such as \scheme{read-char} or \scheme{read}. +The procedure +\scheme{open-output-string} allows new strings to be built up with +output operations such as \scheme{write-char} and \scheme{write}. + +While string ports could be defined as generic ports, they are instead +supported as primitive by the implementation. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-input-string}{\categoryprocedure}{(open-input-string \var{string})} +\returns a new string input port +\listlibraries +\endentryheader + +\noindent +A \index{string input port}string input port is similar to a file input port, except that +characters and objects drawn from the port come from \var{string} +rather than from a file. + +A string port is at ``end of file'' when the port reaches the end of the +string. +It is not necessary to close a string port, although it is okay to do so. + +\schemedisplay +(let ([p (open-input-string "hi mom!")]) + (let ([x (read p)]) + (list x (read p)))) ;=> (hi mom!) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-input-from-string}{\categoryprocedure}{(with-input-from-string \var{string} \var{thunk})} +\returns the values returned by \var{thunk} +\listlibraries +\endentryheader + +\noindent +\var{thunk} must be a procedure and should accept zero arguments. +\scheme{with-input-from-string} parameterizes the current input port to be the +result of opening \var{string} for input during the +application of \var{thunk}. + +\schemedisplay +(with-input-from-string "(cons 3 4)" + (lambda () + (eval (read)))) ;=> (3 . 4) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-output-string}{\categoryprocedure}{(open-output-string)} +\returns a new string output port +\listlibraries +\endentryheader + +\noindent +A \index{string output port}string output port is similar to a file output port, except that +characters and objects written to the port are placed in a string +(which grows as needed) rather than to a file. +The string built by writing to a string output port may be obtained +with \scheme{get-output-string}. +See the example given for \scheme{get-output-string} below. +It is not necessary to close a string port, although it is okay to do so. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-output-string}{\categoryprocedure}{(get-output-string \var{string-output-port})} +\returns the string associated with \var{string-output-port} +\listlibraries +\endentryheader + +\noindent +\var{string-output-port} must be an port returned by \scheme{open-output-string}. + +As a side effect, \scheme{get-output-string} resets \var{string-output-port} +so that subsequent output to \var{string-output-port} is placed +into a fresh string. + +\schemedisplay +(let ([p (open-output-string)]) + (write 'hi p) + (write-char #\space p) + (write 'mom! p) + (get-output-string p)) ;=> "hi mom!" +\endschemedisplay + +\noindent +An implementation of \scheme{format} (Section~\ref{SECTFORMAT}) might be +written using string-output ports to produce string output. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-output-to-string}{\categoryprocedure}{(with-output-to-string \var{thunk})} +\returns a string containing the output +\listlibraries +\endentryheader + +\noindent +\var{thunk} must be a procedure and should accept zero arguments. +\scheme{with-output-to-string} parameterizes the current output port to +a new string output port during the +application of \var{thunk}. +If \var{thunk} returns, the string associated with the new string output +port is returned, as with \scheme{get-output-string}. + +\schemedisplay +(with-output-to-string + (lambda () + (display "Once upon a time ...") + (newline))) ;=> "Once upon a time ...\n" +\endschemedisplay + + +\section{File Ports\label{SECTIOFILEPORTS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{file-buffer-size}{\categorythreadparameter}{file-buffer-size} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{file-buffer-size} is a parameter that determines the size of each +buffer created when the buffer mode is not \scheme{none} for a port +created by one of the file open operations, e.g., \scheme{open-input-file} +or \scheme{open-file-output-port}. +When called with no arguments, the parameter returns the +current buffer size. +When called with a positive fixnum \var{k}, +it sets the current buffer size to \var{k}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-port?}{\categoryprocedure}{(file-port? \var{port})} +\returns \scheme{#t} if \var{port} is a file port, \scheme{#f} otherwise +\listlibraries +\endentryheader + +A file port is any port based directly +on an O/S file descriptor, e.g., one created by \scheme{open-file-input-port}, +\scheme{open-output-port}, \scheme{open-fd-input-port}, etc., but not +a string, bytevector, or custom port. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{port-file-descriptor}{\categoryprocedure}{(port-file-descriptor \var{port})} +\returns the file descriptor associated with \var{port} +\listlibraries +\endentryheader + +\var{port} must be a file port, i.e., a port for which \var{file-port?} +returns \scheme{#t}. + + +\section{Custom Ports\label{SECTIOCUSTOMPORTS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{custom-port-buffer-size}{\categorythreadparameter}{custom-port-buffer-size} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{custom-port-buffer-size} is a parameter that determines the sizes +of the buffers associated with newly created custom ports. +When called with no arguments, the parameter returns the +current buffer size. +When called with a positive fixnum \var{k}, +it sets the current buffer size to \var{k}. + +\section{Input Operations\label{SECTIOINPUT}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{console-input-port}{\categoryglobalparameter}{console-input-port} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{console-input-port} is a parameter that determines the +input port used by the waiter and interactive debugger. +When called with no arguments, it returns the +console input port. +When called with one argument, which must be a textual input port, +it changes the value of the console +input port. +The initial value of this parameter is a port tied to the standard +input (stdin) stream of the Scheme process. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-input-port}{\categorythreadparameter}{current-input-port} +\listlibraries +\endentryheader + +\noindent +\scheme{current-input-port} is a parameter that determines the +default port argument for most input procedures, including +\scheme{read-char}, \scheme{peek-char}, and \scheme{read}, +When called with no arguments, \scheme{current-input-port} returns the +current input port. +When called with one argument, which must be a textual input port, +it changes the value of the current +input port. +The Revised$^6$ Report version of \scheme{current-input-port} accepts +only zero arguments, i.e., it cannot be used to change the current input +port. +The initial value of this parameter is the same port as the initial +value of \scheme{console-input-port}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-input-file}{\categoryprocedure}{(open-input-file \var{path})} +\formdef{open-input-file}{\categoryprocedure}{(open-input-file \var{path} \var{options})} +\returns a new input port +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{open-input-file} opens a textual input port for the file named by +\var{path}. +An exception is raised with condition type +\scheme{&i/o-filename} if the file does not exist or cannot be +opened for input. + +\var{options}, if present, is a symbolic option name or option list. +Possible symbolic option names are +\scheme{compressed}, \scheme{uncompressed}, \scheme{buffered}, +and \scheme{unbuffered}. +An option list is a list containing zero or more symbolic option names. + +The mutually exclusive \scheme{compressed} and +\scheme{uncompressed} options determine whether the input file +should be decompressed if it is compressed (where the compression +format is inferred). +(See \scheme{open-output-file}.) +The default is \scheme{uncompressed}, so the \scheme{uncompressed} +option is useful only as documentation. + +The mutually exclusive \scheme{buffered} and \scheme{unbuffered} +options determine whether input is buffered. +When input is buffered, it is read in large blocks and buffered internally +for efficiency to reduce the number of operating system requests. +When the \scheme{unbuffered} option is specified, input is unbuffered, +but not fully, since one character of buffering is required to support +\scheme{peek-char} and \scheme{unread-char}. +Input is buffered by default, so the \scheme{buffered} option is useful +only as documentation. + +% flushed this: posix lockf works only on file descriptors open for writing +%The mutually exclusive \scheme{exclusive} and \scheme{nonexclusive} +%options determine whether access to the file is ``exclusive.'' +%When the exclusive option is specified, the file is locked until +%the port is closed to prevent access by other processes. +%On some systems the lock is advisory, i.e., it inhibits access by +%other processes only if they also attempt to open exclusively. +%Nonexclusive access is the default, so the \scheme{nonexclusive} option +%is useful only as documentation. + +For example, the call + +\schemedisplay +(open-input-file "frob" '(compressed)) +\endschemedisplay + +opens the file frob with decompression enabled. + +The Revised$^6$ Report version of \scheme{open-input-file} does not +support the optional \var{options} argument. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{call-with-input-file}{\categoryprocedure}{(call-with-input-file \var{path} \var{procedure})} +\formdef{call-with-input-file}{\categoryprocedure}{(call-with-input-file \var{path} \var{procedure} \var{options})} +\returns the values returned by \var{procedure} +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\var{procedure} should accept one argument. + +\scheme{call-with-input-file} creates a new input port for the file named +by \var{path}, as if with \scheme{open-input-file}, and passes this port to \var{procedure}. +If \var{procedure} returns normally, \scheme{call-with-input-file} closes the input port +and returns the values returned by \var{procedure}. + +\scheme{call-with-input-file} does not automatically close the input +port if a continuation created outside of \var{procedure} is invoked, since it +is possible that another continuation created inside of \var{procedure} will be +invoked at a later time, returning control to \var{procedure}. +If \var{procedure} does not return, an implementation is free to close the +input port only if it can prove that the input port is no longer accessible. +As shown in Section~\ref{TSPL:SECTCONTINUATIONS} of {\TSPLFOUR}, \scheme{dynamic-wind} may be used to +ensure that the port is closed if a continuation created outside of +\var{procedure} is invoked. + +See \scheme{open-input-file} above for a description of the optional +\var{options} argument. + +The Revised$^6$ Report version of \scheme{call-with-input-file} does not +support the optional \var{input} argument. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-input-from-file}{\categoryprocedure}{(with-input-from-file \var{path} \var{thunk})} +\formdef{with-input-from-file}{\categoryprocedure}{(with-input-from-file \var{path} \var{thunk} \var{options})} +\returns the values returned by \var{thunk} +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\var{thunk} must be a procedure and should accept zero arguments. + +\scheme{with-input-from-file} temporarily changes the current input port to be the +result of opening the file named by \var{path}, as if with \scheme{open-input-file}, during the +application of \var{thunk}. +If \var{thunk} returns, the port is closed and the current input port +is restored to its old value. + +The behavior of \scheme{with-input-from-file} is unspecified +if a continuation created outside +of \var{thunk} is invoked before \var{thunk} returns. +An implementation may close the port and restore the current input +port to its old value---but it may not. + +See \scheme{open-input-file} above for a description of the optional +\var{options} argument. + +The Revised$^6$ Report version of \scheme{with-input-from-file} does not +support the optional \var{options} argument. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-fd-input-port}{\categoryprocedure}{(open-fd-input-port \var{fd})} +\formdef{open-fd-input-port}{\categoryprocedure}{(open-fd-input-port \var{fd} \var{b-mode})} +\formdef{open-fd-input-port}{\categoryprocedure}{(open-fd-input-port \var{fd} \var{b-mode} \var{?transcoder})} +\returns a new input port for the file descriptor \var{fd} +\listlibraries +\endentryheader + +\noindent +\var{fd} must be a nonnegative exact integer and should be a valid +open file descriptor. +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure returns a textual input port +whose transcoder is \var{?transcoder}. +Otherwise, this procedure returns a binary input port. +See the lead-in to Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR} +for a description of the constraints on and effects of the other +arguments. + +The file descriptor is closed when the port is closed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{standard-input-port}{\categoryprocedure}{(standard-input-port)} +\formdef{standard-input-port}{\categoryprocedure}{(standard-input-port \var{b-mode})} +\formdef{standard-input-port}{\categoryprocedure}{(standard-input-port \var{b-mode} \var{?transcoder})} +\returns a new input port connected to the process's standard input +\listlibraries +\endentryheader + +\noindent +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure returns a textual input port +whose transcoder is \var{?transcoder}. +Otherwise, this procedure returns a binary input port. +The buffer mode \var{b-mode} defaults to \scheme{block}. + +The Revised$^6$ Report version of this procedure does not accept the +optional \var{b-mode} and \var{?transcoder} arguments, which limits +it to an implementation-dependent buffering mode (\scheme{block} in +{\ChezScheme}) and binary output. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-string-some}{\categoryprocedure}{(get-string-some \var{textual-input-port})} +\returns a nonempty string or the eof object +\listlibraries +\endentryheader + +\noindent +If \var{textual-input-port} is at end of file, the eof object is returned. +Otherwise, \scheme{get-string-some} reads (as if with \scheme{get-u8}) +at least one character and possibly more, and returns a string containing +these characters. +The port's position is advanced past the characters read. +The maximum number of characters read by this operation is implementation-dependent. + +An exception to the ``at least one character'' guarantee occurs +if the port is in nonblocking mode (see \scheme{set-port-nonblocking!}) +and no input is ready. +In this case, an empty string is returned. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-string-some!}{\categoryprocedure}{(get-string-some! \var{textual-input-port} \var{string} \var{start} \var{n})} +\returns the count of characters read, as an exact nonnegative integer, or the eof object +\listlibraries +\endentryheader + +\noindent +\var{start} and \var{n} must be exact nonnegative integers, and the sum of +\var{start} and \var{n} must not exceed the length of \var{string}. + +If \var{n} is 0, this procedure returns zero without attempting to +read from \var{textual-input-port} and without modifying \var{string}. + +Otherwise, if \var{textual-input-port} is at end of file, this procedure +returns the eof object, except it returns zero when the port is in nonblocking mode +(see \scheme{set-port-nonblocking!}) and the port cannot be determined +to be at end of file without blocking. +In either case, \var{string} is not modified. + +Otherwise, this procedure reads (as if with \scheme{get-char}) +up to \var{n} characters from the port, stores the characters in consecutive locations of \var{string} +starting at \var{start}, advances the port's position just past the characters read, and +returns the count of characters read. + +If the port is in nonblocking mode, this procedure reads no more +than it can without blocking and thus might read zero characters; +otherwise, it reads at least one character but no more than are available +when the first character becomes available. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-bytevector-some!}{\categoryprocedure}{(get-bytevector-some! \var{binary-input-port} \var{bytevector} \var{start} \var{n})} +\returns the count of bytes read, as an exact nonnegative integer, or the eof object +\listlibraries +\endentryheader + +\noindent +\var{start} and \var{n} must be exact nonnegative integers, and the sum of +\var{start} and \var{n} must not exceed the length of \var{bytevector}. + +If \var{n} is 0, this procedure returns zero without attempting to +read from \var{binary-input-port} and without modifying \var{bytevector}. + +Otherwise, if \var{binary-input-port} is at end of file, this procedure +returns the eof object, except it returns zero when the port is in nonblocking mode +(see \scheme{set-port-nonblocking!}) and the port cannot be determined +to be at end of file without blocking. +In either case, \var{bytevector} is not modified. + +Otherwise, this procedure reads (as if with \scheme{get-u8}) +up to \var{n} bytes from the port, stores the bytes in consecutive locations of \var{bytevector} +starting at \var{start}, advances the port's position just past the bytes read, and +returns the count of bytes read. + +If the port is in nonblocking mode, this procedure reads no more +than it can without blocking and thus might read zero bytes; +otherwise, it reads at least one byte but no more than are available +when the first byte becomes available. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{unread-char}{\categoryprocedure}{(unread-char \var{char})} +\formdef{unread-char}{\categoryprocedure}{(unread-char \var{char} \var{textual-input-port})} +\formdef{unget-char}{\categoryprocedure}{(unget-char \var{textual-input-port} \var{char})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +For \scheme{unread-char}, if \var{textual-input-port} is not supplied, it +defaults to the current input port. +These procedures ``unread'' the last character read from +\scheme{textual-input-port}. +\var{char} may or may not be ignored, depending upon the implementation. +In any case, \var{char} should be last character read from the port. +A character should not be unread twice on the same port +without an intervening call to \scheme{read-char} or \scheme{get-char}. + +\scheme{unread-char} and \scheme{unget-char} are provided for applications +requiring one character of lookahead and may be used in place of, or even +in combination with, \scheme{peek-char} or \scheme{lookahead-char}. +One character of lookahead is required in the procedure +\scheme{read-word}, which is defined below in terms of \scheme{unread-char}. +\scheme{read-word} returns the next word from a textual input port as a string, where +a word is defined to be a sequence of alphabetic characters. +Since it does not know until it reads one character too many that it has +read the entire word, \scheme{read-word} uses \scheme{unread-char} to +return the character to the input port. + +\schemedisplay +(define read-word + (lambda (p) + (list->string + (let f ([c (read-char p)]) + (cond + [(eof-object? c) '()] + [(char-alphabetic? c) + (cons c (f (read-char p)))] + [else + (unread-char c p) + '()]))))) +\endschemedisplay + +\noindent +In the alternate version below, \scheme{peek-char} is used instead of +\scheme{unread-char}. + +\schemedisplay +(define read-word + (lambda (p) + (list->string + (let f ([c (peek-char p)]) + (cond + [(eof-object? c) '()] + [(char-alphabetic? c) + (read-char p) + (cons c (f (peek-char p)))] + [else '()]))))) +\endschemedisplay + +\noindent +The advantage of \scheme{unread-char} in this situation is that only +one call to \scheme{unread-char} per word is required, whereas one +call to \scheme{peek-char} is required for each character in the word +plus the first character beyond. +In many cases, \scheme{unread-char} and \scheme{unget-char} do not enjoy +this advantage, and \scheme{peek-char} or \scheme{lookahead-char} +should be used instead. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{unget-u8}{\categoryprocedure}{(unget-u8 \var{binary-input-port} \var{octet})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +This procedures ``unreads'' the last byte read from +\scheme{binary-input-port}. +\var{octet} may or may not be ignored, depending upon the implementation. +In any case, \var{octet} should be last byte read from the port. +A byte should not be unread twice on the same port +without an intervening call to \scheme{get-u8}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{input-port-ready?}{\categoryprocedure}{(input-port-ready? \var{input-port})} +\returns \scheme{#t} if data is available on \var{input-port}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\scheme{input-port-ready?} allows a program to check to see if input is +available on a textual or binary input port without hanging. +If input is available or the port is at end of file, +\scheme{input-port-ready?} returns \scheme{#t}. +If it cannot determine from the port whether input is ready, +\scheme{input-port-ready?} raises an exception with condition type +\scheme{&i/o-read-error}. +Otherwise, it returns \scheme{#f}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{char-ready?}{\categoryprocedure}{(char-ready?)} +\formdef{char-ready?}{\categoryprocedure}{(char-ready? \var{textual-input-port})} +\returns \scheme{#t} if a character is available on \var{textual-input-port}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +If \var{textual-input-port} is not supplied, it defaults to the current input port. +\scheme{char-ready?} is like \scheme{input-port-ready?} except it is +restricted to textual input ports. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{block-read}{\categoryprocedure}{(block-read \var{textual-input-port} \var{string})} +\formdef{block-read}{\categoryprocedure}{(block-read \var{textual-input-port} \var{string} \var{count})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{count} must be a nonnegative fixnum less than or equal to the +length of \var{string}. +If not provided, it defaults to the length of \var{string}. + +If \var{textual-input-port} is at end-of-file, an eof object is returned. +Otherwise, \var{string} is filled with as many characters as are +available for reading from \var{textual-input-port} up to \var{count}, +and the number of characters placed in the string is returned. + +If \var{textual-input-port} is buffered and the buffer is nonempty, +the buffered input or a portion thereof is returned; otherwise +\scheme{block-read} bypasses the buffer entirely. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{read-token}{\categoryprocedure}{(read-token)} +\formdef{read-token}{\categoryprocedure}{(read-token \var{textual-input-port})} +\formdef{read-token}{\categoryprocedure}{(read-token \var{textual-input-port} \var{sfd} \var{bfp})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{sfd} must be a source-file descriptor. +\var{bfp} must be an exact nonnegative integer and should be the +character position of the next character to be read from +\var{textual-input-port}. + +Parsing of a Scheme datum is conceptually performed in two steps. +First, the sequence of characters that form the datum are grouped into +\scheme{tokens}, such as symbols, numbers, left parentheses, and +double quotes. +During this first step, whitespace and comments are discarded. +Second, these tokens are grouped into data. + +\scheme{read} performs both of these steps and creates an internal +representation of each datum it parses. +\scheme{read-token} may be used to perform the first step only, one +token at a time. +\scheme{read-token} is intended to be used by editors and program +formatters that must be able to parse a program or datum without +actually reading it. + +If \var{textual-input-port} is not supplied, it defaults to the current input port. +One token is read from the input port and returned as four values: + +\begin{description} +\item[\var{type}:] a symbol describing the type of token read, + +\item[\var{value}:] the token value, + +\item[\var{start}:] the position of the first character of the token, +relative to the starting position of the input port (or \scheme{#f}, +if the position cannot be determined), and + +\item[\var{end}:] the first position beyond the token, +relative to the starting position of the input port (or \scheme{#f}, +if the position cannot be determined). +\end{description} + +\noindent +The input port is left pointing to the first character position beyond +the token. + +When the token type fully specifies the token, +\scheme{read-token} returns \scheme{#f} for the value. +The token types are listed below with the corresponding \var{value} +in parentheses. + +\begin{description} +\item[\scheme{atomic}] (\var{atom}) an atomic value, i.e., + a symbol, boolean, number, character, \scheme{#!eof}, + or \scheme{#!bwp} +\item[\scheme{box}] (\scheme{#f}) box prefix, i.e., \scheme{#&} +\item[\scheme{dot}] (\scheme{#f}) dotted pair separator, i.e., \scheme{.} +\item[\scheme{eof}] (\scheme{#!eof}) end of file +\item[\scheme{fasl}] (\scheme{#f}) fasl prefix, i.e., \scheme{#@} +\item[\scheme{insert}] (\var{n}) graph reference, i.e., \scheme{#\var{n}#} +\item[\scheme{lbrack}] (\scheme{#f}) open square bracket +\item[\scheme{lparen}] (\scheme{#f}) open parenthesis +\item[\scheme{mark}] (\var{n}) graph mark, i.e., \scheme{#\var{n}=} +\item[\scheme{quote}] (\scheme{quote}, \scheme{quasiquote}, + \scheme{syntax}, \scheme{unquote}, \scheme{unquote-splicing}, + or \scheme{datum-comment}) + an abbreviation mark, e.g., \scheme{'} or \scheme{,@} or + datum-comment prefix +\item[\scheme{rbrack}] (\scheme{#f}) close square bracket +\item[\scheme{record-brack}] (\scheme{#f}) record open bracket, i.e., \scheme{#[} +\item[\scheme{rparen}] (\scheme{#f}) close parenthesis +\item[\scheme{vfxnparen}] (\var{n}) fxvector prefix, i.e., \scheme{#\var{n}vfx(} +\item[\scheme{vfxparen}] (\scheme{#f}) fxvector prefix, i.e., \scheme{#vfx(} +\item[\scheme{vnparen}] (\var{n}) vector prefix, i.e., \scheme{#\var{n}(} +\item[\scheme{vparen}] (\scheme{#f}) vector prefix, i.e., \scheme{#(} +\item[\scheme{vu8nparen}] (\var{n}) bytevector prefix, i.e., \scheme{#\var{n}vu8(} +\item[\scheme{vu8paren}] (\scheme{#f}) bytevector prefix, i.e., \scheme{#vu8(} +\end{description} + +\noindent +The set of token types is likely to change in future releases of the +system; check the release notes for details on such changes. + +Specifying \var{sfd} and \var{bfp} improves the quality of error messages, +guarantees \var{start} and \var{end} can be determined, +and eliminates the overhead of asking for a file position on each call +to \scheme{read-token}. +In most cases, \var{bfp} should be 0 for the first call +to \scheme{read-token} at the start of a file, +and it should be the fourth return value (\var{end}) of the preceding +call to \scheme{read-token} for each subsequent +call. +This protocol is necessary to handle files containing multiple-byte +characters, since file positions do not necessarily correspond +to character positions. + +\schemedisplay +(define s (open-input-string "(a b c)")) +(read-token s) ;=> lparen + #f + 0 + 1 +(define s (open-input-string "abc 123")) +(read-token s) ;=> atomic + abc + 0 + 3 +(define s (open-input-string "")) +(read-token s) ;=> eof + #!eof + 0 + 0 +(define s (open-input-string "#7=#7#")) +(read-token s) ;=> mark + 7 + 0 + 3 +(read-token s) ;=> insert + 7 + 3 + 6 +\endschemedisplay + +The information \scheme{read-token} returns is not always +sufficient for reconstituting the exact sequence of characters that +make up a token. +For example, \scheme{1.0} and \scheme{1e0} both return +\var{type} \scheme{atomic} with \var{value} \scheme{1.0}. +The exact sequence of characters may be obtained only by repositioning +the port and reading a block of characters of the appropriate length, +using the relative positions given by \var{start} and \var{end}. + + +\section{Output Operations\label{SECTIOOUTPUT}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{console-output-port}{\categoryglobalparameter}{console-output-port} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{console-output-port} is a parameter that determines the +output port used by the waiter and interactive debugger. +When called with no arguments, it returns the +console output port. +When called with one argument, which must be a textual output port, +it changes the value of the console +output port. +The initial value of this parameter is a port tied to the standard +output (stdout) stream of the Scheme process. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-output-port}{\categorythreadparameter}{current-output-port} +\listlibraries +\endentryheader + +\noindent +\scheme{current-output-port} is a parameter that determines the +default port argument for most output procedures, +including \scheme{write-char}, \scheme{newline}, \scheme{write}, +\scheme{display}, and \scheme{pretty-print}. +When called with no arguments, \scheme{current-output-port} returns the +current output port. +When called with one argument, which must be a textual output port, +it changes the value of the current +output port. +The Revised$^6$ Report version of \scheme{current-output-port} accepts +only zero arguments, i.e., it cannot be used to change the current output +port. +The initial value of this parameter is the same port as the initial +value of \scheme{console-output-port}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{console-error-port}{\categorythreadparameter}{console-error-port} +\listlibraries +\endentryheader + +\scheme{console-error-port} is a parameter that can be used to set +or obtain the console error port, which determines the port to which +conditions and other messages are printed by the default exception +handler. +When called with no arguments, \scheme{console-error-port} returns the +console error port. +When called with one argument, which must be a textual output port, +it changes the value of the console +error port. + +If the system determines that the standard output (stdout) and standard +error (stderr) streams refer to the same file, socket, pipe, virtual +terminal, device, etc., this parameter is initially set to the same value +as the parameter \scheme{console-output-port}. +Otherwise, this parameter is initially set to a different port tied to the +standard error (stderr) stream of the Scheme process. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-error-port}{\categorythreadparameter}{current-error-port} +\listlibraries +\endentryheader + +\scheme{current-error-port} is a parameter that can be used to set +or obtain the current error port. +When called with no arguments, \scheme{current-error-port} returns the +current error port. +When called with one argument, which must be a textual output port, +it changes the value of the current error port. +The Revised$^6$ Report version of \scheme{current-error-port} accepts +only zero arguments, i.e., it cannot be used to change the current error +port. +The initial value of this parameter is the same port as the initial +value of \scheme{console-error-port}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-output-file}{\categoryprocedure}{(open-output-file \var{path})} +\formdef{open-output-file}{\categoryprocedure}{(open-output-file \var{path} \var{options})} +\returns a new output port +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{open-output-file} opens a textual output port for the file named by +\var{path}. + +\var{options}, if present, is a symbolic option name or option list. +Possible symbolic option names are +\scheme{error}, \scheme{truncate}, \scheme{replace}, \scheme{append}, +\scheme{compressed}, \scheme{uncompressed}, \scheme{buffered}, +\scheme{unbuffered}, \scheme{exclusive}, and \scheme{nonexclusive}. +An option list is a list containing zero or more symbolic option names +and possibly the two-element +option \scheme{mode \var{mode}}. + +The mutually exclusive \scheme{error}, \scheme{truncate}, +\scheme{replace}, and \scheme{append} options are used to direct what happens when +the file to be opened already exists. +\begin{description} +\item[\scheme{error}:] An exception is raised with condition-type \scheme{&i/o-filename}. +\item[\scheme{replace}:] The existing file is deleted before the new file +is opened. +\item[\scheme{truncate}:] The existing file is opened +and truncated to zero length. +\item[\scheme{append}:] +The existing file is opened +and the output port is positioned at the end of the file before each write +so that output to the port is always appended to the file. +\end{description} +The default behavior is to raise an exception. + +The mutually exclusive \scheme{compressed} and +\scheme{uncompressed} options determine whether the output file is to +be compressed. +The compression format and level are determined by the +\index{\scheme{compress-format}}\scheme{compress-format} +and +\index{\scheme{compress-level}}\scheme{compress-level} +parameters. +Files are uncompressed by default, so the \scheme{uncompressed} +option is useful only as documentation. + +The mutually exclusive \scheme{buffered} and \scheme{unbuffered} +options determine whether output is buffered. +Unbuffered output is sent immediately to the file, whereas buffered +output not written until the port's output buffer is filled or the +port is flushed (via \scheme{flush-output-port}) or closed (via +\scheme{flush-output-port} or by the storage management system when +the port becomes inaccessible). +Output is buffered by default for efficiency, so the +\scheme{buffered} option is useful only as documentation. + +The mutually exclusive \scheme{exclusive} and \scheme{nonexclusive} +options determine whether access to the file is ``exclusive.'' +When the exclusive option is specified, the file is locked until +the port is closed to prevent access by other processes. +On some systems the lock is advisory, i.e., it inhibits access by +other processes only if they also attempt to open exclusively. +Nonexclusive access is the default, so the \scheme{nonexclusive} option +is useful only as documentation. + +The \scheme{mode} option determines the permission bits +on Unix systems when the file is created by the operation, subject +to the process umask. +The subsequent element in the options list must be an exact integer +specifying the permissions in the manner of the Unix \scheme{open} +function. +The mode option is ignored under Windows. + +For example, the call + +\schemedisplay +(open-output-file "frob" '(compressed truncate mode #o644)) +\endschemedisplay + +opens the file frob with compression enabled. +If frob already exists it is truncated. +On Unix-based systems, if frob does not already exist, the permission +bits on the newly created file are set to logical and of \scheme{#o644} and the +process's umask. + +The Revised$^6$ Report version of \scheme{open-output-file} does not +support the optional \var{options} argument. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{call-with-output-file}{\categoryprocedure}{(call-with-output-file \var{path} \var{procedure})} +\formdef{call-with-output-file}{\categoryprocedure}{(call-with-output-file \var{path} \var{procedure} \var{options})} +\returns the values returned by \var{procedure} +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\var{procedure} should accept one argument. + +\scheme{call-with-output-file} creates a new output port for the file named +by \var{path}, as if with \scheme{open-output-file}, and passes this port to \var{procedure}. +If \var{procedure} returns, \scheme{call-with-output-file} closes the output port +and returns the values returned by \var{procedure}. + +\scheme{call-with-output-file} does not automatically close the output +port if a continuation created outside of \var{procedure} is invoked, since it +is possible that another continuation created inside of \var{procedure} will be +invoked at a later time, returning control to \var{procedure}. +If \var{procedure} does not return, an implementation is free to close the +output port only if it can prove that the output port is no longer accessible. +As shown in Section~\ref{TSPL:SECTCONTINUATIONS} of {\TSPLFOUR}, \scheme{dynamic-wind} may be used to +ensure that the port is closed if a continuation created outside of +\var{procedure} is invoked. + +See \scheme{open-output-file} above for a description of the optional +\var{options} argument. + +The Revised$^6$ Report version of \scheme{call-with-output-file} does not +support the optional \var{options} argument. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-output-to-file}{\categoryprocedure}{(with-output-to-file \var{path} \var{thunk})} +\formdef{with-output-to-file}{\categoryprocedure}{(with-output-to-file \var{path} \var{thunk} \var{options})} +\returns the value returned by \var{thunk} +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\var{thunk} must be a procedure and should accept zero arguments. + +\scheme{with-output-to-file} temporarily rebinds the current output port to be the +result of opening the file named by \var{path}, as if with \scheme{open-output-file}, +during the application of \var{thunk}. +If \var{thunk} returns, the port is closed and the current output port +is restored to its old value. + +The behavior of \scheme{with-output-to-file} is unspecified if a +continuation created outside of \var{thunk} is invoked before +\var{thunk} returns. +An implementation may close the port and restore the current output +port to its old value---but it may not. + +See \scheme{open-output-file} above for a description of the optional +\var{options} argument. + +The Revised$^6$ Report version of \scheme{with-output-to-file} does not +support the optional \var{options} argument. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-fd-output-port}{\categoryprocedure}{(open-fd-output-port \var{fd})} +\formdef{open-fd-output-port}{\categoryprocedure}{(open-fd-output-port \var{fd} \var{b-mode})} +\formdef{open-fd-output-port}{\categoryprocedure}{(open-fd-output-port \var{fd} \var{b-mode} \var{?transcoder})} +\returns a new output port for the file descriptor \var{fd} +\listlibraries +\endentryheader + +\noindent +\var{fd} must be a nonnegative exact integer and should be a valid +open file descriptor. +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure returns a textual output port +whose transcoder is \var{?transcoder}. +Otherwise, this procedure returns a binary output port. +See the lead-in to Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR} +for a description of the constraints on and effects of the other +arguments. + +The file descriptor is closed when the port is closed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{standard-output-port}{\categoryprocedure}{(standard-output-port)} +\formdef{standard-output-port}{\categoryprocedure}{(standard-output-port \var{b-mode})} +\formdef{standard-output-port}{\categoryprocedure}{(standard-output-port \var{b-mode} \var{?transcoder})} +\returns a new output port connected to the process's standard output +\listlibraries +\endentryheader + +\noindent +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure returns a textual output port +whose transcoder is \var{?transcoder}. +Otherwise, this procedure returns a binary output port. +The buffer mode \var{b-mode} defaults to \scheme{line}, which differs from +\scheme{block} in {\ChezScheme} only for textual output ports. + +The Revised$^6$ Report version of this procedure does not accept the +optional \var{b-mode} and \var{?transcoder} arguments, which limits +it to an implementation-dependent buffering mode (\scheme{line} in +{\ChezScheme}) and binary output. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{standard-error-port}{\categoryprocedure}{(standard-error-port)} +\formdef{standard-error-port}{\categoryprocedure}{(standard-error-port \var{b-mode})} +\formdef{standard-error-port}{\categoryprocedure}{(standard-error-port \var{b-mode} \var{?transcoder})} +\returns a new output port connected to the process's standard error +\listlibraries +\endentryheader + +\noindent +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure returns a textual output port +whose transcoder is \var{?transcoder}. +Otherwise, this procedure returns a binary output port. +The buffer mode \var{b-mode} defaults to \scheme{none}. +See the lead-in to Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR} +for a description of the constraints on and effects of the other +arguments. + +The Revised$^6$ Report version of this procedure does not accept the +optional \var{b-mode} and \var{?transcoder} arguments, which limits +it to an implementation-dependent buffering mode (\scheme{none} in +{\ChezScheme}) and binary output. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{put-bytevector-some}{\categoryprocedure}{(put-bytevector-some \var{binary-output-port} \var{bytevector})} +\formdef{put-bytevector-some}{\categoryprocedure}{(put-bytevector-some \var{binary-output-port} \var{bytevector} \var{start})} +\formdef{put-bytevector-some}{\categoryprocedure}{(put-bytevector-some \var{binary-output-port} \var{bytevector} \var{start} \var{n})} +\returns the number of bytes written +\listlibraries +\endentryheader + +\noindent +\var{start} and \var{n} must be nonnegative exact integers, and the sum of +\var{start} and \var{n} must not exceed the length of \var{bytevector}. +If not supplied, \var{start} defaults to zero and \var{n} defaults to +the difference between the length of \var{bytevector} and \var{start}. + +This procedure normally writes the \var{n} bytes of \var{bytevector} +starting at \var{start} to the port and advances the its position past the +end of the bytes written. +If the port is in nonblocking mode (see \scheme{set-port-nonblocking!}), +however, the number of bytes written may be less than \var{n}, if +the system would have to block to write more bytes. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{put-string-some}{\categoryprocedure}{(put-string-some \var{textual-output-port} \var{string})} +\formdef{put-string-some}{\categoryprocedure}{(put-string-some \var{textual-output-port} \var{string} \var{start})} +\formdef{put-string-some}{\categoryprocedure}{(put-string-some \var{textual-output-port} \var{string} \var{start} \var{n})} +\returns the number of characters written +\listlibraries +\endentryheader + +\noindent +\var{start} and \var{n} must be nonnegative exact integers, and the sum of +\var{start} and \var{n} must not exceed the length of \var{string}. +If not supplied, \var{start} defaults to zero and \var{n} defaults to +the difference between the length of \var{string} and \var{start}. + +This procedure normally writes the \var{n} characters of \var{string} +starting at \var{start} to the port and advances the its position past the +end of the characters written. +If the port is in nonblocking mode (see \scheme{set-port-nonblocking!}), +however, the number of characters written may be less than \var{n}, if +the system would have to block to write more characters. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{display-string}{\categoryprocedure}{(display-string \var{string})} +\formdef{display-string}{\categoryprocedure}{(display-string \var{string} \var{textual-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{display-string} writes the characters contained within +\var{string} to \var{textual-output-port} or to the current-output port +if \scheme{textual-output-port} is not specified. +The enclosing string quotes are not printed, and special characters +within the string are not escaped. +\scheme{display-string} is a more efficient alternative to +\scheme{display} for displaying strings. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{block-write}{\categoryprocedure}{(block-write \var{textual-output-port} \var{string})} +\formdef{block-write}{\categoryprocedure}{(block-write \var{textual-output-port} \var{string} \var{count})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{count} must be a nonnegative fixnum less than or equal to the +length of \var{string}. +If not provided, it defaults to the length of \var{string}. + +\scheme{block-write} writes the first \var{count} characters of \var{string} +to \var{textual-output-port}. +If the port is buffered and the buffer is nonempty, the +buffer is flushed before the contents of \var{string} are written. +In any case, the contents of \var{string} are written immediately, +without passing through the buffer. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{truncate-port}{\categoryprocedure}{(truncate-port \var{output-port})} +\formdef{truncate-port}{\categoryprocedure}{(truncate-port \var{output-port} \var{pos})} +\formdef{truncate-file}{\categoryprocedure}{(truncate-file \var{output-port})} +\formdef{truncate-file}{\categoryprocedure}{(truncate-file \var{output-port} \var{pos})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{truncate-port} and \scheme{truncate-file} are identical. + +\var{pos} must be an exact nonnegative integer. It defaults to 0. + +These procedures truncate the file or other object associated with +\var{output-port} to \var{pos} and repositions the port +to that position, i.e., it combines the functionality of +\scheme{set-port-length!} and \scheme{set-port-position!} and +can be called on a port only if \scheme{port-has-set-port-length!?} and +\scheme{port-has-set-port-position!?} are both true of the port. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:fresh-line} +\formdef{fresh-line}{\categoryprocedure}{(fresh-line)} +\formdef{fresh-line}{\categoryprocedure}{(fresh-line \var{textual-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +If \var{textual-output-port} is not supplied, it defaults to the current output port. + +This procedure behaves like \scheme{newline}, i.e., sends a newline +character to \var{textual-output-port}, unless it can determine that the port +is already positioned at the start of a line. +It does this by flushing the port and consulting the +``beginning-of-line'' (BOL) flag associated with the port. +(See page~\pageref{desc:set-port-bol}.) + + +\section{Input/Output Operations\label{SECTIOINPUTOUTPUT}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{open-input-output-file}{\categoryprocedure}{(open-input-output-file \var{path})} +\formdef{open-input-output-file}{\categoryprocedure}{(open-input-output-file \var{path} \var{options})} +\returns a new input-output port +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{open-input-output-file} opens a textual input-output port for the file named by +\var{path}. + +The port may be used to read from or write to the named file. +The file is created if it does not already exist. + +\var{options}, if present, is a symbolic option name or option list. +Possible symbolic option names are +\scheme{buffered}, +\scheme{unbuffered}, \scheme{exclusive}, and \scheme{nonexclusive}. +An option list is a list containing zero or more symbolic option names +and possibly the two-element +option \scheme{mode \var{mode}}. +See the description of \scheme{open-output-file} for an explanation +of these options. + +Input/output files are usually closed using \scheme{close-port} +but may also be closed with either +\scheme{close-input-port} or +\scheme{close-output-port}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-fd-input/output-port}{\categoryprocedure}{(open-fd-input/output-port \var{fd})} +\formdef{open-fd-input/output-port}{\categoryprocedure}{(open-fd-input/output-port \var{fd} \var{b-mode})} +\formdef{open-fd-input/output-port}{\categoryprocedure}{(open-fd-input/output-port \var{fd} \var{b-mode} \var{?transcoder})} +\returns a new input/output port for the file descriptor \var{fd} +\listlibraries +\endentryheader + +\noindent +\var{fd} must be a nonnegative exact integer and should be a valid +open file descriptor. +If \var{?transcoder} is present and not \scheme{#f}, it must be a +transcoder, and this procedure returns a textual input/output port +whose transcoder is \var{?transcoder}. +Otherwise, this procedure returns a binary input/output port. +See the lead-in to Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR} +for a description of the constraints on and effects of the other +arguments. + +The file descriptor is closed when the port is closed. + + +\section{Non-Unicode Bytevector/String Conversions\label{SECTMBCONVS}} + +The procedures described in this section convert bytevectors containing +single- and multiple-byte sequences in non-Unicode character sets to and +from Scheme strings. +They are available only under Windows. +Under other operating systems, and when an \scheme{iconv} DLL is +available under Windows, \scheme{bytevector->string} and +\scheme{string->bytevector} can be used with a transcoder based +on a codec constructed via +\index{\scheme{iconv-codec}}\scheme{iconv-codec} +to achieve the same results, with more control over the handling +of invalid characters and line endings. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{multibyte->string}{\categoryprocedure}{(multibyte->string \var{code-page} \var{bytevector})} +\returns a string containing the characters encoded in \var{bytevector} +\formdef{string->multibyte}{\categoryprocedure}{(string->multibyte \var{code-page} \var{string})} +\returns a bytevector containing the encodings of the characters in \var{string} +\listlibraries +\endentryheader + +These procedures are available only under Windows. +The procedure \scheme{multibyte->string} is a wrapper for the Windows API +\scheme{MultiByteToWideChar} function, +and \scheme{string->multibyte} is a wrapper for the Windows API +\scheme{WideCharToMultiByte} function. + +\var{code-page} declares the encoding of the byte sequences in the input +or output bytevectors. +It must be an exact nonnegative integer identifying a code page or one of +the symbols \scheme{cp-acp}, \scheme{cp-maccp}, \scheme{cp-oemcp}, +\scheme{cp-symbol}, \scheme{cp-thread-acp}, \scheme{cp-utf7}, or +\scheme{cp-utf8}, which have the same meanings as the API function +meanings for the like-named constants. + +\section{Pretty Printing\label{SECTPRETTY}} + +The pretty printer is a version of the \scheme{write} procedure that +produces more human-readable output via introduced whitespace, i.e., +line breaks and indentation. +The pretty printer is the default printer used by the read-eval-print +loop (waiter) to print the output(s) of each evaluated form. +The pretty printer may also be invoked explicitly by calling the +procedure \scheme{pretty-print}. + +The pretty printer's operation can be controlled via the \scheme{pretty-format} +procedure described later in this section, which allows the +programmer to specify how specific forms are to be printed, various +pretty-printer controls, also described later in this section, and also +by the generic input/output controls described in Section~\ref{SECTMISCIOCONTROL}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-print}{\categoryprocedure}{(pretty-print \var{obj})} +\formdef{pretty-print}{\categoryprocedure}{(pretty-print \var{obj} \var{textual-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +If \var{textual-output-port} is not supplied, it defaults to the current output port. + +\scheme{pretty-print} is similar to \scheme{write} except that it uses +any number of spaces and newlines in order to print \var{obj} in a +style that is pleasing to look at and which shows the nesting level via +indentation. +For example, + +\schemedisplay +(pretty-print '(define factorial (lambda (n) (let fact ((i n) (a 1)) + (if (= i 0) a (fact (- i 1) (* a i))))))) +\endschemedisplay + +\noindent +might produce + +\schemedisplay +(define factorial + (lambda (n) + (let fact ([i n] [a 1]) + (if (= i 0) a (fact (- i 1) (* a i)))))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-file}{\categoryprocedure}{(pretty-file \var{ifn} \var{ofn})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{ifn} and \var{ofn} must be strings. +\scheme{pretty-file} reads each object in turn from the file named by +\var{ifn} and pretty prints the object to the file named by \var{ofn}. +Comments present in the input are discarded by the reader and so do +not appear in the output file. +If the file named by \var{ofn} already exists, it is replaced. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-format}{\categoryprocedure}{(pretty-format \var{sym})} +\returns see below +\formdef{pretty-format}{\categoryprocedure}{(pretty-format \var{sym} \var{fmt})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +By default, the pretty printer uses a generic algorithm for printing +each form. +This procedure is used to override this default and guide the +pretty-printers treatment of specific forms. +The symbol \var{sym} names a syntactic form or procedure. +With just one argument, \scheme{pretty-format} returns the current +format associated with \var{sym}, or \scheme{#f} if no format is +associated with \var{sym}. + +In the two-argument case, the format \var{fmt} is associated with +\var{sym} for future invocations of the pretty printer. +\var{fmt} must be in the formatting language described below. + +\begin{grammar} +\ang{fmt}\longis\scheme{(quote \var{symbol})}\\ + \orbar\scheme{var}\\ + \orbar\scheme{\var{symbol}}\\ + \orbar\scheme{(read-macro \var{string} \var{symbol})}\\ + \orbar\scheme{(meta)}\\ + \orbar\scheme{(bracket . \var{fmt-tail})}\\ + \orbar\scheme{(alt \var{fmt} \var{fmt}*)}\\ + \orbar\scheme{\var{fmt-tail}}\\ +\var{fmt-tail}\longis\scheme{()}\\ + \orbar\scheme{(\var{tab} \var{fmt} ...)}\\ + \orbar\scheme{(\var{fmt} \var{tab} ...)}\\ + \orbar\scheme{(\var{tab} \var{fmt} . \var{fmt-tail})}\\ + \orbar\scheme{(\var{fmt} ...)}\\ + \orbar\scheme{(\var{fmt} . \var{fmt-tail})}\\ + \orbar\scheme{(fill \var{tab} \var{fmt} ...)}\\ +\var{tab}\longis\scheme{\var{int}}\\ + \orbar\scheme{#f} +\end{grammar} + +Some of the format forms are used for matching when there are multiple +alternatives, while others are used for matching and control indentation +or printing. +A description of each \var{fmt} is given below. + +\begin{description} +\item[\scheme{(quote \var{symbol})}:] +This matches only the symbol \var{symbol}. + +\item[\scheme{var}:] +This matches any symbol. + +\item[\scheme{\var{symbol}}:] +This matches any input. + +\item[\scheme{(read-macro \var{string} \var{symbol})}:] +This is used for read macros like \scheme{quote} and \var{syntax}. +It matches any input of the form (\var{symbol} \var{subform}). +For forms that match, the pretty printer prints +\var{string} immediately followed by \var{subform}. + +\item[\scheme{(meta)}:] +This is a special case used for the \scheme{meta} keyword +(Section~\ref{SECTSYNTAXMETA}) which is used as a keyword prefix of +another form. + +\item[\scheme{(alt \var{fmt} \var{fmt}*)}:] +This compares the input against the specified formats and uses the +one that is the closest match. +Most often, one of the formats will match exactly, but in other +cases, as when input is malformed or appears in abstract form in the +template of a syntactic abstraction, none of the formats will match +exactly. + +\item[\scheme{(bracket . \var{fmt-tail})}:] +This matches any list-structured input and prints the input enclosed +in square brackets, i.e., +\index{\scheme{[}}\scheme{[} and \index{\scheme{]}}\scheme{]}, +rather than parentheses. + +\item[\scheme{\var{fmt-tail}}:] +This matches any list-structured input. +\end{description} + +Indentation of list-structured forms is determined via the +\var{fmt-tail} specifier used to the last two cases above. +A description of each \var{fmt-tail} is given below. + +\begin{description} +\item[\scheme{()}:] +This matches an empty list tail. + +\item[\scheme{(\var{tab} \var{fmt} ...)}:] +This matches the tail of any proper list; if the tail is nonempty +and the list does not fit entirely on the current line, a line break is +inserted before the first subform of the tail and \var{tab} (see +below) determines the amount by which this and all subsequent subforms +are indented. + +\item[\scheme{(\var{fmt} \var{tab} ...)}:] +This matches the tail of any proper list; if the tail is nonempty +and the list does not fit entirely on the current line, a line break is +inserted after the first subform of the tail and \var{tab} (see +below) determines the amount by which all subsequent subforms are +indented. + +\item[\scheme{(\var{tab} \var{fmt} . \var{fmt-tail})}:] +This matches a nonempty tail if the tail of the tail matches \var{fmt-tail}. +If the list does not fit entirely on the current line, a line break is +inserted before the first subform of the tail and \var{tab} (see +below) determines the amount by which the subform is indented. + +\item[\scheme{(\var{fmt} ...)}:] +This matches the tail of any proper list and specified that no +line breaks are to be inserted before or after the current or +subsequent subforms. + +\item[\scheme{(\var{fmt} . \var{fmt-tail})}:] +This matches a nonempty tail if the tail of the tail matches \var{fmt-tail} +and specifies that no line break is to be inserted before or after +the current subform. + +\item[\scheme{(fill \var{tab} \var{fmt} ...)}:] +This matches the tail of any proper list and invokes a fill mode in +which the forms are packed with as many as will fit on each line. +\end{description} + +A \var{tab} determines the amount by which a list subform is indented. +If \var{tab} is a nonnegative exact integer \var{int}, the subform +is indented \var{int} spaces in from the character position just after +the opening parenthesis or bracket of the parent form. +If \var{tab} is \scheme{#f}, the standard indentation is used. +The standard indentation can be determined or changed via the parameter +\scheme{pretty-standard-indent}, which is described later in this +section. + +In cases where a format is given that doesn't quite match, the pretty +printer tries to use the given format as far as it can. +For example, if a format matches a list-structured form with a specific +number of subforms, but more or fewer subform are given, the pretty +printer will discard or replicate subform formats as necessary. + +Here is an example showing the formatting of \var{let} might be specified. + +\schemedisplay +(pretty-format 'let + '(alt (let ([bracket var x] 0 ...) #f e #f e ...) + (let var ([bracket var x] 0 ...) #f e #f e ...))) +\endschemedisplay + +Since \scheme{let} comes in two forms, named and unnamed, two alternatives +are specified. +In either case, the \scheme{bracket} \var{fmt} is used to enclose the +bindings in square brackets, with all bindings after the first appearing +just below the first (and just after the enclosing opening parenthesis), +if they don't all fit on one line. +Each body form is indented by the standard indentation. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-line-length}{\categorythreadparameter}{pretty-line-length} +\formdef{pretty-one-line-limit}{\categorythreadparameter}{pretty-one-line-limit} +\listlibraries +\endentryheader + +\noindent +The value of each of these parameters must be a positive fixnum. + +The parameters \scheme{pretty-line-length} and +\scheme{pretty-one-line-limit} control the output produced by +\index{\scheme{pretty-print}}\scheme{pretty-print}. +\scheme{pretty-line-length} determines after which character position (starting +from the first) on a line the pretty printer attempts to cut off output. +This is a soft limit only; if necessary, the pretty-printer will go beyond +\scheme{pretty-line-length}. + +\scheme{pretty-one-line-limit} is similar to +\scheme{pretty-line-length}, except that it is relative to the first +nonblank position on each line of output. +It is also a soft limit. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-initial-indent}{\categorythreadparameter}{pretty-initial-indent} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a nonnegative fixnum. + +The parameter \scheme{pretty-initial-indent} is used to tell +\index{\scheme{pretty-print}}\scheme{pretty-print} where on an output +line it has been called. +If \scheme{pretty-initial-indent} is zero (the default), \scheme{pretty-print} +assumes that the first line of output it produces will start at the +beginning of the line. +If set to a nonzero value \var{n}, \scheme{pretty-print} assumes that the first +line will appear at character position \var{n} and will adjust its +printing of subsequent lines. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-standard-indent}{\categorythreadparameter}{pretty-standard-indent} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a nonnegative fixnum. + +This determines the amount by which +\scheme{pretty-print} indents subexpressions of most forms, such as \scheme{let} +expressions, from the form's keyword or first subexpression. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pretty-maximum-lines}{\categorythreadparameter}{pretty-maximum-lines} +\listlibraries +\endentryheader + +\noindent +The parameter \scheme{pretty-maximum-lines} controls how many lines +\scheme{pretty-print} prints when it is called. +If set to \scheme{#f} (the default), no limit is imposed; if set to a +nonnegative fixnum \var{n}, at most \var{n} lines are printed. + + +\section{Formatted Output\label{SECTFORMAT}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{format}{\categoryprocedure}{(format \var{format-string} \var{obj} \dots)} +\formdef{format}{\categoryprocedure}{(format #f \var{format-string} \var{obj} \dots)} +\formdef{format}{\categoryprocedure}{(format #t \var{format-string} \var{obj} \dots)} +\formdef{format}{\categoryprocedure}{(format \var{textual-output-port} \var{format-string} \var{obj} \dots)} +\returns see below +\listlibraries +\endentryheader + +\noindent +\index{formatted output}% +When the first argument to format is a string or \scheme{#f} (first and +second forms above), +\scheme{format} constructs an output string from \var{format-string} and the +objects \scheme{\var{obj} \dots}. +Characters are copied from \var{format-string} to the output string from +left to right, until \var{format-string} is exhausted. +The format string may contain one or more \var{format directives}, which are +multi-character sequences prefixed by a tilde (~\scheme{~}~). +Each directive is replaced by some other text, often involving one or more +of the \scheme{\var{obj} \dots} arguments, as determined by the semantics +of the directive. + +When the first argument is \scheme{#t}, output is sent to the current output +port instead, as with \scheme{printf}. +When the first argument is a port, output is sent to that port, as with +\scheme{fprintf}. +\scheme{printf} and \scheme{fprintf} are described later in this section. + +{\ChezScheme}'s implementation of \scheme{format} supports all of the +Common Lisp~\cite{Steele:common} format directives except for those specific +to the Common Lisp pretty printer. +Please consult a Common Lisp reference or the +\hyperlink{http://www.lispworks.com/documentation/HyperSpec/Front/index.htm}{Common Lisp Hyperspec}, +for complete documentation. +A few of the most useful directives are described below. + +% \begin{itemize} +% \item \scheme{~s} +% is replaced by the printed representation of the next \var{obj}, which +% may be any object, in machine-readable format, as with \scheme{write}. +% ``s'' is used for compatibility with \index{Common Lisp}Common Lisp, where it stands for +% ``s-expression,'' the Lisp term for object. +% +% \item \scheme{~a} +% is replaced by the printed representation of the next \var{obj}, which +% may be any object, in human-readable format, as with \scheme{display}. +% ``a'' is used for compatibility with \index{Common Lisp}Common Lisp, where it stands for +% ``ascii.'' +% +% \item \scheme{~c} +% is replaced by the next \var{obj}, which must be a character, as with +% \scheme{write-char}. +% +% \item \scheme{~%} +% is replaced by a newline character, as with \scheme{newline}. +% +% \item \scheme{~~} +% is replaced by a single tilde. +% \end{itemize} +% +% An exception is raised with condition-type \scheme{&assertion} +% if more or fewer \var{objs} are given than required by +% a \var{format-string} that requires a fixed number of objects, or if the +% format string is malformed in any way. + +Absent any format directives, \scheme{format} simply displays its string +argument. + +\schemedisplay +(format "hi there") ;=> "hi there" +\endschemedisplay + +The \scheme{~s} directive is replaced by the printed representation of +the next \var{obj}, which may be any object, in machine-readable format, +as with \scheme{write}. + +\schemedisplay +(format "hi ~s" 'mom) ;=> "hi mom" +(format "hi ~s" "mom") ;=> "hi \"mom\"" +(format "hi ~s~s" 'mom #\!) ;=> "hi mom#\\!" +\endschemedisplay + +The general form of a \scheme{~s} directive is actually +\scheme{~\var{mincol},\var{colinc},\var{minpad},\var{padchar}s}, +and the \scheme{s} can be preceded by an at sign (~\scheme{@}~) +modifier. +These additional parameters are used to control padding in the +output, with at least \var{minpad} copies of \var{padchar} +plus an integer multiple of \var{colinc} copies of \var{padchar} +to make the total width, including the written object, +\var{mincol} characters wide. +The padding is placed on the left if the \var{@} modifier is +present, otherwise on the right. +\var{mincol} and \var{minpad} default to 0, \var{colinc} defaults +to 1, and \var{padchar} defaults to space. +If specified, \var{padchar} is prefixed by a single quote mark. + +\schemedisplay +(format "~10s" 'hello) ;=> "hello " +(format "~10@s" 'hello) ;=> " hello" +(format "~10,,,'*@s" 'hello) ;=> "*****hello" +\endschemedisplay + +The \scheme{~a} directive is similar, but prints the object as with +\scheme{display}. + +\schemedisplay +(format "hi ~s~s" "mom" #\!) ;=> "hi \"mom\"#\\!" +(format "hi ~a~a" "mom" #\!) ;=> "hi mom!" +\endschemedisplay + +A tilde may be inserted into the output with \scheme{~~}, and a newline +may be inserted with \scheme{~%} (or embedded in the string with +\scheme{\n}). + +\schemedisplay +(format "~~line one,~%line two.~~") ;=> "~line one,\nline two.~" +(format "~~line one,\nline two.~~") ;=> "~line one,\nline two.~" +\endschemedisplay + +Real numbers may be printed in floating-point notation with \scheme{~f}. + +\schemedisplay +(format "~f" 3.14159) ;=> 3.14159 +\endschemedisplay + +Exact numbers may printed as well as inexact numbers in this manner; they +are simply converted to inexact first as if with \scheme{exact->inexact}. + +\schemedisplay +(format "~f" 1/3) ;=> "0.3333333333333333" +\endschemedisplay + +The general form is actually \scheme{~\var{w},\var{d},\var{k},\var{overflowchar},\var{padchar}f}. +If specified, \var{w} determines the overall width of the output, +and \var{d} the number of digits to the right of the decimal point. +\var{padchar}, which defaults to space, is the pad character used +if padding is needed. +Padding is always inserted on the left. +The number is scaled by $10^k$ when printed; \var{k} defaults to zero. +The entire \var{w}-character field is filled with copies of +\var{overflowchar} if \var{overflowchar} is specified and the number +cannot be printed in \var{w} characters. +\var{k} defaults to 1 +If an \scheme{@} modifier is present, a plus sign is printed before the +number for nonnegative inputs; otherwise, a sign is printed only if the +number is negative. + +\schemedisplay +(format "~,3f" 3.14159) ;=> "3.142" +(format "~10f" 3.14159) ;=> " 3.14159" +(format "~10,,,'#f" 1e20) ;=> "##########" +\endschemedisplay + +Real numbers may also be printed with \scheme{~e} for scientific +notation or with \scheme{~g}, which uses either floating-point or +scientific notation based on the size of the input. + +\schemedisplay +(format "~e" 1e23) ;=> "1.0e+23" +(format "~g" 1e23) ;=> "1.0e+23" +\endschemedisplay + +A real number may also be printed with \scheme{~$}, which uses +monetary notation defaulting to two digits to the right of the +decimal point. + +\schemedisplay +(format "$~$" (* 39.95 1.06)) ;=> "$42.35" +(format "~$USD" 1/3) ;=> "0.33USD" +\endschemedisplay + +Words can be pluralized automatically using \scheme{p}. +\schemedisplay +(format "~s bear~:p in ~s den~:p" 10 1) ;=> "10 bears in 1 den" +\endschemedisplay + +Numbers may be printed out in words or roman numerals using variations +on \scheme{~r}. + +\schemedisplay +(format "~r" 2599) ;=> "two thousand five hundred ninety-nine" +(format "~:r" 99) ;=> "ninety-ninth" +(format "~@r" 2599) ;=> "MMDXCIX" +\endschemedisplay + +Case conversions can be performed by bracketing a portion of the +format string with the \scheme{~@(} and \scheme{~)} directives. + +\schemedisplay +(format "~@(~r~)" 2599) ;=> "Two thousand five hundred ninety-nine" +(format "~@:(~a~)" "Ouch!") ;=> "OUCH!" +\endschemedisplay + +\noindent +Some of the directives shown above have more options and parameters, and +there are other directives as well, including directives for conditionals, +iteration, indirection, and justification. +Again, please consult a Common Lisp reference for complete documentation. + +An implementation of a greatly simplified version of \scheme{format} +appears in Section~\ref{TSPL:SECTEXPRINTF} of {\TSPLFOUR}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{printf}{\categoryprocedure}{(printf \var{format-string} \var{obj} \dots)} +\formdef{fprintf}{\categoryprocedure}{(fprintf \var{textual-output-port} \var{format-string} \var{obj} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +These procedures are simple wrappers for \scheme{format}. +\scheme{printf} prints the formatted output to the current output, +as with a first-argument of \scheme{#t} to \scheme{format}, and +\scheme{fprintf} prints the formatted output to the \var{textual-output-port}, +as when the first argument to \scheme{format} is a port. + +\section{Input/Output Control Operations\label{SECTMISCIOCONTROL}} + +The I/O control operations described in this section are used to +control how the reader reads and printer writes, displays, or +pretty-prints +characters, +symbols, +gensyms, +numbers, +vectors, +long or deeply nested lists or vectors, +and graph-structured objects. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:char-name} +\formdef{char-name}{\categoryprocedure}{(char-name \var{obj})} +\returns see below +\formdef{char-name}{\categoryprocedure}{(char-name \var{name} \var{char})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{char-name} is used to associate names (symbols) with characters +or to retrieve the most recently associated name or character for a +given character or name. +A name can map to only one character, but more than one name +can map to the same character. +The name most recently associated with a character determines +how that character prints, and each name associated with a character +may be used after the \scheme{#\} character prefix to name that +character on input. + +Character associations created by \scheme{char-name} are ignored by the +printer unless the parameter \scheme{print-char-name} is set to a true +value. +The reader recognizes character names established by \scheme{char-name} +except after \scheme{#!r6rs}, which is implied within a library or +R6RS top-level program. + +In the one-argument form, \var{obj} must be a symbol or character. +If it is a symbol and a character is associated with the +symbol, \scheme{char-name} returns that character. +If it is a symbol and no character is associated with the symbol, +\scheme{char-name} returns \scheme{#f}. +Similarly, if \var{obj} is a character, \scheme{char-name} returns the +most recently associated symbol for the character or \scheme{#f} if +no name is associated with the character. +For example, with the default set of character names: + +\schemedisplay +(char-name #\space) ;=> space +(char-name 'space) ;=> #\space +(char-name 'nochar) ;=> #f +(char-name #\a) ;=> #f +\endschemedisplay + +When passed two arguments, \var{name} is added to the set of names +associated with \var{char}, and any other association for \var{name} +is dropped. +\var{char} may be \scheme{#f}, in which case any other association +for \var{name} is dropped and no new association is formed. +In either case, any other names associated with \var{char} remain +associated with \var{char}. + +The following interactive session demonstrates the use of +\scheme{char-name} to establish and remove associations between +characters and names, including the association of more than +one name with a character. + +\schemedisplay +(print-char-name #t) +(char-name 'etx) ;=> #f +(char-name 'etx #\x3) +(char-name 'etx) ;=> #\etx +(char-name #\x3) ;=> etx +#\etx ;=> #\etx +(eq? #\etx #\x3) ;=> #t +#!r6rs #\etx ;=> \var{exception: invalid character name etx} +#!chezscheme #\etx ;=> #\etx +(char-name 'etx #\space) +(char-name #\x3) ;=> #f +(char-name 'etx) ;=> #\etx +#\space ;=> #\etx +(char-name 'etx #f) +#\etx ;=> \var{exception: invalid character name etx} +#\space ;=> #\space +\endschemedisplay + +(When using the expression editor, it is necessary to type Control-J to +force the editor to read the erroneous \scheme{#\etx} input on the two +inputs above that result in read errors, since typing Enter +causes the expression editor to read the input only if the input is +well-formed.) + +The reader does not recognize hex scalar value escapes in character names, +as it does in symbols, so \scheme{#\new\x6c;ine} is not equivalent +to \scheme{#\newline}. +In general, programmers should avoid the use of character name symbols +that cannot be entered without the use of hex scalar value escapes or +other symbol-name escape mechanisms, since such character names will +not be readable. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-char-name}{\categorythreadparameter}{print-char-name} +\listlibraries +\endentryheader + +\noindent +When \scheme{print-char-name} is set to \scheme{#f} (the default), associations +created by \scheme{char-name} are ignored by \scheme{write}, +\scheme{put-datum}, \scheme{pretty-print}, and the \scheme{format} +``\scheme{~s}'' directive. +Otherwise, these procedures use the names established by +\scheme{char-name} when printing character objects. + +\schemedisplay +(char-name 'etx #\x3) +(format "~s" #\x3) ;=> "#\\x3" +(parameterize ([print-char-name #t]) + (format "~s" #\x3)) ;=> "#\\etx" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{case-sensitive}{\categorythreadparameter}{case-sensitive} +\listlibraries +\endentryheader + +\noindent +The \scheme{case-sensitive} parameter determines whether the +reader is case-sensitive with respect to symbol and character names. +When set to true (the default, as required by the Revised$^6$ Report) +the case of alphabetic characters +within symbol names is significant. +When set to \scheme{#f}, case is insignificant. +More precisely, when set to \scheme{#f}, symbol and character names are +folded (as if by \scheme{string-foldcase}); otherwise, they are left +as they appear in the input. + +The value of the \scheme{case-sensitive} matters only +if neither \scheme{#!fold-case} nor \scheme{#!no-fold-case} has appeared +previously in the same input stream. +That is, symbol and character name are folded if \scheme{#!fold-case} has +been seen. +They are not folded if \scheme{#!no-fold-case} has been seen. +If neither has been seen, they are folded if and only if +\scheme{(case-sensitive)} is \scheme{#f}. + +\schemedisplay +(case-sensitive) ;=> #t +(eq? 'abc 'ABC) ;=> #f +'ABC ;=> ABC +(case-sensitive #f) +'ABC ;=> abc +(eq? 'abc 'ABC) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-graph}{\categorythreadparameter}{print-graph} +\listlibraries +\endentryheader + +\noindent +When \scheme{print-graph} is set to a true value, +\scheme{write} and \scheme{pretty-print} +locate and print objects with shared structure, including +cycles, in a notation that may be read subsequently with \scheme{read}. +This notation employs the syntax +\index{#= (graph mark)@\scheme{#\var{n}=} (graph mark)}``\scheme{#\var{n}=\var{obj}},'' +where \var{n} +is a nonnegative integer and \var{obj} is the printed representation +of an object, to label the first occurrence of \var{obj} in the output. +The syntax +\index{## (graph reference)@\scheme{#\var{n}#} (graph reference)}``\scheme{#\var{n}#}'' +is used to refer to the object labeled by +\var{n} thereafter in the output. +\scheme{print-graph} is set to \scheme{#f} by default. + +If graph printing is not enabled, +the settings of \scheme{print-length} and \scheme{print-level} +are insufficient to force finite output, +and \scheme{write} or \scheme{pretty-print} detects a cycle in an +object it is given to print, +a warning is issued (an exception with condition type \scheme{&warning} is +raised) and the object is printed as if +\scheme{print-graph} were enabled. + +Since objects printed through the \scheme{~s} option in the format control +strings of \scheme{format}, \scheme{printf}, and \scheme{fprintf} are printed as with +\scheme{write}, the printing of such objects is also affected by \scheme{print-graph}. + +\schemedisplay +(parameterize ([print-graph #t]) + (let ([x (list 'a 'b)]) + (format "~s" (list x x)))) ;=> "(#0=(a b) #0#)" + +(parameterize ([print-graph #t]) + (let ([x (list 'a 'b)]) + (set-car! x x) + (set-cdr! x x) + (format "~s" x))) ;=> "#0=(#0# . #0#)" +\endschemedisplay + +\noindent +The graph syntax is understood by the procedure +\index{\scheme{read}}\scheme{read}, allowing graph structures +to be printed and read consistently. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-level}{\categorythreadparameter}{print-level} +\formdef{print-length}{\categorythreadparameter}{print-length} +\listlibraries +\endentryheader + +\noindent +These parameters can be used to limit the extent to which nested +or multiple-element structures are printed. +When called without arguments, \scheme{print-level} returns the current +print level and \scheme{print-length} returns the current print length. +When called with one argument, which must be a nonnegative fixnum or +\scheme{#f}, \scheme{print-level} sets the current print level and +\scheme{print-length} sets the current print length to the argument. + +When \scheme{print-level} is set to a nonnegative integer \var{n}, +\scheme{write} and \scheme{pretty-print} +traverse only \var{n} levels deep into nested structures. +If a structure being printed exceeds \var{n} levels of nesting, +the substructure beyond that point is replaced in the output by an +\index{\scheme{...}~(ellipses)}\index{ellipses (~\scheme{...}~)}ellipsis +(~\scheme{...}~). +\scheme{print-level} is set to \scheme{#f} by default, which places +no limit on the number of levels printed. + +When \scheme{print-length} is set to a nonnegative integer \var{n}, the +procedures \scheme{write} and \scheme{pretty-print} +print only \var{n} elements of a list or vector, +replacing the remainder of the list or vector with an +\index{\scheme{...}~(ellipses)}\index{ellipses (~\scheme{...}~)}ellipsis +(~\scheme{...}~). +\scheme{print-length} is set to \scheme{#f} by default, which places +no limit on the number of elements printed. + +Since objects printed through the \scheme{~s} option in +the format control strings of \scheme{format}, \scheme{printf}, and \scheme{fprintf} are +printed as with \scheme{write}, +the printing of such objects is also affected by \scheme{print-level} +and \scheme{print-length}. + +The parameters \scheme{print-level} and \scheme{print-length} are useful for +controlling the volume of output in contexts where only a small portion +of the output is needed to identify the object being printed. +They are also useful in situations where circular structures may be +printed (see also \scheme{print-graph}). + +\schemedisplay +(format "~s" '((((a) b) c) d e f g)) ;=> "((((a) b) c) d e f g)" + +(parameterize ([print-level 2]) + (format "~s" '((((a) b) c) d e f g))) ;=> "(((...) c) d e f g)" + +(parameterize ([print-length 3]) + (format "~s" '((((a) b) c) d e f g))) ;=> "((((a) b) c) d e ...)" + +(parameterize ([print-level 2] + [print-length 3]) + (format "~s" '((((a) b) c) d e f g))) ;=> "(((...) c) d e ...)" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-radix}{\categorythreadparameter}{print-radix} +\listlibraries +\endentryheader + +\noindent +The \scheme{print-radix} parameter determines the radix in which +numbers are printed by \scheme{write}, \scheme{pretty-print}, and +\scheme{display}. +Its value should be an integer between 2 and 36, inclusive. +Its default value is 10. + +When the value of \scheme{print-radix} is not 10, \scheme{write} and +\scheme{pretty-print} print a radix prefix before the number +(\scheme{#b} for radix 2, \scheme{#o} for radix 8, \scheme{#x} for +radix 16, and \scheme{#\var{n}r} for any other radix \var{n}). + +Since objects printed through the \scheme{~s} and +\scheme{~a} options in the format control strings of +\scheme{format}, \scheme{printf}, and \scheme{fprintf} are printed as +with \scheme{write} and \scheme{display}, the printing of such objects +is also affected by \scheme{print-radix}. + +\schemedisplay +(format "~s" 11242957) ;=> "11242957" + +(parameterize ([print-radix 16]) + (format "~s" 11242957)) ;=> "#xAB8DCD" + +(parameterize ([print-radix 16]) + (format "~a" 11242957)) ;=> "AB8DCD" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-gensym}{\categorythreadparameter}{print-gensym} +\listlibraries +\endentryheader + +\noindent +\index{\scheme{gensym}}\index{\scheme{#:} (gensym prefix)}When +\scheme{print-gensym} is set to \scheme{#t} (the default) +gensyms are printed with an +extended symbol syntax that includes both the pretty name and the unique +name of the gensym: +\index{\scheme{#\schlbrace} (gensym prefix)}\scheme{#\schlbrace\var{pretty-name} \var{unique-name}\schrbrace}. +When set to \scheme{pretty}, the pretty name only is shown, with the +prefix \index{\scheme{#:} (gensym prefix)}\scheme{#:}. +When set to \scheme{pretty/suffix}, +the printer prints the gensym's ``pretty'' name along with a +suffix based on the gensym's ``unique'' name, separated by a dot (~"."~). +If the gensym's unique name is generated automatically during the current +session, the suffix is that portion of the unique name that is not common +to all gensyms created during the current session. +Otherwise, the suffix is the entire unique name. +When set to \scheme{#f}, the pretty name only is shown, with no +prefix. + +Since objects printed through the \scheme{~s} option in the +format control strings of \scheme{format}, \scheme{printf}, +\scheme{errorf}, etc., are printed as with \scheme{write}, the printing of +such objects is also affected by \scheme{print-gensym}. + +When printing an object that may contain more than one occurrence of a +gensym and \scheme{print-graph} is set to \scheme{pretty} or \scheme{#f}, +it is useful to set \scheme{print-graph} to \scheme{#t} so that +multiple occurrences of the same gensym are marked as identical in +the output. + +\schemedisplay +(let ([g (gensym)]) + (format "~s" g)) ;=> "#{g0 bdids2xl6v49vgwe-a}" + +(let ([g (gensym)]) + (parameterize ([print-gensym 'pretty]) + (format "~s" g))) ;=> "#:g1 + +(let ([g (gensym)]) + (parameterize ([print-gensym #f]) + (format "~s" g))) ;=> "g2" + +(let ([g (gensym)]) + (parameterize ([print-graph #t] [print-gensym 'pretty]) + (format "~s" (list g g)))) ;=> "(#0=#:g3 #0#)" + +(let ([g1 (gensym "x")] + [g2 (gensym "x")] + [g3 (gensym "y")]) + (parameterize ([print-gensym 'pretty/suffix]) + (format "~s ~s ~s" g1 g2 g3))) ;=> "x.1 x.2 y.3" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-brackets}{\categorythreadparameter}{print-brackets} +\listlibraries +\endentryheader + +\noindent +When \scheme{print-brackets} is set to a true value, the pretty printer +(see \index{\scheme{pretty-print}}\scheme{pretty-print}) uses square +brackets rather than parentheses around certain subexpressions of +common control structures, e.g., around \scheme{let} bindings and +\scheme{cond} clauses. +\scheme{print-brackets} is set to \scheme{#t} by default. + +\schemedisplay +(let ([p (open-output-string)]) + (pretty-print '(let ([x 3]) x) p) ;=> "(let ([x 3]) x) + (get-output-string p)) ;== " + +(parameterize ([print-brackets #f]) + (let ([p (open-output-string)]) + (pretty-print '(let ([x 3]) x) p) ;=> "(let ((x 3)) x) + (get-output-string p))) ;== " +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-extended-identifiers}{\categorythreadparameter}{print-extended-identifiers} +\listlibraries +\endentryheader + +Chez Scheme extends the syntax of identifiers as described in +Section~\ref{SECTINTROSYNTAX}, except within a set of forms prefixed by +\scheme{#!r6rs} (which is implied in a library or top-level program). + +When this parameter is set to false (the default), identifiers in the +extended set are printed with hex scalar value escapes as necessary to +conform to the R6RS syntax for identifiers. +When this parameter is set to a true value, identifiers in the +extended set are printed without the escapes. +Identifiers whose names fall outside of both syntaxes are printed with +the escapes regardless of the setting of this parameter. + +For example: + +\schemedisplay +(parameterize ([print-extended-identifiers #f]) + (printf "~s\n~s\n" + '(1+ --- { } .xyz) + (string->symbol "123"))) +\endschemedisplay + +prints + +\schemedisplay +(\x31;+ \x2D;-- \x7B; \x7D; \x2E;xyz) +\x31;23 +\endschemedisplay + +while + +\schemedisplay +(parameterize ([print-extended-identifiers #t]) + (printf "~s\n~s\n" + '(1+ --- { } .xyz) + (string->symbol "123"))) +\endschemedisplay + +prints + +\schemedisplay +(1+ --- { } .xyz) +\x31;23 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-vector-length}{\categorythreadparameter}{print-vector-length} +\listlibraries +\endentryheader + +\noindent +When \scheme{print-vector-length} is set to a true value, +\scheme{write}, \scheme{put-datum}, and \scheme{pretty-print} includes the length +for all vectors between the ``\scheme{#}'' and open parenthesis, +all bytevectors between the ``\scheme{#vu8}'' and open parenthesis, +and all fxvectors between the ``\scheme{#vfx}'' and open parenthesis. +This parameter is set to \scheme{#f} by default. + +\index{vector printing}When \scheme{print-vector-length} is set to a +true value, \scheme{write}, \scheme{put-datum}, and \scheme{pretty-print} +also suppress duplicated trailing elements in the vector to +reduce the amount of output. +This form is also recognized by the reader. + +Since objects printed through the \scheme{~s} option in the +format control strings of \scheme{format}, \scheme{printf}, and +\scheme{fprintf} are printed as with \scheme{write}, the printing of +such objects is also affected by the setting of +\scheme{print-vector-length}. + +\schemedisplay +(format "~s" (vector 'a 'b 'c 'c 'c)) ;=> "#(a b c c c)" + +(parameterize ([print-vector-length #t]) + (format "~s" (vector 'a 'b 'c 'c 'c))) ;=> "#5(a b c)" + +(parameterize ([print-vector-length #t]) + (format "~s" (bytevector 1 2 3 4 4 4))) ;=> "#6vu8(1 2 3 4)" + +(parameterize ([print-vector-length #t]) + (format "~s" (fxvector 1 2 3 4 4 4))) ;=> "#6vfx(1 2 3 4)" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-precision}{\categorythreadparameter}{print-precision} +\listlibraries +\endentryheader + +\noindent +When \scheme{print-precision} is set to \scheme{#f} (the default), +\scheme{write}, \scheme{put-datum}, \scheme{pretty-print}, and the +\scheme{format} ``\scheme{~s}'' directive do not include the +vertical-bar ``mantissa-width'' syntax after each floating-point +number. +When set to a nonnegative exact integer, the mantissa width is +included, as per the precision argument to +\scheme{number->string}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-unicode}{\categorythreadparameter}{print-unicode} +\listlibraries +\endentryheader + +\noindent +When \scheme{print-unicode} is set to \scheme{#f}, +\scheme{write}, \scheme{put-datum}, \scheme{pretty-print}, and the +\scheme{format} ``\scheme{~s}'' directive display Unicode characters +with encodings $80_{16}$ (128) and above that appear +within character objects, symbols, and strings +using hexadecimal character escapes. +When set to a true value (the default), they are displayed like +other printing characters, as if by \scheme{put-char}. + +\schemedisplay +(format "~s" #\x3bb) ;=> "#\\\raw{$\lambda$}" +(parameterize ([print-unicode #f]) + (format "~s" #\x3bb)) ;=> "#\\x3BB" +\endschemedisplay + +\section{Fasl Output\label{SECTFASL}} + +\index{fast loading format}% +The procedures \scheme{write} and \scheme{pretty-print} print objects in a +human readable format. +For objects with external datum representations, the output produced by +\scheme{write} and \scheme{pretty-print} is also machine-readable with +\scheme{read}. +Objects with external datum representations include pairs, symbols, +vectors, strings, numbers, characters, booleans, and records but not +procedures and ports. + +An alternative \emph{fast loading}, or \emph{fasl}, format may be used for +objects with external datum representations. +The fasl format is not human readable, but it is machine readable and both +more compact and more quickly processed by \scheme{read}. +This format is always used for compiled code generated by +\scheme{compile-file}, but it may also be used for data that needs to be +written and read quickly, such as small databases encoded with Scheme data +structures. + +Objects are printed in fasl format with \scheme{fasl-write}. +Because the fasl format is a binary format, fasl output must be written +to a binary port. +For this reason, it is not possible to include data written in fasl +format with textual data in the same file, as was the case in +earlier versions of {\ChezScheme}. +Similarly, the (textual) reader does not handle objects written in +fasl format; the procedure \scheme{fasl-read}, which requires a binary +input port, must be used instead. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{fasl-write} writes the fasl representation of \var{obj} to +\var{binary-output-port}. +An exception is raised with condition-type \scheme{&assertion} if +\var{obj} or any portion of \var{obj} has no external fasl representation, +e.g., if \var{obj} is or contains a procedure. + +The fasl representation of \var{obj} is compressed if the parameter +\scheme{fasl-compressed}, described below, is set to \scheme{#t}, +its default value. +For this reason, \var{binary-output-port} generally should not be opened +with the compressed option. +A warning is issued (an exception with condition type \scheme{&warning} +is raised) on the first attempt to write fasl objects to or read +fasl objects from a compressed file. + +\schemedisplay +(define bop (open-file-output-port "tmp.fsl")) +(fasl-write '(a b c) bop) +(close-port bop) + +(define bip (open-file-input-port "tmp.fsl")) +(fasl-read bip) ;=> (a b c) +(fasl-read bip) ;=> #!eof +(close-port bip) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port})} +\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port \var{situation}})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +If present, \var{situation} must be one of the symbols \scheme{load}, +\scheme{visit}, or \scheme{revisit}. +It defaults to \scheme{load}. + +\scheme{fasl-read} reads one object from +\var{binary-input-port}, which must be positioned at the +front of an object written in fasl format. +\scheme{fasl-read} returns the eof object if the file is positioned +at the end of file. +If the situation is \scheme{visit}, \scheme{fasl-read} skips over +any revisit (run-time-only) objects, and +if the situation is \scheme{revisit}, \scheme{fasl-read} skips over +any visit (compile-time-only) objects. +It doesn't skip any if the situation is \scheme{load}. +Similarly, objects marked as both visit and revisit (e.g., object code +corresponding to source code within an \scheme{eval-when} form with +situation \scheme{load} or situations \scheme{visit} and \scheme{revisit}) +are never skipped. + +\scheme{fasl-read} automatically decompresses the representation +of each fasl object written in compressed format by \scheme{fasl-write}. +Thus, \var{binary-input-port} generally should not be opened with +the compressed option. +A warning is issued (an exception with condition type \scheme{&warning} +is raised) on the first attempt to write fasl objects to or read +fasl objects from a compressed file. + +\schemedisplay +(define bop (open-file-output-port "tmp.fsl")) +(fasl-write '(a b c) bop) +(close-port bop) + +(define bip (open-file-input-port "tmp.fsl")) +(fasl-read bip) ;=> (a b c) +(fasl-read bip) ;=> #!eof +(close-port bip) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fasl-compressed}{\categorythreadparameter}{fasl-compressed} +\listlibraries +\endentryheader + +\noindent +When this parameter is set to its default value, \scheme{#t}, +\scheme{fasl-write} compresses the representation of each object +as it writes it, often resulting in substantially smaller output +but possibly taking more time to write and read. +The compression format and level are determined by the +\index{\scheme{compress-format}}\scheme{compress-format} +and +\index{\scheme{compress-level}}\scheme{compress-level} +parameters. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fasl-file}{\categoryprocedure}{(fasl-file \var{ifn} \var{ofn})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{ifn} and \var{ofn} must be strings. +\scheme{fasl-file} may be used to convert a file in human-readable +format into an equivalent +file written in fasl format. +\scheme{fasl-file} reads each object in turn from the file named by +\var{ifn} and writes the fasl format for the object onto the file +named by \var{ofn}. +If the file named by \var{ofn} already exists, it is replaced. + + +\section{File System Interface\label{SECTIOFILESYSTEM}} + +This section describes operations on files, directories, and pathnames. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-directory}{\categoryglobalparameter}{current-directory} +\formdef{cd}{\categoryglobalparameter}{cd} +\listlibraries +\endentryheader + +\noindent +When invoked without arguments, \scheme{current-directory} returns a string +representing the current working directory. +Otherwise, the current working directory is changed to the directory +specified by the argument, which must be a string representing a valid +directory pathname. + +\scheme{cd} is bound to the same parameter. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{directory-list}{\categoryprocedure}{(directory-list \var{path})} +\returns a list of file names +\listlibraries +\endentryheader + +\var{path} must be a string. +The return value is a list of strings representing the names of +files found in the directory named by \var{path}. +\scheme{directory-list} raises an exception with condition +type \scheme{&i/o-filename} if \var{path} does not name a directory +or if the process cannot list the directory. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-exists?}{\categoryprocedure}{(file-exists? \var{path})} +\formdef{file-exists?}{\categoryprocedure}{(file-exists? \var{path} \var{follow?})} +\returns \scheme{#t} if the file named by \var{path} exists, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{path} must be a string. +If the optional \var{follow?} argument is true (the default), +\scheme{file-exists?} follows symbolic links; otherwise it does not. +Thus, \scheme{file-exists?} will return \scheme{#f} when handed the +pathname of a broken symbolic link unless \var{follow?} is provided +and is \scheme{#f}. + +The Revised$^6$ Report \scheme{file-exists?} does not accept the +optional \var{follow?} argument. +Whether it follows symbolic links is unspecified. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-regular?}{\categoryprocedure}{(file-regular? \var{path})} +\formdef{file-regular?}{\categoryprocedure}{(file-regular? \var{path} \var{follow?})} +\returns \scheme{#t} if the file named by \var{path} is a regular file, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{path} must be a string. +If the optional \var{follow?} argument is true (the default), +\scheme{file-regular?} follows symbolic links; otherwise it does not. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-directory?}{\categoryprocedure}{(file-directory? \var{path})} +\formdef{file-directory?}{\categoryprocedure}{(file-directory? \var{path} \var{follow?})} +\returns \scheme{#t} if the file named by \var{path} is a directory, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{path} must be a string. +If the optional \var{follow?} argument is true (the default), +this procedure follows symbolic links; otherwise it does not. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-symbolic-link?}{\categoryprocedure}{(file-symbolic-link? \var{path})} +\returns \scheme{#t} if the file named by \var{path} is a symbolic link, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{path} must be a string. +\scheme{file-symbolic-link?} never follows symbolic links in making its +determination. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{file-access-time}{\categoryprocedure}{(file-access-time \var{path/port})} +\formdef{file-access-time}{\categoryprocedure}{(file-access-time \var{path/port} \var{follow?})} +\returns the access time of the specified file +\formdef{file-change-time}{\categoryprocedure}{(file-change-time \var{path/port})} +\formdef{file-change-time}{\categoryprocedure}{(file-change-time \var{path/port} \var{follow?})} +\returns the change time of the specified file +\formdef{file-modification-time}{\categoryprocedure}{(file-modification-time \var{path/port})} +\formdef{file-modification-time}{\categoryprocedure}{(file-modification-time \var{path/port} \var{follow?})} +\returns the modification time of the specified file +\listlibraries +\endentryheader + +\var{path/port} must be a string or port. +If \var{path/port} is a string, the time returned is for the file named +by the string, and the optional \var{follow?} argument determines whether +symbolic links are followed. +If \var{follow?} is true (the default), +this procedure follows symbolic links; otherwise it does not. +If \var{path/port} is a port, it must be a file port, and the time returned +is for the associated file. +In this case, \var{follow?} is ignored. + +The returned times are represented as time objects +(Section~\ref{SECTSYSTEMTIMESNDATES}). + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mkdir}{\categoryprocedure}{(mkdir \var{path})} +\formdef{mkdir}{\categoryprocedure}{(mkdir \var{path} \var{mode})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\var{mode} must be a fixnum. + +\scheme{mkdir} creates a directory with the name given by \var{path}. +All \var{path} path components leading up to the last must already +exist. +If the optional \var{mode} argument is present, it overrides the default +permissions for the new directory. +Under Windows, the \var{mode} argument is ignored. + +\scheme{mkdir} raises an exception with condition +type \scheme{&i/o-filename} if the directory cannot be created. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{delete-file}{\categoryprocedure}{(delete-file \var{path})} +\formdef{delete-file}{\categoryprocedure}{(delete-file \var{path} \var{error?})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{delete-file} removes the file named by \var{path}. +If the optional \var{error?} argument is \scheme{#f} (the default), +\scheme{delete-file} returns a boolean value: \scheme{#t} if the +operation is successful and \scheme{#f} if it is not. +Otherwise, \scheme{delete-file} returns an unspecified value if the +operation is successful and raises an exception with condition +type \scheme{&i/o-filename} if it is not. + +The Revised$^6$ Report \scheme{delete-file} does not accept the +optional \var{error?} argument but behaves as if \var{error?} +is true. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{delete-directory}{\categoryprocedure}{(delete-directory \var{path})} +\formdef{delete-directory}{\categoryprocedure}{(delete-directory \var{path} \var{error?})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{delete-directory} removes the directory named by \var{path}. +If the optional \var{error?} argument is \scheme{#f} (the default), +\scheme{delete-directory} returns a boolean value: \scheme{#t} if the +operation is successful and \scheme{#f} if it is not. +Otherwise, \scheme{delete-directory} returns an unspecified value if the +operation is successful and raises an exception with condition +type \scheme{&i/o-filename} if it is not. +The behavior is unspecified if the directory is not empty, but on +most systems the operations will not succeed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{rename-file}{\categoryprocedure}{(rename-file \var{old-pathname} \var{new-pathname})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{old-pathname} and \var{new-pathname} must be strings. +\scheme{rename-file} changes the name of the file named by \var{old-pathname} +to \var{new-pathname}. +If the file does not exist or cannot be renamed, +an exception is raised with condition type \scheme{&i/o-filename}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{chmod}{\categoryprocedure}{(chmod \var{path} \var{mode})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\var{mode} must be a fixnum. + +\scheme{chmod} sets the permissions on the file named by +\var{path} to \var{mode}. +Bits 0, 1, and~2 of \var{mode} are the execute, write, and read permission bits +for users other than the file's owner who are not in the file's group. +Bits 3-5 are the execute, write, and read permission bits for users other +than the file's owner but in the file's group. +Bits 6-8 are the execute, write, and read permission bits +for the file's owner. +Bits 7-9 are the Unix sticky, set-group-id, and set-user-id bits. +Under Windows, all but the user ``write'' bit are ignored. +If the file does not exist or the permissions cannot be changed, +an exception is raised with condition type \scheme{&i/o-filename}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-mode}{\categoryprocedure}{(get-mode \var{path})} +\formdef{get-mode}{\categoryprocedure}{(get-mode \var{path} \var{follow?})} +\returns the current permissions mode for \var{path} +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{get-mode} retrieves the permissions on the file named by +\var{path} and returns them as a fixnum in the same form as the \var{mode} +argument to \scheme{chmod}. +If the optional \var{follow?} argument is true (the default), +this procedure follows symbolic links; otherwise it does not. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{directory-separator?}{\categoryprocedure}{(directory-separator? \var{char})} +\returns \scheme{#t} if \var{char} is a directory separator, \scheme{#f} otherwise +\listlibraries +\endentryheader + +The character \scheme{#\/} is a directory separator on all +current machine types, and \scheme{#\\} is a directory separator +under Windows. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{directory-separator}{\categoryprocedure}{(directory-separator)} +\returns the preferred directory separator +\listlibraries +\endentryheader + +The preferred directory separator is \scheme{#\\} for Windows and +\scheme{#\/} for other systems. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{path-first}{\categoryprocedure}{(path-first \var{path})} +\formdef{path-rest}{\categoryprocedure}{(path-rest \var{path})} +\formdef{path-last}{\categoryprocedure}{(path-last \var{path})} +\formdef{path-parent}{\categoryprocedure}{(path-parent \var{path})} +\formdef{path-extension}{\categoryprocedure}{(path-extension \var{path})} +\formdef{path-root}{\categoryprocedure}{(path-root \var{path})} +\returns the specified component of \var{path} +\formdef{path-absolute?}{\categoryprocedure}{(path-absolute? \var{path})} +\returns \scheme{#t} if \var{path} is absolute, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\var{path} must be a string. +The return value is also a (possibly empty) string. + +The path first component is the first directory in the path, or the +empty string if the path consists only of a single filename. +The path rest component is the portion of the path that does not +include the path first component or the directory separator (if +any) that separates it from the rest of the path. +The path last component is the last (filename) portion of \var{path}. +The path parent component is the portion of \var{path} that does not +include the path last component, if any, or the directory separator that +separates it from the rest of the path. + +If the first component of the path names a root directory (including drives +and shares under Windows), home directory +(e.g., \scheme{~/abc} or \scheme{~user/abc}), +the current directory (\scheme{.}), or the parent directory +(\scheme{..}), \scheme{path-first} returns that component. +For paths that consist only of such a directory, +both \scheme{path-first} and \scheme{path-parent} act as +identity procedures, while \scheme{path-rest} and \scheme{path-last} +return the empty string. + +The path extension component is the portion of \var{path} that follows +the last dot (period) in the last component of a path name. +The path root component is the portion of \var{path} that does not +include the extension, if any, or the dot that precedes it. + +If the first component names a root directory (including drives +and shares under Windows) or home directory, +\scheme{path-absolute?} returns \scheme{#t}. +Otherwise, \scheme{path-absolute?} returns \scheme{#f}. + +The tables below identify the components for several example paths, +with underscores representing empty strings. + +\begin{tabular}{llllllll} +path & abs & first & rest & parent & last & root & ext \\ +\scheme{a} & \scheme{#f} & \scheme{_} & \scheme{a} & \scheme{_} & \scheme{a} & \scheme{a} & \scheme{_} \\ +\scheme{a/} & \scheme{#f} & \scheme{a} & \scheme{_} & \scheme{a} & \scheme{_} & \scheme{a/} & \scheme{_} \\ +\scheme{a/b} & \scheme{#f} & \scheme{a} & \scheme{b} & \scheme{a} & \scheme{b} & \scheme{a/b} & \scheme{_} \\ +\scheme{a/b.c} & \scheme{#f} & \scheme{a} & \scheme{b.c} & \scheme{a} & \scheme{b.c} & \scheme{a/b} & \scheme{c} \\ +\scheme{/} & \scheme{#t} & \scheme{/} & \scheme{_} & \scheme{/} & \scheme{_} & \scheme{/} & \scheme{_} \\ +\scheme{/a/b.c} & \scheme{#t} & \scheme{/} & \scheme{a/b.c} & \scheme{/a} & \scheme{b.c} & \scheme{/a/b} & \scheme{c} \\ +\scheme{~/a/b.c} & \scheme{#t} & \scheme{~} & \scheme{a/b.c} & \scheme{~/a} & \scheme{b.c} & \scheme{~/a/b} & \scheme{c} \\ +\scheme{~u/a/b.c} & \scheme{#t} & \scheme{~u} & \scheme{a/b.c} & \scheme{~u/a} & \scheme{b.c} & \scheme{~u/a/b} & \scheme{c} \\ +\scheme{../..} & \scheme{#f} & \scheme{..} & \scheme{..} & \scheme{..} & \scheme{..} & \scheme{../..} & \scheme{_} \\ +\end{tabular} + +The second table shows the components when Windows drives and shares +are involved. + +\begin{tabular}{llllllll} +path & abs & first & rest & parent & last & root & ext \\ +\scheme{c:} & \scheme{#f} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} \\ +\scheme{c:/} & \scheme{#t} & \scheme{c:/} & \scheme{_} & \scheme{c:/} & \scheme{_} & \scheme{c:/} & \scheme{_} \\ +\scheme{c:a/b} & \scheme{#f} & \scheme{c:} & \scheme{a/b} & \scheme{c:a} & \scheme{b} & \scheme{c:a/b} & \scheme{_} \\ +\scheme{//s/a/b.c} & \scheme{#t} & \scheme{//s} & \scheme{a/b.c} & \scheme{//s/a} & \scheme{b.c} & \scheme{//s/a/b} & \scheme{c} \\ +\scheme{//s.com} & \scheme{#t} & \scheme{//s.com} & \scheme{_} & \scheme{//s.com} & \scheme{_} & \scheme{//s.com} & \scheme{_} \\ +\end{tabular} + +The following procedure can be used to reproduce the tables above. + +\schemedisplay +(define print-table + (lambda path* + (define print-row + (lambda (abs? path first rest parent last root extension) + (printf "~a~11t~a~17t~a~28t~a~39t~a~50t~a~61t~a~73t~a\n" + abs? path first rest parent last root extension))) + (print-row "path" "abs" "first" "rest" "parent" "last" "root" "ext") + (for-each + (lambda (path) + (define uscore (lambda (s) (if (eqv? s "") "_" s))) + (apply print-row path + (map (lambda (s) (if (eqv? s "") "_" s)) + (list (path-absolute? path) (path-first path) + (path-rest path) (path-parent path) (path-last path) + (path-root path) (path-extension path))))) + path*))) +\endschemedisplay + +For example, the first table can be produced with: + +\schemedisplay +(print-table "a" "a/" "a/b" "a/b.c" "/" "/a/b.c" "~/a/b.c" + "~u/a/b.c" "../..") +\endschemedisplay + +while the second can be produced (under Windows) with: + +\schemedisplay +(print-table "c:" "c:/" "c:a/b" "//s/a/b.c" "//s.com") +\endschemedisplay + +\section{Generic Port Examples\label{SECTPORTEXAMPLES}} + +This section presents the definitions for three types of generic ports: +two-way ports, transcript ports, and process ports. + +\parheader{Two-way ports} +\index{two-way ports}The first example defines \scheme{make-two-way-port}, which constructs a +textual input/output port from a given pair of textual input and output ports. +For example: + +\schemedisplay +(define ip (open-input-string "this is the input")) +(define op (open-output-string)) +(define p (make-two-way-port ip op)) +\endschemedisplay + +\noindent +The port returned by \scheme{make-two-way-port} is both an input and an output +port, and it is also a textual port: + +\schemedisplay +(port? p) ;=> #t +(input-port? p) ;=> #t +(output-port? p) ;=> #t +(textual-port? p) ;=> #t +\endschemedisplay + +\noindent +Items read from a two-way port come from the constituent input port, +and items written to a two-way port go to the constituent output +port: + +\schemedisplay +(read p) ;=> this +(write 'hello p) +(get-output-string op) ;=> hello +\endschemedisplay + +\noindent +The definition of \scheme{make-two-way-port} is straightforward. +To keep the example simple, +no local buffering is performed, +although it would be more efficient to do so. + +\schemedisplay +(define make-two-way-port + (lambda (ip op) + (define handler + (lambda (msg . args) + (record-case (cons msg args) + [block-read (p s n) (block-read ip s n)] + [block-write (p s n) (block-write op s n)] + [char-ready? (p) (char-ready? ip)] + [clear-input-port (p) (clear-input-port ip)] + [clear-output-port (p) (clear-output-port op)] + [close-port (p) (mark-port-closed! p)] + [flush-output-port (p) (flush-output-port op)] + [file-position (p . pos) (apply file-position ip pos)] + [file-length (p) (file-length ip)] + [peek-char (p) (peek-char ip)] + [port-name (p) "two-way"] + [read-char (p) (read-char ip)] + [unread-char (c p) (unread-char c ip)] + [write-char (c p) (write-char c op)] + [else (assertion-violationf 'two-way-port + "operation ~s not handled" + msg)]))) + (make-input/output-port handler "" ""))) +\endschemedisplay + +\noindent +Most of the messages are passed directly to one of the constituent +ports. +Exceptions are \scheme{close-port}, which is handled directly by +marking the port closed, \scheme{port-name}, which is also handled directly. +\scheme{file-position} and \scheme{file-length} are rather arbitrarily +passed off to the input port. + + +\parheader{Transcript ports} +\index{transcript ports}The next example defines \scheme{make-transcript-port}, which constructs a +textual input/output port from three ports: a textual input port \var{ip} and two textual +output ports, \var{op} and \var{tp}. +Input read from a transcript port comes from \var{ip}, and output +written to a transcript port goes to \var{op}. +In this manner, transcript ports are similar to two-way ports. +Unlike two-way ports, input from \var{ip} and output to \var{op} is +also written to \var{tp}, so that \var{tp} reflects both input from +\var{ip} and output to \var{op}. + +Transcript ports may be used to define the Scheme procedures +\scheme{transcript-on} and \scheme{transcript-off}, or the {\ChezScheme} procedure +\scheme{transcript-cafe}. +For example, here is a definition of \scheme{transcript-cafe}: + +\schemedisplay +(define transcript-cafe + (lambda (pathname) + (let ([tp (open-output-file pathname 'replace)]) + (let ([p (make-transcript-port + (console-input-port) + (console-output-port) + tp)]) + ; set both console and current ports so that + ; the waiter and read/write will be in sync + (parameterize ([console-input-port p] + [console-output-port p] + [current-input-port p] + [current-output-port p]) + (let-values ([vals (new-cafe)]) + (close-port p) + (close-port tp) + (apply values vals))))))) +\endschemedisplay + + +The implementation of transcript ports is significantly more complex +than the implementation of two-way ports defined above, primarily +because it buffers input and output locally. +Local buffering is needed to allow the transcript file to reflect +accurately the actual input and output performed in the presence of +\scheme{unread-char}, \scheme{clear-output-port}, and \scheme{clear-input-port}. +Here is the code: + +% exercise: Try rewriting make-transcript-port without local buffering. +% Why does this not work satisfactorily? + +\schemedisplay +(define make-transcript-port + (lambda (ip op tp) + (define (handler msg . args) + (record-case (cons msg args) + [block-read (p str cnt) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (if (< i s) + (let ([cnt (fxmin cnt (fx- s i))]) + (do ([i i (fx+ i 1)] + [j 0 (fx+ j 1)]) + ((fx= j cnt) + (set-port-input-index! p i) + cnt) + (string-set! str j (string-ref b i)))) + (let ([cnt (block-read ip str cnt)]) + (unless (eof-object? cnt) + (block-write tp str cnt)) + cnt))))] + [char-ready? (p) + (or (< (port-input-index p) (port-input-size p)) + (char-ready? ip))] + [clear-input-port (p) + ; set size to zero rather than index to size + ; in order to invalidate unread-char + (set-port-input-size! p 0)] + [clear-output-port (p) + (set-port-output-index! p 0)] + [close-port (p) + (with-interrupts-disabled + (flush-output-port p) + (set-port-output-size! p 0) + (set-port-input-size! p 0) + (mark-port-closed! p))] + [file-position (p . pos) + (if (null? pos) + (most-negative-fixnum) + (assertion-violationf 'transcript-port "cannot reposition"))] + [flush-output-port (p) + (with-interrupts-disabled + (let ([b (port-output-buffer p)] + [i (port-output-index p)]) + (unless (fx= i 0) + (block-write op b i) + (block-write tp b i) + (set-port-output-index! p 0) + (set-port-bol! p + (char=? (string-ref b (fx- i 1)) #\newline)))) + (flush-output-port op) + (flush-output-port tp))] + [peek-char (p) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (if (fx< i s) + (string-ref b i) + (begin + (flush-output-port p) + (let ([s (block-read ip b)]) + (if (eof-object? s) + s + (begin + (block-write tp b s) + (set-port-input-size! p s) + (string-ref b 0))))))))] + [port-name (p) "transcript"] + [constituent-ports (p) (values ip op tp)] + [read-char (p) + (with-interrupts-disabled + (let ([c (peek-char p)]) + (unless (eof-object? c) + (set-port-input-index! p + (fx+ (port-input-index p) 1))) + c))] + [unread-char (c p) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (when (fx= i 0) + (assertion-violationf 'unread-char + "tried to unread too far on ~s" + p)) + (set-port-input-index! p (fx- i 1)) + ; following could be skipped; it's supposed + ; to be the same character anyway + (string-set! b (fx- i 1) c)))] + [write-char (c p) + (with-interrupts-disabled + (let ([b (port-output-buffer p)] + [i (port-output-index p)] + [s (port-output-size p)]) + (string-set! b i c) + ; could check here to be sure that we really + ; need to flush; we may end up here even if + ; the buffer isn't full + (block-write op b (fx+ i 1)) + (block-write tp b (fx+ i 1)) + (set-port-output-index! p 0) + (set-port-bol! p (char=? c #\newline))))] + [block-write (p str cnt) + (with-interrupts-disabled + ; flush buffered data + (let ([b (port-output-buffer p)] + [i (port-output-index p)]) + (unless (fx= i 0) + (block-write op b i) + (block-write tp b i) + (set-port-output-index! p 0) + (set-port-bol! p (char=? (string-ref b (fx- i 1)) #\newline)))) + ; write new data + (unless (fx= cnt 0) + (block-write op str cnt) + (block-write tp str cnt) + (set-port-bol! p + (char=? (string-ref str (fx- cnt 1)) #\newline))))] + [else (assertion-violationf 'transcript-port + "operation ~s not handled" + msg)])) + (let ([ib (make-string 1024)] [ob (make-string 1024)]) + (let ([p (make-input/output-port handler ib ob)]) + (set-port-input-size! p 0) + (set-port-output-size! p (fx- (string-length ob) 1)) + p)))) +\endschemedisplay + +\noindent +The chosen length of both the input and output ports is the same; this +is not necessary. +They could have different lengths, or one could be buffered locally and +the other not buffered locally. +Local buffering could be disabled effectively by providing zero-length +buffers. + +After we create the port, the input size is set to zero since there +is not yet any data to be read. +The port output size is set to one less than the length of the buffer. +This is done so that \scheme{write-char} always has one character position +left over into which to write its character argument. +Although this is not necessary, it does simplify the code somewhat +while allowing the buffer to be flushed as soon as the last character +is available. + +Block reads and writes are performed on the constituent ports for +efficiency and (in the case of writes) to ensure that the operations +are performed immediately. + +The call to \scheme{flush-output-port} in the handling of \scheme{read-char} insures +that all output written to \scheme{op} appears before input is read from +\scheme{ip}. +Since \scheme{block-read} is typically used to support higher-level operations +that are performing their own buffering, or for direct input and output +in support of I/O-intensive applications, the flush call has been +omitted from that part of the handler. + +Critical sections are used whenever the handler manipulates one of the +buffers, to protect against untimely interrupts that could lead to +reentry into the handler. +The critical sections are unnecessary if no such reentry is possible, +i.e., if only one ``thread'' of the computation can have access to the +port. + +\parheader{Process ports} +\index{process ports}\index{sockets}The final example +demonstrates how to incorporate the socket interface +defined in Section~\ref{SECTFOREIGNSOCKETS} into a generic port that +allows transparent communication with subprocesses via normal Scheme +input/output operations. + +A process port is created with \scheme{open-process}, which accepts a +shell command as a string. +\scheme{open-process} sets up a socket, forks a child process, sets up +two-way communication via the socket, and invokes the command in a +subprocess. + +The sample session below demonstrates the use of \scheme{open-process}, +running and communicating with another Scheme process started with the +``\scheme{-q}'' switch to suppress the greeting and prompts. + +\schemedisplay +> (define p (open-process "exec scheme -q")) +> (define s (make-string 1000 #\nul)) +> (pretty-print '(+ 3 4) p) +> (read p) +7 +> (pretty-print '(define (f x) (if (= x 0) 1 (* x (f (- x 1))))) p) +> (pretty-print '(f 10) p) +> (read p) +3628800 +> (pretty-print '(exit) p) +> (read p) +#!eof +> (close-port p) +\endschemedisplay + +\noindent +Since process ports, like transcript ports, are two-way, the implementation +is somewhat similar. +The main difference is that a transcript port reads from and writes to its +subordinate ports, whereas a process port reads from and writes to a socket. +When a process port is opened, the socket is created and subprocess +invoked, and when the port is closed, the socket is closed and the +subprocess is terminated. + +\schemedisplay +(define open-process + (lambda (command) + (define handler + (lambda (pid socket) + (define (flush-output who p) + (let ([i (port-output-index p)]) + (when (fx> i 0) + (check who (c-write socket (port-output-buffer p) i)) + (set-port-output-index! p 0)))) + (lambda (msg . args) + (record-case (cons msg args) + [block-read (p str cnt) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (if (< i s) + (let ([cnt (fxmin cnt (fx- s i))]) + (do ([i i (fx+ i 1)] + [j 0 (fx+ j 1)]) + ((fx= j cnt) + (set-port-input-index! p i) + cnt) + (string-set! str j (string-ref b i)))) + (begin + (flush-output 'block-read p) + (let ([n (check 'block-read + (c-read socket str cnt))]) + (if (fx= n 0) + #!eof + n))))))] + [char-ready? (p) + (or (< (port-input-index p) (port-input-size p)) + (bytes-ready? socket))] + [clear-input-port (p) + ; set size to zero rather than index to size + ; in order to invalidate unread-char + (set-port-input-size! p 0)] + [clear-output-port (p) (set-port-output-index! p 0)] + [close-port (p) + (with-interrupts-disabled + (flush-output 'close-port p) + (set-port-output-size! p 0) + (set-port-input-size! p 0) + (mark-port-closed! p) + (terminate-process pid))] + [file-length (p) 0] + [file-position (p . pos) + (if (null? pos) + (most-negative-fixnum) + (assertion-violationf 'process-port "cannot reposition"))] + [flush-output-port (p) + (with-interrupts-disabled + (flush-output 'flush-output-port p))] + [peek-char (p) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (if (fx< i s) + (string-ref b i) + (begin + (flush-output 'peek-char p) + (let ([s (check 'peek-char + (c-read socket b (string-length b)))]) + (if (fx= s 0) + #!eof + (begin (set-port-input-size! p s) + (string-ref b 0))))))))] + [port-name (p) "process"] + [read-char (p) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (if (fx< i s) + (begin + (set-port-input-index! p (fx+ i 1)) + (string-ref b i)) + (begin + (flush-output 'peek-char p) + (let ([s (check 'read-char + (c-read socket b (string-length b)))]) + (if (fx= s 0) + #!eof + (begin (set-port-input-size! p s) + (set-port-input-index! p 1) + (string-ref b 0))))))))] + [unread-char (c p) + (with-interrupts-disabled + (let ([b (port-input-buffer p)] + [i (port-input-index p)] + [s (port-input-size p)]) + (when (fx= i 0) + (assertion-violationf 'unread-char + "tried to unread too far on ~s" + p)) + (set-port-input-index! p (fx- i 1)) + ; following could be skipped; supposed to be + ; same character + (string-set! b (fx- i 1) c)))] + [write-char (c p) + (with-interrupts-disabled + (let ([b (port-output-buffer p)] + [i (port-output-index p)] + [s (port-output-size p)]) + (string-set! b i c) + (check 'write-char (c-write socket b (fx+ i 1))) + (set-port-output-index! p 0)))] + [block-write (p str cnt) + (with-interrupts-disabled + ; flush buffered data + (flush-output 'block-write p) + ; write new data + (check 'block-write (c-write socket str cnt)))] + [else + (assertion-violationf 'process-port + "operation ~s not handled" + msg)])))) + (let* ([server-socket-name (tmpnam 0)] + [server-socket (setup-server-socket server-socket-name)]) + (dofork + (lambda () ; child + (check 'close (close server-socket)) + (let ([sock (setup-client-socket server-socket-name)]) + (dodup 0 sock) + (dodup 1 sock)) + (check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" command)) + (assertion-violationf 'open-process "subprocess exec failed")) + (lambda (pid) ; parent + (let ([sock (accept-socket server-socket)]) + (check 'close (close server-socket)) + (let ([ib (make-string 1024)] [ob (make-string 1024)]) + (let ([p (make-input/output-port + (handler pid sock) + ib ob)]) + (set-port-input-size! p 0) + (set-port-output-size! p (fx- (string-length ob) 1)) + p)))))))) +\endschemedisplay diff --git a/csug/libraries.stex b/csug/libraries.stex new file mode 100644 index 0000000..57bb3a3 --- /dev/null +++ b/csug/libraries.stex @@ -0,0 +1,1219 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Libraries and Top-level Programs\label{CHPTLIBRARIES}} + +\index{libraries}% +\index{top-level-programs}% +The Revised$^6$ Report describes two units of portable code: +libraries and top-level programs. +A library is a named collection of bindings with a declared set of +explicitly exported bindings, a declared set of imported libraries, and a +body that initializes its bindings. +A top-level program is a stand-alone program with a declared set of +imported libraries and a body that is run when the top-level program is +run. +The bindings in a library are created and its initialization code run only +if the library is used, directly or indirectly, by a top-level program. + +\index{\scheme{import}}% +The \scheme{import} declarations appearing within libraries and top-level +programs serve two purposes: first, they cause the imported libraries to +be loaded, and second, they cause the bindings of the imported libraries +to become visible in the importing library or top-level program. +Libraries are typically stored in the file system, with one library per +file, and the library name typically identifies the file-system path to +the library, possibly relative to a default or programmer-specified set of +library locations. +The exact mechanism by which top-level programs are run and libraries are +loaded is implementation-dependent. + +This chapter describes the mechanisms by which libraries and programs are +loaded in {\ChezScheme} along with various features for controlling and +tracking this process. +It also describes the set of built-in libraries and syntactic forms for +defining new libraries and top-level programs outside of a library or +top-level program file. + +% \section{Locating Libraries\label{SECTLOCATINGLIBRARIES}} +% +% In {\ChezScheme}, a library to be loaded implicitly by \scheme{import} +% must reside in a file whose name reflects the name of the library. +% For example, if the library's name is \scheme{(tools sorting)}, the +% base name of the file must be \scheme{sorting} with a valid extension, and +% the file must be in a directory named \scheme{tools} which itself resides +% in one of the directories searched by \scheme{import}. +% The set of directories searched by \scheme{import} is determined by +% the +% \index{\scheme{library-directories}}\scheme{library-directories} +% parameter, and the set of +% extensions is determined by the +% \index{\scheme{library-extensions}}\scheme{library-extensions} +% parameter. +% So, if \scheme{(library-directories)} contains the pathnames +% \scheme{"/usr/lib/scheme/libraries"} and \scheme{"."}, and +% \scheme{(library-extensions)} contains the extensions \scheme{.ss} +% and \scheme{.sls}, the path of the \scheme{(tools sorting)} +% library must be one of the following. +% +% \schemedisplay +% /usr/lib/scheme/libraries/tools/sorting.ss +% /usr/lib/scheme/libraries/tools/sorting.sls +% ./tools/sorting.ss +% ./tools/sorting.sls +% \endschemedisplay +% +% A file containing a library or set of libraries can be explicitly loaded +% via \scheme{load}, in which case the file may have any name and may reside +% anywhere in the file system. +% +% \index{\scheme{compile-library}}% +% \index{\scheme{compile-imported-libraries}}% +% A file containing a library may be compiled with \scheme{compile-file} +% or \scheme{compile-library}. +% The only difference between the two is that the latter treats the source +% file as if it were prefixed by an implicit \scheme{#!r6rs}. +% Any libraries upon which the library depends must be compiled first. +% This can be done manually or by setting the parameter +% \scheme{compile-imported-libraries} to \scheme{#t} before compiling +% the importing library. +% If one of the libraries imported by the library is subsequently +% recompiled (say because it was modified), the importing library must also +% be recompiled. + + +\section{Built-in Libraries\label{SECTBUILTINLIBRARIES}} + +In addition to the RNRS libraries mandated by the Revised$^6$ Report: + +\schemedisplay + (rnrs base (6)) + (rnrs arithmetic bitwise (6)) + (rnrs arithmetic fixnums (6)) + (rnrs arithmetic flonums (6)) + (rnrs bytevectors (6)) + (rnrs conditions (6)) + (rnrs control (6)) + (rnrs enums (6)) + (rnrs eval (6)) + (rnrs exceptions (6)) + (rnrs files (6)) + (rnrs hashtables (6)) + (rnrs io ports (6)) + (rnrs io simple (6)) + (rnrs lists (6)) + (rnrs mutable-pairs (6)) + (rnrs mutable-strings (6)) + (rnrs programs (6)) + (rnrs r5rs (6)) + (rnrs records procedural (6)) + (rnrs records syntactic (6)) + (rnrs records inspection (6)) + (rnrs sorting (6)) + (rnrs syntax-case (6)) + (rnrs unicode (6)) +\endschemedisplay + +\index{\scheme{(chezscheme)} library}% +\index{\scheme{(chezscheme csv7)} library}% +\index{\scheme{(scheme)} library}% +\index{\scheme{(scheme csv7)} library}% +{\ChezScheme} also provides two additional libraries: \scheme{(chezscheme)} +and \scheme{(chezscheme csv7)}. +The former can also be referenced as \scheme{(scheme)} and the latter can +also be referenced as \scheme{(scheme csv7)}. + +The \scheme{(chezscheme)} library exports bindings for every identifier whose +binding is described in this document, including those for keywords like +\scheme{lambda}, auxiliary keywords like \scheme{else}, module names +like \scheme{scheme}, and procedure names like \scheme{cons}. +In most cases where an identifier exported from the +\scheme{(chezscheme)} library corresponds to an identifier exported from +one of the RNRS libraries, the bindings are identical. +In some cases, however, the \scheme{(chezscheme)} bindings extend the +\scheme{rnrs} bindings in some way. +For example, the \scheme{(chezscheme)} \scheme{syntax-rules} form allows +its clauses to have fenders (Section~\ref{SECTSYNTAXRULES}), while the +\scheme{(rnrs)} \scheme{syntax-rules} form does not. +Similarly, the \scheme{(chezscheme)} \scheme{current-input-port} procedure +accepts an optional \var{port} argument that, when specified, sets the +current input port to \var{port} (Section~\ref{SECTIOINPUT}), while the +\scheme{(rnrs)} \scheme{current-input-port} procedure does not. +When the \scheme{(chezscheme)} library extends an RNRS binding in some +way, the \scheme{(chezscheme)} library also exports the RNRS version, +with the name prefixed by \scheme{r6rs:}, e.g., \scheme{r6rs:syntax-rules} +or \scheme{r6rs:current-input-port}. + +The \scheme{(chezscheme csv7)} Version~7 backward compatibility library +contains bindings for a set of syntactic forms and procedures whose syntax +or semantics directly conflicts with the RNRS bindings for the same +identifiers. +The following identifiers are exported from \scheme{(chezscheme csv7)}. + +\schemedisplay +record-field-accessible? +record-field-accessor +record-field-mutable? +record-field-mutator +record-type-descriptor +record-type-field-decls +record-type-field-names +record-type-name +record-type-symbol +\endschemedisplay + +The bindings of this library should be used only for old code; new +code should use the RNRS variants. +Each of these is also available in the \scheme{(chezscheme)} library with +the prefix \scheme{csv7:}, e.g., \scheme{csv7:record-type-name}. + +The interaction environment in which code outside of a library or +RNRS top-level program is scoped contains all of the bindings of the +\scheme{(chezscheme)} library, as described in +Section~\ref{SECTUSEINTERACTIONENVIRONMENT}. + + +\section{Running Top-level Programs\label{SECTRUNNINGTOPLEVELPROGRAMS}} + +\index{\scheme{scheme-script}}% +\index{\scheme{--program} command-line option}% +\index{\scheme{load-program}}% +A top-level program must reside in its own file, which may have any +name and may reside anywhere in the file system. +A top-level program residing in a file is run by one of three mechanisms: +the \scheme{scheme-script} command, the \scheme{--program} command-line +argument, or the \scheme{load-program} procedure. + +The \scheme{scheme-script} command is used as follows: + +\schemedisplay +scheme-script \var{program-filename} \var{arg} \dots +\endschemedisplay + +It may also be run implicitly on Unix-based systems by placing the line + +\schemedisplay +#! /usr/bin/env scheme-script +\endschemedisplay + +at the front of the file containing the top-level program, making the +top-level program file executable, and executing the file. +This line may be replaced with + +\schemedisplay +#! /usr/bin/scheme-script +\endschemedisplay + +with \scheme{/usr/bin} replaced by the absolute path to the directory +containing \scheme{scheme-script} if it is not in \scheme{/usr/bin}. +The first form is recommended in the nonnormative appendices to the +Revised$^6$ Report~\cite{r6rsapps}, and works wherever +\scheme{scheme-script} appears in the path. + +The \scheme{--program} command is used similarly with the \scheme{scheme} +or \scheme{petite} executables, either by running: + +\schemedisplay +scheme --program \var{program-filename} \var{arg} \dots +petite --program \var{program-filename} \var{arg} \dots +\endschemedisplay + +or by including + +\schemedisplay +#! /usr/bin/scheme --script +\endschemedisplay + +or + +\schemedisplay +#! /usr/bin/petite --script +\endschemedisplay + +at the front of the top-level program file, making the file executable, +and executing the file. +Again, \scheme{/usr/bin} should be replaced with the absolute path to +the actual directory in which \scheme{scheme} and/or \scheme{petite} +resides, if not \scheme{/usr/bin}. + +The \scheme{load-program} procedure, described in +Section~\ref{SECTMISCCOMPILEEVAL}, is used like \scheme{load}: + +\schemedisplay +(load-program \var{string}) +\endschemedisplay + +where \var{string} names the file in which the top-level program resides. + +Regardless of the mechanism used, if the opening line is in one of the +forms described above, or more generally, consists of +\scheme{#!} followed by a space or a forward slash, the opening line +is not considered part of the program and is ignored once the Scheme +system starts up and begins to run the program. +Thus, the line may be present even in a file loaded by \scheme{load-program}. +In fact, \scheme{load-program} is ultimately used by the other two +mechanisms described above, via the value of the \scheme{scheme-program} +parameter described in Section~\ref{SECTMISCWAITERS}, and it is +\scheme{load-program} that scans past the \scheme{#!} line, if present, +before evaluating the program. + +A top-level program may be compiled with the +\index{\scheme{compile-program}}\scheme{compile-program} +procedure described in Section~\ref{SECTMISCCOMPILEEVAL}. +\scheme{compile-program} copies the \scheme{#!} line from the source +file to the object file, followed by a compiled version of the source +code. +Any libraries upon which the top-level program depends, other than +built-in libraries, must be compiled first via \scheme{compile-file} +or \scheme{compile-library}. +This can be done manually or by setting the parameter +\scheme{compile-imported-libraries} to \scheme{#t} before compiling +the program. +The program must be recompiled if any of the libraries upon which +it depends are recompiled. +A compiled top-level program can be run just like a source top-level +program via each of the mechanisms described above. + +\index{\scheme{load-library}}% +In {\ChezScheme}, a library may also be defined in the REPL or placed in a +file to be loaded via \scheme{load} or \scheme{load-library}. +The syntax for a library is the same whether the library is placed in +its own file and implicitly loaded via \scheme{import}, entered into +the REPL, or placed in a file along with other top-level expressions to +be evaluated by \scheme{load}. +A top-level program may also be defined in the REPL or placed in a file +to be loaded via \scheme{load}, but in this case, the syntax is slightly +different. +In the language of the Revised$^6$ Report, a top-level program is merely +an unwrapped sequence of subforms consisting of an \scheme{import} form +and a body, delimited only by the boundaries of the file in which it +resides. +In order for a top-level program to be entered in the REPL or placed in +a file to be evaluated by \scheme{load}, {\ChezScheme} allows top-level +programs to be enclosed in a +\index{\scheme{top-level-program}}\scheme{top-level-program} form. + +\section{Library and Top-level Program Forms\label{SECTLIBRARYFORMS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{library}{\categorysyntax}{(library \var{name} \var{exports} \var{imports} \var{library-body})} +\returns unspecified +\listlibraries +\endnoskipentryheader + +The \scheme{library} form defines a new library with the specified +name, exports, imports, and body. +Details on the syntax and semantics of the library form are given in +Section~\ref{TSPL:SECTLIBPROGRAMS} of {\TSPLFOUR} and in the Revised$^6$ +Report. + +Only one version of a library can be loaded at any given time, and an +exception is raised if a library is implicitly loaded via \scheme{import} +when another version of the library has already been loaded. +{\ChezScheme} permits a different version of the library, or a new +instance of the same version, to be entered explicitly into the REPL +or loaded explicitly from a file, to facilitate interactive testing +and debugging. +The programmer should take care to make sure that any code that uses +the library is also reentered or reloaded, to make sure that code +accesses the bindings of the new instance of the library. + +\schemedisplay +(library (test (1)) (export x) (import (rnrs)) (define x 3)) +(import (test)) +(define f (lambda () x)) +(f) ;=> 3 + +(library (test (1)) (export x) (import (rnrs)) (define x 4)) +(import (test)) +(f) ;=> 3 ; oops---forgot to redefine f +(define f (lambda () x)) +(f) ;=> 4 + +(library (test (2)) (export x) (import (rnrs)) (define x 5)) +(import (test)) +(define f (lambda () x)) +(f) ;=> 5 +\endschemedisplay + +As with module imports (Section~\ref{SECTSYNTAXMODULES}), a library +\scheme{import} may appear anywhere a definition may appear, including at +top level in the REPL, in a file to be loaded by \scheme{load}, or within +a \scheme{lambda}, \scheme{let}, \scheme{letrec}, \scheme{letrec*}, +etc., body. +The same \scheme{import} form may be used to import from both libraries +and modules. + +\schemedisplay +(library (foo) (export a) (import (rnrs)) (define a 'a-from-foo)) +(module bar (b) (define b 'b-from-bar)) +(let () (import (foo) bar) (list a b)) ;=> (a-from-foo b-from-bar) +\endschemedisplay + +The \scheme{import} keyword is not visible within a library body +unless the library imports it from the \scheme{(chezscheme)} library. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{top-level-program}{\categorysyntax}{(top-level-program \var{imports} \var{body})} +\returns unspecified +\listlibraries +\endentryheader + +\index{top-level-programs}% +A \scheme{top-level-program} form may be entered into the REPL or placed +in a file to be loaded via \scheme{load}, where it behaves as if its +subforms were placed in a file and loaded via \scheme{load-program}. +Details on the syntax and semantics of a top-level program are given in +Section~\ref{TSPL:SECTLIBPROGRAMS} of {\TSPLFOUR} and in the Revised$^6$ +Report. + +The following transcript illustrates a \scheme{top-level-program} being +tested in the REPL. + +\schemedisplay +> (top-level-program (import (rnrs)) + (display "hello!\n")) +hello! +\endschemedisplay + +\section{Standalone import and export forms\label{SECTLIBRARYIMPORTEXPORTFORMS}} + +Although not required by the Revised$^6$ Report, +{\ChezScheme} supports the use of standalone import and +export forms. +The import forms can appear anywhere other definitions +can appear, including within a \scheme{library} body, +\scheme{module} (Section~\ref{SECTSYNTAXMODULES}) body, +\scheme{lambda} or other local body, and at top level. +The export forms can appear within the definitions of a +\scheme{library} or \scheme{module} body to specify additional +exports for the library or module. + +Within a library or top-level program, the keywords for +these forms must be imported from the \scheme{(chezscheme)} +library to be available for use, since they are not +defined in any of the Revised$^6$ Report libraries. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{import}{\categorysyntax}{(import \var{import-spec} \dots)} +\formdef{import-only}{\categorysyntax}{(import-only \var{import-spec} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +An \scheme{import} or \scheme{import-only} form is a definition and can +appear anywhere other definitions can appear, including +at the top level of a program, nested within the bodies of +\scheme{lambda} expressions, and nested within modules +and libraries. + +Each \var{import-spec} must take one of the following forms. + +\schemedisplay +\var{import-set} +(for \var{import-set} \var{import-level} \dots) +\endschemedisplay + +\noindent +The \scheme{for} wrapper and \var{import-level} are described in +Chapter~\ref{TSPL:CHPTLIBRARIES} of {\TSPLFOUR}. +They are ignored by {\ChezScheme}, which determines +automatically the levels at which identifiers must +be imported, as permitted by the Revised$^6$ Report. +This frees the programmer from the obligation +to do so and results in more generality as well as more +precision in the set of libraries actually imported +at compile and run time~\cite{Ghuloum:libraries,Ghuloum:phd}. + +An \var{import-set} must take one of the following forms: + +\schemedisplay +\var{library-spec} +\var{module-name} +(only \var{import-set} \var{identifier} \dots) +(except \var{import-set} \var{identifier} \dots) +(prefix \var{import-set} \var{prefix}) +(add-prefix \var{import-set} \var{prefix}) +(drop-prefix \var{import-set} \var{prefix}) +(rename \var{import-set} (\var{import-name} \var{internal-name}) \dots) +(alias \var{import-set} (\var{import-name} \var{internal-name}) \dots) +\endschemedisplay + +Several of these are specified by the Revised$^6$ Report; the remainder +are {\ChezScheme} extensions, including \var{module-name} and the +\scheme{add-prefix}, \scheme{drop-prefix}, and \scheme{alias} forms. + +An \scheme{import} or \scheme{import-only} form makes the specified bindings +visible in the scope in which they appear. +Except at top level, they differ in that \scheme{import} leaves all bindings +except for those shadowed by the imported names visible, whereas \scheme{import-only} +hides all existing bindings, i.e., makes only the imported names visible. +At top level, \scheme{import-only} behaves like \scheme{import}. + +Each \var{import-set} identifies a set of names to make visible +as follows. + +\begin{description} +\item[\scheme{\var{library-spec}}:] +all exports of the library identified by the Revised$^6$ Report \var{library-spec} +(Chapter~\ref{TSPL:CHPTLIBRARIES}). + +\item[\scheme{\var{module-name}}:] +all exports of module named by the identifier \var{module-name} + +\item[\scheme{(only \var{import-set} \var{identifier} \dots)}:] +of those specified by \var{import-set}, just \scheme{\var{identifier} \dots} + +\item[\scheme{(except \var{import-set} \var{identifier} \dots)}:] +all specified by \var{import-set} except \scheme{\var{identifier} \dots} + +\item[\scheme{(prefix \var{import-set} \var{prefix})}:] +all specified by \var{import-set}, each prefixed by \var{prefix} + +\item[\scheme{(add-prefix \var{import-set} \var{prefix})}:] +all specified by \var{import-set}, each prefixed by \var{prefix} +(just like \scheme{prefix}) + +\item[\scheme{(drop-prefix \var{import-set} \var{prefix})}:] +all specified by \var{import-set}, with prefix \var{prefix} removed + +\item[\scheme{(rename \var{import-set} (\var{import-name} \var{internal-name}) \dots)}:] +all specified by \var{import-set}, with each identifier \var{import-name} +renamed to the corresponding identifier \var{internal-name} + +\item[\scheme{(alias \var{import-set} (\var{import-name} \var{internal-name}) \dots)}:] +all specified by \var{import-set}, with each \var{internal-name} as an alias +for \var{import-name} +\end{description} + +The \scheme{alias} form differs from the \scheme{rename} form in that both +\var{import-name} and \var{internal-name} are in the resulting set, +rather than just \var{internal-name}. + +It is a syntax violation if the +given selection or transformation cannot be made because of a missing +export or prefix. + +An identifier made visible via an import of a module or library is scoped as if its +definition appears where the import occurs. +The following example illustrates these scoping rules, using a local +module \scheme{m}. + +\schemedisplay +(library (A) (export x) (import (rnrs)) (define x 0)) +(let ([x 1]) + (module m (x setter) + (define-syntax x (identifier-syntax z)) + (define setter (lambda (x) (set! z x))) + (define z 2)) + (let ([y x] [z 3]) + (import m (prefix (A) a:)) + (setter 4) + (list x a:x y z))) ;=> (4 0 1 3) +\endschemedisplay + +\noindent +The inner \scheme{let} expression binds \scheme{y} to the value of +the \scheme{x} bound by the outer \scheme{let}. +The import of \scheme{m} makes the definitions of \scheme{x} +and \scheme{setter} visible within the inner \scheme{let}. +The import of \scheme{(A)} makes the variable \scheme{x} exported +from \scheme{(A)} visible as \scheme{a:x} within the body of the +inner \scheme{let}. +Thus, in the expression \scheme{(list x a:x y z)}, \scheme{x} refers to the +identifier macro exported from \scheme{m} while \scheme{a:x} refers to the +variable \scheme{x} exported from \scheme{(A)} and \scheme{y} and \scheme{z} +refer to the bindings established by the inner \scheme{let}. +The identifier macro \scheme{x} expands into a reference to +the variable \scheme{z} defined within the module. + +With local import forms, it is rarely necessary to use the extended +import specifiers. +For example, an abstraction that encapsulates the import and reference +can easily be defined and used as follows. + +\schemedisplay +(define-syntax from + (syntax-rules () + [(_ m id) (let () (import-only m) id)])) + +(library (A) (export x) (import (rnrs)) (define x 1)) +(let ([x 10]) + (module M (x) (define x 2)) + (cons (from (A) x) (from M x))) ;=> (1 . 2) +\endschemedisplay + +\noindent +The definition of \scheme{from} could use \scheme{import} rather than +\scheme{import-only}, but by using \scheme{import-only} we get feedback +if an attempt is made to import an identifier from a library or +module that does not export the identifier. +With \scheme{import} instead of \scheme{import-only}, the current binding, +if any, would be visible if the library or module does not export the +specified name. + +\schemedisplay +(define-syntax lax-from + (syntax-rules () + [(_ m id) (let () (import m) id)])) + +(library (A) (export x) (import (rnrs)) (define x 1)) + +(let ([x 10]) + (module M (x) (define x 2)) + (+ (from (A) x) (from M y))) ;=> \var{exception: unbound identifier y} + +(let ([x 10] [y 20]) + (module M (x) (define x 2)) + (+ (lax-from (A) x) (lax-from M y))) ;=> 21 +\endschemedisplay + +Import visibility interacts with hygienic macro expansion in such a +way that, as one might expect, +an identifier \var{x} imported from a module \var{M} is treated in +the importing context as if the corresponding export identifier had +been present in the import form along with \var{M}. + +The \scheme{from} abstraction above works because both \var{M} and \var{id} +appear in the input to the abstraction, so the imported \var{id} captures +the reference to \var{id}. + +The following variant of \var{from} also works, because both names are +introduced into the output by the transformer. + +\schemedisplay +(module M (x) (define x 'x-of-M)) +(define-syntax x-from-M + (syntax-rules () + [(_) (let () (import M) x)])) + +(let ([x 'local-x]) (x-from-M)) ;=> x-of-M +\endschemedisplay + +On the other hand, imports of introduced module names do not capture +free references. + +\schemedisplay +(let ([x 'local-x]) + (define-syntax alpha + (syntax-rules () + [(_ var) (let () (import M) (list x var))])) + + (alpha x)) ;=> (x-of-M local-x) +\endschemedisplay + +Similarly, imports from free module names do not capture references +to introduced variables. + +\schemedisplay +(let ([x 'local-x]) + (define-syntax beta + (syntax-rules () + [(_ m var) (let () (import m) (list x var))])) + + (beta M x)) ;=> (local-x x-of-M) +\endschemedisplay + +This semantics extends to prefixed, renamed, and aliased bindings +created by the extended \scheme{import} specifiers \scheme{prefix}, +\scheme{rename}, and \scheme{alias}. + +The \scheme{from} abstraction +works for variables but not for exported keywords, record names, +or module names, since the output is an expression and may thus appear only where +expressions may appear. +A generalization of this technique is used in the following definition +of \scheme{import*}, which supports renaming of imported bindings and +selective import of specific bindings---without the use of the built-in +\scheme{import} subforms for selecting and renaming identifiers + +\schemedisplay +(define-syntax import* + (syntax-rules () + [(_ m) (begin)] + [(_ m (new old)) + (module (new) + (module (tmp) + (import m) + (alias tmp old)) + (alias new tmp))] + [(_ m id) (module (id) (import m))] + [(_ m spec0 spec1 ...) + (begin (import* m spec0) (import* m spec1 ...))])) +\endschemedisplay + +\noindent +To selectively import an identifier from module or library \scheme{m}, the +\scheme{import*} form expands into an anonymous module that first +imports all exports of \scheme{m} then re-exports only the selected +identifier. +To rename on import the macro expands into an anonymous module that +instead exports an alias (Section~\ref{SECTSYNTAXALIAS}) bound to the new name. + +If the output placed the definition of \scheme{new} in the same +scope as the import of \scheme{m}, a naming conflict would arise +whenever \scheme{new} is also present in the interface +of \scheme{m}. +To prevent this, the output instead places the import within a nested +anonymous module and links \scheme{old} and \scheme{new} +by means of an alias for the introduced identifier \scheme{tmp}. + +The macro expands recursively to handle multiple import specifications. +Each of the following examples imports \scheme{cons} as \scheme{+} and \scheme{+} as +\scheme{cons}, which is probably not a very good idea. + +\schemedisplay +(let () + (import* scheme (+ cons) (cons +)) + (+ (cons 1 2) (cons 3 4))) ;=> (3 . 7) + +(let () + (import* (rnrs) (+ cons) (cons +)) + (+ (cons 1 2) (cons 3 4))) ;=> (3 . 7) +\endschemedisplay + +% for testing +% (module m (x y z) +% (define x 'x) +% (define y 'y) +% (define z 'z)) + +%---------------------------------------------------------------------------- +\entryheader +\formdef{export}{\categorysyntax}{(export \var{export-spec} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +An \scheme{export} form is a definition and can appear with other +definitions at the front of a \scheme{library} or \scheme{module}. +It is a syntax error for an \scheme{export} form to appear in other +contexts, including at top level or among the definitions of a +top-level program or \scheme{lambda} body. + +Each \var{export-spec} must take one of the following forms. + +\schemedisplay +\var{identifier} +(rename (\var{internal-name} \var{export-name}) \dots) +(import \var{import-spec} \dots) +\endschemedisplay + +\noindent +where each \var{internal-name} and \var{export-name} is an identifier. +The first two are syntactically identical to \scheme{library} +\var{export-spec}s, while the third is syntactically +identical to a {\ChezScheme} \scheme{import} form, which is an extension of the +R6RS library \scheme{import} subform. +The first form names a single export, \var{identifier}, whose export +name is the same as its internal name. +The second names a set of exports, each of whose export name is +given explicitly and may differ from its internal name. + +For the third, the identifiers identified by the \scheme{import} form +become exports, with aliasing, renaming, prefixing, etc., as specified by the +\var{import-spec}s. +The module or library whose bindings are exported by an \scheme{import} +form appearing within an \scheme{export} form can +be defined within or outside the exporting module or library and need +not be imported elsewhere within the exporting module or library. + +The following library exports a two-armed-only variant of \scheme{if} +along with all remaining bindings of the \scheme{(rnrs)} library. + +\schemedisplay +(library (rnrs-no-one-armed-if) (export) (import (except (chezscheme) if)) + (export if (import (except (rnrs) if))) + (define-syntax if + (let () + (import (only (rnrs) if)) + (syntax-rules () + [(_ tst thn els) (if tst thn els)])))) + +(import (rnrs-no-one-armed-if)) +(if #t 3 4) ;=> 3 +(if #t 3) ;=> \var{exception: invalid syntax} +\endschemedisplay + +Another way to define the same library would be to define the +two-armed-only \scheme{if} with a different internal name and use +\scheme{rename} to export it under the name \scheme{if}: + +\schemedisplay +(library (rnrs-no-one-armed-if) (export) (import (chezscheme)) + (export (rename (two-armed-if if)) (import (except (rnrs) if))) + (define-syntax two-armed-if + (syntax-rules () + [(_ tst thn els) (if tst thn els)]))) + +(import (rnrs-no-one-armed-if)) +(if #t 3 4) ;=> 3 +(if #t 3) ;=> \var{exception: invalid syntax} +\endschemedisplay + +The placement of the \scheme{export} form in the library body is +irrelevant, e.g., the \scheme{export} form can appear after the +definition in the examples above. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{indirect-export}{\categorysyntax}{(indirect-export \var{id} \var{indirect-id} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +This form is a definition and can appear wherever any other definition +can appear. + +An \scheme{indirect-export} form declares that the named +\var{indirect-id}s are indirectly exported to top level if \var{id} +is exported to top level. + +In general, if an identifier is not directly exported by a library or +module, it can be referenced outside of the library or module only in +the expansion of a macro defined within and exported from the library +or module. +Even this cannot occur for libraries or modules defined at top level +(or nested within other libraries or modules), unless either (1) +the library or module has been set up to implicitly export all +identifiers as indirect exports, or (2) each indirectly exported +identifier is explicitly declared as an indirect export of some +other identifier that is exported, either directly or indirectly, from +the library or module, via an \scheme{indirect-export} or the built-in +indirect export feature of a \scheme{module} export subform. +By default, (1) is true for a library and false for a module, but the +default can be overridden via the \scheme{implicit-exports} +form, which is described below. + +This form is meaningful only within a top-level library, top-level module, +or module enclosed within a library or top-level module, although it +has no effect if the library or module already implicitly exports all +bindings. +It is allowed anywhere else definitions can appear, however, so macros +that expand into indirect export forms can be used in any definition +context. + +Indirect exports are listed so the compiler can determine the +exact set of bindings (direct and indirect) that must be inserted +into the top-level environment, and conversely, the set of bindings +that may be treated more efficiently as local bindings (and +perhaps discarded, if they are not used). + +In the example below, \scheme{indirect-export} is used to indirectly +export \scheme{count} to top level when \scheme{current-count} is +exported to top level. + +\schemedisplay +(module M (bump-count current-count) + (define-syntax current-count (identifier-syntax count)) + (indirect-export current-count count) + (define count 0) + (define bump-count + (lambda () + (set! count (+ count 1))))) + +(import M) +(bump-count) +current-count ;=> 1 +count ;=> \var{exception: unbound identifier count} +\endschemedisplay + +An \scheme{indirect-export} form is not required to make \scheme{count} +visible for \scheme{bump-count}, since it is a procedure whose code +is contained within the module rather than a macro that might expand +into a reference to \scheme{count} somewhere outside the module. + +It is often useful to use \scheme{indirect-export} in the output +of a macro that expands into another macro named \var{a} if +\var{a} expands into references to identifiers that might not +be directly exported, as illustrated by the alternative definition +of module \scheme{M} above. + +\schemedisplay +(define-syntax define-counter + (syntax-rules () + [(_ getter bumper init incr) + (begin + (define count init) + (define-syntax getter (identifier-syntax count)) + (indirect-export getter count) + (define bumper + (lambda () + (set! count (incr count)))))])) + +(module M (bump-count current-count) + (define-counter current-count bump-count 0 add1)) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{implicit-exports}{\categorysyntax}{(implicit-exports #t)} +\formdef{implicit-exports}{\categorysyntax}{(implicit-exports #f)} +\returns unspecified +\listlibraries +\endentryheader + +An \scheme{implicit-exports} form is a definition and can appear with other +definitions at the front of a \scheme{library} or \scheme{module}. +It is a syntax error for an \scheme{implicit-exports} form to appear in other +contexts, including at top level or among the definitions of a +top-level program or \scheme{lambda} body. + +The \scheme{implicit-exports} form determines whether identifiers +not directly exported from a module or library are automatically +indirectly exported to the top level if any meta-binding (keyword, meta +definition, or property definition) is directly exported to top level +from the library or module. +The default for libraries is \scheme{#t}, to match the behavior required +by the Revised$^6$ Report, while the default for modules is \scheme{#f}. +The \scheme{implicit-exports} form is meaningful only within a library, +top-level module, or module enclosed within a library or top-level module. +It is allowed in a module enclosed within a \scheme{lambda}, \scheme{let}, +or similar body, but ignored there because none of that module's bindings +can be exported to top level. + +The advantage of \scheme{(implicit-exports #t)} is that indirect exports +need not be listed explicitly, which is convenient. +A disadvantage is that it often results in more bindings than necessary +being elevated to top level where they cannot be discarded as useless +by the optimizer. +For modules, another disadvantage is such bindings +cannot be proven immutable, which inhibits important optimizations such +as procedure inlining. +This can result in significantly lower run-time performance. + +\section{Explicitly invoking libraries\label{SECTLIBRARYINVOCATION}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{invoke-library}{\categoryprocedure}{(invoke-library \var{libref})} +\returns unspecified +\listlibraries +\endnoskipentryheader + +\var{libref} must be an s-expression in the form of a library reference. +The syntax for library references is given in +Chapter~\ref{TSPL:CHPTLIBRARIES} of {\TSPLFOUR} and in the Revised$^6$ +Report. + +A library is implicitly invoked when or before some expression +outside the library (e.g., in another library or in a top-level +program) evaluates a reference to one of the library's exported +variables. +When the library is invoked, its body expressions (the right-hand-sides +of the library's variable definitions and its initialization +expressions) are evaluated. +Once invoked, the library is not invoked again within the same process, +unless it is first explicitly redefined or reloaded. + +\scheme{invoke-library} explicitly invokes the library specified +by \var{libref} if it has not already been invoked or has since +been redefined or reloaded. +If the library has not yet been loaded, \scheme{invoke-library} +first loads the library via the process described in +Section~\ref{SECTUSELIBRARIES}. + +\scheme{invoke-library} is typically only useful for libraries whose +body expressions have side effects. +It is useful to control when the side effects occur and to force +invocation of a library that has no exported variables. +Invoking a library does not force the compile-time code (macro +transformer expressions and meta definitions) to be loaded or +evaluated, nor does it cause the library's bindings to become +visible. + +It is good practice to avoid externally visible side effects in +library bodies so the library can be used equally well at compile +time and run time. +When feasible, consider moving the side effects of a library body +to an initialization routine and adding a top-level program that +imports the library and calls the initialization routine. +With this structure, calls to \scheme{invoke-library} on the +library can be replaced by calls to +\index{\scheme{load-program}}\scheme{load-program} on the +top-level program. + +\section{Library Parameters\label{SECTLIBRARYPARAMETERS}} + +\index{\scheme{import}}% +The parameters described below control where \scheme{import} looks +when attempting to load a library, whether it compiles the libraries +it loads, and whether it displays tracking messages as it performs its +search. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{library-directories}{\categorythreadparameter}{library-directories} +\formdef{library-extensions}{\categorythreadparameter}{library-extensions} +\listlibraries +\endentryheader + +The parameter \scheme{library-directories} determines where the files +containing library source and object code are located in the file system, +and the parameter \scheme{library-extensions} determines the filename +extensions for the files holding the code, as described in +section~\ref{SECTUSELIBRARIES}. +The values of both parameters are lists of pairs of strings. +The first string in each \scheme{library-directories} pair identifies a +source-file root directory, and the second identifies the corresponding +object-file root directory. +Similarly, the first string in each \scheme{library-extensions} pair +identifies a source-file extension, and the second identifies the +corresponding object-file extension. +The full path of a library source or object file consists of the source or +object root followed by the components of the library name prefixed by +slashes, with the library extension added on the end. +For example, for root \scheme{/usr/lib/scheme}, library name +\scheme{(app lib1)}, and extension \scheme{.sls}, the full path is +\scheme{/usr/lib/scheme/app/lib1.sls}. +If the library name portion forms an absolute pathname, e.g., +\scheme{~/.myappinit}, the \scheme{library-directories} parameter is +ignored and no prefix is added. + +The initial values of these parameters are shown below. + +\schemedisplay +(library-directories) ;=> (("." . ".")) + +(library-extensions) ;=> ((".chezscheme.sls" . ".chezscheme.so") + ;== (".ss" . ".so") + ;== (".sls" . ".so") + ;== (".scm" . ".so") + ;== (".sch" . ".so")) +\endschemedisplay + +As a convenience, when either of these parameters is set, any element of +the list can be specified as a single source string, in which case the +object string is determined automatically. +For \scheme{library-directories}, the object string is the same as +the source string, effectively naming the +same directory as a source- and object-code root. +For \scheme{library-extensions}, the object string is the result of +removing the last (or only) extension from the string and appending +\scheme{".so"}. +The \scheme{library-directories} and \scheme{library-extensions} +parameters also accept as input strings in the format described +in Section~\ref{SECTUSESCRIPTING} +for the +\index{\scheme{--libdirs} command-line option}\scheme{--libdirs} and +\index{\scheme{--libexts} command-line option}\scheme{--libexts} command-line +options. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-imported-libraries}{\categorythreadparameter}{compile-imported-libraries} +\listlibraries +\endentryheader + +When the value of this parameter is \scheme{#t}, \scheme{import} +automatically calls the value of the \scheme{compile-library-handler} parameter (which defaults +to a procedure that simply calls \scheme{compile-library}) on any imported library if +the object file is missing, older than the corresponding source file, +older than any source files included (via \index{\scheme{include}}\scheme{include}) when the +object file was created, or itself requires a library that has or must +be recompiled, as described in Section~\ref{SECTUSELIBRARIES}. +The default initial value of this parameter is \scheme{#f}. +It can be set to \scheme{#t} via the command-line option +\index{\scheme{--compile-imported-libraries} command-line option}\scheme{--compile-imported-libraries}. + +When \scheme{import} compiles a library via this mechanism, it does not +also load the compiled library, because this would cause portions of +library to be reevaluated. +Because of this, run-time expressions in the file outside of a +\scheme{library} form will not be evaluated. +If such expressions are present and should be evaluated, the library +should be loaded explicitly. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{import-notify}{\categorythreadparameter}{import-notify} +\listlibraries +\endentryheader + +When the new parameter \scheme{import-notify} is set to a true value, +\scheme{import} displays messages to the console-output port as it +searches for the file containing each library it needs to load. +The default value of this parameter is \scheme{#f}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{library-search-handler}{\categorythreadparameter}{library-search-handler} +\listlibraries +\endentryheader + +The value of parameter must be a procedure that follows the protocol described +below for \scheme{default-library-search-handler}, which is the default value +of this parameter. + +The value of this parameter is invoked to locate the source or object code for +a library during \scheme{import}, \scheme{compile-whole-program}, or +\scheme{compile-whole-library}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-library-search-handler}{\categoryprocedure}{(default-library-search-handler \var{who} \var{library} \var{directories} \var{extensions})} +\returns see below +\listlibraries +\endentryheader + +This procedure is the default value of the \scheme{library-search-handler}, +which is +called to locate the source or object code for a library +during \scheme{import}, +\scheme{compile-whole-program}, or \scheme{compile-whole-library}. +\var{who} is a symbol that provides context in \scheme{import-notify} messages. +\var{library} is the name of the desired library. +\var{directories} is a list of source and object directory pairs in +the form returned by \scheme{library-directories}. +\var{extensions} is a list of source and object extension pairs in the form +returned by \scheme{library-extensions}. + +This procedure searches the specified directories until it finds a library source or +object file with one of the specified extensions. +If it finds the source file first, it constructs the corresponding +object file path and checks whether the file exists. +If it finds the object file first, the procedure looks for a corresponding +source file with one of the given source extensions in a source directory paired +with that object directory. +The procedure returns three values: +the file-system path of the library source file or \scheme{#f} if not found, +the file-system path of the corresponding object file, which may be \scheme{#f}, +and a boolean that is true if the object file exists. + +\section{Library Inspection\label{SECTLIBRARYINSPECTION}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{library-list}{\categoryprocedure}{(library-list)} +\returns a list of the libraries currently defined +\listlibraries +\endnoskipentryheader + +The set of libraries initially defined includes those listed in +Section~\ref{SECTBUILTINLIBRARIES} above. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{library-version}{\categoryprocedure}{(library-version \var{libref})} +\returns the version of the specified library +\formdef{library-exports}{\categoryprocedure}{(library-exports \var{libref})} +\returns a list of the exports of the specified library +\formdef{library-requirements}{\categoryprocedure}{(library-requirements \var{libref})} +\returns a list of libraries required by the specified library +\formdef{library-requirements}{\categoryprocedure}{(library-requirements \var{libref} \var{options})} +\returns a list of libraries required by the specified library, filtered by \var{options} +\formdef{library-object-filename}{\categoryprocedure}{(library-object-filename \var{libref})} +\returns the name of the object file holding the specified library, if any +\listlibraries +\endentryheader + +Information can be obtained only for built-in libraries or libraries +previously loaded into the system. +\var{libref} must be an s-expression in the form of a library reference. +The syntax for library references is given in +Chapter~\ref{TSPL:CHPTLIBRARIES} of {\TSPLFOUR} and in the Revised$^6$ +Report. + +The \scheme{library-version} return value is a list of numbers +(possibly empty) representing the library's version. + +The list of exports returned by \scheme{library-exports} is a list of +symbols, each identifying one of the library's exports. +The order in which the elements appear is unspecified. + +When the optional \var{options} argument is supplied, it must be +an enumeration set over the symbols constituting +valid library-requirements options, as described in the +\scheme{library-requirements-options} entry below. +It defaults to a set containing all of the options. +Each element of the list of libraries returned by +\scheme{library-requirements} is an s-expression form of a library +reference. +The library reference includes the actual version of the library that is +present in the system (if nonempty), even if a version was not specified +when it was imported. +The order in which the libraries appear in the list returned by +\scheme{library-requirements} is unspecified. + +\scheme{library-object-filename} returns a string naming the object +file if the specified library was loaded from or compiled to an object +file. +Otherwise, it returns \scheme{#f}. + + +\schemedisplay +(with-output-to-file "A.ss" + (lambda () + (pretty-print + '(library (A (1 2)) (export x z) + (import (rnrs)) + (define x 'ex) + (define y 23) + (define-syntax z + (syntax-rules () + [(_ e) (+ y e)]))))) + 'replace) +(with-output-to-file "B.ss" + (lambda () + (pretty-print + '(library (B) (export x w) + (import (rnrs) (A)) + (define w (cons (z 12) x))))) + 'replace) +(compile-imported-libraries #t) +(import (B)) +(library-exports '(A)) ;=> (x z) ; or (z x) +(library-exports '(A (1 2))) ;=> (x z) ; or (z x) +(library-exports '(B)) ;=> (x w) ; or (w x) +(library-version '(A)) ;=> (1 2) +(library-version '(B)) ;=> () +(library-requirements '(A)) ;=> ((rnrs (6))) +(library-requirements '(B)) ;=> ((rnrs (6)) (A (1 2))) +(library-object-filename '(A)) ;=> "A.so" +(library-object-filename '(B)) ;=> "B.so" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{library-requirements-options}{\categorysyntax}{(library-requirements-options \var{symbol} \dots)} +\returns a library-requirements-options enumeration set +\listlibraries +\endentryheader + +\noindent +Library-requirements-options enumeration sets are passed to +\scheme{library-requirements} to determine the library requirements +to be listed. The available options are described below. + +\begin{description} +\item[\scheme{import}:] +Include the libraries that must be imported when the specified library +is imported. + +\item[\scheme{visit@visit}:] +Includes the libraries that must be visited when the specified library +is visited. + +\item[\scheme{invoke@visit}:] +Include the libraries that must be invoked when the specified library +is visited. + +\item[\scheme{invoke}:] +Includes the libraries that must be invoked when the specified library +is invoked. +\end{description} + diff --git a/csug/math/Makefile b/csug/math/Makefile new file mode 100644 index 0000000..3392ea8 --- /dev/null +++ b/csug/math/Makefile @@ -0,0 +1,25 @@ +include mathfiles + +density=-r90x90 + +.SUFFIXES: +.SUFFIXES: .tex .gif + +# translate ps file to ppm, crop to minimum background, and translate ppm +# to gif with white (background) transparent +# +.tex.gif: + echo | latex $* &&\ + dvips -f < $*.dvi |\ + gs -q -dNOPAUSE -dSAFER -sDEVICE=ppmraw -sOutputFile=-\ + ${density} - |\ + pnmcrop |\ + ppmtogif -transparent white > $*.gif + rm -f $*.dvi $*.log $*.aux + test -f $*.gif && chmod 644 $*.gif + +all: ${gifs} + +${gifs}: mathmacros + +clean: ; rm -f *.gif Make.out diff --git a/csug/math/mathmacros b/csug/math/mathmacros new file mode 100644 index 0000000..22753c4 --- /dev/null +++ b/csug/math/mathmacros @@ -0,0 +1,17 @@ +\catcode`@=11 % borrow the private macros of PLAIN (with care) +\def\W#1{W_{\!\!#1}} +\def\fftcases#1{\left\{\,\vcenter{\m@th\baselineskip=18pt + \ialign{$##\hfil$&\quad##\hfil\crcr#1\crcr}}\right.} +\input epsf + +\setlength\fboxrule{.4\p@} +\newlength{\chpicsize} +\setlength{\chpicsize}{30pc} +\addtolength{\chpicsize}{-\fboxrule} +\addtolength{\chpicsize}{-\fboxrule} +\def\chpic#1{\begingroup% + \def\epsfsize##1##2{##1} + \fboxsep=0pt + \vbox{\noindent% + \fbox{\vbox{\hbox to \chpicsize{\hfil\vbox to \chpicsize{\vfil% + \epsfbox{#1}\vfil}\hfil}}}}\endgroup} diff --git a/csug/myfile.ss b/csug/myfile.ss new file mode 100644 index 0000000..43939cb --- /dev/null +++ b/csug/myfile.ss @@ -0,0 +1,2 @@ +(+ 3 4) +"hello" diff --git a/csug/numeric.stex b/csug/numeric.stex new file mode 100644 index 0000000..29c6733 --- /dev/null +++ b/csug/numeric.stex @@ -0,0 +1,1697 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Numeric Operations\label{CHPTNUMERIC}} + +This chapter describes {\ChezScheme} extensions to the standard set of +operations on numbers. +See Chapter~\ref{TSPL:CHPTOBJECTS} of {\TSPLFOUR} or the Revised$^6$ Report +on Scheme for a description of standard operations on numbers. + +{\ChezScheme} supports the full set of Scheme numeric datatypes, including +exact and inexact integer, rational, real, and complex numbers. +A variety of representations are used to support these datatypes: + +\begin{description} +\item[\index{fixnum}\emph{Fixnums}] represent exact integers in the +fixnum range (see \scheme{most-negative-fixnum} and +\scheme{most-positive-fixnum}). +The length of a string, vector, or fxvector is constrained to be a fixnum. + +\item[\index{bignum}\emph{Bignums}] represent arbitrary-precision +exact integers outside of the fixnum range. + +\item[\index{ratnum}\emph{Ratnums}] represent arbitrary-precision +exact rational numbers. +Each ratnum contains an exact integer (fixnum +or bignum) numerator and an exact integer denominator. +Ratios are always reduced to lowest terms and never have a denominator +of one or a numerator of zero. + +\item[\index{flonum}\emph{Flonums}] represent inexact real numbers. +Flonums are IEEE 64-bit floating-point numbers. +(Since flonums cannot represent irrational numbers, all inexact real +numbers are actually rational, although they may approximate irrational +quantities.) + +\item[\index{exact complexnum}\emph{Exact complexnums}] +represent exact complex numbers. +Each exact complexnum contains an exact rational (fixnum, bignum, or +ratnum) real part and an exact rational imaginary part. + +\item[\index{inexact complexnum}\emph{Inexact complexnums}] +represent inexact complex numbers. +Each inexact complexnum contains a flonum real part and a flonum imaginary part. +\end{description} + +\noindent +Most numbers can be represented in only one way; however, real numbers +are sometimes represented as inexact complex numbers with imaginary +component equal to zero. + +{\ChezScheme} extends the syntax of numbers with arbitrary radixes from +two through 36, nondecimal floating-point and scientific notation, +and printed representations for +IEEE infinities and NANs. (NAN stands for ``not-a-number.'') + +Arbitrary radixes are specified with the prefix \scheme{#\var{n}r}, where +\var{n} ranges from 2 through 36. +Digits beyond 9 are specified with the letters (in either +upper or lower case) \scheme{a} through \scheme{z}. +For example, \scheme{#2r101} is $5_{10}$, and +\scheme{#36rZ} is $35_{10}$. + +For higher radixes, an ambiguity arises between the interpretation of +certain letters, e.g., \scheme{e}, as digits or exponent specifiers; in +such cases, the letter is assumed to be a digit. +For example, the \scheme{e} in \scheme{#x3.2e5} is interpreted as a +digit, not as an exponent marker, whereas in \scheme{3.2e5} it is +treated as an exponent marker. + +IEEE infinities are printed as \scheme{+inf.0} and \scheme{-inf.0}, +while IEEE NANs are printed as \scheme{+nan.0} or \scheme{-nan.0}. +(+nan.0 is used on output for all NANs.) + +\schemedisplay +(/ 1.0 0.0) ;=> +inf.0 +(/ 1.0 -0.0) ;=> -inf.0 +(/ 0.0 0.0) ;=> +nan.0 +(/ +inf.0 -inf.0) ;=> +nan.0 +\endschemedisplay + +The first section of this chapter describes type-specific numeric type +predicates. +Sections~\ref{SECTNUMERICFIXNUM} through~\ref{SECTNUMERICCOMPLEXNUM} +describe fast, type-specific +numeric operations on fixnums, flonums, and inexact complex numbers +(flonums and/or inexact complexnums). +The fixnum-specific versions should be used only when the programmer +is certain that the operands and results (where appropriate) will be +fixnums, i.e., integers in the range \scheme{(most-negative-fixnum)} to +\scheme{(most-positive-fixnum)}, inclusive. +The flonum-specific versions should be used only when the +inputs and outputs (where appropriate) are certain to be flonums. +The mixed flonum/complexnum versions should be used only when the +inputs are certain to be either flonums or inexact complexnums. +Section~\ref{SECTNUMERICLOGICAL} describes operations, both +arbitrary precision and fixnum-specific, that allow +exact integers to be treated as sets or sequences of bits. +Random number generation is covered Section~\ref{SECTNUMERICRANDOM}, +and miscellaneous numeric operations are covered in the +Section~\ref{SECTNUMERICMISC}. + + +\section{Numeric Type Predicates} + +\index{fixnum}\index{flonum}\index{bignum}\index{ratnum}\index{cflonum}% +The Revised$^6$ Report distinguishes two types of special numeric objects: +fixnums and flonums. +{\ChezScheme} additionally distinguishes \emph{bignums} (exact integers outside +of the fixnum range) and \emph{ratnums} (ratios of exact integers). +It also provides a predicate for recognizing \emph{cflonums}, which are +flonums or inexact complex numbers. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bignum?}{\categoryprocedure}{(bignum? \var{obj})} +\returns \scheme{#t} if \var{obj} is a bignum, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(bignum? 0) ;=> #f +(bignum? (most-positive-fixnum)) ;=> #f +(bignum? (most-negative-fixnum)) ;=> #f +(bignum? (* (most-positive-fixnum) 2)) ;=> #t +(bignum? 3/4) ;=> #f +(bignum? 'a) ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ratnum?}{\categoryprocedure}{(ratnum? \var{obj})} +\returns \scheme{#t} if \var{obj} is a ratnum, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(ratnum? 0) ;=> #f +(ratnum? (* (most-positive-fixnum) 2)) ;=> #f +(ratnum? 3/4) ;=> #t +(ratnum? -10/2) ;=> #f +(ratnum? -11/2) ;=> #t +(ratnum? 'a) ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cflonum?}{\categoryprocedure}{(cflonum? \var{obj})} +\returns \scheme{#t} if \var{obj} is an inexact complexnum or flonum, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(cflonum? 0) ;=> #f +(cflonum? 0.0) ;=> #t +(cflonum? 3+4i) ;=> #f +(cflonum? 3.0+4i) ;=> #t +(cflonum? +i) ;=> #f +(cflonum? +1.0i) ;=> #t +\endschemedisplay + +\section{Fixnum Operations\label{SECTNUMERICFIXNUM}} + +Fixnum-specific procedures normally check their inputs and outputs (where +appropriate), but at optimization level 3 the compiler generates, in most +cases, code that does not perform these checks. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{most-positive-fixnum}{\categoryprocedure}{(most-positive-fixnum)} +\returns the most positive fixnum supported by the system +\formdef{most-negative-fixnum}{\categoryprocedure}{(most-negative-fixnum)} +\returns the most negative fixnum supported by the system +\listlibraries +\endentryheader + +\noindent +These procedures are identical to the Revised$^6$ Report +\scheme{greatest-fixnum} and \scheme{least-fixnum} procedures. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fx=}{\categoryprocedure}{(fx= \var{fixnum_1} \var{fixnum_2} \dots)} +\formdef{fx<}{\categoryprocedure}{(fx< \var{fixnum_1} \var{fixnum_2} \dots)} +\formdef{fx>}{\categoryprocedure}{(fx> \var{fixnum_1} \var{fixnum_2} \dots)} +\formdef{fx<=}{\categoryprocedure}{(fx<= \var{fixnum_1} \var{fixnum_2} \dots)} +\formdef{fx>=}{\categoryprocedure}{(fx>= \var{fixnum_1} \var{fixnum_2} \dots)} +\returns \scheme{#t} if the relation holds, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +The predicate \scheme{fx=} returns \scheme{#t} if its arguments are equal. +The predicate \scheme{fx<} returns \scheme{#t} if its arguments are monotonically +increasing, i.e., each argument is greater than the preceding ones, +while \scheme{fx>} returns \scheme{#t} if its arguments are monotonically decreasing. +The predicate \scheme{fx<=} returns \scheme{#t} if its arguments are monotonically +nondecreasing, i.e., each argument is not less than the preceding ones, +while \scheme{fx>=} returns \scheme{#t} if its arguments are monotonically nonincreasing. +When passed only one argument, each of these predicates returns \scheme{#t}. + +These procedures are similar to the Revised$^6$ Report procedures +\scheme{fx=?}, \scheme{fx?}, \scheme{fx<=?}, +and \scheme{fx>=?} except that the Revised$^6$ Report procedures +require two or more arguments, and their names have the ``\scheme{?}'' +suffix. + +\schemedisplay +(fx= 0) ;=> #t +(fx= 0 0) ;=> #t +(fx< (most-negative-fixnum) 0 (most-positive-fixnum)) ;=> #t +(let ([x 3]) (fx<= 0 x 9)) ;=> #t +(fx<= 0 3 3) ;=> #t +(fx>= 0 0 (most-negative-fixnum)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxnonpositive?}{\categoryprocedure}{(fxnonpositive? \var{fixnum})} +\returns \scheme{#t} if \var{fixnum} is not greater than zero, \scheme{#f} otherwise +\formdef{fxnonnegative?}{\categoryprocedure}{(fxnonnegative? \var{fixnum})} +\returns \scheme{#t} if \var{fixnum} is not less than zero, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\scheme{fxnonpositive?} is equivalent to \scheme{(lambda (x) (fx<= x 0))}, +and +\scheme{fxnonnegative?} is equivalent to \scheme{(lambda (x) (fx>= x 0))}. + +\schemedisplay +(fxnonpositive? 128) ;=> #f +(fxnonpositive? 0) ;=> #t +(fxnonpositive? -1) ;=> #t + +(fxnonnegative? -65) ;=> #f +(fxnonnegative? 0) ;=> #t +(fxnonnegative? 1) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fx+}{\categoryprocedure}{(fx+ \var{fixnum} \dots)} +\returns the sum of the arguments \scheme{\var{fixnum} \dots} +\listlibraries +\endentryheader + +\noindent +When called with no arguments, \scheme{fx+} returns \scheme{0}. + +\schemedisplay +(fx+) ;=> 0 +(fx+ 1 2) ;=> 3 +(fx+ 3 4 5) ;=> 12 +(apply fx+ '(1 2 3 4 5)) ;=> 15 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fx-}{\categoryprocedure}{(fx- \var{fixnum_1} \var{fixnum_2} \dots)} +\returns a fixnum +\listlibraries +\endentryheader + +\noindent +When called with one argument, \scheme{fx-} returns the negative of \var{fixnum_1}. +Thus, \scheme{(fx- \var{fixnum_1})} is an idiom for \scheme{(fx- 0 \var{fixnum_1})}. + +When called with two or more arguments, \scheme{fx-} returns the result of +subtracting the sum of the numbers \scheme{\var{fixnum_2} \dots} from +\var{fixnum_1}. + +\schemedisplay +(fx- 3) ;=> -3 +(fx- 4 3) ;=> 1 +(fx- 4 3 2 1) ;=> -2 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fx*}{\categoryprocedure}{(fx* \var{fixnum} \dots)} +\returns the product of the arguments \scheme{\var{fixnum} \dots} +\listlibraries +\endentryheader + +\noindent +When called with no arguments, \scheme{fx*} returns \scheme{1}. + +\schemedisplay +(fx*) ;=> 1 +(fx* 1 2) ;=> 2 +(fx* 3 -4 5) ;=> -60 +(apply fx* '(1 -2 3 -4 5)) ;=> 120 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fx/}{\categoryprocedure}{(fx/ \var{fixnum_1} \var{fixnum_2} \dots)} +\returns see explanation +\listlibraries +\endentryheader + +\noindent +When called with one argument, \scheme{fx/} returns the reciprocal +of \var{fixnum_1}. +That is, \scheme{(fx/ \var{fixnum_1})} is an idiom for +\scheme{(fx/ 1 \var{fixnum_1})}. + +When called with two or more arguments, \scheme{fx/} returns +the result of +dividing \var{fixnum_1} by the product of the remaining arguments +\scheme{\var{fixnum_2} \dots}. + +\schemedisplay +(fx/ 1) ;=> 1 +(fx/ -17) ;=> 0 +(fx/ 8 -2) ;=> -4 +(fx/ -9 2) ;=> -4 +(fx/ 60 5 3 2) ;=> 2 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fx1+}{\categoryprocedure}{(fx1+ \var{fixnum})} +\formdef{fx1-}{\categoryprocedure}{(fx1- \var{fixnum})} +\returns \var{fixnum} plus 1 or \var{fixnum} minus 1 +\listlibraries +\endentryheader + +\schemedisplay +(define fxplus + (lambda (x y) + (if (fxzero? x) + y + (fxplus (fx1- x) (fx1+ y))))) + +(fxplus 7 8) ;=> 15 +\endschemedisplay + +\noindent +\scheme{fx1+} and \scheme{fx1-} can be defined as follows: + +\schemedisplay +(define fx1+ (lambda (x) (fx+ x 1))) +(define fx1- (lambda (x) (fx- x 1))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxquotient}{\categoryprocedure}{(fxquotient \var{fixnum_1} \var{fixnum_2} \dots)} +\returns see explanation +\listlibraries +\endentryheader + +\noindent +\scheme{fxquotient} is identical to \scheme{fx/}. +See the description of \scheme{fx/} above. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxremainder}{\categoryprocedure}{(fxremainder \var{fixnum_1} \var{fixnum_2})} +\returns the fixnum remainder of \var{fixnum_1} divided by \var{fixnum_2} +\listlibraries +\endentryheader + +\noindent +The result of \scheme{fxremainder} has the same sign as \var{fixnum_1}. + +\schemedisplay +(fxremainder 16 4) ;=> 0 +(fxremainder 5 2) ;=> 1 +(fxremainder -45 7) ;=> -3 +(fxremainder 10 -3) ;=> 1 +(fxremainder -17 -9) ;=> -8 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxmodulo}{\categoryprocedure}{(fxmodulo \var{fixnum_1} \var{fixnum_2})} +\returns the fixnum modulus of \var{fixnum_1} and \var{fixnum_2} +\listlibraries +\endentryheader + +\noindent +The result of \scheme{fxmodulo} has the same sign as \var{fixnum_2}. + +\schemedisplay +(fxmodulo 16 4) ;=> 0 +(fxmodulo 5 2) ;=> 1 +(fxmodulo -45 7) ;=> 4 +(fxmodulo 10 -3) ;=> -2 +(fxmodulo -17 -9) ;=> -8 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxabs}{\categoryprocedure}{(fxabs \var{fixnum})} +\returns the absolute value of \var{fixnum} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(fxabs 1) ;=> 1 +(fxabs -1) ;=> 1 +(fxabs 0) ;=> 0 +\endschemedisplay + + +\section{Flonum Operations\label{SECTNUMERICFLONUM}} + +Inexact real numbers are normally represented by \var{flonums}. +A flonum is a single 64-bit double-precision floating point +number. +This section describes operations on flonums, most of which accept +flonum arguments and return flonum values. +In most cases, the operations are inline-coded or coded as machine +language subroutines at optimize-level~3 with +no argument type checking; full type checking is performed at lower +optimize levels. +Flonum-specific procedure names begin with the prefix ``\scheme{fl}'' to +set them apart from their generic counterparts. + +Inexact real numbers may also be represented by inexact complexnums +with imaginary parts equal to zero, which cannot be used as input +to the flonum-specific operators. +Such numbers are produced, however, only from operations involving +complex numbers with nonzero imaginary parts, by explicit calls +to \scheme{fl-make-rectangular}, \scheme{make-rectangular}, or +\scheme{make-polar}, or by numeric input in either polar or rectangular +format. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{flonum->fixnum}{\categoryprocedure}{(flonum->fixnum \var{flonum})} +\returns the fixnum representation of \var{flonum}, truncated +\listlibraries +\endentryheader + +\noindent +The truncated value of \var{flonum} must fall within the fixnum range. +\scheme{flonum->fixnum} is a restricted version of +\index{\scheme{exact}}\scheme{exact}, +which converts any numeric representation +to its exact equivalent. + +\schemedisplay +(flonum->fixnum 0.0) ;=> 0 +(flonum->fixnum 3.9) ;=> 3 +(flonum->fixnum -2.2) ;=> -2 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fl=}{\categoryprocedure}{(fl= \var{flonum_1} \var{flonum_2} \dots)} +\formdef{fl<}{\categoryprocedure}{(fl< \var{flonum_1} \var{flonum_2} \dots)} +\formdef{fl>}{\categoryprocedure}{(fl> \var{flonum_1} \var{flonum_2} \dots)} +\formdef{fl<=}{\categoryprocedure}{(fl<= \var{flonum_1} \var{flonum_2} \dots)} +\formdef{fl>=}{\categoryprocedure}{(fl>= \var{flonum_1} \var{flonum_2} \dots)} +\returns \scheme{#t} if the relation holds, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +The predicate \scheme{fl=} returns \scheme{#t} if its arguments are equal. +The predicate \scheme{fl<} returns \scheme{#t} if its arguments are monotonically +increasing, i.e., each argument is greater than the preceding ones, +while \scheme{fl>} returns \scheme{#t} if its arguments are monotonically decreasing. +The predicate \scheme{fl<=} returns \scheme{#t} if its arguments are monotonically +nondecreasing, i.e., each argument is not less than the preceding ones, +while \scheme{fl>=} returns \scheme{#t} if its arguments are monotonically nonincreasing. +When passed only one argument, each of these predicates returns \scheme{#t}. + +IEEE NANs are not comparable, i.e., comparisons involving NANs always return +\scheme{#f}. + +These procedures are similar to the Revised$^6$ Report procedures +\scheme{fl=?}, \scheme{fl?}, \scheme{fl<=?}, +and \scheme{fl>=?} except that the Revised$^6$ Report procedures +require two or more arguments, and their names have the ``\scheme{?}'' +suffix. + +\schemedisplay +(fl= 0.0) ;=> #t +(fl= 0.0 0.0) ;=> #t +(fl< -1.0 0.0 1.0) ;=> #t +(fl> -1.0 0.0 1.0) ;=> #f +(fl<= 0.0 3.0 3.0) ;=> #t +(fl>= 4.0 3.0 3.0) ;=> #t +(fl< 7.0 +inf.0) ;=> #t +(fl= +nan.0 0.0) ;=> #f +(fl= +nan.0 +nan.0) ;=> #f +(fl< +nan.0 +nan.0) ;=> #f +(fl> +nan.0 +nan.0) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{flnonpositive?}{\categoryprocedure}{(flnonpositive? \var{fl})} +\returns \scheme{#t} if \var{fl} is not greater than zero, \scheme{#f} otherwise +\formdef{flnonnegative?}{\categoryprocedure}{(flnonnegative? \var{fl})} +\returns \scheme{#t} if \var{fl} is not less than zero, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\scheme{flnonpositive?} is equivalent to \scheme{(lambda (x) (fl<= x 0.0))}, +and +\scheme{flnonnegative?} is equivalent to \scheme{(lambda (x) (fl>= x 0.0))}. + +\noindent +Even if the flonum representation distinguishes -0.0 from +0.0, both +are considered nonpositive and nonnegative. + +\schemedisplay +(flnonpositive? 128.0) ;=> #f +(flnonpositive? 0.0) ;=> #t +(flnonpositive? -0.0) ;=> #t +(flnonpositive? -1.0) ;=> #t + +(flnonnegative? -65.0) ;=> #f +(flnonnegative? 0.0) ;=> #t +(flnonnegative? -0.0) ;=> #t +(flnonnegative? 1.0) ;=> #t + +(flnonnegative? +nan.0) ;=> #f +(flnonpositive? +nan.0) ;=> #f + +(flnonnegative? +inf.0) ;=> #t +(flnonnegative? -inf.0) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{decode-float}{\categoryprocedure}{(decode-float \var{x})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{x} must be a flonum. +\scheme{decode-float} returns a vector with three integer elements, +\var{m}, \var{e}, and \var{s}, such that +$x = sm2^e$. +It is useful primarily in the printing of floating-point numbers. + +\schemedisplay +(decode-float 1.0) ;=> #(4503599627370496 -52 1) +(decode-float -1.0) ;=> #(4503599627370496 -52 -1) + +(define slow-identity + (lambda (x) + (inexact + (let ([v (decode-float x)]) + (let ([m (vector-ref v 0)] + [e (vector-ref v 1)] + [s (vector-ref v 2)]) + (* s m (expt 2 e))))))) + +(slow-identity 1.0) ;=> 1.0 +(slow-identity -1e20) ;=> -1e20 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fllp}{\categoryprocedure}{(fllp \var{flonum})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\scheme{fllp} returns the 12-bit integer consisting of the exponent +plus highest order represented bit of a flonum (ieee 64-bit +floating-point number). +It can be used to compute a fast approximation of the logarithm of +the number. + +\schemedisplay +(fllp 0.0) ;=> 0 +(fllp 1.0) ;=> 2046 +(fllp -1.0) ;=> 2046 + +(fllp 1.5) ;=> 2047 + +(fllp +inf.0) ;=> 4094 +(fllp -inf.0) ;=> 4094 + +(fllp #b1.0e-1111111111) ;=> 1 +(fllp #b1.0e-10000000000) ;=> 0 +\endschemedisplay + + +\section{Inexact Complex Operations\label{SECTNUMERICCOMPLEXNUM}} + +The procedures described in this section provide mechanisms for +creating and operating on inexact complex numbers. +Inexact complex numbers with nonzero imaginary parts are represented as +\emph{inexact complexnums}. +An inexact complexnum contains two 64-bit double-precision floating point +numbers. +Inexact \index{imaginary numbers}\index{complex numbers}complex numbers +with imaginary parts equal to zero (in other words, inexact real numbers) +may be represented as either inexact complexnums or flonums. +The operations described in this section accept any mix of +inexact complexnum and flonum arguments +(collectively, ``\index{cflonums}cflonums''). + +In most cases, the operations are performed with minimal type checking +at optimize-level 3; full type checking is performed at lower optimize +levels. +Inexact complex procedure names begin with the prefix ``\scheme{cfl}'' +to set them apart from their generic counterparts. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fl-make-rectangular}{\categoryprocedure}{(fl-make-rectangular \var{flonum_1} \var{flonum_2})} +\returns an inexact complexnum +\listlibraries +\endentryheader + +\noindent +The inexact complexnum produced by fl-make-rectangular has real part equal +to \var{flonum_1} and imaginary part equal to \var{flonum_2}. + +\schemedisplay +(fl-make-rectangular 2.0 -3.0) ;=> 2.0-3.0i +(fl-make-rectangular 2.0 0.0) ;=> 2.0+0.0i +(fl-make-rectangular 2.0 -0.0) ;=> 2.0-0.0i +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cfl-real-part}{\categoryprocedure}{(cfl-real-part \var{cflonum})} +\returns the real part of \var{cflonum} +\formdef{cfl-imag-part}{\categoryprocedure}{(cfl-imag-part \var{cflonum})} +\returns the imaginary part of \var{cflonum} +\listlibraries +\endentryheader + +%\noindent +%Due to the flonum and inexact complexnum representations employed by +%{\ChezScheme}, these operations require no memory +%references and no heap allocation. + +\schemedisplay +(cfl-real-part 2.0-3.0i) ;=> 2.0 +(cfl-imag-part 2.0-3.0i) ;=> -3.0 +(cfl-imag-part 2.0-0.0i) ;=> -0.0 +(cfl-imag-part 2.0-inf.0i) ;=> -inf.0 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cfl=}{\categoryprocedure}{(cfl= \var{cflonum} \dots)} +\returns \scheme{#t} if its arguments are equal, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(cfl= 7.0+0.0i 7.0) ;=> #t +(cfl= 1.0+2.0i 1.0+2.0i) ;=> #t +(cfl= 1.0+2.0i 1.0-2.0i) ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cfl+}{\categoryprocedure}{(cfl+ \var{cflonum} \dots)} +\formdef{cfl*}{\categoryprocedure}{(cfl* \var{cflonum} \dots)} +\formdef{cfl-}{\categoryprocedure}{(cfl- \var{cflonum_1} \var{cflonum_2} \dots)} +\formdef{cfl/}{\categoryprocedure}{(cfl/ \var{cflonum_1} \var{cflonum_2} \dots)} +\returns a cflonum +\listlibraries +\endentryheader + +\noindent +These procedures compute the sum, difference, product, or quotient +of inexact complex quantities, whether these quantities are represented +by flonums or inexact complexnums. +For example, if \scheme{cfl+} receives two flonum arguments $a$ and $b$, it +returns the sum $a+b$; in this case, it behaves the same as \scheme{fl+}. +With two inexact complexnum arguments $a+bi$ and $c+di$, it returns +the sum $(a+c)+(b+d)i$. +If one argument is a flonum $a$ and the other an inexact complexnum +$c+di$, \scheme{cfl+} returns $(a+c)+di$. + +When passed zero arguments, \scheme{cfl+} returns 0.0 and +\scheme{cfl*} returns 1.0. +When passed one argument, \scheme{cfl-} returns the additive inverse +of the argument, and \scheme{cfl/} returns the multiplicative inverse +of the argument. +When passed three or more arguments, \scheme{cfl-} returns the +difference between its first and the sum of its remaining arguments, +and \scheme{cfl/} returns the quotient of its first and the product +of its remaining arguments. + +%On machines supporting the IEEE Standard for Floating Point Arithmetic +%\cite{IEEEFLOAT}, +%adding a flonum $a$ to a complexnum $c+di$ is not always the same +%as adding the complexnum $a+0.0i$ to $c+di$. +%The counter example is when $d=-0.0$, in which case the former leads +%to $(a+c)-0.0i$ while the latter leads to $(a+c)+0.0i$. +%{\ChezScheme} performs the former operation under the assumption that +%the imaginary part of a flonum representing a complex quantity always +%has an exact zero imaginary part. +%We do not treat flonums $a$ as if they were equivalent to $a+0.0i$. +%Although this would seem to simplify the semantics slightly, it leads +%to unfortunate consistency problems. +%For example, assuming that we do want to treat flonums $a$ as +%equivalent to $a+0.0i$, the product $ab$ of two flonums $a$ and $b$ +%would presumably be equivalent $ab+0.0i$. +%However, if $a$ and $b$ are negative, the product of $a+0.0i$ and +%$b+0.0i$ is actually $ab-0.0i$, not $ab+0.0i$. +%Unfortunately, {\ChezScheme} currently represents imaginary numbers +%as complexnums, so while 1.0 is assumed to have an exact +%zero imaginary part, +1.0i is arbitrarily assigned a real part of +%+0.0. + +\schemedisplay +(cfl+) ;=> 0.0 +(cfl*) ;=> 1.0 +(cfl- 5.0+1.0i) ;=> -5.0-1.0i +(cfl/ 2.0+2.0i) ;=> 0.25-0.25i + +(cfl+ 1.0+2.2i -3.7+5.3i) ;=> -2.7+7.5i +(cfl+ 1.0 -5.3) ;=> -4.3 +(cfl+ 1.0 2.0 -5.3i) ;=> 3.0-5.3i +(cfl- 1.0+2.5i -3.7) ;=> 4.7+2.5i +(cfl* 1.0+2.0i 3.0+4.0i) ;=> -5.0+10.0i +(cfl/ -5.0+10.0i 1.0+2.0i 2.0) ;=> 1.5+2.0i +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cfl-conjugate}{\categoryprocedure}{(cfl-conjugate \var{cflonum})} +\returns complex conjugate of \var{cflonum} +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{cfl-conjugate}, when passed an inexact complex argument +$a + bi$, returns its complex conjugate $a + (-b)i$. + +See also \index{\scheme{conjugate}}\scheme{conjugate}, which is a generic +version of this operator that returns the complex conjugate of any +valid representation for a complex number. + +\schemedisplay +(cfl-conjugate 3.0) ;=> 3.0 +(cfl-conjugate 3.0+4.0i) ;=> 3.0-4.0i +(cfl-conjugate 1e-20-2e-30i) ;=> 1e-20+2e-30i +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cfl-magnitude-squared}{\categoryprocedure}{(cfl-magnitude-squared \var{cflonum})} +\returns magnitude of \var{cflonum} squared +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{cfl-magnitude-squared}, when passed an inexact complex +argument $a + bi$ returns a flonum representing the magnitude of the +argument squared, i.e., $a^2 + b^2$. + +See also \index{\scheme{magnitude-squared}}\scheme{magnitude-squared}, +which is a generic version of this +operator that returns the magnitude squared of any valid representation +for a complex number. +Both operations are similar to the \index{\scheme{magnitude}}\scheme{magnitude} procedure, +which returns the magnitude, $sqrt(a^2 + b^2)$, of its generic complex +argument. + +\schemedisplay +(cfl-magnitude-squared 3.0) ;=> 9.0 +(cfl-magnitude-squared 3.0-4.0i) ;=> 25.0 +\endschemedisplay + +\section{Bitwise and Logical Operators\label{SECTNUMERICLOGICAL}} + +{\ChezScheme} provides a set of logical operators that allow exact +integers (fixnums and bignums) to be treated as sets or sequences +of bits. +These operators include +\scheme{logand} (bitwise logical \scheme{and}), +\scheme{logior} (bitwise logical \scheme{or}), +\scheme{logxor} (bitwise logical exclusive \scheme{or}), +\scheme{lognot} (bitwise logical \scheme{not}), +\scheme{logtest} (test multiple bits), +\scheme{logbit?} (test single bit), +\scheme{logbit0} (reset single bit), +\scheme{logbit1} (set single bit), +and \scheme{ash} (arithmetic shift). +Each of these operators treats its arguments as two's complement integers, +regardless of the underlying representation. +This treatment can be exploited to represent infinite sets: +a negative number represents an infinite number of one bits beyond the +leftmost zero, and a nonnegative number represents an infinite number of zero +bits beyond the leftmost one bit. + +Fixnum equivalents of the logical operators are provided, as +\scheme{fxlogand}, \scheme{fxlogior}, \scheme{fxlogxor}, +\scheme{fxlognot}, \scheme{fxlogtest}, \scheme{fxlogbit?}, +\scheme{fxlogbit0}, and \scheme{fxlogbit1}. +Three separate fixnum operators are provided for shifting: +\scheme{fxsll} (shift-left logical), +\scheme{fxsrl} (shift-right logical), +\scheme{fxsra} (shift-right arithmetic). +Logical and arithmetic shifts differ only for right shifts. +Shift-right logical shifts in zero bits on the left end, and shift-right +arithmetic replicates the sign bit. + +Logical shifts do not make sense for arbitrary-precision integers, +since these have no ``left end'' into which bits must be shifted. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logand}{\categoryprocedure}{(logand \var{int} \dots)} +\returns the logical ``and'' of the arguments \scheme{\var{int} \dots} +\listlibraries +\endentryheader + +\noindent +The arguments must be exact integers (fixnums or bignums) and are treated +as two's complement integers, regardless of the underlying representation. +With no arguments, \scheme{logand} returns -1, i.e., all bits set. + +\schemedisplay +(logand) ;=> -1 +(logand 15) ;=> 15 +(logand -1 -1) ;=> -1 +(logand -1 0) ;=> 0 +(logand 5 3) ;=> 1 +(logand #x173C8D95 7) ;=> 5 +(logand #x173C8D95 -8) ;=> #x173C8D90 +(logand #b1100 #b1111 #b1101) ;=> #b1100 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logior}{\categoryprocedure}{(logior \var{int} \dots)} +\formdef{logor}{\categoryprocedure}{(logor \var{int} \dots)} +\returns the logical ``or'' of the arguments \scheme{\var{int} \dots} +\listlibraries +\endentryheader + +\noindent +The arguments must be exact integers (fixnums or bignums) and are treated +as two's complement integers, regardless of the underlying representation. +With no arguments, \scheme{logior} returns 0, i.e., all bits reset. + +\schemedisplay +(logior) ;=> 0 +(logior 15) ;=> 15 +(logior -1 -1) ;=> -1 +(logior -1 0) ;=> -1 +(logior 5 3) ;=> 7 +(logior #b111000 #b101010) ;=> #b111010 +(logior #b1000 #b0100 #b0010) ;=> #b1110 +(apply logior '(1 2 4 8 16)) ;=> 31 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logxor}{\categoryprocedure}{(logxor \var{int} \dots)} +\returns the logical ``exclusive or'' of the arguments \scheme{\var{int} \dots} +\listlibraries +\endentryheader + +\noindent +The arguments must be exact integers (fixnums or bignums) and are treated +as two's complement integers, regardless of the underlying representation. +With no arguments, \scheme{logxor} returns 0, i.e., all bits reset. + +\schemedisplay +(logxor) ;=> 0 +(logxor 15) ;=> 15 +(logxor -1 -1) ;=> 0 +(logxor -1 0) ;=> -1 +(logxor 5 3) ;=> 6 +(logxor #b111000 #b101010) ;=> #b010010 +(logxor #b1100 #b0100 #b0110) ;=> #b1110 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{lognot}{\categoryprocedure}{(lognot \var{int})} +\returns the logical ``not'' of \var{int} +\listlibraries +\endentryheader + +\noindent +The argument must be an exact integer (fixnum or bignum) and is treated +as a two's complement integer, regardless of the underlying representation. + +\schemedisplay +(lognot -1) ;=> 0 +(lognot 0) ;=> -1 +(lognot 7) ;=> -8 +(lognot -8) ;=> 7 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logbit?}{\categoryprocedure}{(logbit? \var{index} \var{int})} +\returns \scheme{#t} if the specified bit is set, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\var{index} must be a nonnegative exact integer. +\var{int} must be an exact integer (fixnum or bignum) and is treated +as a two's complement integer, regardless of the underlying representation. + +\scheme{logbit?} returns \scheme{#t} if the bit at index \var{index} +of \var{int} is set (one) and \scheme{#f} otherwise. +The index is zero-based, counting from the lowest-order toward +higher-order bits. +There is no upper limit on the index; for nonnegative values of \var{int}, +the bits above the highest order set bit are all considered to be zero, +and for negative values, the bits above the highest order reset bit are +all considered to be one. + +\scheme{logbit?} is equivalent to + +\schemedisplay +(lambda (k n) (not (zero? (logand n (ash 1 k))))) +\endschemedisplay + +but more efficient. + +\schemedisplay +(logbit? 0 #b1110) ;=> #f +(logbit? 1 #b1110) ;=> #t +(logbit? 2 #b1110) ;=> #t +(logbit? 3 #b1110) ;=> #t +(logbit? 4 #b1110) ;=> #f +(logbit? 100 #b1110) ;=> #f + +(logbit? 0 -6) ;=> #f ; \var{the two's complement of} -6 \var{is} 1...1010 +(logbit? 1 -6) ;=> #t +(logbit? 2 -6) ;=> #f +(logbit? 3 -6) ;=> #t +(logbit? 100 -6) ;=> #t + +(logbit? (random 1000000) 0) ;=> #f +(logbit? (random 1000000) -1) ;=> #t + +(logbit? 20000 (ash 1 20000)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logtest}{\categoryprocedure}{(logtest \var{int_1} \var{int_2})} +\returns \scheme{#t} if any common bits are set, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +The arguments must be exact integers (fixnums or bignums) and are treated +as two's complement integers, regardless of the underlying representation. + +\scheme{logtest} returns \scheme{#t} if any bit set in one argument is +also set in the other. +It returns \scheme{#f} if the two arguments have no set bits in common. + +\scheme{logtest} is equivalent to + +\schemedisplay +(lambda (n1 n2) (not (zero? (logand n1 n2)))) +\endschemedisplay + +but more efficient. + +\schemedisplay +(logtest #b10001 #b1110) ;=> #f +(logtest #b10101 #b1110) ;=> #t +(logtest #b111000 #b110111) ;=> #t + +(logtest #b101 -6) ;=> #f ; \var{the two's complement of} -6 \var{is} 1...1010 +(logtest #b1000 -6) ;=> #t +(logtest 100 -6) ;=> #t + +(logtest (+ (random 1000000) 1) 0) ;=> #f +(logtest (+ (random 1000000) 1) -1) ;=> #t + +(logtest (ash #b101 20000) (ash #b111 20000)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logbit0}{\categoryprocedure}{(logbit0 \var{index} \var{int})} +\returns the result of clearing bit \var{index} of \var{int} +\listlibraries +\endentryheader + +\noindent +\var{index} must be a nonnegative exact integer. +\var{int} must be an exact integer (fixnum or bignum) and is treated +as a two's complement integer, regardless of the underlying representation. + +The index is zero-based, counting from the lowest-order toward +higher-order bits. +As with \scheme{logbit?}, there is no upper limit on the index. + +\scheme{logbit0} is equivalent to + +\schemedisplay +(lambda (i n) (logand (lognot (ash 1 i)) n)) +\endschemedisplay + +but more efficient. + +\schemedisplay +(logbit0 3 #b10101010) ;=> #b10100010 +(logbit0 4 #b10101010) ;=> #b10101010 +(logbit0 0 -1) ;=> -2 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{logbit1}{\categoryprocedure}{(logbit1 \var{index} \var{int})} +\returns the result of setting bit \var{index} of \var{int} +\listlibraries +\endentryheader + +\noindent +\var{index} must be a nonnegative exact integer. +\var{int} must be an exact integer (fixnum or bignum) and is treated +as a two's complement integer, regardless of the underlying representation. + +The index is zero-based, counting from the lowest-order toward +higher-order bits. +As with \scheme{logbit?}, there is no upper limit on the index. + +\scheme{logbit1} is equivalent to + +\schemedisplay +(lambda (i n) (logor (ash 1 i) n)) +\endschemedisplay + +but more efficient. + +\schemedisplay +(logbit1 3 #b10101010) ;=> #b10101010 +(logbit1 4 #b10101010) ;=> #b10111010 +(logbit1 4 0) ;=> #b10000 +(logbit1 0 -2) ;=> -1 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ash}{\categoryprocedure}{(ash \var{int} \var{count})} +\returns \var{int} shifted left arithmetically by \var{count}. +\listlibraries +\endentryheader + +\noindent +Both arguments must be exact integers. +The first argument is treated as a two's complement integer, regardless +of the underlying representation. +If \var{count} is negative, \var{int} is shifted right by +$-$\var{count} bits. + +\schemedisplay +(ash 8 0) ;=> 8 +(ash 8 2) ;=> 32 +(ash 8 -2) ;=> 2 +(ash -1 2) ;=> -4 +(ash -1 -2) ;=> -1 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogand}{\categoryprocedure}{(fxlogand \var{fixnum} \dots)} +\returns the logical ``and'' of the arguments \scheme{\var{fixnum} \dots} +\listlibraries +\endentryheader + +\noindent +The arguments are treated as two's complement integers, regardless +of the underlying representation. +With no arguments, \scheme{fxlogand} returns -1, i.e., all bits set. + +\schemedisplay +(fxlogand) ;=> -1 +(fxlogand 15) ;=> 15 +(fxlogand -1 -1) ;=> -1 +(fxlogand -1 0) ;=> 0 +(fxlogand 5 3) ;=> 1 +(fxlogand #b111000 #b101010) ;=> #b101000 +(fxlogand #b1100 #b1111 #b1101) ;=> #b1100 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogior}{\categoryprocedure}{(fxlogior \var{fixnum} \dots)} +\formdef{fxlogor}{\categoryprocedure}{(fxlogor \var{fixnum} \dots)} +\returns the logical ``or'' of the arguments \scheme{\var{fixnum} \dots} +\listlibraries +\endentryheader + +\noindent +The arguments are treated as two's complement integers, regardless +of the underlying representation. +With no arguments, \scheme{fxlogior} returns 0, i.e., all bits reset. + +\schemedisplay +(fxlogior) ;=> 0 +(fxlogior 15) ;=> 15 +(fxlogior -1 -1) ;=> -1 +(fxlogior -1 0) ;=> -1 +(fxlogior #b111000 #b101010) ;=> #b111010 +(fxlogior #b1000 #b0100 #b0010) ;=> #b1110 +(apply fxlogior '(1 2 4 8 16)) ;=> 31 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogxor}{\categoryprocedure}{(fxlogxor \var{fixnum} \dots)} +\returns the logical ``exclusive or'' of the arguments \scheme{\var{fixnum} \dots} +\listlibraries +\endentryheader + +\noindent +The arguments are treated as two's complement integers, regardless +of the underlying representation. +With no arguments, \scheme{fxlogxor} returns 0, i.e., all bits reset. + +\schemedisplay +(fxlogxor) ;=> 0 +(fxlogxor 15) ;=> 15 +(fxlogxor -1 -1) ;=> 0 +(fxlogxor -1 0) ;=> -1 +(fxlogxor 5 3) ;=> 6 +(fxlogxor #b111000 #b101010) ;=> #b010010 +(fxlogxor #b1100 #b0100 #b0110) ;=> #b1110 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlognot}{\categoryprocedure}{(fxlognot \var{fixnum})} +\returns the logical ``not'' of \var{fixnum} +\listlibraries +\endentryheader + +\noindent +The argument is treated as a two's complement integer, regardless +of the underlying representation. + +\schemedisplay +(fxlognot -1) ;=> 0 +(fxlognot 0) ;=> -1 +(fxlognot 1) ;=> -2 +(fxlognot -2) ;=> 1 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogbit?}{\categoryprocedure}{(fxlogbit? \var{index} \var{fixnum})} +\returns \scheme{#t} if the specified bit is set, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\var{index} must be a nonnegative fixnum. +\var{fixnum} is treated as a two's complement integer, regardless of +the underlying representation. + +\scheme{fxlogbit?} returns \scheme{#t} if the bit at index \var{index} +of \var{fixnum} is set (one) and \scheme{#f} otherwise. +The index is zero-based, counting from the lowest-order toward +higher-order bits. +The index is limited only by the fixnum range; for nonnegative values of +\var{fixnum}, the bits above the highest order set bit are all considered +to be zero, and for negative values, the bits above the highest order +reset bit are all considered to be one. + +\schemedisplay +(fxlogbit? 0 #b1110) ;=> #f +(fxlogbit? 1 #b1110) ;=> #t +(fxlogbit? 2 #b1110) ;=> #t +(fxlogbit? 3 #b1110) ;=> #t +(fxlogbit? 4 #b1110) ;=> #f +(fxlogbit? 100 #b1110) ;=> #f + +(fxlogbit? 0 -6) ;=> #f ; \var{the two's complement of} -6 \var{is} 1...1010 +(fxlogbit? 1 -6) ;=> #t +(fxlogbit? 2 -6) ;=> #f +(fxlogbit? 3 -6) ;=> #t +(fxlogbit? 100 -6) ;=> #t + +(fxlogbit? (random 1000000) 0) ;=> #f +(fxlogbit? (random 1000000) -1) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogtest}{\categoryprocedure}{(fxlogtest \var{fixnum_1} \var{fixnum_2})} +\returns \scheme{#t} if any common bits are set, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +The arguments are treated as two's complement integers, regardless of +the underlying representation. + +\scheme{fxlogtest} returns \scheme{#t} if any bit set in one argument is +also set in the other. +It returns \scheme{#f} if the two arguments have no set bits in common. + +\schemedisplay +(fxlogtest #b10001 #b1110) ;=> #f +(fxlogtest #b10101 #b1110) ;=> #t +(fxlogtest #b111000 #b110111) ;=> #t + +(fxlogtest #b101 -6) ;=> #f ; \var{the two's complement of} -6 \var{is} 1...1010 +(fxlogtest #b1000 -6) ;=> #t +(fxlogtest 100 -6) ;=> #t + +(fxlogtest (+ (random 1000000) 1) 0) ;=> #f +(fxlogtest (+ (random 1000000) 1) -1) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogbit0}{\categoryprocedure}{(fxlogbit0 \var{index} \var{fixnum})} +\returns the result of clearing bit \var{index} of \var{fixnum} +\listlibraries +\endentryheader + +\noindent +\var{fixnum} is treated +as a two's complement integer, regardless of the underlying representation. +\var{index} must be nonnegative and less than the number of +bits in a fixnum, excluding the sign bit, i.e., less than +\scheme{(integer-length (most-positive-fixnum))}. +The index is zero-based, counting from the lowest-order toward +higher-order bits. + +\scheme{fxlogbit0} is equivalent to + +\schemedisplay +(lambda (i n) (fxlogand (fxlognot (fxsll 1 i)) n)) +\endschemedisplay + +but more efficient. + +\schemedisplay +(fxlogbit0 3 #b10101010) ;=> #b10100010 +(fxlogbit0 4 #b10101010) ;=> #b10101010 +(fxlogbit0 0 -1) ;=> -2 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxlogbit1}{\categoryprocedure}{(fxlogbit1 \var{index} \var{fixnum})} +\returns the result of setting bit \var{index} of \var{fixnum} +\listlibraries +\endentryheader + +\noindent +\var{fixnum} is treated +as a two's complement integer, regardless of the underlying representation. +\var{index} must be nonnegative and less than the number of +bits in a fixnum, excluding the sign bit, i.e., less than +\scheme{(integer-length (most-positive-fixnum))}. +The index is zero-based, counting from the lowest-order toward +higher-order bits. + +\scheme{fxlogbit1} is equivalent to + +\schemedisplay +(lambda (i n) (fxlogor (fxsll 1 i) n)) +\endschemedisplay + +but more efficient. + +\schemedisplay +(fxlogbit1 3 #b10101010) ;=> #b10101010 +(fxlogbit1 4 #b10101010) ;=> #b10111010 +(fxlogbit1 4 0) ;=> #b10000 +(fxlogbit1 0 -2) ;=> -1 +\endschemedisplay + + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxsll}{\categoryprocedure}{(fxsll \var{fixnum} \var{count})} +\returns \var{fixnum} shifted left by \var{count} +\listlibraries +\endentryheader + +\noindent +\var{fixnum} is treated as a two's complement integer, regardless +of the underlying representation. +\var{count} must be nonnegative and not more than the number of +bits in a fixnum, i.e., +\scheme{(+ (integer-length (most-positive-fixnum)) 1)}. +An exception is raised with condition-type +\scheme{&implementation-restriction} if the result cannot be represented +as a fixnum. + +\schemedisplay +(fxsll 1 2) ;=> 4 +(fxsll -1 2) ;=> -4 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxsrl}{\categoryprocedure}{(fxsrl \var{fixnum} \var{count})} +\returns \var{fixnum} logically shifted right by \var{count} +\listlibraries +\endentryheader + +\noindent +\var{fixnum} is treated as a two's complement integer, regardless +of the underlying representation. +\var{count} must be nonnegative and not more than the number of +bits in a fixnum, i.e., +\scheme{(+ (integer-length (most-positive-fixnum)) 1)}. + +\schemedisplay +(fxsrl 4 2) ;=> 1 +(= (fxsrl -1 1) (most-positive-fixnum)) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxsra}{\categoryprocedure}{(fxsra \var{fixnum} \var{count})} +\returns \var{fixnum} arithmetically shifted right by \var{count} +\listlibraries +\endentryheader + +\noindent +\var{fixnum} is treated as a two's complement integer, regardless +of the underlying representation. +\var{count} must be nonnegative and not more than the number of +bits in a fixnum, i.e., +\scheme{(+ (integer-length (most-positive-fixnum)) 1)}. + +\schemedisplay +(fxsra 64 3) ;=> 8 +(fxsra -1 1) ;=> -1 +(fxsra -64 3) ;=> -8 +\endschemedisplay + + +\section{Random Number Generation\label{SECTNUMERICRANDOM}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{random}{\categoryprocedure}{(random \var{real})} +\returns a nonnegative pseudo-random number less than \var{real} +\listlibraries +\endnoskipentryheader + +\noindent +\var{real} must be a positive integer or positive inexact real number. + +\schemedisplay +(random 1) ;=> 0 +(random 1029384535235) ;=> 1029384535001, \var{every} \var{now} \var{and} \var{then} +(random 1.0) ;=> 0.5, \var{every} \var{now} \var{and} \var{then} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{random-seed}{\categorythreadparameter}{random-seed} +\listlibraries +\endentryheader + +\noindent +The \index{random number generator}random number generator allows the +current random seed to be obtained and modified via the parameter +\scheme{random-seed}. + +When called without arguments, \scheme{random-seed} returns the current +random seed. +When called with one argument, which must be a nonnegative exact integer +ranging from 1 through $2^{32}-1$, \scheme{random-seed} sets the current +random seed to the argument. + +\schemedisplay +(let ([s (random-seed)]) + (let ([r1 (random 1.0)]) + (random-seed s) + (eqv? (random 1.0) r1))) ;=> #t +\endschemedisplay + + + +\section{Miscellaneous Numeric Operations\label{SECTNUMERICMISC}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{=}{\categoryprocedure}{(= \var{num_1} \var{num_2} \var{num_3} \dots)} +\formdef{<}{\categoryprocedure}{(< \var{real_1} \var{real_2} \var{real_3} \dots)} +\formdef{>}{\categoryprocedure}{(> \var{real_1} \var{real_2} \var{real_3} \dots)} +\formdef{<=}{\categoryprocedure}{(<= \var{real_1} \var{real_2} \var{real_3} \dots)} +\formdef{>=}{\categoryprocedure}{(>= \var{real_1} \var{real_2} \var{real_3} \dots)} +\returns \scheme{#t} if the relation holds, \scheme{#f} otherwise +\listlibraries +\endnoskipentryheader + +\noindent +These predicates are identical to the Revised$^6$ Report counterparts, +except they are extended to accept one or more rather than two or more +arguments. +When passed one argument, each of these predicates returns \scheme{#t}. + +\schemedisplay +(> 3/4) ;=> #t +(< 3/4) ;=> #t +(= 3/4) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{1+}{\categoryprocedure}{(1+ \var{num})} +\formdef{add1}{\categoryprocedure}{(add1 \var{num})} +\formdef{1-}{\categoryprocedure}{(1- \var{num})} +\formdef{-1+}{\categoryprocedure}{(-1+ \var{num})} +\formdef{sub1}{\categoryprocedure}{(sub1 \var{num})} +\returns \var{num} plus 1 or \var{num} minus 1 +\listlibraries +\endentryheader + +\noindent +\scheme{1+} and \scheme{add1} are equivalent to +\scheme{(lambda (x) (+ x 1))}; +\scheme{1-}, \scheme{-1+}, and \scheme{sub1} are equivalent to +\scheme{(lambda (x) (- x 1))}. + +\schemedisplay +(define plus + ; x should be a nonnegative integer + (lambda (x y) + (if (zero? x) + y + (plus (1- x) (1+ y))))) + +(plus 7 8) ;=> 15 + +(define double + ; x should be a nonnegative integer + (lambda (x) + (if (zero? x) + 0 + (add1 (add1 (double (sub1 x))))))) + +(double 7) ;=> 14 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{expt-mod}{\categoryprocedure}{(expt-mod \var{int_1} \var{int_2} \var{int_3})} +\returns \var{int_1} raised to the \var{int_2} power, modulo \var{int_3} +\listlibraries +\endentryheader + +\noindent +\var{int_1}, \var{int_2} and \var{int_3} +must be nonnegative integers. +\scheme{expt-mod} performs its computation in such a way that the +intermediate results are never much larger than \var{int_3}. +This means that when \var{int_2} is large, \scheme{expt-mod} is more efficient +than the equivalent procedure \scheme{(lambda (x y z) (modulo (expt x y) z))}. + +\schemedisplay +(expt-mod 2 4 3) ;=> 1 +(expt-mod 2 76543 76543) ;=> 2 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{isqrt}{\categoryprocedure}{(isqrt \var{n})} +\returns the integer square root of \var{n} +\listlibraries +\endentryheader + +\noindent +\var{n} must be a nonnegative integer. +The integer square root of $n$ is defined to be +$\bigl\lfloor\sqrt n\bigr\rfloor$. + + +\schemedisplay +(isqrt 0) ;=> 0 +(isqrt 16) ;=> 4 +(isqrt 16.0) ;=> 4.0 +(isqrt 20) ;=> 4 +(isqrt 20.0) ;=> 4.0 +(isqrt (* 2 (expt 10 20))) ;=> 14142135623 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{integer-length}{\categoryprocedure}{(integer-length \var{n})} +\returns see below +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{integer-length} returns the length in bits of +the smallest two's complement representation for \var{n}, with an +assumed leading 1 (sign) bit for negative numbers. +For zero, \scheme{integer-length} returns 0. + +\schemedisplay +(integer-length 0) ;=> 0 +(integer-length 1) ;=> 1 +(integer-length 2) ;=> 2 +(integer-length 3) ;=> 2 +(integer-length 4) ;=> 3 +(integer-length #b10000000) ;=> 8 +(integer-length #b11111111) ;=> 8 +(integer-length -1) ;=> 0 +(integer-length -2) ;=> 1 +(integer-length -3) ;=> 2 +(integer-length -4) ;=> 2 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{nonpositive?}{\categoryprocedure}{(nonpositive? \var{real})} +\returns \scheme{#t} if \var{real} is not greater than zero, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\scheme{nonpositive?} is equivalent to \scheme{(lambda (x) (<= x 0))}. + +\schemedisplay +(nonpositive? 128) ;=> #f +(nonpositive? 0.0) ;=> #t +(nonpositive? 1.8e-15) ;=> #f +(nonpositive? -2/3) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{nonnegative?}{\categoryprocedure}{(nonnegative? \var{real})} +\returns \scheme{#t} if \var{real} is not less than zero, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\scheme{nonnegative?} is equivalent to \scheme{(lambda (x) (>= x 0))}. + +\schemedisplay +(nonnegative? -65) ;=> #f +(nonnegative? 0) ;=> #t +(nonnegative? -0.0121) ;=> #f +(nonnegative? 15/16) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{conjugate}{\categoryprocedure}{(conjugate \var{num})} +\returns complex conjugate of \var{num} +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{conjugate}, when passed a complex argument +$a + bi$, returns its complex conjugate $a + (-b)i$. + +\schemedisplay +(conjugate 3.0+4.0i) ;=> 3.0-4.0i +(conjugate 1e-20-2e-30i) ;=> 1e-20+2e-30i +(conjugate 3) ;=> 3 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{magnitude-squared}{\categoryprocedure}{(magnitude-squared \var{num})} +\returns magnitude of \var{num} squared +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{magnitude-squared}, when passed a complex +argument $a + bi$ returns its magnitude squared, +i.e., $a^2 + b^2$. + +\schemedisplay +(magnitude-squared 3.0-4.0i) ;=> 25.0 +(magnitude-squared 3.0) ;=> 9.0 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sinh}{\categoryprocedure}{(sinh \var{num})} +\formdef{cosh}{\categoryprocedure}{(cosh \var{num})} +\formdef{tanh}{\categoryprocedure}{(tanh \var{num})} +\returns the hyperbolic sine, cosine, or tangent of \var{num} +\listlibraries +\endentryheader + +\schemedisplay +(sinh 0.0) ;=> 0.0 +(cosh 0.0) ;=> 1.0 +(tanh -0.0) ;=> -0.0 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{asinh}{\categoryprocedure}{(asinh \var{num})} +\formdef{acosh}{\categoryprocedure}{(acosh \var{num})} +\formdef{atanh}{\categoryprocedure}{(atanh \var{num})} +\returns the hyperbolic arc sine, arc cosine, or arc tangent of \var{num} +\listlibraries +\endentryheader + + +\schemedisplay +(acosh 0.0) ;=> 0.0+1.5707963267948966i +(acosh 1.0) ;=> 0.0 +(atanh -1.0) ;=> -inf.0 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{string->number}{\categoryprocedure}{(string->number \var{string})} +\formdef{string->number}{\categoryprocedure}{(string->number \var{string} \var{radix})} +\returns the number represented by \var{string}, or \scheme{#f} +\listlibraries +\endentryheader + +\noindent +This procedure is identical to the Revised$^6$ Report version except +that \scheme{radix} may be any exact integer between 2 and 36, inclusive. +The Revised$^6$ Report version requires radix to be in the set +$\{2,8,10,16\}$. + +\schemedisplay +(string->number "211012" 3) ;=> 559 +(string->number "tobeornottobe" 36) ;=> 140613689159812836698 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{number->string}{\categoryprocedure}{(number->string \var{num})} +\formdef{number->string}{\categoryprocedure}{(number->string \var{num} \var{radix})} +\formdef{number->string}{\categoryprocedure}{(number->string \var{num} \var{radix} \var{precision})} +\returns an external representation of \var{num} as a string +\listlibraries +\endentryheader + +\noindent +This procedure is identical to the Revised$^6$ Report version except +that \scheme{radix} may be any exact integer between 2 and 36, inclusive. +The Revised$^6$ Report version requires radix to be in the set +$\{2,8,10,16\}$. + +\schemedisplay +(number->string 10000 4) ;=> "2130100" +(number->string 10000 27) ;=> "DJA" +\endschemedisplay + diff --git a/csug/objects.stex b/csug/objects.stex new file mode 100644 index 0000000..7a468be --- /dev/null +++ b/csug/objects.stex @@ -0,0 +1,3892 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Operations on Objects\label{CHPTOBJECTS}} + +This chapter describes operations specific to {\ChezScheme} on +nonnumeric objects, including standard objects such as pairs and +numbers and {\ChezScheme} extensions such as boxes and records. +Chapter~\ref{CHPTNUMERIC} describes operations on numbers. +See Chapter~\ref{TSPL:CHPTOBJECTS} of {\TSPLFOUR} or the Revised$^6$ Report +on Scheme for a description of standard operations on objects. + +\section{Missing R6RS Type Predicates\label{SECTMISSINGR6RSTYPEPREDS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{enum-set?}{\categoryprocedure}{(enum-set? \var{obj})} +\returns \scheme{#t} if \var{obj} is an enum set, \scheme{#f} otherwise +\listlibraries +\endnoskipentryheader + +This predicate is not defined by the Revised$^6$ Report, but should be. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-constructor-descriptor?}{\categoryprocedure}{(record-constructor-descriptor? \var{obj})} +\returns \scheme{#t} if \var{obj} is a record constructor descriptor, \scheme{#f} otherwise +\listlibraries +\endentryheader + +This predicate is not defined by the Revised$^6$ Report, but should be. + + +\section{Pairs and Lists} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{atom?}{\categoryprocedure}{(atom? \var{obj})} +\returns \scheme{#t} if \var{obj} is not a pair, \scheme{#f} otherwise +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{atom?} is equivalent to \scheme{(lambda (x) (not (pair? x)))}. + +\schemedisplay +(atom? '(a b c)) ;=> #f +(atom? '(3 . 4)) ;=> #f +(atom? '()) ;=> #t +(atom? 3) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{list-head}{\categoryprocedure}{(list-head \var{list} \var{n})} +\returns a list of the first \var{n} elements of \var{list} +\listlibraries +\endentryheader + +\noindent +\var{n} must be an exact nonnegative integer less than or equal to +the length of \var{list}. + +\scheme{list-head} and the standard Scheme procedure \scheme{list-tail} +may be used together to split a list into two separate lists. +While \scheme{list-tail} performs no allocation but instead returns a +sublist of the original list, \scheme{list-head} always returns a copy +of the first portion of the list. + +\scheme{list-head} may be defined as follows. + +\schemedisplay +(define list-head + (lambda (ls n) + (if (= n 0) + '() + (cons (car ls) (list-head (cdr ls) (- n 1)))))) + +(list-head '(a b c) 0) ;=> () +(list-head '(a b c) 2) ;=> (a b) +(list-head '(a b c) 3) ;=> (a b c) +(list-head '(a b c . d) 2) ;=> (a b) +(list-head '(a b c . d) 3) ;=> (a b c) +(list-head '#1=(a . #1#) 5) ;=> (a a a a a) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{last-pair}{\categoryprocedure}{(last-pair \var{list})} +\returns the last pair of a \var{list} +\listlibraries +\endentryheader + +\noindent +\var{list} must not be empty. +\scheme{last-pair} returns the last pair (not the last element) of \var{list}. +\var{list} may be an improper list, in which case the last pair is the +pair containing the last element and the terminating object. + +\schemedisplay +(last-pair '(a b c d)) ;=> (d) +(last-pair '(a b c . d)) ;=> (c . d) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{list-copy}{\categoryprocedure}{(list-copy \var{list})} +\returns a copy of \var{list} +\listlibraries +\endentryheader + +\noindent +\scheme{list-copy} returns a list \scheme{equal?} to \var{list}, using new pairs +to reform the top-level list structure. + +\schemedisplay +(list-copy '(a b c)) ;=> (a b c) + +(let ([ls '(a b c)]) + (equal? ls (list-copy ls))) ;=> #t + +(let ([ls '(a b c)]) + (let ([ls-copy (list-copy ls)]) + (or (eq? ls-copy ls) + (eq? (cdr ls-copy) (cdr ls)) + (eq? (cddr ls-copy) (cddr ls))))) ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{list*}{\categoryprocedure}{(list* \var{obj} \dots \var{final-obj})} +\returns a list of \scheme{\var{obj} \dots} terminated by \var{final-obj} +\listlibraries +\endentryheader + +\noindent +\scheme{list*} is identical to the Revised$^6$ Report \scheme{cons*}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-list}{\categoryprocedure}{(make-list \var{n})} +\formdef{make-list}{\categoryprocedure}{(make-list \var{n} \var{obj})} +\returns a list of \var{n} \var{objs} +\listlibraries +\endentryheader + +\noindent +\var{n} must be a nonnegative integer. +If \var{obj} is omitted, the elements of the list are unspecified. + +\schemedisplay +(make-list 0 '()) ;=> () +(make-list 3 0) ;=> (0 0 0) +(make-list 2 "hi") ;=> ("hi" "hi") +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{iota}{\categoryprocedure}{(iota \var{n})} +\returns a list of integers from 0 (inclusive) to \var{n} (exclusive) +\listlibraries +\endentryheader + +\var{n} must be an exact nonnegative integer. + +\schemedisplay +(iota 0) ;=> () +(iota 5) ;=> (0 1 2 3 4) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{enumerate}{\categoryprocedure}{(enumerate \var{ls})} +\returns a list of integers from 0 (inclusive) to the length of \var{ls} (exclusive) +\listlibraries +\endentryheader + +\schemedisplay +(enumerate '()) ;=> () +(enumerate '(a b c)) ;=> (0 1 2) +(let ([ls '(a b c)]) + (map cons ls (enumerate ls))) ;=> ((a . 0) (b . 1) (c . 2)) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{remq!}{\categoryprocedure}{(remq! \var{obj} \var{list})} +\formdef{remv!}{\categoryprocedure}{(remv! \var{obj} \var{list})} +\formdef{remove!}{\categoryprocedure}{(remove! \var{obj} \var{list})} +\returns a list containing the elements of \var{list} with all occurrences of \var{obj} removed +\listlibraries +\endentryheader + +\noindent +These procedures are similar to the Revised$^6$ Report +\scheme{remq}, \scheme{remv}, and \scheme{remove} procedures, except +\scheme{remq!}, \scheme{remv!} and \scheme{remove!} use pairs from the +input list to build the output list. +They perform less allocation but are not +necessarily faster than their nondestructive counterparts. +Their use can easily lead to confusing or incorrect results if used +indiscriminately. + +\schemedisplay +(remq! 'a '(a b a c a d)) ;=> (b c d) + +(remv! #\a '(#\a #\b #\c)) ;=> (#\b #\c) + +(remove! '(c) '((a) (b) (c))) ;=> ((a) (b)) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{substq}{\categoryprocedure}{(substq \var{new} \var{old} \var{tree})} +\formdef{substv}{\categoryprocedure}{(substv \var{new} \var{old} \var{tree})} +\formdef{subst}{\categoryprocedure}{(subst \var{new} \var{old} \var{tree})} +\formdef{substq!}{\categoryprocedure}{(substq! \var{new} \var{old} \var{tree})} +\formdef{substv!}{\categoryprocedure}{(substv! \var{new} \var{old} \var{tree})} +\formdef{subst!}{\categoryprocedure}{(subst! \var{new} \var{old} \var{tree})} +\returns a tree with \var{new} substituted for occurrences of \var{old} in \var{tree} +\listlibraries +\endentryheader + +\noindent +These procedures traverse \var{tree}, replacing all objects equivalent to +the object \var{old} with the object \var{new}. + +The equivalence test for \scheme{substq} and \scheme{substq!} is \scheme{eq?}, +for \scheme{substv} and \scheme{substv!} is \scheme{eqv?}, +and for \scheme{subst} and \scheme{subst!} is \scheme{equal?}. + +\scheme{substq!}, \scheme{substv!}, and \scheme{subst!} perform the +substitutions destructively. +They perform less allocation but are not +necessarily faster than their nondestructive counterparts. +Their use can easily lead to confusing or incorrect results if used +indiscriminately. + + +\schemedisplay +(substq 'a 'b '((b c) b a)) ;=> ((a c) a a) + +(substv 2 1 '((1 . 2) (1 . 4) . 1)) ;=> ((2 . 2) (2 . 4) . 2) + +(subst 'a + '(a . b) + '((a . b) (c a . b) . c)) ;=> (a (c . a) . c) + +(let ([tr '((b c) b a)]) + (substq! 'a 'b tr) + tr) ;=> ((a c) a a) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{reverse!}{\categoryprocedure}{(reverse! \var{list})} +\returns a list containing the elements of \var{list} in reverse order +\listlibraries +\endentryheader + +\noindent +\scheme{reverse!} destructively reverses \var{list} +by reversing its links. +Using \scheme{reverse!} in place of \scheme{reverse} reduces allocation but is not +necessarily faster than \scheme{reverse}. +Its use can easily lead to confusing or incorrect results if used +indiscriminately. + +\schemedisplay +(reverse! '()) ;=> () +(reverse! '(a b c)) ;=> (c b a) + +(let ([x '(a b c)]) + (reverse! x) + x) ;=> (a) + +(let ([x '(a b c)]) + (set! x (reverse! x)) + x) ;=> (c b a) +\endschemedisplay + + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{append!}{\categoryprocedure}{(append! \var{list} \dots)} +\returns the concatenation of the input lists +\listlibraries +\endentryheader + +\noindent +Like \scheme{append}, +\scheme{append!} returns a new list consisting of the elements of the first +list followed by the elements of the second list, the elements of the +third list, and so on. +Unlike \scheme{append}, +\scheme{append!} reuses the pairs in all of the +arguments in forming the new list. +That is, the last cdr of each list argument but the last is changed to +point to the next list argument. +If any argument but the last is the empty list, it is essentially ignored. +The final argument (which need not be a list) is not altered. + +\scheme{append!} performs less allocation than \scheme{append} but is not +necessarily faster. +Its use can easily lead to confusing or incorrect results if used +indiscriminately. + +\schemedisplay +(append! '(a b) '(c d)) ;=> (a b c d) + +(let ([x '(a b)]) + (append! x '(c d)) + x) ;=> (a b c d) +\endschemedisplay + + + +\section{Characters} + +{\ChezScheme} extends the syntax of characters in two ways. +First, a \scheme{#\} prefix followed by exactly three octal digits is read +as a character whose numeric code is the octal value of the three digits, +e.g., \scheme{#\044} is read as \scheme{#\$}. +Second, it recognizes several nonstandard named characters: +\scheme{#\rubout} (which is the same as \scheme{#\delete}), +\scheme{#\bel} (which is the same as \scheme{#\alarm}), +\scheme{#\vt} (which is the same as \scheme{#\vtab}), +\scheme{#\nel} (the Unicode NEL character), and +\scheme{#\ls} (the Unicode LS character). +The set of nonstandard character names may be changed via the procedure +\index{\scheme{char-name}}\scheme{char-name} (page \ref{desc:char-name}). + +These extensions are disabled in an input stream after \scheme{#!r6rs} has +been seen by the reader, unless \scheme{#!chezscheme} has been seen more +recently. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{char=?}{\categoryprocedure}{(char=? \var{char_1} \var{char_2} \dots)} +\formdef{char?}{\categoryprocedure}{(char>? \var{char_1} \var{char_2} \dots)} +\formdef{char<=?}{\categoryprocedure}{(char<=? \var{char_1} \var{char_2} \dots)} +\formdef{char>=?}{\categoryprocedure}{(char>=? \var{char_1} \var{char_2} \dots)} +\formdef{char-ci=?}{\categoryprocedure}{(char-ci=? \var{char_1} \var{char_2} \dots)} +\formdef{char-ci?}{\categoryprocedure}{(char-ci>? \var{char_1} \var{char_2} \dots)} +\formdef{char-ci<=?}{\categoryprocedure}{(char-ci<=? \var{char_1} \var{char_2} \dots)} +\formdef{char-ci>=?}{\categoryprocedure}{(char-ci>=? \var{char_1} \var{char_2} \dots)} +\returns \scheme{#t} if the relation holds, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +These predicates are identical to the Revised$^6$ Report counterparts, +except they are extended to accept one or more rather than two or more +arguments. +When passed one argument, each of these predicates returns \scheme{#t}. + +\schemedisplay +(char>? #\a) ;=> #t +(char #t +(char-ci=? #\a) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{char-}{\categoryprocedure}{(char- \var{char_1} \var{char_2})} +\returns the integer difference between \var{char_1} and \var{char_2} +\listlibraries +\endentryheader + +\noindent +\scheme{char-} subtracts the integer value of \var{char_2} from the +integer value of \var{char_1} and returns the difference. +The following examples assume that the integer representation is the +ASCII code for the character. + +\schemedisplay +(char- #\f #\e) ;=> 1 + +(define digit-value + ; returns the digit value of the base-r digit c, or #f if c + ; is not a valid digit + (lambda (c r) + (let ([v (cond + [(char<=? #\0 c #\9) (char- c #\0)] + [(char<=? #\A c #\Z) (char- c #\7)] + [(char<=? #\a c #\z) (char- c #\W)] + [else 36])]) + (and (fx< v r) v)))) +(digit-value #\8 10) ;=> 8 +(digit-value #\z 10) ;=> #f +(digit-value #\z 36) ;=> 35 +\endschemedisplay + +\noindent +\scheme{char-} might be defined as follows. + +\schemedisplay +(define char- + (lambda (c1 c2) + (- (char->integer c1) (char->integer c2)))) +\endschemedisplay + +\section{Strings} + +{\ChezScheme} extends the standard string syntax with two character +escapes: \scheme{\'}, which produces the single quote character, and +\scheme{\\var{nnn}}, i.e., backslash followed by 3 octal digits, +which produces the character equivalent of the octal value of +the 3 digits. +These extensions are disabled in an input stream after \scheme{#!r6rs} has +been seen by the reader, unless \scheme{#!chezscheme} has been seen more +recently. + +\index{immutable strings}\index{mutable strings}% +All strings are mutable by default, including constants. +A program can create immutable strings via +\index{\scheme{string->immutable-string}}\scheme{string->immutable-string}. +Any attempt to modify an immutable string causes an exception to be raised. + +The length and indices of a string in {\ChezScheme} are always fixnums. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{string=?}{\categoryprocedure}{(string=? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string?}{\categoryprocedure}{(string>? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string<=?}{\categoryprocedure}{(string<=? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string>=?}{\categoryprocedure}{(string>=? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string-ci=?}{\categoryprocedure}{(string-ci=? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string-ci?}{\categoryprocedure}{(string-ci>? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string-ci<=?}{\categoryprocedure}{(string-ci<=? \var{string_1} \var{string_2} \var{string_3} \dots)} +\formdef{string-ci>=?}{\categoryprocedure}{(string-ci>=? \var{string_1} \var{string_2} \var{string_3} \dots)} +\returns \scheme{#t} if the relation holds, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +These predicates are identical to the Revised$^6$ Report counterparts, +except they are extended to accept one or more rather than two or more +arguments. +When passed one argument, each of these predicates returns \scheme{#t}. + +\schemedisplay +(string>? "a") ;=> #t +(string #t +(string-ci=? "a") ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{string-copy!}{\categoryprocedure}{(string-copy! \var{src} \var{src-start} \var{dst} \var{dst-start} \var{n})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{src} and \var{dst} must be strings, and \var{dst} must be mutable. +\var{src-start}, \var{dst-start}, and \var{n} must be exact nonnegative +integers. +The sum of \var{src-start} and \var{n} must not exceed the length of \var{src}, +and the sum of \var{dst-start} and \var{n} must not exceed the length of \var{dst}. + +\scheme{string-copy!} overwrites the \var{n} bytes of \var{dst} +starting at \var{dst-start} with the \var{n} bytes of \var{dst} +starting at \var{src-start}. +This works even if \var{dst} is the same string as \var{src} and the +source and destination locations overlap. +That is, the destination is filled with the characters that appeared at the +source before the operation began. + +\schemedisplay +(define s1 "to boldly go") +(define s2 (make-string 10 #\-)) + +(string-copy! s1 3 s2 1 3) +s2 ;=> "-bol------" + +(string-copy! s1 7 s2 4 2) +s2 ;=> "-bolly----" + +(string-copy! s2 2 s2 5 4) +s2 ;=> "-bollolly-" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{substring-fill!}{\categoryprocedure}{(substring-fill! \var{string} \var{start} \var{end} \var{char})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{string} must be mutable. +The characters of \var{string} from \var{start} (inclusive) to \var{end} +(exclusive) are set to \var{char}. +\var{start} and \var{end} must be nonnegative integers; \var{start} +must be strictly less than the length of \var{string}, while \var{end} may +be less than or equal to the length of \var{string}. +If $end\le start$, the string is left unchanged. + +\schemedisplay +(let ([str (string-copy "a tpyo typo")]) + (substring-fill! str 2 6 #\X) + str) ;=> "a XXXX typo" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{string-truncate!}{\categoryprocedure}{(string-truncate! \var{string} \var{n})} +\returns \var{string} or the empty string +\listlibraries +\endentryheader + +\noindent +\var{string} must be mutable. +\var{n} must be an exact nonnegative fixnum not greater than the length of +\var{string}. +If \var{n} is zero, \scheme{string-truncate!} returns the empty string. +Otherwise, \var{string-truncate!} destructively truncates \var{string} to +its first \var{n} characters and returns \var{string}. + +\schemedisplay +(define s (make-string 7 #\$)) +(string-truncate! s 0) ;=> "" +s ;=> "$$$$$$$" +(string-truncate! s 3) ;=> "$$$" +s ;=> "$$$" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutable-string?}{\categoryprocedure}{(mutable-string? \var{obj})} +\returns \scheme{#t} if \var{obj} is a mutable string, \scheme{#f} otherwise +\formdef{immutable-string?}{\categoryprocedure}{(immutable-string? \var{obj})} +\returns \scheme{#t} if \var{obj} is an immutable string, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(mutable-string? (string #\a #\b #\c)) ;=> #t +(mutable-string? (string->immutable-string "abc")) ;=> #f +(immutable-string? (string #\a #\b #\c)) ;=> #f +(immutable-string? (string->immutable-string "abc")) ;=> #t +(immutable-string? (cons 3 4)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{string->immutable-string}{\categoryprocedure}{(string->immutable-string \var{string})} +\returns an immutable string equal to \var{string} +\listlibraries +\endentryheader + +\noindent +\index{immutable strings}\index{mutable strings}% +The result is \var{string} itself if \var{string} +is immutable; otherwise, the result is an immutable string with the same content as \var{string}. + +\schemedisplay +(define s (string->immutable-string (string #\x #\y #\z))) +(string-set! s 0 #\a) ;=> \var{exception: not mutable} +\endschemedisplay + + +\section{Vectors} + +{\ChezScheme} extends the syntax of vectors to allow the length of the +vector to be specified between the \scheme{#} and open parenthesis, e.g., +\scheme{#3(a b c)}. +If fewer elements are supplied in the syntax than the specified length, +each element after the last printed element is the same as the last +printed element. +This extension is disabled in an input stream after \scheme{#!r6rs} has +been seen by the reader, unless \scheme{#!chezscheme} has been seen more +recently. + +The length and indices of a vector in {\ChezScheme} are always fixnums. + +\index{immutable vectors}\index{mutable vectors}% +All vectors are mutable by default, including constants. +A program can create immutable vectors via +\index{\scheme{vector->immutable-vector}}\scheme{vector->immutable-vector}. +Any attempt to modify an immutable vector causes an exception to be raised. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{vector-copy}{\categoryprocedure}{(vector-copy \var{vector})} +\returns a copy of \var{vector} +\listlibraries +\endentryheader + +\noindent +\scheme{vector-copy} creates a new vector of the same length and contents +as \var{vector}. +The elements themselves are not copied. + +\schemedisplay +(vector-copy '#(a b c)) ;=> #(a b c) + +(let ([v '#(a b c)]) + (eq? v (vector-copy v))) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{vector-set-fixnum!}{\categoryprocedure}{(vector-set-fixnum! \var{vector} \var{n} \var{fixnum})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{vector} must be mutable. +\scheme{vector-set-fixnum!} changes the \var{n}th element of \var{vector} to \var{fixnum}. +\var{n} must be an exact nonnegative integer strictly less than +the length of \var{vector}. + +It is faster to store a fixnum than an arbitrary value, +since for arbitrary values, the system has to record potential assignments from older to +younger objects to support generational garbage collection. +Care must be taken to ensure that the argument is indeed a fixnum, however; +otherwise, the collector may not properly track the assignment. +The primitive performs a fixnum check on the argument except at +optimization level~3. + +See also the description of fixnum-only vectors (fxvectors) below. + +\schemedisplay +(let ([v (vector 1 2 3 4 5)]) + (vector-set-fixnum! v 2 73) + v) ;=> #(1 2 73 4 5) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{vector-cas!}{\categoryprocedure}{(vector-cas! \var{vector} \var{n} \var{old-obj} \var{new-obj})} +\returns \scheme{#t} if \var{vector} is changed, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\var{vector} must be mutable. +\scheme{vector-cas!} atomically changes the \var{n}th element of \var{vector} to \var{new-obj} +if the replaced \var{n}th element is \scheme{eq?} to \var{old-obj}. +If the \var{n}th element of \var{vector} that would be replaced +is not \scheme{eq?} to \var{old-obj}, then +\var{vector} is unchanged. + +\schemedisplay +(define v (vector 'old0 'old1 'old2)) +(vector-cas! v 1 'old1 'new1) ;=> #t +(vector-ref v 1) ;=> 'new1 +(vector-cas! v 2 'old1 'new2) ;=> #f +(vector-ref v 2) ;=> 'old2 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutable-vector?}{\categoryprocedure}{(mutable-vector? \var{obj})} +\returns \scheme{#t} if \var{obj} is a mutable vector, \scheme{#f} otherwise +\formdef{immutable-vector?}{\categoryprocedure}{(immutable-vector? \var{obj})} +\returns \scheme{#t} if \var{obj} is an immutable vector, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(mutable-vector? (vector 1 2 3)) ;=> #t +(mutable-vector? (vector->immutable-vector (vector 1 2 3))) ;=> #f +(immutable-vector? (vector 1 2 3)) ;=> #f +(immutable-vector? (vector->immutable-vector (vector 1 2 3))) ;=> #t +(immutable-vector? (cons 3 4)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{vector->immutable-vector}{\categoryprocedure}{(vector->immutable-vector \var{vector})} +\returns an immutable vector equal to \var{vector} +\listlibraries +\endentryheader + +\noindent +\index{immutable vectors}\index{mutable vectors}% +The result is \var{vector} itself if \var{vector} +is immutable; otherwise, the result is an immutable vector with the same content as \var{vector}. + +\schemedisplay +(define v (vector->immutable-vector (vector 1 2 3))) +(vector-set! v 0 0) ;=> \var{exception: not mutable} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{self-evaluating-vectors}{\categorythreadparameter}{self-evaluating-vectors} +\listlibraries +\endentryheader + +\noindent +The default value of this parameter is \scheme{#f}, meaning that vector literals must be quoted, as +required by the Revised$^6$ Report. +Setting \scheme{self-evaluating-vectors} to a true value may be useful to provide compatibility with +R$^7$RS, as the latter states that vectors are self-evaluating. + +\schemedisplay +#(a b c) ;=> \var{exception: invalid syntax} + +(self-evaluating-vectors #t) +#(a b c) ;=> #(a b c) +\endschemedisplay + +\section{Fixnum-Only Vectors\label{SECTFXVECTORS}} + +\index{fxvectors}% +Fixnum-only vectors, or ``fxvectors,'' are like vectors but contain +only fixnums. +Fxvectors are written with the \scheme{#vfx} prefix in place of the +\scheme{#} prefix for vectors, e.g., \scheme{#vfx(1 2 3)} or +\scheme{#10vfx(2)}. +The fxvector syntax is disabled in an input stream after \scheme{#!r6rs} +has been seen by the reader, unless \scheme{#!chezscheme} has been seen +more recently. + +The length and indices of an fxvector are always fixnums. + +Updating an fxvector is generally less expensive than updating a vector, +since for vectors, the system records potential assignments from older to +younger objects to support generational garbage collection. +The storage management system also takes advantage of the fact that +fxvectors contain no pointers to place them in an area of memory that +does not have to be traced during collection. + +\index{immutable fxvectors}\index{mutable fxvectors}% +All fxvectors are mutable by default, including constants. +A program can create immutable fxvectors via +\index{\scheme{fxvector->immutable-fxvector}}\scheme{fxvector->immutable-fxvector}. +Any attempt to modify an immutable fxvector causes an exception to be raised. + +See also \scheme{vector-set-fixnum!} above. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector?}{\categoryprocedure}{(fxvector? \var{obj})} +\returns \scheme{#t} if \var{obj} is an fxvector, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(fxvector? #vfx()) ;=> #t +(fxvector? #vfx(1 2 3)) ;=> #t +(fxvector? (fxvector 1 2 3)) ;=> #t +(fxvector? '#(a b c)) ;=> #f +(fxvector? '(a b c)) ;=> #f +(fxvector? "abc") ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector}{\categoryprocedure}{(fxvector \var{fixnum} \dots)} +\returns an fxvector of the fixnums \scheme{\var{fixnum} \dots} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(fxvector) ;=> #vfx() +(fxvector 1 3 5) ;=> #vfx(1 3 5) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-fxvector}{\categoryprocedure}{(make-fxvector \var{n})} +\formdef{make-fxvector}{\categoryprocedure}{(make-fxvector \var{n} \var{fixnum})} +\returns an fxvector of length \var{n} +\listlibraries +\endentryheader + +\noindent +\var{n} must be a fixnum. +If \var{fixnum} is supplied, each element of the fxvector is initialized +to \var{fixnum}; otherwise, the elements are unspecified. + +\schemedisplay +(make-fxvector 0) ;=> #vfx() +(make-fxvector 0 7) ;=> #vfx() +(make-fxvector 5 7) ;=> #vfx(7 7 7 7 7) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector-length}{\categoryprocedure}{(fxvector-length \var{fxvector})} +\returns the number of elements in \var{fxvector} +\listlibraries +\endentryheader + +\schemedisplay +(fxvector-length #vfx()) ;=> 0 +(fxvector-length #vfx(1 2 3)) ;=> 3 +(fxvector-length #10vfx(1 2 3)) ;=> 10 +(fxvector-length (fxvector 1 2 3 4)) ;=> 4 +(fxvector-length (make-fxvector 300)) ;=> 300 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector-ref}{\categoryprocedure}{(fxvector-ref \var{fxvector} \var{n})} +\returns the \var{n}th element (zero-based) of \var{fxvector} +\listlibraries +\endentryheader + +\noindent +\var{n} must be a nonnegative fixnum strictly less than +the length of \var{fxvector}. + +\schemedisplay +(fxvector-ref #vfx(-1 2 4 7) 0) ;=> -1 +(fxvector-ref #vfx(-1 2 4 7) 1) ;=> 2 +(fxvector-ref #vfx(-1 2 4 7) 3) ;=> 7 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector-set!}{\categoryprocedure}{(fxvector-set! \var{fxvector} \var{n} \var{fixnum})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{fxvector} must be mutable. +\var{n} must be a nonnegative fixnum strictly less than +the length of \var{fxvector}. +\scheme{fxvector-set!} changes the \var{n}th element of \var{fxvector} to \var{fixnum}. + +\schemedisplay +(let ([v (fxvector 1 2 3 4 5)]) + (fxvector-set! v 2 (fx- (fxvector-ref v 2))) + v) ;=> #vfx(1 2 -3 4 5) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector-fill!}{\categoryprocedure}{(fxvector-fill! \var{fxvector} \var{fixnum})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{fxvector} must be mutable. +\scheme{fxvector-fill!} replaces each element of \var{fxvector} with \var{fixnum}. + +\schemedisplay +(let ([v (fxvector 1 2 3)]) + (fxvector-fill! v 0) + v) ;=> #vfx(0 0 0) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector->list}{\categoryprocedure}{(fxvector->list \var{fxvector})} +\returns a list of the elements of \var{fxvector} +\listlibraries +\endentryheader + +\schemedisplay +(fxvector->list (fxvector)) ;=> () +(fxvector->list #vfx(7 5 2)) ;=> (7 5 2) + +(let ([v #vfx(1 2 3 4 5)]) + (apply fx* (fxvector->list v))) ;=> 120 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{list->fxvector}{\categoryprocedure}{(list->fxvector \var{list})} +\returns an fxvector of the elements of \var{list} +\listlibraries +\endentryheader + +\noindent +\var{list} must consist entirely of fixnums. + +\schemedisplay +(list->fxvector '()) ;=> #vfx() +(list->fxvector '(3 5 7)) ;=> #vfx(3 5 7) + +(let ([v #vfx(1 2 3 4 5)]) + (let ([ls (fxvector->list v)]) + (list->fxvector (map fx* ls ls)))) ;=> #vfx(1 4 9 16 25) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector-copy}{\categoryprocedure}{(fxvector-copy \var{fxvector})} +\returns a copy of \var{fxvector} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{fxvector-copy} creates a new fxvector with the same length and contents +as \var{fxvector}. + +\schemedisplay +(fxvector-copy #vfx(3 4 5)) ;=> #vfx(3 4 5) + +(let ([v #vfx(3 4 5)]) + (eq? v (fxvector-copy v))) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutable-fxvector?}{\categoryprocedure}{(mutable-fxvector? \var{obj})} +\returns \scheme{#t} if \var{obj} is a mutable fxvector, \scheme{#f} otherwise +\formdef{immutable-fxvector?}{\categoryprocedure}{(immutable-fxvector? \var{obj})} +\returns \scheme{#t} if \var{obj} is an immutable fxvector, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(mutable-fxvector? (fxvector 1 2 3)) ;=> #t +(mutable-fxvector? (fxvector->immutable-fxvector (fxvector 1 2 3))) ;=> #f +(immutable-fxvector? (fxvector 1 2 3)) ;=> #f +(immutable-fxvector? (fxvector->immutable-fxvector (fxvector 1 2 3))) ;=> #t +(immutable-fxvector? (cons 3 4)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fxvector->immutable-fxvector}{\categoryprocedure}{(fxvector->immutable-fxvector \var{fxvector})} +\returns either an immutable copy of \var{fxvector} or \var{fxvector} itself +\listlibraries +\endentryheader + +\noindent +\index{immutable fxvectors}\index{mutable fxvectors}% +The result is \var{fxvector} itself if \var{fxvector} +is immutable; otherwise, the result is an immutable fxvector with the same content as \var{fxvector}. + +\schemedisplay +(define v (fxvector->immutable-fxvector (fxvector 1 2 3))) +(fxvector-set! v 0 0) ;=> \var{exception: not mutable} +\endschemedisplay + + +\section{Bytevectors\label{SECTBYTEVECTORS}} + +As with vectors, {\ChezScheme} extends the syntax of bytevectors to allow +the length of the vector to be specified between the \scheme{#} and open +parenthesis, e.g., \scheme{#3vu8(1 105 73)}. +If fewer elements are supplied in the syntax than the specified length, +each element after the last printed element is the same as the last +printed element. +This extension is disabled in an input stream after \scheme{#!r6rs} has +been seen by the reader, unless \scheme{#!chezscheme} has been seen more +recently. + +{\ChezScheme} also extends the set of bytevector primitives, including +primitives for loading and storing 3, 5, 6, and 7-byte quantities. + +The length and indices of a bytevector in {\ChezScheme} are always fixnums. + +\index{immutable bytevectors}\index{mutable bytevectors}% +All bytevectors are mutable by default, including constants. +A program can create immutable bytevectors via +\index{\scheme{bytevector->immutable-bytevector}}\scheme{bytevector->immutable-bytevector}. +Any attempt to modify an immutable bytevector causes an exception to be raised. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector}{\categoryprocedure}{(bytevector \var{fill} \dots)} +\returns a new bytevector containing \scheme{\var{fill} \dots} +\listlibraries +\endentryheader + +Each \var{fill} value must be an exact integer representing a signed or +unsigned 8-bit value, i.e., +a value in the range -128 to 255 inclusive. +A negative fill value is treated as its two's complement equivalent. + +\schemedisplay +(bytevector) ;=> #vu8() +(bytevector 1 3 5) ;=> #vu8(1 3 5) +(bytevector -1 -3 -5) ;=> #vu8(255 253 251) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector->s8-list}{\categoryprocedure}{(bytevector->s8-list \var{bytevector})} +\returns a new list of the 8-bit signed elements of \var{bytevector} +\listlibraries +\endentryheader + +The values in the returned list are exact eight-bit signed integers, +i.e., values in the range -128 to 127 inclusive. +\scheme{bytevector->s8-list} is similar to the Revised$^6$ Report +\scheme{bytevector->u8-list} except the values in the returned list +are signed rather than unsigned. + +\schemedisplay +(bytevector->s8-list (make-bytevector 0)) ;=> () +(bytevector->s8-list #vu8(1 127 128 255)) ;=> (1 127 -128 -1) + +(let ([v #vu8(1 2 3 255)]) + (apply * (bytevector->s8-list v))) ;=> -6 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{s8-list->bytevector}{\categoryprocedure}{(s8-list->bytevector \var{list})} +\returns a new bytevector of the elements of \var{list} +\listlibraries +\endentryheader + +\var{list} must consist entirely of exact eight-bit signed integers, i.e., +values in the range -128 to 127 inclusive. +\scheme{s8-list->bytevector} is similar to the Revised$^6$ Report +procedure +\scheme{u8-list->bytevector}, except the elements of the input list +are signed rather than unsigned. + +\schemedisplay +(s8-list->bytevector '()) ;=> #vu8() +(s8-list->bytevector '(1 127 -128 -1)) ;=> #vu8(1 127 128 255) + +(let ([v #vu8(1 2 3 4 5)]) + (let ([ls (bytevector->s8-list v)]) + (s8-list->bytevector (map - ls)))) ;=> #vu8(255 254 253 252 251) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector-truncate!}{\categoryprocedure}{(bytevector-truncate! \var{bytevector} \var{n})} +\returns \var{bytevector} or the empty bytevector +\listlibraries +\endentryheader + +\noindent +\var{bytevector} must be mutable. +\var{n} must be an exact nonnegative fixnum not greater than the length of +\var{bytevector}. +If \var{n} is zero, \scheme{bytevector-truncate!} returns the empty bytevector. +Otherwise, \var{bytevector-truncate!} destructively truncates \var{bytevector} to +its first \var{n} bytes and returns \var{bytevector}. + +\schemedisplay +(define bv (make-bytevector 7 19)) +(bytevector-truncate! bv 0) ;=> #vu8() +bv ;=> #vu8(19 19 19 19 19 19 19) +(bytevector-truncate! bv 3) ;=> #vu8(19 19 19) +bv ;=> #vu8(19 19 19) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector-u24-ref}{\categoryprocedure}{(bytevector-u24-ref \var{bytevector} \var{n} \var{eness})} +\returns the 24-bit unsigned integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-s24-ref}{\categoryprocedure}{(bytevector-s24-ref \var{bytevector} \var{n} \var{eness})} +\returns the 24-bit signed integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-u40-ref}{\categoryprocedure}{(bytevector-u40-ref \var{bytevector} \var{n} \var{eness})} +\returns the 40-bit unsigned integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-s40-ref}{\categoryprocedure}{(bytevector-s40-ref \var{bytevector} \var{n} \var{eness})} +\returns the 40-bit signed integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-u48-ref}{\categoryprocedure}{(bytevector-u48-ref \var{bytevector} \var{n} \var{eness})} +\returns the 48-bit unsigned integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-s48-ref}{\categoryprocedure}{(bytevector-s48-ref \var{bytevector} \var{n} \var{eness})} +\returns the 48-bit signed integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-u56-ref}{\categoryprocedure}{(bytevector-u56-ref \var{bytevector} \var{n} \var{eness})} +\returns the 56-bit unsigned integer at index \var{n} (zero-based) of \var{bytevector} +\formdef{bytevector-s56-ref}{\categoryprocedure}{(bytevector-s56-ref \var{bytevector} \var{n} \var{eness})} +\returns the 56-bit signed integer at index \var{n} (zero-based) of \var{bytevector} +\listlibraries +\endentryheader + +\noindent +\var{n} must be an exact nonnegative integer and +indexes the starting byte of the value. +The sum of \var{n} and the number of bytes occupied by the value +(3 for 24-bit values, 5 for 40-bit values, 6 for 48-bit values, +and 7 for 56-bit values) must not exceed the length of \var{bytevector}. +\var{eness} must be a valid endianness symbol naming the endianness. + +The return value is an exact integer in the appropriate range for +the number of bytes occupied by the value. +Signed values are the equivalent of the stored value treated as a two's +complement value. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector-u24-set!}{\categoryprocedure}{(bytevector-u24-set! \var{bytevector} \var{n} \var{u24} \var{eness})} +\formdef{bytevector-s24-set!}{\categoryprocedure}{(bytevector-s24-set! \var{bytevector} \var{n} \var{s24} \var{eness})} +\formdef{bytevector-u40-set!}{\categoryprocedure}{(bytevector-u40-set! \var{bytevector} \var{n} \var{u40} \var{eness})} +\formdef{bytevector-s40-set!}{\categoryprocedure}{(bytevector-s40-set! \var{bytevector} \var{n} \var{s40} \var{eness})} +\formdef{bytevector-u48-set!}{\categoryprocedure}{(bytevector-u48-set! \var{bytevector} \var{n} \var{u48} \var{eness})} +\formdef{bytevector-s48-set!}{\categoryprocedure}{(bytevector-s48-set! \var{bytevector} \var{n} \var{s48} \var{eness})} +\formdef{bytevector-u56-set!}{\categoryprocedure}{(bytevector-u56-set! \var{bytevector} \var{n} \var{u56} \var{eness})} +\formdef{bytevector-s56-set!}{\categoryprocedure}{(bytevector-s56-set! \var{bytevector} \var{n} \var{s56} \var{eness})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{bytevector} must be mutable. +\var{n} must be an exact nonnegative integer and +indexes the starting byte of the value. +The sum of \var{n} and the number of bytes occupied by the value must +not exceed the length of \var{bytevector}. +\var{u24} must be a 24-bit unsigned value, i.e., a value in the range +0 to $2^{24}-1$ inclusive; +\var{s24} must be a 24-bit signed value, i.e., a value in the range +$-2^{23}$ to $2^{23}-1$ inclusive; +\var{u40} must be a 40-bit unsigned value, i.e., a value in the range +0 to $2^{40}-1$ inclusive; +\var{s40} must be a 40-bit signed value, i.e., a value in the range +$-2^{39}$ to $2^{39}-1$ inclusive; +\var{u48} must be a 48-bit unsigned value, i.e., a value in the range +0 to $2^{48}-1$ inclusive; +\var{s48} must be a 48-bit signed value, i.e., a value in the range +$-2^{47}$ to $2^{47}-1$ inclusive; +\var{u56} must be a 56-bit unsigned value, i.e., a value in the range +0 to $2^{56}-1$ inclusive; and +\var{s56} must be a 56-bit signed value, i.e., a value in the range +$-2^{55}$ to $2^{55}-1$ inclusive. +\var{eness} must be a valid endianness symbol naming the endianness. + +These procedures store the given value in the 3, 5, 6, or 7 bytes starting +at index \var{n} (zero-based) of \var{bytevector}. +Negative values are stored as their two's complement equivalent. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutable-bytevector?}{\categoryprocedure}{(mutable-bytevector? \var{obj})} +\returns \scheme{#t} if \var{obj} is a mutable bytevector, \scheme{#f} otherwise +\formdef{immutable-bytevector?}{\categoryprocedure}{(immutable-bytevector? \var{obj})} +\returns \scheme{#t} if \var{obj} is an immutable bytevector, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(mutable-bytevector? (bytevector 1 2 3)) ;=> #t +(mutable-bytevector? + (bytevector->immutable-bytevector (bytevector 1 2 3))) ;=> #f +(immutable-bytevector? (bytevector 1 2 3)) ;=> #f +(immutable-bytevector? + (bytevector->immutable-bytevector (bytevector 1 2 3))) ;=> #t +(immutable-bytevector? (cons 3 4)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector->immutable-bytevector}{\categoryprocedure}{(bytevector->immutable-bytevector \var{bytevector})} +\returns an immutable bytevector equal to \var{bytevector} +\listlibraries +\endentryheader + +\noindent +\index{immutable bytevectors}\index{mutable bytevectors}% +The result is \var{bytevector} itself if \var{bytevector} +is immutable; otherwise, the result is an immutable bytevector with the same content as \var{bytevector}. + +\schemedisplay +(define bv (bytevector->immutable-bytevector (bytevector 1 2 3))) +(bytevector-u8-set! bv 0 0) ;=> \var{exception: not mutable} +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector-compress}{\categoryprocedure}{(bytevector-compress \var{bytevector})} +\returns a new bytevector containing compressed content of \var{bytevector} +\listlibraries +\endentryheader + +\noindent +The result is the raw compressed data with a minimal header to record +the uncompressed size and the compression mode. The result does not include +the header that is written by port-based compression using the +\scheme{compressed} option. The compression format is determined by the +\index{\scheme{compress-format}}\scheme{compress-format} +parameter, and the compression level is determined by the +\index{\scheme{compress-level}}\scheme{compress-level} +parameter. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytevector-uncompress}{\categoryprocedure}{(bytevector-uncompress \var{bytevector})} +\returns a bytevector containing uncompressed content of \var{bytevector} +\listlibraries +\endentryheader + +\noindent +Uncompresses a \var{bytevector} produced by +\scheme{bytevector-compress} to a new bytevector with the same content +as the original given to \scheme{bytevector-compress}. + + +\section{Boxes\label{SECTBOXES}} + +\index{boxes}Boxes are single-cell objects that are primarily useful for providing +an ``extra level of indirection.'' +This extra level of indirection is typically used to allow more than one body +of code or data structure to share a \index{reference}reference, or \index{pointer}pointer, to an object. +For example, boxes may be used to implement \index{call-by-reference}\emph{call-by-reference} semantics +in an interpreter for a language employing this parameter passing discipline. + +\index{\scheme{#&} (box prefix)}Boxes are written with +the prefix \scheme{#&} (pronounced ``hash-ampersand''). +For example, \scheme{#&(a b c)} is a box holding the list \scheme{(a b c)}. +The box syntax is disabled in an input stream after \scheme{#!r6rs} has +been seen by the reader, unless \scheme{#!chezscheme} has been seen more +recently. + +\index{immutable boxes}\index{mutable boxes}% +All boxes are mutable by default, including constants. +A program can create immutable boxes via +\index{\scheme{box-immutable}}\scheme{box-immutable}. +Any attempt to modify an immutable box causes an exception to be raised. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{box?}{\categoryprocedure}{(box? \var{obj})} +\returns \scheme{#t} if \var{obj} is a box, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(box? '#&a) ;=> #t +(box? 'a) ;=> #f +(box? (box 3)) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{box}{\categoryprocedure}{(box \var{obj})} +\returns a new box containing \var{obj} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(box 'a) ;=> #&a +(box (box '(a b c))) ;=> #&#&(a b c) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{unbox}{\categoryprocedure}{(unbox \var{box})} +\returns contents of \var{box} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(unbox #&a) ;=> a +(unbox #&#&(a b c)) ;=> #&(a b c) + +(let ([b (box "hi")]) + (unbox b)) ;=> "hi" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-box!}{\categoryprocedure}{(set-box! \var{box} \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{box} must be mutable. +\scheme{set-box!} sets the contents of \var{box} to \var{obj}. + +\schemedisplay +(let ([b (box 'x)]) + (set-box! b 'y) + b) ;=> #&y + +(let ([incr! + (lambda (x) + (set-box! x (+ (unbox x) 1)))]) + (let ([b (box 3)]) + (incr! b) + (unbox b))) ;=> 4 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{box-cas!}{\categoryprocedure}{(box-cas! \var{box} \var{old-obj} \var{new-obj})} +\returns \scheme{#t} if \var{box} is changed, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noindent +\var{box} must be mutable. +\scheme{box-cas!} atomically changes the content of \var{box} to \var{new-obj} +if the replaced content is \scheme{eq?} to \var{old-obj}. +If the content of \var{box} that would be replaced is not \scheme{eq?} to \var{old-obj}, then +\var{box} is unchanged. + +\schemedisplay +(define b (box 'old)) +(box-cas! b 'old 'new) ;=> #t +(unbox b) ;=> 'new +(box-cas! b 'other 'wrong) ;=> #f +(unbox b) ;=> 'new +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutable-box?}{\categoryprocedure}{(mutable-box? \var{obj})} +\returns \scheme{#t} if \var{obj} is a mutable box, \scheme{#f} otherwise +\formdef{immutable-box?}{\categoryprocedure}{(immutable-box? \var{obj})} +\returns \scheme{#t} if \var{obj} is an immutable box, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(mutable-box? (box 1)) ;=> #t +(mutable-box? (box-immutable 1)) ;=> #f +(immutable-box? (box 1)) ;=> #f +(immutable-box? (box-immutable 1)) ;=> #t +(mutable-box? (cons 3 4)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{box-immutable}{\categoryprocedure}{(box-immutable \var{obj})} +\returns a new immutable box containing \var{obj} +\listlibraries +\endentryheader + +\noindent +\index{immutable boxes}\index{mutable boxes}% +Boxes are typically intended to support shared, mutable structure, so immutable boxes +are not often useful. + +\schemedisplay +(define b (box-immutable 1)) +(set-box! b 0) ;=> \var{exception: not mutable} +\endschemedisplay + + +\section{Symbols\label{SECTMISCSYMBOLS}} + +{\ChezScheme} extends the standard symbol syntax in several ways: + +\begin{itemize} +\item +Symbol names may begin with \scheme{@}, but \scheme{,@abc} is parsed +as \scheme{(unquote-splicing abc)}; to produce \scheme{(unquote @abc)} +one can type \scheme{, @abc}, \scheme{\x40;abc}, or \scheme{,|@abc|}. + +\item +The single-character sequences \scheme{\schlbrace} and \scheme{\schrbrace} +are read as symbols. + +\item +A symbol's name may begin with any character that might normally start a +number, including a digit, \scheme{.}, \scheme{+}, \scheme{-}, as long as +the delimited sequence of characters starting with that character cannot +be parsed as a number. + +\item +A symbol whose name contains arbitrary characters may be written by +escaping them with \scheme{\} or with \scheme{|}. +\scheme{\} is used to escape a single character (except 'x', since +\scheme{\x} marks the start of a hex scalar value), +whereas \scheme{|} is used +to escape the group of characters that follow it up through the +matching \scheme{|}. +\end{itemize} + +The printer always prints symbols using the standard R6RS syntax, so that, +e.g., \scheme{@abc} prints as \scheme{\x40;abc} and \scheme{1-} prints as +\scheme{\x31;-}. ' + +Gensyms are printed +\index{\scheme{#\schlbrace} (gensym prefix)}\scheme{#\schlbrace} and +\scheme{\schrbrace} brackets that enclose both the ``pretty'' and ``unique'' +names, +e.g., \scheme{#\schlbrace\raw{{}}g1426 e5g1c94g642dssw-a\schrbrace}. +They may also be printed using the pretty name only with the prefix +\index{\scheme{#:} (gensym prefix)}\scheme{#:}, e.g., +\scheme{#:g1426}. + +These extensions are disabled in an input stream after \scheme{#!r6rs} has +been seen by the reader, unless \scheme{#!chezscheme} has been seen more +recently. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:gensym} +\formdef{gensym}{\categoryprocedure}{(gensym)} +\formdef{gensym}{\categoryprocedure}{(gensym \var{pretty-name})} +\formdef{gensym}{\categoryprocedure}{(gensym \var{pretty-name} \var{unique-name})} +\returns a unique generated symbol +\listlibraries +\endentryheader + +\noindent +\index{gensyms}\index{generated symbols}Each +call to \scheme{gensym} returns a unique generated symbol, or \emph{gensym}. +Each generated symbol has two names: a ``pretty'' name and a +``unique'' name. + +In the first form above, the pretty name is formed (lazily---see +below) by combining an +internal prefix with the value of an internal counter. +After each name is formed, the internal counter is incremented. +The parameters \scheme{gensym-prefix} and +\scheme{gensym-count}, described below, may be used to access and set +the internal prefix and counter. +By default, the prefix is the single-character string \scheme{"g"}. +In the second and third forms, the pretty name of the new gensym +is \var{pretty-name}, which must be a string. +The pretty name of a gensym is returned by the procedure +\scheme{symbol->string}. + +In both the first and second forms, the unique name is an +automatically generated globally unique name. +Globally unique names are constructed (lazily---see below) from the +combination of a universally unique identifier and an internal +counter. +In the third form of gensym, the unique name of the new gensym is +\var{unique-name}, which must be a string. +The unique name of a gensym may be obtained via the procedure +\scheme{gensym->unique-string}. + +The unique name allows gensyms to be written in such a way that they +can be read back and reliably commonized on input. +\index{\scheme{#\schlbrace} (gensym prefix)}The syntax for gensyms +includes both the pretty name and the unique name, as shown in the +example below: + +\schemedisplay +(gensym) ;=> #{g0 bcsfg5eq4e9b3h9o-a} +\endschemedisplay + +\noindent +When the parameter \index{\scheme{print-gensym}}\scheme{print-gensym} is set to \scheme{pretty}, +the printer prints the pretty name only, with a +\index{\scheme{#:} (gensym prefix)}\scheme{#:} syntax, so + +\schemedisplay +(parameterize ([print-gensym 'pretty]) + (write (gensym))) +\endschemedisplay + +prints \scheme{#:g0}. + +When the reader sees the \scheme{#:} syntax, it produces a gensym with +the given pretty name, but the original unique name is lost. + +When the parameter is set to \scheme{#f}, the printer prints just the +pretty name, so + +\schemedisplay +(parameterize ([print-gensym #f]) + (write (gensym))) +\endschemedisplay + +\noindent +prints \scheme{g0}. +This is useful only when gensyms do not need to be read back in +as gensyms. + +In order to reduce construction and (when threaded) synchronization +overhead when gensyms are frequently created but rarely printed or +stored in an object file, generated pretty and unique names are created +lazily, i.e., not until first requested, either by the printer, fasl +writer, or explicitly by one of the procedures \scheme{symbol->string} +or \scheme{gensym->unique-string}. +In addition, a gensym is not placed into the system's internal symbol +table (the oblist; see page~\pageref{desc:oblist}) until the unique name +is requested. +This allows a gensym to be reclaimed by the storage manager +if no references to the gensym exist and no unique name exists by which to +access it, even if it has a top-level binding or a nonempty property +list. + +\schemedisplay +(define x (gensym)) +x ;=> #{g2 bcsfg5eq4e9b3h9o-c} +(symbol->string x) ;=> "g2" +(gensym->unique-string x) ;=> "bcsfg5eq4e9b3h9o-c" +\endschemedisplay + +Gensyms subsume the notion of \index{uninterned symbols}\emph{uninterned +symbols} supported by earlier versions of {\ChezScheme}. +Similarly, the predicate +\index{uninterned-symbol?}\scheme{uninterned-symbol?} has been replaced +by \scheme{gensym?}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{gensym-prefix}{\categorythreadparameter}{gensym-prefix} +\formdef{gensym-count}{\categorythreadparameter}{gensym-count} +\listlibraries +\endentryheader + +\noindent +\index{\scheme{gensym}}The parameters \scheme{gensym-prefix} and +\scheme{gensym-count} are used to access and set the internal prefix +and counter from which the pretty name of a gensym +is generated when \scheme{gensym} is not given an explicit string +argument. +\scheme{gensym-prefix} defaults to the string \scheme{"g"} and may be +set to any object. +\scheme{gensym-count} starts at 0 and may be set to any nonnegative +integer. + +As described above, {\ChezScheme} delays the creation +of the pretty name until the name is first requested by the printer or by +an explicit call to \scheme{symbol->string}. +These parameters are not consulted until that time; setting them when +\scheme{gensym} is called thus has no effect on the generated name. + +\schemedisplay +(let ([x (parameterize ([gensym-prefix "genny"] + [gensym-count 17] + [print-gensym 'pretty]) + (gensym))]) + (format "~s" x)) ;=> "#{g4 bcsfg5eq4e9b3h9o-e}" +(let ([x (gensym)]) + (parameterize ([gensym-prefix "genny"] + [gensym-count 17] + [print-gensym #f]) + (format "~s" (gensym)))) ;=> "genny17" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{gensym->unique-string}{\categoryprocedure}{(gensym->unique-string \var{gensym})} +\returns the unique name of \var{gensym} +\listlibraries +\endentryheader + +\noskip\schemedisplay +(gensym->unique-string (gensym)) ;=> "bd3kufa7ypjcuvut-g" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{gensym?}{\categoryprocedure}{(gensym? \var{obj})} +\returns \scheme{#t} if \var{obj} is gensym, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(gensym? (string->symbol "z")) ;=> #f +(gensym? (gensym "z")) ;=> #t +(gensym? 'a) ;=> #f +(gensym? 3) ;=> #f +(gensym? (gensym)) ;=> #t +(gensym? '#{g2 bcsfg5eq4e9b3h9o-c}) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader\label{property-lists} +\formdef{putprop}{\categoryprocedure}{(putprop \var{symbol} \var{key} \var{value})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +{\ChezScheme} associates a \index{property lists}\emph{property list} with +each symbol, allowing multiple \var{key-value} pairs to be stored +directly with the symbol. +New key-value pairs may be placed in the property list or retrieved in +a manner analogous to the use of association lists, using the procedures +\scheme{putprop} and \scheme{getprop}. +Property lists are often used to store information related to the symbol +itself. +For example, a natural language program might use symbols to represent +words, using their property lists to store information about use and +meaning. + +\scheme{putprop} associates \var{value} with \var{key} on the +property list of \var{symbol}. +\var{key} and \var{value} may be any types of object, although \var{key} is +typically a symbol. + +\scheme{putprop} may be used to establish a new property or to change +an existing property. + +See the examples under \scheme{getprop} below. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{getprop}{\categoryprocedure}{(getprop \var{symbol} \var{key})} +\formdef{getprop}{\categoryprocedure}{(getprop \var{symbol} \var{key} \var{default})} +\returns the value associated with \var{key} on the property list of \var{symbol} +\listlibraries +\endentryheader + +\noindent +\index{property lists}\scheme{getprop} searches the property list of +\var{symbol} for a key identical to \var{key} (in the sense of +\scheme{eq?}), and returns the value associated with this key, if any. +If no value is associated with \var{key} on the property list of +\var{symbol}, \scheme{getprop} returns \var{default}, or \scheme{#f} if +the \var{default} argument is not supplied. + + +\schemedisplay +(putprop 'fred 'species 'snurd) +(putprop 'fred 'age 4) +(putprop 'fred 'colors '(black white)) + +(getprop 'fred 'species) ;=> snurd +(getprop 'fred 'colors) ;=> (black white) +(getprop 'fred 'nonkey) ;=> #f +(getprop 'fred 'nonkey 'unknown) ;=> unknown + +(putprop 'fred 'species #f) +(getprop 'fred 'species 'unknown) ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{remprop}{\categoryprocedure}{(remprop \var{symbol} \var{key})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{remprop} removes the property with key \var{key} from the property +list of \var{symbol}, if such a property exists\index{Fred}. + +\schemedisplay +(putprop 'fred 'species 'snurd) +(getprop 'fred 'species) ;=> snurd + +(remprop 'fred 'species) +(getprop 'fred 'species 'unknown) ;=> unknown +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{property-list}{\categoryprocedure}{(property-list \var{symbol})} +\returns a copy of the internal property list for \var{symbol} +\listlibraries +\endentryheader + +\noindent +A property list is a list of alternating keys and values, +i.e., \scheme{(\var{key} \var{value} \dots)}. + +\schemedisplay +(putprop 'fred 'species 'snurd) +(putprop 'fred 'colors '(black white)) +(property-list 'fred) ;=> (colors (black white) species snurd) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader\label{desc:oblist} +\formdef{oblist}{\categoryprocedure}{(oblist)} +\returns a list of interned symbols +\listlibraries +\endentryheader + +\noindent +The system maintains an internal symbol table used +to insure that any two occurrences of the same +symbol name resolve to the same symbol object. +The \scheme{oblist} procedure returns a list of the symbols currently in +this symbol table. + +The list of interned symbols grows when a new symbol +is introduced into the system or when the unique name of a +gensym (see page~\pageref{desc:gensym}) is requested. +It shrinks when the garbage collector determines that it is +safe to discard a symbol. +It is safe to discard a symbol only if the symbol is not accessible except +through the oblist, +has no top-level binding, and has no properties on its property +list. + +\schemedisplay +(if (memq 'tiger (oblist)) 'yes 'no) ;=> yes +(equal? (oblist) (oblist)) ;=> #t +(= (length (oblist)) (length (oblist))) ;=> #t \var{or} #f +\endschemedisplay + +\noindent +The first example above follows from the property that all interned +symbols are in the oblist from the time they are read, which happens +prior to evaluation. +The second example follows from the fact that no symbols can be +removed from the oblist while references to those symbols exist, in +this case, within the list returned by the first call to +\scheme{oblist} (whichever call is performed first). +The expression in the third example can return \scheme{#f} only if a garbage +collection occurs sometime between the two calls to \scheme{oblist}, and only +if one or more symbols are removed from the oblist by that collection. + +\section{Void\label{SECTMISCVOID}} + +Many Scheme operations return an unspecified result. +{\ChezScheme} typically returns a special \emph{void} object when the +value returned by an operation is unspecified. +The {\ChezScheme} void object is not meant to be used as a datum, and +consequently does not have a reader syntax. +As for other objects without a reader syntax, such as procedures and +ports, {\ChezScheme} output procedures print the void object using a +nonreadable representation, i.e., \scheme{#}. +Since the void object should be returned only by operations that do not +have ``interesting'' values, the default waiter printer (see +\scheme{waiter-write}) suppresses the printing of the void object. +\scheme{set!}, \scheme{set-car!}, \scheme{load}, and \scheme{write} are examples of {\ChezScheme} +operations that return the void object. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{void}{\categoryprocedure}{(void)} +\returns the void object +\listlibraries +\endentryheader + +\noindent +\scheme{void} is a procedure of no arguments that returns the void object. +It can be used to force expressions that are used for effect or whose +values are otherwise unspecified to evaluate to a consistent, trivial +value. +Since most {\ChezScheme} operations that are used for effect +return the void object, however, it is rarely necessary to explicitly +invoke the \scheme{void} procedure. + +Since the void object is used explicitly as an ``unspecified'' value, +it is a bad idea to use it for any other purpose or to count on any +given expression evaluating to the void object. + +The default waiter printer suppresses the void object; that is, nothing +is printed for expressions that evaluate to the void object. + +\schemedisplay +(eq? (void) #f) ;=> #f +(eq? (void) #t) ;=> #f +(eq? (void) '()) ;=> #f +\endschemedisplay + +\section{Sorting\label{SECTMISCSORTING}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{sort}{\categoryprocedure}{(sort \var{predicate} \var{list})} +\formdef{sort!}{\categoryprocedure}{(sort! \var{predicate} \var{list})} +\returns a list containing the elements of \var{list} sorted according to \var{predicate} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{sort} is identical to the Revised$^6$ Report \scheme{list-sort}, +and \scheme{sort!} is a destructive version of \scheme{sort}, i.e., it +reuses pairs from the input list to form the output list. + +\schemedisplay +(sort < '(3 4 2 1 2 5)) ;=> (1 2 2 3 4 5) +(sort! < '(3 4 2 1 2 5)) ;=> (1 2 2 3 4 5) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{merge}{\categoryprocedure}{(merge \var{predicate} \var{list_1} \var{list_2})} +\formdef{merge!}{\categoryprocedure}{(merge! \var{predicate} \var{list_1} \var{list_2})} +\returns \var{list_1} merged with \var{list_2} in the order specified by \var{predicate} +\listlibraries +\endentryheader + +\noindent +\var{predicate} should be a procedure that expects two arguments and +returns \scheme{#t} if its first argument must precede its second in +the merged list. +It should not have any side effects. +That is, if \var{predicate} is applied to two objects \var{x} and +\var{y}, where \var{x} is taken from the second list and \var{y} +is taken from the first list, +it should return true only if \var{x} should appear before \var{y} +in the output list. +If this constraint is met, +\scheme{merge} and \scheme{merge!} are stable, in that items from \var{list_1} are +placed in front of equivalent items from \var{list_2} in the output list. +Duplicate elements are included in the merged list. + +\scheme{merge!} combines the lists destructively, using pairs from the input +lists to form the output list. + +\schemedisplay +(merge char (#\a #\b #\c #\c #\d) +(merge < + '(1/2 2/3 3/4) + '(0.5 0.6 0.7)) ;=> (1/2 0.5 0.6 2/3 0.7 3/4) +\endschemedisplay + + +\section{Hashtables\label{SECTMISCHASHTABLES}} + +{\ChezScheme} provides several extensions to the hashtable mechanism, +including a mechanism for directly accessing a key, value pair in a +hashtable, support for weak eq and eqv hashtables, and a set of procedures +specialized to eq and symbol hashtables. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-cell}{\categoryprocedure}{(hashtable-cell \var{hashtable} \var{key} \var{default})} +\returns a pair (see below) +\listlibraries +\endentryheader + +\var{hashtable} must be a hashtable. +\var{key} and \var{default} may be any Scheme values. + +If no value is associated with \var{key} in \var{hashtable}, +\scheme{hashtable-cell} modifies \var{hashtable} to associate \var{key} with +\var{default}. +It returns a pair whose car is \var{key} and whose cdr is +the associated value. +Changing the cdr of this pair effectively updates the table to +associate \var{key} with a new value. +The \var{key} in the car field should not be changed. +The advantage of this procedure over the Revised$^6$ Report procedures +for manipulating hashtable entries is that the value associated with +a key may be read or written many times with only a single hashtable +lookup. + +\schemedisplay +(define ht (make-eq-hashtable)) +(define v (vector 'a 'b 'c)) +(define cell (hashtable-cell ht v 3)) +cell ;=> (#(a b c) . 3) +(hashtable-ref ht v 0) ;=> 3 +(set-cdr! cell 4) +(hashtable-ref ht v 0) ;=> 4 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-keys}{\categoryprocedure}{(hashtable-keys \var{hashtable})} +\formdef{hashtable-keys}{\categoryprocedure}{(hashtable-keys \var{hashtable} \var{size})} +\returns a vector containing the keys in \var{hashtable} +\listlibraries +\endentryheader + +\noindent +Identical to the Revised$^6$ Report counterpart, but allowing an optional +\var{size} argument. +If \var{size} is specified, then it must be an exact, nonnegative integer, and the +result vector contains no more than \var{size} elements. +Different calls to \scheme{hashtable-keys} +with a \var{size} less than \scheme{(hashtable-size \var{hashtable})} +may return different subsets of \var{hashtable}'s keys. + +\schemedisplay +(define ht (make-eq-hashtable)) +(hashtable-set! ht 'a "one") +(hashtable-set! ht 'b "two") +(hashtable-set! ht 'c "three") +(hashtable-keys ht) ;=> #(a b c) \var{or any permutation} +(hashtable-keys ht 1) ;=> #(a) \var{or} #(b) \var{or} #(c) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-values}{\categoryprocedure}{(hashtable-values \var{hashtable})} +\formdef{hashtable-values}{\categoryprocedure}{(hashtable-values \var{hashtable} \var{size})} +\returns a vector containing the values in \var{hashtable} +\listlibraries +\endentryheader + +\noindent +Each value is the value of one of the keys in \var{hashtable}. +Duplicate values are not removed. +The values may appear in any order in the returned vector. +If \var{size} is specified, then it must be an exact, nonnegative integer, and the +result vector contains no more than \var{size} elements. +Different calls to \scheme{hashtable-values} +with a \var{size} less than \scheme{(hashtable-size \var{hashtable})} +may return different subsets of \var{hashtable}'s values. + +\schemedisplay +(define ht (make-eq-hashtable)) +(define p1 (cons 'a 'b)) +(define p2 (cons 'a 'b)) +(hashtable-set! ht p1 "one") +(hashtable-set! ht p2 "two") +(hashtable-set! ht 'q "two") +(hashtable-values ht) ;=> #("one" "two" "two") \var{or any permutation} +(hashtable-values ht 1) ;=> #("one") \var{or} #("two") +\endschemedisplay + +This procedure is equivalent to calling \scheme{hashtable-entries} and returning only +the second result, but it is more efficient since the separate vector of keys need +not be created. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-entries}{\categoryprocedure}{(hashtable-entries \var{hashtable})} +\formdef{hashtable-entries}{\categoryprocedure}{(hashtable-entries \var{hashtable} \var{size})} +\returns two vectors containing the keys and values in \var{hashtable} +\listlibraries +\endentryheader + +\noindent +Identical to the Revised$^6$ Report counterpart, but allowing an optional +\var{size} argument. +If \var{size} is specified, then it must be an exact, nonnegative integer, and the +result vectors contain no more than \var{size} elements. +Different calls to \scheme{hashtable-entries} +with a \var{size} less than \scheme{(hashtable-size \var{hashtable})} +may return different subsets of \var{hashtable}'s entries. + +\schemedisplay +(define ht (make-eq-hashtable)) +(hashtable-set! ht 'a "one") +(hashtable-set! ht 'b "two") +(hashtable-entries ht) ;=> #(a b) #("one" "two") \var{or the other permutation} +(hashtable-entries ht 1) ;=> #(a) #("one") \var{or} #(b) #("two") +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-cells}{\categoryprocedure}{(hashtable-cells \var{hashtable})} +\formdef{hashtable-cells}{\categoryprocedure}{(hashtable-cells \var{hashtable} \var{size})} +\returns a vector of up to \var{size} elements containing the cells of \var{hashtable} +\listlibraries +\endentryheader + +\noindent +Each element of the result vector is the value of one of the cells in \var{hashtable}. +The cells may appear in any order in the returned vector. +If \var{size} is specified, then it must be an exact, nonnegative integer, and the +result vector contains no more than \var{size} cells. +If \var{size} is not specified, then the result vector has \scheme{(hashtable-size \var{hashtable})} elements. +Different calls to \scheme{hashtable-cells} +with a \var{size} less than \scheme{(hashtable-size \var{hashtable})} +may return different subsets of \var{hashtable}'s cells. + +\schemedisplay +(define ht (make-eqv-hashtable)) +(hashtable-set! ht 1 'one) +(hashtable-set! ht 2 'two) +(hashtable-cells ht) ;=> #((1 . one) (2 . two)) \var{or} #((2 . two) (1 . one)) +(hashtable-cells ht 1) ;=> #((1 . one)) \var{or} #((2 . two)) +(hashtable-cells ht 0) ;=> #() +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-weak-eq-hashtable}{\categoryprocedure}{(make-weak-eq-hashtable)} +\formdef{make-weak-eq-hashtable}{\categoryprocedure}{(make-weak-eq-hashtable \var{size})} +\formdef{make-weak-eqv-hashtable}{\categoryprocedure}{(make-weak-eqv-hashtable)} +\formdef{make-weak-eqv-hashtable}{\categoryprocedure}{(make-weak-eqv-hashtable \var{size})} +\returns a new weak eq hashtable +\listlibraries +\endentryheader + +These procedures are like the Revised$^6$ Report procedures \scheme{make-eq-hashtable} +and \scheme{make-eqv-hashtable} +except the keys of the hashtable are held weakly, i.e., they are not +protected from the garbage collector. +Keys reclaimed by the garbage collector are removed from the table, +and their associated values are dropped the next time the table +is modified, if not sooner. + +Values in the hashtable are referenced normally as long as the key is +not reclaimed, since keys are paired values using weak pairs. Consequently, +if a value in the hashtable refers to its own key, then +garbage collection is prevented from reclaiming the key. See +\scheme{make-ephemeron-eq-hashtable} and \scheme{make-ephemeron-eqv-hashtable}. + +A copy of a weak eq or eqv hashtable created by \scheme{hashtable-copy} is +also weak. +If the copy is immutable, inaccessible keys may still be dropped from the +hashtable, even though the contents of the table is otherwise unchanging. +The effect of this can be observed via \scheme{hashtable-keys} and +\scheme{hashtable-entries}. + +\schemedisplay +(define ht1 (make-weak-eq-hashtable)) +(define ht2 (make-weak-eq-hashtable 32)) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-ephemeron-eq-hashtable}{\categoryprocedure}{(make-ephemeron-eq-hashtable)} +\formdef{make-ephemeron-eq-hashtable}{\categoryprocedure}{(make-ephemeron-eq-hashtable \var{size})} +\formdef{make-ephemeron-eqv-hashtable}{\categoryprocedure}{(make-ephemeron-eqv-hashtable)} +\formdef{make-ephemeron-eqv-hashtable}{\categoryprocedure}{(make-ephemeron-eqv-hashtable \var{size})} +\returns a new ephemeron eq hashtable +\listlibraries +\endentryheader + +These procedures are like \scheme{make-weak-eq-hashtable} and +\scheme{make-weak-eqv-hashtable}, but a value in the hashtable can refer to a +key in the hashtable (directly or indirectly) without preventing garbage collection from +reclaiming the key, because keys are paired with values using ephemeron pairs. + +A copy of an ephemeron eq or eqv hashtable created by +\scheme{hashtable-copy} is also an ephemeron table, and an inaccessible +key can be dropped from an immutable ephemeron hashtable in the same +way as for an immutable weak hashtable. + +\schemedisplay +(define ht1 (make-ephemeron-eq-hashtable)) +(define ht2 (make-ephemeron-eq-hashtable 32)) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-weak?}{\categoryprocedure}{(hashtable-weak? \var{obj})} +\returns \scheme{#t} if \var{obj} is a weak eq or eqv hashtable, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(define ht1 (make-weak-eq-hashtable)) +(define ht2 (hashtable-copy ht1)) +(hashtable-weak? ht2) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{hashtable-ephemeron?}{\categoryprocedure}{(hashtable-ephemeron? \var{obj})} +\returns \scheme{#t} if \var{obj} is an ephemeron eq or eqv hashtable, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(define ht1 (make-ephemeron-eq-hashtable)) +(define ht2 (hashtable-copy ht1)) +(hashtable-ephemeron? ht2) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable?}{\categoryprocedure}{(eq-hashtable? \var{obj})} +\returns \scheme{#t} if \var{obj} is an eq hashtable, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(eq-hashtable? (make-eq-hashtable)) ;=> #t +(eq-hashtable? '(not a hash table)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-weak?}{\categoryprocedure}{(eq-hashtable-weak? \var{hashtable})} +\returns \scheme{#t} if \var{hashtable} is weak, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{hashtable} must be an eq hashtable. + +\schemedisplay +(eq-hashtable-weak? (make-eq-hashtable)) ;=> #f +(eq-hashtable-weak? (make-weak-eq-hashtable)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-ephemeron?}{\categoryprocedure}{(eq-hashtable-ephemeron? \var{hashtable})} +\returns \scheme{#t} if \var{hashtable} uses ephemeron pairs, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{hashtable} must be an eq hashtable. + +\schemedisplay +(eq-hashtable-ephemeron? (make-eq-hashtable)) ;=> #f +(eq-hashtable-ephemeron? (make-ephemeron-eq-hashtable)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-set!}{\categoryprocedure}{(eq-hashtable-set! \var{hashtable} \var{key} \var{value})} +\returns unspecified +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable eq hashtable. +\var{key} and \var{value} may be any Scheme values. + +\scheme{eq-hashtable-set!} associates the value +\var{value} with the key \var{key} in \var{hashtable}. + +\schemedisplay +(define ht (make-eq-hashtable)) +(eq-hashtable-set! ht 'a 73) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-ref}{\categoryprocedure}{(eq-hashtable-ref \var{hashtable} \var{key} \var{default})} +\returns see below +\listlibraries +\endentryheader + +\var{hashtable} must be an eq hashtable. +\var{key} and \var{default} may be any Scheme values. + +\scheme{eq-hashtable-ref} returns the value +associated with \var{key} in \var{hashtable}. +If no value is associated with \var{key} in \var{hashtable}, +\scheme{eq-hashtable-ref} returns \var{default}. + +% Key comparisons are performed with \var{eq?}. + +\schemedisplay +(define ht (make-eq-hashtable)) +(define p1 (cons 'a 'b)) +(define p2 (cons 'a 'b)) +(eq-hashtable-set! ht p1 73) +(eq-hashtable-ref ht p1 55) ;=> 73 +(eq-hashtable-ref ht p2 55) ;=> 55 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-contains?}{\categoryprocedure}{(eq-hashtable-contains? \var{hashtable} \var{key})} +\returns \scheme{#t} if an association for \var{key} exists in \var{hashtable}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{hashtable} must be an eq hashtable. +\var{key} may be any Scheme value. + +\schemedisplay +(define ht (make-eq-hashtable)) +(define p1 (cons 'a 'b)) +(define p2 (cons 'a 'b)) +(eq-hashtable-set! ht p1 73) +(eq-hashtable-contains? ht p1) ;=> #t +(eq-hashtable-contains? ht p2) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-update!}{\categoryprocedure}{(eq-hashtable-update! \var{hashtable} \var{key} \var{procedure} \var{default})} +\returns unspecified +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable eq hashtable. +\var{key} and \var{default} may be any Scheme values. +\var{procedure} should accept one argument, should return one value, and +should not modify \var{hashtable}. + +\scheme{eq-hashtable-update!} applies \var{procedure} to the value associated with +\var{key} in \var{hashtable}, or to \var{default} if no value is associated with +\var{key} in \var{hashtable}. +If \var{procedure} returns, \scheme{eq-hashtable-update!} associates \var{key} +with the value returned by \var{procedure}, replacing the old association, +if any. + +A version of \scheme{eq-hashtable-update!} that does not verify that it receives +arguments of the proper type might be defined as follows. + +\schemedisplay +(define eq-hashtable-update! + (lambda (ht key proc value) + (eq-hashtable-set! ht key + (proc (eq-hashtable-ref ht key value))))) +\endschemedisplay + +An implementation may, however, be able to implement +\scheme{eq-hashtable-update!} more efficiently by avoiding multiple +hash computations and hashtable lookups. + +\schemedisplay +(define ht (make-eq-hashtable)) +(eq-hashtable-update! ht 'a + (lambda (x) (* x 2)) + 55) +(eq-hashtable-ref ht 'a 0) ;=> 110 +(eq-hashtable-update! ht 'a + (lambda (x) (* x 2)) + 0) +(eq-hashtable-ref ht 'a 0) ;=> 220 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-cell}{\categoryprocedure}{(eq-hashtable-cell \var{hashtable} \var{key} \var{default})} +\returns a pair (see below) +\listlibraries +\endentryheader + +\var{hashtable} must be an eq hashtable. +\var{key} and \var{default} may be any Scheme values. + +If no value is associated with \var{key} in \var{hashtable}, +\scheme{eq-hashtable-cell} modifies \var{hashtable} to associate \var{key} with +\var{default}. +It returns a pair whose car is \var{key} and whose cdr is +the associated value. +Changing the cdr of this pair effectively updates the table to +associate \var{key} with a new value. +The \var{key} should not be changed. + +\schemedisplay +(define ht (make-eq-hashtable)) +(define v (vector 'a 'b 'c)) +(define cell (eq-hashtable-cell ht v 3)) +cell ;=> (#(a b c) . 3) +(eq-hashtable-ref ht v 0) ;=> 3 +(set-cdr! cell 4) +(eq-hashtable-ref ht v 0) ;=> 4 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eq-hashtable-delete!}{\categoryprocedure}{(eq-hashtable-delete! \var{hashtable} \var{key})} +\returns unspecified +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable eq hashtable. +\var{key} may be any Scheme value. + +\scheme{eq-hashtable-delete!} drops any association +for \var{key} from \var{hashtable}. + +\schemedisplay +(define ht (make-eq-hashtable)) +(define p1 (cons 'a 'b)) +(define p2 (cons 'a 'b)) +(eq-hashtable-set! ht p1 73) +(eq-hashtable-contains? ht p1) ;=> #t +(eq-hashtable-delete! ht p1) +(eq-hashtable-contains? ht p1) ;=> #f +(eq-hashtable-contains? ht p2) ;=> #f +(eq-hashtable-delete! ht p2) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable?}{\categoryprocedure}{(symbol-hashtable? \var{obj})} +\returns \scheme{#t} if \var{obj} is an eq hashtable, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(symbol-hashtable? (make-hashtable symbol-hash eq?)) ;=> #t +(symbol-hashtable? (make-eq-hashtable)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable-set!}{\categoryprocedure}{(symbol-hashtable-set! \var{hashtable} \var{key} \var{value})} +\returns unspecified +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable symbol hashtable. +(A symbol hashtable is a hashtable created with hash function \scheme{symbol-hash} +and equivalence function \scheme{eq?}, \scheme{eqv?}, \scheme{equal?}, or \scheme{symbol=?}.) +\var{key} must be a symbol, and \var{value} may be any Scheme value. + +\scheme{symbol-hashtable-set!} associates the value +\var{value} with the key \var{key} in \var{hashtable}. + +\schemedisplay +(define ht (make-hashtable symbol-hash eq?)) +(symbol-hashtable-ref ht 'a #f) ;=> #f +(symbol-hashtable-set! ht 'a 73) +(symbol-hashtable-ref ht 'a #f) ;=> 73 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable-ref}{\categoryprocedure}{(symbol-hashtable-ref \var{hashtable} \var{key} \var{default})} +\returns see below +\listlibraries +\endentryheader + +\var{hashtable} must be a symbol hashtable. +(A symbol hashtable is a hashtable created with hash function \scheme{symbol-hash} +and equivalence function \scheme{eq?}, \scheme{eqv?}, \scheme{equal?}, or \scheme{symbol=?}.) +\var{key} must be a symbol, and \var{default} may be any Scheme value. + +\scheme{symbol-hashtable-ref} returns the value +associated with \var{key} in \var{hashtable}. +If no value is associated with \var{key} in \var{hashtable}, +\scheme{symbol-hashtable-ref} returns \var{default}. + +% Key comparisons are performed with \var{eq?}. + +\schemedisplay +(define ht (make-hashtable symbol-hash eq?)) +(define k1 'abcd) +(define k2 'not-abcd) +(symbol-hashtable-set! ht k1 "hi") +(symbol-hashtable-ref ht k1 "bye") ;=> "hi" +(symbol-hashtable-ref ht k2 "bye") ;=> "bye" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable-contains?}{\categoryprocedure}{(symbol-hashtable-contains? \var{hashtable} \var{key})} +\returns \scheme{#t} if an association for \var{key} exists in \var{hashtable}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{hashtable} must be a symbol hashtable. +(A symbol hashtable is a hashtable created with hash function \scheme{symbol-hash} +and equivalence function \scheme{eq?}, \scheme{eqv?}, \scheme{equal?}, or \scheme{symbol=?}.) +\var{key} must be a symbol. + +\schemedisplay +(define ht (make-hashtable symbol-hash eq?)) +(define k1 'abcd) +(define k2 'not-abcd) +(symbol-hashtable-set! ht k1 "hi") +(symbol-hashtable-contains? ht k1) ;=> #t +(symbol-hashtable-contains? ht k2 ) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable-update!}{\categoryprocedure}{(symbol-hashtable-update! \var{hashtable} \var{key} \var{procedure} \var{default})} +\returns unspecified +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable symbol hashtable. +(A symbol hashtable is a hashtable created with hash function \scheme{symbol-hash} +and equivalence function \scheme{eq?}, \scheme{eqv?}, \scheme{equal?}, or \scheme{symbol=?}.) +\var{key} must be a symbol, and \var{default} may be any Scheme value. +\var{procedure} should accept one argument, should return one value, and +should not modify \var{hashtable}. + +\scheme{symbol-hashtable-update!} applies \var{procedure} to the value associated with +\var{key} in \var{hashtable}, or to \var{default} if no value is associated with +\var{key} in \var{hashtable}. +If \var{procedure} returns, \scheme{symbol-hashtable-update!} associates \var{key} +with the value returned by \var{procedure}, replacing the old association, +if any. + +A version of \scheme{symbol-hashtable-update!} that does not verify that it receives +arguments of the proper type might be defined as follows. + +\schemedisplay +(define symbol-hashtable-update! + (lambda (ht key proc value) + (symbol-hashtable-set! ht key + (proc (symbol-hashtable-ref ht key value))))) +\endschemedisplay + +An implementation may, however, be able to implement +\scheme{symbol-hashtable-update!} more efficiently by avoiding multiple +hash computations and hashtable lookups. + +\schemedisplay +(define ht (make-hashtable symbol-hash eq?)) +(symbol-hashtable-update! ht 'a + (lambda (x) (* x 2)) + 55) +(symbol-hashtable-ref ht 'a 0) ;=> 110 +(symbol-hashtable-update! ht 'a + (lambda (x) (* x 2)) + 0) +(symbol-hashtable-ref ht 'a 0) ;=> 220 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable-cell}{\categoryprocedure}{(symbol-hashtable-cell \var{hashtable} \var{key} \var{default})} +\returns a pair (see below) +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable symbol hashtable. +(A symbol hashtable is a hashtable created with hash function \scheme{symbol-hash} +and equivalence function \scheme{eq?}, \scheme{eqv?}, \scheme{equal?}, or \scheme{symbol=?}.) +\var{key} must be a symbol, and \var{default} may be any Scheme value. + +If no value is associated with \var{key} in \var{hashtable}, +\scheme{symbol-hashtable-cell} modifies \var{hashtable} to associate \var{key} with +\var{default}. +It returns a pair whose car is \var{key} and whose cdr is +the associated value. +Changing the cdr of this pair effectively updates the table to +associate \var{key} with a new value. +The \var{key} should not be changed. + +\schemedisplay +(define ht (make-hashtable symbol-hash eq?)) +(define k 'a-key) +(define cell (symbol-hashtable-cell ht k 3)) +cell ;=> (a-key . 3) +(symbol-hashtable-ref ht k 0) ;=> 3 +(set-cdr! cell 4) +(symbol-hashtable-ref ht k 0) ;=> 4 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{symbol-hashtable-delete!}{\categoryprocedure}{(symbol-hashtable-delete! \var{hashtable} \var{key})} +\returns unspecified +\listlibraries +\endentryheader + +\var{hashtable} must be a mutable symbol hashtable. +(A symbol hashtable is a hashtable created with hash function \scheme{symbol-hash} +and equivalence function \scheme{eq?}, \scheme{eqv?}, \scheme{equal?}, or \scheme{symbol=?}.) +\var{key} must be a symbol. + +\scheme{symbol-hashtable-delete!} drops any association +for \var{key} from \var{hashtable}. + +\schemedisplay +(define ht (make-hashtable symbol-hash eq?)) +(define k1 (gensym)) +(define k2 (gensym)) +(symbol-hashtable-set! ht k1 73) +(symbol-hashtable-contains? ht k1) ;=> #t +(symbol-hashtable-delete! ht k1) +(symbol-hashtable-contains? ht k1) ;=> #f +(symbol-hashtable-contains? ht k2) ;=> #f +(symbol-hashtable-delete! ht k2) +\endschemedisplay + + +\section{Record Types\label{SECTR6RSRECORDS}} + +\index{\scheme{define-record-type}}\index{\scheme{require-nongenerative-clause}}% +Chez Scheme extends the Revised$^6$ Report's \scheme{define-record-type} +syntax in one way, which is that it allows a generative record type +to be declared explicitly as such (in a double-negative sort of way) +by including a \scheme{nongenerative} clause with \scheme{#f} as the +uid, i.e.: + +\schemedisplay +(nongenerative #f) +\endschemedisplay + +This can be used in conjunction with the parameter +\scheme{require-nongenerative-clause} to catch the accidental use of +generative record types while avoiding spurious errors for record types +that must be generative. +Generative record types are rarely needed and are generally less +efficient since a run-time representation of the type is created each +time the \scheme{define-record-clause} is evaluated, rather than once +at compile (expansion) time. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{require-nongenerative-clause}{\categorythreadparameter}{require-nongenerative-clause} +\listlibraries +\endentryheader + +This parameter holds a boolean value that determines whether +\index{\scheme{define-record-type}}\scheme{define-record-type} +requires a nongenerative clause. +The default value is \scheme{#f}. +The lead-in above describes why one might want to set this to \scheme{#t}. + +\section{Record Equality and Hashing\label{SECTRECORDEQUALTYANDHASHING}} + +\index{record equality}\index{\scheme{equal?} on records}% +By default, the \index{\scheme{equal?}}\scheme{equal?} primitive +compares record instances using \scheme{eq?}, i.e., it distinguishes +non-eq? instances even if they are of the same type and have equal +contents. +A program can override this behavior for instances of a +record type (and its subtypes that do not have their own equality +procedures) by using +\index{\scheme{record-type-equal-procedure}}\scheme{record-type-equal-procedure} +to associate an equality procedure with the record-type descriptor +(\var{rtd}) that describes the record type. + +When comparing two eq? instances, \scheme{equal?} always returns +\scheme{#t}. +When comparing two non-eq? instances that share an equality procedure +\var{equal-proc}, \scheme{equal?} uses \var{equal-proc} to compare +the instances. +Two instances \var{x} and \var{y} share an equality procedure if +they inherit an equality procedure from the same point in the inheritance +chain, i.e., if +\index{\scheme{record-equal-procedure}}\scheme{(record-equal-procedure \var{x} \var{y})} +returns a procedure (\var{equal-proc}) rather +than \scheme{#f}. +\var{equal?} passes \var{equal-proc} three arguments: the two +instances plus a \var{eql?} procedure that should be used for +recursive comparison of values within the two instances. +Use of \var{eql?} for recursive comparison is necessary to allow +comparison of potentially cyclic structure. +When comparing two non-eq? instances that do not share an equality +procedure, \scheme{equal?} returns \scheme{#f}. + +A default equality procedure to be used for all record types (including +opaque types) can be specified via the parameter +\index{\scheme{default-record-equal-procedure}}\scheme{default-record-equal-procedure}. +The default equality procedure is used only if neither instance's type has or inherits +a type-specific record equality procedure. + +\index{record hashing}\index{\scheme{equal-hash} on records}% +Similarly, when the \index{\scheme{equal-hash}}\scheme{equal-hash} +primitive hashes a record instance, it defaults to a value that is +independent of the record type and contents of the instance. +A program can override this behavior for instances of a +record type by using \index{\scheme{record-type-hash-procedure}}\scheme{record-type-hash-procedure} +to associate a hash procedure with the record-type descriptor (\var{rtd}) +that describes the record type. +The procedure \index{\scheme{record-hash-procedure}}\scheme{record-hash-procedure} can be used to find +the hash procedure for a given record instance, following the inheritance +chain. +\var{equal-hash} passes the hash procedure two arguments: the +instance plus a \var{hash} procedure that should be used for +recursive hashing of values within the instance. +Use of \var{hash} for recursive hashing is necessary to allow +hashing of potentially cyclic structure and to make the hashing +of shared structure more efficient. + +A default hash procedure to be used for all record types (including +opaque types) can be specified via the parameter +\index{\scheme{default-record-hash-procedure}}\scheme{default-record-hash-procedure}. +The default hash procedure is used only if an instance's type does not have or inherit +a type-specific hash procedure. + +The following example illustrates the setting of equality and hash +procedures. + +\schemedisplay +(define-record-type marble + (nongenerative) + (fields color quality)) + +(record-type-equal-procedure (record-type-descriptor marble)) ;=> #f +(equal? (make-marble 'blue 'medium) (make-marble 'blue 'medium)) ;=> #f +(equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)) ;=> #f + +; Treat marbles as equal when they have the same color +(record-type-equal-procedure (record-type-descriptor marble) + (lambda (m1 m2 eql?) + (eql? (marble-color m1) (marble-color m2)))) +(record-type-hash-procedure (record-type-descriptor marble) + (lambda (m hash) + (hash (marble-color m)))) + +(equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)) ;=> #t +(equal? (make-marble 'red 'high) (make-marble 'blue 'high)) ;=> #f + +(define ht (make-hashtable equal-hash equal?)) +(hashtable-set! ht (make-marble 'blue 'medium) "glass") +(hashtable-ref ht (make-marble 'blue 'high) #f) ;=> "glass" + +(define-record-type shooter + (nongenerative) + (parent marble) + (fields size)) + +(equal? (make-marble 'blue 'medium) (make-shooter 'blue 'large 17)) ;=> #t +(equal? (make-shooter 'blue 'large 17) (make-marble 'blue 'medium)) ;=> #t +(hashtable-ref ht (make-shooter 'blue 'high 17) #f) ;=> "glass" +\endschemedisplay + +This example illustrates the application of equality and hash procedures +to cyclic record structures. + +\schemedisplay +(define-record-type node + (nongenerative) + (fields (mutable left) (mutable right))) + +(record-type-equal-procedure (record-type-descriptor node) + (lambda (x y e?) + (and + (e? (node-left x) (node-left y)) + (e? (node-right x) (node-right y))))) +(record-type-hash-procedure (record-type-descriptor node) + (lambda (x hash) + (+ (hash (node-left x)) (hash (node-right x)) 23))) + +(define graph1 + (let ([x (make-node "a" (make-node #f "b"))]) + (node-left-set! (node-right x) x) + x)) +(define graph2 + (let ([x (make-node "a" (make-node (make-node "a" #f) "b"))]) + (node-right-set! (node-left (node-right x)) (node-right x)) + x)) +(define graph3 + (let ([x (make-node "a" (make-node #f "c"))]) + (node-left-set! (node-right x) x) + x)) + +(equal? graph1 graph2) ;=> #t +(equal? graph1 graph3) ;=> #f +(equal? graph2 graph3) ;=> #f + +(define h (make-hashtable equal-hash equal?)) +(hashtable-set! h graph1 #t) +(hashtable-ref h graph1 #f) ;=> #t +(hashtable-ref h graph2 #f) ;=> #t +(hashtable-ref h graph3 #f) ;=> #f +\endschemedisplay + +\entryheader +\formdef{record-type-equal-procedure}{\categoryprocedure}{(record-type-equal-procedure \var{rtd} \var{equal-proc})} +\returns unspecified +\formdef{record-type-equal-procedure}{\categoryprocedure}{(record-type-equal-procedure \var{rtd})} +\returns equality procedure associated with \var{rtd}, if any, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +In the first form, \var{equal-proc} must be a procedure or \scheme{#f}. +If \var{equal-proc} is a procedure, a new association between +\var{rtd} and \var{equal-proc} is established, replacing any existing +such association. +If \var{equal-proc} is \scheme{#f}, any existing association between +\var{rtd} and an equality procedure is dropped. + +In the second form, \scheme{record-type-equal-procedure} returns +the equality procedure associated with \var{rtd}, if any, otherwise \scheme{#f}. + +When changing a record type's equality procedure, the record type's +hash procedure, if any, should be updated if necessary to maintain +the property that it produces the same hash value for any two +instances the equality procedure considers equal. + +\entryheader +\formdef{record-equal-procedure}{\categoryprocedure}{(record-equal-procedure \var{record_1} \var{record_2})} +\returns the shared equality procedure for \var{record_1} and \var{record_2}, if there is one, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\scheme{record-equal-procedure} traverses the inheritance chains +for both record instances in an attempt to find the most specific +type for each that is associated with an equality procedure, if any. +If such type is found and is the same for both instances, the +equality procedure associated with the type is returned. +Otherwise, \scheme{#f} is returned. + +\entryheader +\formdef{record-type-hash-procedure}{\categoryprocedure}{(record-type-hash-procedure \var{rtd} \var{hash-proc})} +\returns unspecified +\formdef{record-type-hash-procedure}{\categoryprocedure}{(record-type-hash-procedure \var{rtd})} +\returns hash procedure associated with \var{rtd}, if any, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +In the first form, \var{hash-proc} must be a procedure or \scheme{#f}. +If \var{hash-proc} is a procedure, a new association between +\var{rtd} and \var{hash-proc} is established, replacing any existing +such association. +If \var{hash-proc} is \scheme{#f}, any existing association between +\var{rtd} and a hash procedure is dropped. + +In the second form, \scheme{record-type-hash-procedure} returns +the hash procedure associated with \var{rtd}, if any, otherwise \scheme{#f}. + +The procedure \var{hash-proc} should accept two arguments, the +instance for which it should compute a hash value and a hash procedure +to use to compute hash values for arbitrary fields of the instance, +and it returns a nonnegative exact integer. +A record type's hash procedure should produce the same hash value +for any two instances the record type's equality procedure considers +equal. + +\entryheader +\formdef{record-hash-procedure}{\categoryprocedure}{(record-hash-procedure \var{record})} +\returns the hash procedure for \var{record}, if there is one, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\scheme{record-hash-procedure} traverses the inheritance chain +for the record instance in an attempt to find the most specific +type that is associated with a hash procedure, if any. +If such type is found, the hash procedure associated with the type +is returned. +Otherwise, \scheme{#f} is returned. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-record-equal-procedure}{\categorythreadparameter}{default-record-equal-procedure} +\listlibraries +\endentryheader + +This parameter determines how two record instances are compared by +\scheme{equal?} if neither has a type-specific equality procedure. +When the parameter has the value \scheme{#f} (the default), \scheme{equal?} +compares the instances with \scheme{eq?}, i.e., there is no attempt at +determining structural equivalence. +Otherwise, the parameter's value must be a procedure, and \scheme{equal?} +invokes that procedure to compare the instances, passing it three arguments: +the two instances and a procedure that should be used to recursively +compare arbitrary values within the instances. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-record-hash-procedure}{\categorythreadparameter}{default-record-hash-procedure} +\listlibraries +\endentryheader + +This parameter determines the hash procedure used when \scheme{equal-hash} +is called on a record instance and the instance does not have a type-specific +hash procedure. +When the parameter has the value \scheme{#f} (the default), \scheme{equal-hash} +returns a value that is independent of the record type and contents +of the instance. +Otherwise, the parameter's value must be a procedure, and \scheme{equal-hash} +invokes the procedure to compute the instance's hash value, passing it +the record instance and a procedure to invoke to recursively compute +hash values for arbitrary values contained within the record. +The procedure should return a nonnegative exact integer, and the +return value should be the same for any two instances the default +equal procedure considers equivalent. + +\section{Legacy Record Types\label{SECTCSV7RECORDS}} + +\index{records}\index{\scheme{define-record}}\index{\scheme{make-record-type}}% +In addition to the Revised$^6$ Report record-type creation and definition +mechanisms, which are described in Chapter~\ref{TSPL:CHPTRECORDS} of {\TSPLFOUR}, +{\ChezScheme} continues to support pre-R6RS mechanisms for creating new +data types, or \emph{record types}, with fixed sets of named fields. +Many of the procedures described in this section are available only when +imported from the \scheme{(chezscheme csv7)} library. + +Code intended to be portable should use the R6RS mechanism instead. + +Records may be defined via the \scheme{define-record} syntactic form or +via the \scheme{make-record-type} procedure. +The underlying representation of records and record-type descriptors is the +same for the Revised$^6$ Report mechanism and the alternative mechanism. +Record types created by one can be used as parent record types for the +other via the procedural mechanisms, though not via the syntactic mechanisms. + +% undocumented: +% record-type-interfaces + +The syntactic (\scheme{define-record}) +interface is the most commonly used interface. +Each \scheme{define-record} form defines a constructor +procedure for records of the new type, a type predicate that returns +true only for records of the new type, an access procedure for each field, +and an assignment procedure for each mutable field. +For example, + +\schemedisplay +(define-record point (x y)) +\endschemedisplay + +creates a new \scheme{point} record type with two fields, \scheme{x} +and \scheme{y}, and defines the following procedures: + +\begin{tabular}{ll} +\scheme{(make-point \var{x} \var{y})} & constructor\\ +\scheme{(point? \var{obj})} & predicate\\ +\scheme{(point-x \var{p})} & accessor for field \scheme{x}\\ +\scheme{(point-y \var{p})} & accessor for field \scheme{y}\\ +\scheme{(set-point-x! \var{p} \var{obj})} & mutator for field \scheme{x}\\ +\scheme{(set-point-y! \var{p} \var{obj})} & mutator for field \scheme{y} +\end{tabular} + +The names of these procedures follow a regular naming convention by +default, but the programmer can override the defaults if desired. +\scheme{define-record} allows the programmer to control which fields +are arguments to the generated constructor procedure and which +are explicitly initialized by the constructor procedure. +Fields are mutable by default, but may be declared immutable. +Fields can generally contain any Scheme value, but the internal +representation of each field may be specified, which places implicit +constraints on the type of value that may be stored there. +These customization options are covered in the formal description +of \scheme{define-record} later in this section. + +The procedural (\scheme{make-record-type}) interface may be used to +implement interpreters that must handle \scheme{define-record} forms. +Each call to \scheme{make-record-type} returns a \emph{record-type +descriptor} representing the record type. +Using this record-type descriptor, programs may generate constructors, +type predicates, field accessors, and field mutators dynamically. +The following code demonstrates how the procedural interface might +be used to create a similar \scheme{point} record type and associated +definitions. + +\schemedisplay +(define point (make-record-type "point" '(x y))) +(define make-point (record-constructor point)) +(define point? (record-predicate point)) +(define point-x (record-field-accessor point 'x)) +(define point-y (record-field-accessor point 'y)) +(define set-point-x! (record-field-mutator point 'x)) +(define set-point-y! (record-field-mutator point 'y)) +\endschemedisplay + +The procedural interface is more flexible than the syntactic interface, +but this flexibility can lead to less readable programs and +compromises the compiler's ability to generate efficient code. +Programmers should use the syntactic interface whenever it suffices. + +A record-type descriptor may also be extracted from an instance +of a record type, whether the record type was produced by +\scheme{define-record} or \scheme{make-record-type}, and the extracted +descriptor may also be used to produce constructors, predicates, +accessors, and mutators, with a few limitations noted in the description +of \scheme{record-type-descriptor} below. +This is a powerful feature that permits the coding of portable printers +and object inspectors. +For example, the printer employs this feature in its default record +printer, and the inspector uses it to allow inspection and mutation of +system- and user-defined records during debugging. + +\index{record inheritance}\index{inheritance in records}A parent record +may be specified in the \scheme{define-record} syntax or as an optional +argument to \scheme{make-record-type}. +A new record inherits the parent record's fields, and each instance +of the new record type is considered to be an instance of the parent +type as well, so that accessors and mutators for the parent type may +be used on instances of the new type. + +\index{record generativity}\index{generativity of record definitions}Record +type definitions may be classified as either generative or nongenerative. +A new type results for each \emph{generative} record definition, +while only one type results for all occurrences of a given +\emph{nongenerative} record definition. +This distinction is important semantically since record accessors +and setters are applicable only to objects with the same type. + +Syntactic (\scheme{define-record}) record definitions are +\index{expand-time generativity}\emph{expand-time generative} by default, which means that a new +record is created when the code is expanded. +Expansion happens once for each form prior to compilation or +interpretation, as when it is entered interactively, loaded from source, +or compiled by \scheme{compile-file}. +As a result, multiple evaluations of a single \scheme{define-record} +form, e.g., in the body of a procedure called multiple times, always +produce the same record type. + +\index{nongenerative record definitions}Separate \scheme{define-record} forms +usually produce different types, even if the forms are textually +identical. +The only exception occurs when the name of a record is specified as +a generated symbol, or \emph{gensym} (page~\pageref{desc:gensym}). +Multiple copies of a record definition whose name is given by a gensym +always produce the same record type; i.e., such definitions are +nongenerative. +Each copy of the record definition must contain the same fields and field +modifiers in the same order; an exception is raised with condition-type +\scheme{&assertion} when two differing +record types with the same generated name are loaded into the same +Scheme process. + +Procedural (\scheme{make-record-type}) record definitions are +\index{run-time generativity}\emph{run-time generative} by default. +That is, each call to \scheme{make-record-type} usually produces a new +record type. +As with the syntactic interface, +the only exception occurs when the name of the record is specified +as a gensym, in which case the record type is +fully nongenerative. + +By default, a record is printed with the syntax + +\schemedisplay +#[\var{type-name} \var{field} \dots] +\endschemedisplay + +\noindent +where \scheme{\var{field} \dots} are the printed representations of +the contents of the fields of the record, and +\var{type-name} is a generated symbol, or \emph{gensym} +(page~\pageref{desc:gensym}), that uniquely identifies the record type. +For nongenerative records, \var{type-name} is the gensym +provided by the program. +Otherwise, it is a gensym whose ``pretty'' name +(page~\pageref{desc:gensym}) is the name given to the record by +\scheme{define-record} or \scheme{make-record-type}. + +The default printing of records of a given type may be overridden +with \scheme{record-writer}. + +The default syntax may be used as input to the reader as well, as long +as the corresponding record type has already been defined in the Scheme +session in which the read occurs. +The parameter \scheme{record-reader} may be used to specify a +different name to be recognized by the reader in place of the +generated name. +Specifying a different name in this manner also changes the name used +when the record is printed. +This reader extension is disabled in an input stream after \scheme{#!r6rs} +has been seen by the reader, unless \scheme{#!chezscheme} has been seen +more recently. + +The mark (\scheme{#\var{n}=}) and reference (\scheme{#\var{n}#}) +syntaxes may be used within the record syntax, with the result +of creating shared or cyclic structure as desired. +All cycles must be resolvable, however, without mutation of an +immutable record field. +That is, any cycle must contain at least one pointer through a +mutable field, whether it is a mutable record field or a mutable +field of a built-in object type such as a pair or vector. + +When the parameter \scheme{print-record} is set to \scheme{#f}, records +are printed using the simpler syntax + +\schemedisplay +# +\endschemedisplay + +\noindent +where \var{name} is the ``pretty'' name of the record (not the full +gensym) or the reader name first assigned to the record +type. + +%%% need more define-record examples +%%% - show use of field types other than ptr +%%% - show non-top-level use + +%%% make-record-type and company +%%% - (scan primvars for record-related primitives) +%%% - adapt some of the define-record examples +%%% - show definition of default print method + +%---------------------------------------------------------------------------- +\entryheader +\formdef{define-record}{\categorysyntax}{(define-record \var{name} (\var{fld_1} \dots) ((\var{fld_2} \var{init}) \dots) (\var{opt} \dots))} +\formdef{define-record}{\categorysyntax}{(define-record \var{name} \var{parent} (\var{fld_1} \dots) ((\var{fld_2} \var{init}) \dots) (\var{opt} \dots))} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +A \scheme{define-record} form is a definition and may appear anywhere +and only where other definitions may appear. + +\scheme{define-record} creates a new record type containing a specified +set of named fields and defines a set of procedures for creating and +manipulating instances of the record type. + +\var{name} must be an identifier. +If \var{name} is a generated symbol (gensym), the record definition is +\emph{nongenerative}, otherwise it is \emph{expand-time generative}. +(See the discussion of generativity earlier in this section.) + +Each \var{fld} must be an identifier \var{field-name}, or it must take +the form + +\schemedisplay +(\var{class} \var{type} \var{field-name}) +\endschemedisplay + +\noindent +where \var{class} and \var{type} are optional and +\var{field-name} is an identifier. +\var{class}, if present, must be the keyword \scheme{immutable} +or the keyword \scheme{mutable}. +If the \scheme{immutable} class specifier is present, the field is +immutable; otherwise, the field is mutable. +\var{type}, if present, specifies how the field is represented, +as described below. + +\begin{tabular}{ll}\label{record-field-types} +\scheme{ptr} & any Scheme object\\ +\scheme{scheme-object} & same as \scheme{ptr}\\ +\scheme{int} & a C \scheme{int}\\ +\scheme{unsigned} & a C \scheme{unsigned int}\\ +\scheme{short} & a C \scheme{short}\\ +\scheme{unsigned-short} & a C \scheme{unsigned short}\\ +\scheme{long} & a C \scheme{long}\\ +\scheme{unsigned-long} & a C \scheme{unsigned long}\\ +\scheme{iptr} & a signed integer the size of a \scheme{ptr}\\ +\scheme{uptr} & an unsigned integer the size of a \scheme{ptr}\\ +\scheme{float} & a C \scheme{float}\\ +\scheme{double} & a C \scheme{double}\\ +\scheme{integer-8} & an eight-bit signed integer\\ +\scheme{unsigned-8} & an eight-bit unsigned integer\\ +\scheme{integer-16} & a 16-bit signed integer\\ +\scheme{unsigned-16} & a 16-bit unsigned integer\\ +\scheme{integer-32} & a 32-bit signed integer\\ +\scheme{unsigned-32} & a 32-bit unsigned integer\\ +\scheme{integer-64} & a 64-bit signed integer\\ +\scheme{unsigned-64} & a 64-bit unsigned integer\\ +\scheme{single-float} & a 32-bit single floating point number\\ +\scheme{double-float} & a 64-bit double floating point number +\end{tabular} + +\noindent +If a type is specified, the field can contain objects only of the +specified type. +If no type is specified, the field is of type \scheme{ptr}, +meaning that it can contain any Scheme object. + +The field identifiers name the fields of the record. +The values of the $n$ fields described by \scheme{\var{fld_1} \dots} are +specified by the $n$ arguments to the generated constructor procedure. +The values of the remaining fields, \scheme{\var{fld_2} \dots}, are +given by the corresponding expressions, \scheme{\var{init} \dots}. +Each \var{init} is evaluated within the scope of the set of field names +given by \scheme{\var{fld_1} \dots} and each field in +\scheme{\var{fld_2} \dots} that precedes it, as if within a +\scheme{let*} expression. +Each of these field names is bound to the value of the corresponding field +during initialization. + +\index{record inheritance}\index{inheritance in records}If +\var{parent} is present, the record type named by \var{parent} +is the parent of the record. +The new record type inherits each of the parent record's fields, +and records of the new type are considered records of the +parent type. +If \var{parent} is not present, the parent record type is +a base record type with no fields. + +The following procedures are defined by \scheme{define-record}: + +\begin{itemize} +\item +a constructor procedure whose name is \scheme{make-\var{name}}, + +\item +a type predicate whose name is \scheme{\var{name}?}, + +\item +an access procedure whose name is \scheme{\var{name}-\var{fieldname}} +for each noninherited field, and + +\item +an assignment procedure whose name is +\scheme{set-\var{name}-\var{fieldname}!} +for each noninherited mutable field. +\end{itemize} + +\noindent +If no parent record type is specified, +the constructor behaves as if defined as + +\schemedisplay +(define make-\var{name} + (lambda (\var{id_1} \dots) + (let* ([\var{id_2} \var{init}] \dots) + \var{body}))) +\endschemedisplay + +\noindent +where \scheme{\var{id_1} \dots} are the names of the fields defined by +\scheme{\var{fld_1} \dots}, +\scheme{\var{id_2} \dots} are the names of the fields defined by +\scheme{\var{fld_2} \dots}, +and \var{body} builds the record from the values of the identifiers +\scheme{\var{id_1} \dots} and \scheme{\var{id_2} \dots}. + +If a parent record type is specified, the parent arguments appear first, +and the parent fields are inserted into the record before the child +fields. + +The options \scheme{\var{opt} \dots} control the selection of names +of the generated constructor, predicate, accessors, and mutators. + +\schemedisplay +(constructor \var{id}) +(predicate \var{id}) +(prefix \var{string}) +\endschemedisplay + +\noindent +The option +\scheme{(constructor \var{id})} causes the generated constructor's name +to be \var{id} rather than \scheme{make-\var{name}}. +The option \scheme{(predicate \var{id})} likewise causes the generated +predicate's name to be \var{id} rather than \scheme{\var{name}?}. +The option \scheme{(prefix \var{string})} determines the prefix +to be used in the generated accessor and mutator names in place of +\scheme{\var{name}-}. + +If no options are needed, the third subexpression, +\scheme{(\var{opt} \dots)}, may be omitted. +If no options and no fields other than those initialized by the arguments +to the +constructor procedure are needed, both the second and third subexpressions +may be omitted. +If options are specified, the second subexpression must be present, +even if it contains no field specifiers. + +Here is a simple example with no inheritance and no options. + +\schemedisplay +(define-record marble (color quality)) +(define x (make-marble 'blue 'medium)) +(marble? x) ;=> #t +(pair? x) ;=> #f +(vector? x) ;=> #f +(marble-color x) ;=> blue +(marble-quality x) ;=> medium +(set-marble-quality! x 'low) +(marble-quality x) ;=> low + +(define-record marble ((immutable color) (mutable quality)) + (((mutable shape) (if (eq? quality 'high) 'round 'unknown)))) +(marble-shape (make-marble 'blue 'high)) ;=> round +(marble-shape (make-marble 'blue 'low)) ;=> unknown +(define x (make-marble 'blue 'high)) +(set-marble-quality! x 'low) +(marble-shape x) ;=> round +(set-marble-shape! x 'half-round) +(marble-shape x) ;=> half-round +\endschemedisplay + +\pagebreak +The following example illustrates inheritance. + +\schemedisplay +(define-record shape (x y)) +(define-record point shape ()) +(define-record circle shape (radius)) + +(define a (make-point 7 -3)) +(shape? a) ;=> #t +(point? a) ;=> #t +(circle? a) ;=> #f + +(shape-x a) ;=> 7 +(set-shape-y! a (- (shape-y a) 1)) +(shape-y a) ;=> -4 + +(define b (make-circle 7 -3 1)) +(shape? b) ;=> #t +(point? b) ;=> #f +(circle? b) ;=> #t + +(circle-radius b) ;=> 1 +(circle-radius a) ;=> \var{exception: not of type circle} + +(define c (make-shape 0 0)) +(shape? c) ;=> #t +(point? c) ;=> #f +(circle? c) ;=> #f +\endschemedisplay + +This example demonstrates the use of options: + +\schemedisplay +(define-record pair (car cdr) + () + ((constructor cons) + (prefix ""))) + +(define x (cons 'a 'b)) +(car x) ;=> a +(cdr x) ;=> b +(pair? x) ;=> #t + +(pair? '(a b c)) ;=> #f +x ;=> #[#{pair bdhavk1bwafxyss1-a} a b] +\endschemedisplay + +This example illustrates the use a specified reader name, immutable +fields, and the graph mark and reference syntax. + +\schemedisplay +(define-record triple ((immutable x1) (mutable x2) (immutable x3))) +(record-reader 'triple (type-descriptor triple)) + +(let ([t '#[triple #1=(1 2) (3 4) #1#]]) + (eq? (triple-x1 t) (triple-x3 t))) ;=> #t +(let ([x '(#1=(1 2) . #[triple #1# b c])]) + (eq? (car x) (triple-x1 (cdr x)))) ;=> #t +(let ([t #[triple #1# (3 4) #1=(1 2)]]) + (eq? (triple-x1 t) (triple-x3 t))) ;=> #t +(let ([t '#1=#[triple a #1# c]]) + (eq? t (triple-x2 t))) ;=> #t +(let ([t '#1=(#[triple #1# b #1#])]) + (and (eq? t (triple-x1 (car t))) + (eq? t (triple-x1 (car t))))) ;=> #t +\endschemedisplay + +\noindent +Cycles established with the mark and reference syntax can be +resolved only if a mutable record field or mutable location +of some other object is involved the cycle, as in the last +two examples above. +An exception is raised with condition type \scheme{&lexical} if only +immutable fields are involved. + +\schemedisplay +'#1=#[triple #1# (3 4) #1#] ;=> \var{exception} +\endschemedisplay + +\index{nongenerative record definitions}The following example demonstrates +the use of nongenerative record definitions. + +\schemedisplay +(module A (point-disp) + (define-record #{point bdhavk1bwafxyss1-b} (x y)) + (define square (lambda (x) (* x x))) + (define point-disp + (lambda (p1 p2) + (sqrt (+ (square (- (point-x p1) (point-x p2))) + (square (- (point-y p1) (point-y p2)))))))) + +(module B (base-disp) + (define-record #{point bdhavk1bwafxyss1-b} (x y)) + (import A) + (define base-disp + (lambda (p) + (point-disp (make-point 0 0) p)))) + +(let () + (import B) + (define-record #{point bdhavk1bwafxyss1-b} (x y)) + (base-disp (make-point 3 4))) ;=> 5 +\endschemedisplay + +\noindent +This works even if the different program components are loaded from +different source files or are compiled separately and loaded from +different object files. + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\entryheader +\formdef{predicate}{\categorysyntax}{predicate} +\formdef{prefix}{\categorysyntax}{prefix} +\formdef{constructor}{\categorysyntax}{constructor} +% \formdef{mutable}{\categorysyntax}{mutable} +% \formdef{immutable}{\categorysyntax}{immutable} +\listlibraries +\endentryheader + +\noindent +\index{mutable}\index{immutable}% +These identifiers are auxiliary keywords for \scheme{define-record}. +It is a syntax violation to reference these identifiers except in +contexts where they are recognized as auxiliary keywords. +\scheme{mutable} and \scheme{immutable} are also auxiliary keywords for +\scheme{define-record}, shared with the Revised$^6$ Report +\scheme{define-record-type}. + + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\entryheader +\formdef{type-descriptor}{\categorysyntax}{(type-descriptor \var{name})} +\returns the record-type descriptor associated with \var{name} +\listlibraries +\endentryheader + +\noindent +\var{name} must name a record type defined by \scheme{define-record} +or \scheme{define-record-type}. + +This form is equivalent to the Revised$^6$ Report +\scheme{record-type-descriptor} form. + +The record-type descriptor is useful for overriding the default +read and write syntax using \scheme{record-reader} and +\scheme{record-writer} and may also be used with the procedural +interface routines described later in this section. + +\schemedisplay +(define-record frob ()) +(type-descriptor frob) ;=> # +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-reader}{\categoryprocedure}{(record-reader \var{name})} +\returns the record-type descriptor associated with \var{name} +\formdef{record-reader}{\categoryprocedure}{(record-reader \var{rtd})} +\returns the first name associated with \var{rtd} +\formdef{record-reader}{\categoryprocedure}{(record-reader \var{name} \var{rtd})} +\returns unspecified +\formdef{record-reader}{\categoryprocedure}{(record-reader \var{name} #f)} +\returns unspecified +\formdef{record-reader}{\categoryprocedure}{(record-reader \var{rtd} #f)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{name} must be a symbol, and \var{rtd} must be a +record-type descriptor. + +With one argument, \scheme{record-reader} is used to retrieve the record +type associated with a name or name associated with a record type. +If no association has been created, \scheme{record-reader} returns +\scheme{#f} + +With arguments \var{name} and \var{rtd}, \scheme{record-reader} registers +\var{rtd} as the record-type descriptor to be used whenever the +\scheme{read} procedure encounters a record named by \var{name} and +printed in the default record syntax. + +With arguments \var{name} and \scheme{#f}, \scheme{record-reader} removes +any association for \var{name} to a record-type descriptor. +Similarly, with arguments \var{rtd} and \scheme{#f}, \scheme{record-reader} +removes any association for \var{rtd} to a name. + +\schemedisplay +(define-record marble (color quality)) +(define m (make-marble 'blue 'perfect)) +m ;=> #[#{marble bdhavk1bwafxyss1-c} blue perfect] + +(record-reader (type-descriptor marble)) ;=> #f +(record-reader 'marble) ;=> #f + +(record-reader 'marble (type-descriptor marble)) +(marble-color '#[marble red miserable]) ;=> red + +(record-reader (type-descriptor marble)) ;=> marble +(record-reader 'marble) ;=> # + +(record-reader (type-descriptor marble) #f) +(record-reader (type-descriptor marble)) ;=> #f +(record-reader 'marble) ;=> #f + +(record-reader 'marble (type-descriptor marble)) +(record-reader 'marble #f) +(record-reader (type-descriptor marble)) ;=> #f +(record-reader 'marble) ;=> #f +\endschemedisplay + +\noindent +The introduction of a record reader also changes the default +printing of records. +The printer always chooses the reader name first assigned +to the record, if any, in place of the unique record name, as this +continuation of the example above demonstrates. + +\schemedisplay +(record-reader 'marble (type-descriptor marble)) +(make-marble 'pink 'splendid) ;=> #[marble pink splendid] +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-writer}{\categoryprocedure}{(record-writer \var{rtd})} +\returns the record writer associated with \var{rtd} +\formdef{record-writer}{\categoryprocedure}{(record-writer \var{rtd} \var{procedure})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor, and \var{procedure} should +accept three arguments, as described below. + +When passed only one argument, \scheme{record-writer} returns the +record writer associated with \var{rtd}, which is initially the +default record writer for all records. +The default print method prints all records in a uniform syntax that +includes the generated name for the record +and the values of each of the fields, as described in the introduction +to this section. + +When passed two arguments, \scheme{record-writer} establishes a +new association between \var{rtd} and \var{procedure} so that +\var{procedure} will be used by the printer in place of the default +printer for records of the given type. +The printer passes \var{procedure} three arguments: +the record \var{r}, a port \var{p}, and a procedure \var{wr} that +should be used to write out the values of arbitrary Scheme objects that +the print method chooses to include in the printed representation of the +record, e.g., values of the record's fields. + +\schemedisplay +(define-record marble (color quality)) +(define m (make-marble 'blue 'medium)) + +m ;=> #[#{marble bdhavk1bwafxyss1-d} blue medium] + +(record-writer (type-descriptor marble) + (lambda (r p wr) + (display "#<" p) + (wr (marble-quality r) p) + (display " quality " p) + (wr (marble-color r) p) + (display " marble>" p))) + +m ;=> # +\endschemedisplay + +The record writer is used only when \scheme{print-record} is true +(the default). +When the parameter \scheme{print-record} is set to \scheme{#f}, records +are printed using a compressed syntax that identifies only the type +of record. + +\schemedisplay +(parameterize ([print-record #f]) + (format "~s" m)) ;=> "#" +\endschemedisplay + +A print method may be called more than once during the printing of a +single record to support cycle detection and graph printing +(see \index{\scheme{print-graph}}\scheme{print-graph}), +so print +methods that perform side effects other than printing to the given +port are discouraged. +Whenever a print method is called more than once during the printing +of a single record, in all but one call, a generic ``bit sink'' port +is used to suppress output automatically so that only one copy of +the object appears on the actual port. +In order to avoid confusing the cycle detection and graph printing +algorithms, a print method should always produce the same printed +representation for each object. +Furthermore, a print method should normally use the supplied procedure +\var{wr} to print subobjects, though atomic values, such as strings +or numbers, may be printed by direct calls to \scheme{display} or +\scheme{write} or by other means. + +\schemedisplay +(let () + (define-record ref () ((contents 'nothing))) + (record-writer (type-descriptor ref) + (lambda (r p wr) + (display "<" p) + (wr (ref-contents r) p) + (display ">" p))) + (let ([ref-lexive (make-ref)]) + (set-ref-contents! ref-lexive ref-lexive) + ref-lexive)) ;=> #0=<#0#> +\endschemedisplay + +Print methods need not be concerned with handling nonfalse values of +the parameters +\index{\scheme{print-length}}\scheme{print-level}. +The printer handles \scheme{print-level} automatically even when +user-defined print procedures are used. +Since records typically contain a small, fixed number of fields, it +is usually possible to ignore nonfalse values of +\index{\scheme{print-length}}\scheme{print-length} as well. + +\schemedisplay +(print-level 3) +(let () + (define-record ref () ((contents 'nothing))) + (record-writer (type-descriptor ref) + (lambda (r p wr) + (display "<" p) + (wr (ref-contents r) p) + (display ">" p))) + (let ([ref-lexive (make-ref)]) + (set-ref-contents! ref-lexive ref-lexive) + ref-lexive)) ;=> <<<<#[...]>>>> +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{print-record}{\categorythreadparameter}{print-record} +\listlibraries +\endentryheader + +\noindent +This parameter controls the printing of records. +If set to true (the default) the record writer associated with a +record type is used to print records of that type. +If set to false, all records are printed with the syntax +\scheme{#}, where \var{name} is the +name of the record type as returned by \scheme{record-type-name}. + +% not documented: +% extended version with base-rtd, parent, name, fields, interfaces, and extras + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-record-type}{\categoryprocedure}{(make-record-type \var{type-name} \var{fields})} +\formdef{make-record-type}{\categoryprocedure}{(make-record-type \var{parent-rtd} \var{type-name} \var{fields})} +\returns a record-type descriptor for a new record type +\listlibraries +\endentryheader + +\noindent +\scheme{make-record-type} creates a new data type and returns a +record-type descriptor, a value representing the new data type. +The new type is disjoint from all others. + +If present, \var{parent-rtd} must be a record-type descriptor. + +\var{type-name} must be a string or gensym. +If \var{type-name} is a string, a new record type is generated. +If \var{type-name} is a gensym, a new record type is generated only +if one with the same gensym has not already been defined. +If one has already been defined, the parent and fields must be identical +to those of the existing record type, and the +existing record type is used. +If the parent and fields are not identical, an exception is raised with +condition-type \scheme{&assertion}. + +\var{fields} must be a list of field descriptors, each of which +describes one field of instances of the new record type. +A field descriptor is either a symbol or a list in the following form: + +\schemedisplay +(\var{class} \var{type} \var{field-name}) +\endschemedisplay + +\noindent +where \var{class} and \var{type} are optional. +\var{field-name} must be a symbol. +\var{class}, if present, must be the symbol \scheme{immutable} or +the symbol \scheme{mutable}. +If the \scheme{immutable} class-specifier is present, the field is +immutable; otherwise, the field is mutable. +\var{type}, if present, specifies how the field is represented. +The types are the same as those given in the description +of \scheme{define-record} on page~\pageref{record-field-types}. + +\noindent +If a type is specified, the field can contain objects only of the +specified type. +If no type is specified, the field is of type \scheme{ptr}, +meaning that it can contain any Scheme object. + +The behavior of a program that modifies the string \var{type-name} +or the list \var{fields} or any of its sublists is unspecified. + +The record-type descriptor may be passed as an argument to any of the +Revised$^6$ Report procedures + +\begin{itemize} +\item \scheme{record-constructor}, +\item \scheme{record-predicate}, +\item \scheme{record-accessor}, and +\item \scheme{record-mutator}, +\end{itemize} + +or to the {\ChezScheme} variants + +\begin{itemize} +\item \scheme{record-constructor}, +\item \scheme{record-field-accessor}, and +\item \scheme{record-field-mutator} +\end{itemize} + +\noindent +to obtain procedures for creating and manipulating records of the +new type. + +\schemedisplay +(define marble + (make-record-type "marble" + '(color quality) + (lambda (r p wr) + (display "#<" p) + (wr (marble-quality r) p) + (display " quality " p) + (wr (marble-color r) p) + (display " marble>" p)))) +(define make-marble + (record-constructor marble)) +(define marble? + (record-predicate marble)) +(define marble-color + (record-field-accessor marble 'color)) +(define marble-quality + (record-field-accessor marble 'quality)) +(define set-marble-quality! + (record-field-mutator marble 'quality)) +(define x (make-marble 'blue 'high)) +(marble? x) ;=> #t +(marble-quality x) ;=> high +(set-marble-quality! x 'low) +(marble-quality x) ;=> low +x ;=> # +\endschemedisplay + +The order in which the fields appear in \var{fields} is important. +While field names are generally distinct, it is permissible for one field +name to be the same as another in the list of fields or the same as +an inherited name. +In this case, \index{ordinals}\index{record field ordinals}field ordinals +must be used to select fields in calls to \scheme{record-field-accessor} +and \scheme{record-field-mutator}. +Ordinals range from zero through one less than the number of fields. +Parent fields come first, if any, followed by the fields in +\var{fields}, in the order given. + +\schemedisplay +(define r1 (make-record-type "r1" '(t t))) +(define r2 (make-record-type r1 "r2" '(t))) +(define r3 (make-record-type r2 "r3" '(t t t))) + +(define x ((record-constructor r3) 'a 'b 'c 'd 'e 'f)) +((record-field-accessor r3 0) x) ;=> a +((record-field-accessor r3 2) x) ;=> c +((record-field-accessor r3 4) x) ;=> e +((record-field-accessor r3 't) x) ;=> \var{unspecified} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-constructor}{\categoryprocedure}{(record-constructor \var{rcd})} +\formdef{record-constructor}{\categoryprocedure}{(record-constructor \var{rtd})} +\returns a constructor for records of the type represented by \var{rtd} +\listlibraries +\endentryheader + +\noindent +Like the Revised$^6$ Report version of this procedure, this procedure +may be passed a record-constructor descriptor, \var{rcd}, which determines +the behavior of the constructor. +It may also be passed a record-type descriptor, \var{rtd}, in which +case the constructor accepts as many arguments as there are fields in the +record; these arguments are the initial values of the fields in the +order given when the record-type descriptor was created. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-field-accessor}{\categoryprocedure}{(record-field-accessor \var{rtd} \var{field-id})} +\returns an accessor for the identified field +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor, \var{field-id} must be +a symbol or field ordinal, i.e., a nonnegative exact integer less than +the number of fields of the given record type. +The specified field must be accessible. + +The generated accessor expects one argument, which must be a record of +the type represented by \var{rtd}. +It returns the contents of the specified field of the record. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-field-accessible?}{\categoryprocedure}{(record-field-accessible? \var{rtd} \var{field-id})} +\returns \scheme{#t} if the specified field is accessible, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor, \var{field-id} must be +a symbol or field ordinal, i.e., a nonnegative exact integer less than +the number of fields of the given record type. + +The compiler is free to eliminate a record field if it can prove that +the field is not accessed. +In making this determination, the compiler is free to ignore the +possibility that an accessor might be created from a record-type +descriptor obtained by calling \scheme{record-type-descriptor} on an +instance of the record type. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-field-mutator}{\categoryprocedure}{(record-field-mutator \var{rtd} \var{field-id})} +\returns a mutator for the identified field +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor, \var{field-id} must be +a symbol or field ordinal, i.e., a nonnegative exact integer less than +the number of fields of the given record type. +The specified field must be mutable. + +\noindent +The mutator expects two arguments, \var{r} and \var{obj}. +\var{r} must be a record of the type represented by \var{rtd}. +\var{obj} must be a value that is compatible with the type declared for +the specified field when the record-type descriptor was created. +\var{obj} is stored in the specified field of the record. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-field-mutable?}{\categoryprocedure}{(record-field-mutable? \var{rtd} \var{field-id})} +\returns \scheme{#t} if the specified field is mutable, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor, \var{field-id} must be +a symbol or field ordinal, i.e., a nonnegative exact integer less than +the number of fields of the given record type. + +Any field declared immutable is immutable. +In addition, +the compiler is free to treat a field as immutable if it can prove that +the field is never assigned. +In making this determination, the compiler is free to ignore the +possibility that a mutator might be created from a record-type +descriptor obtained by calling \scheme{record-type-descriptor} on an +instance of the record type. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-type-name}{\categoryprocedure}{(record-type-name \var{rtd})} +\returns the name of the record-type represented by \var{rtd} +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor. + +The name is a always a string. +If a gensym is provided as the record-type name in a +\scheme{define-record} form or \scheme{make-record-type} call, the result +is the ``pretty'' name of the gensym (see~\ref{desc:gensym}). + +\schemedisplay +(record-type-name (make-record-type "empty" '())) ;=> "empty" + +(define-record #{point bdhavk1bwafxyss1-b} (x y)) +(define p (type-descriptor #{point bdhavk1bwafxyss1-b})) +(record-type-name p) ;=> "point" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-type-symbol}{\categoryprocedure}{(record-type-symbol \var{rtd})} +\returns the generated symbol associated with \var{rtd} +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor. + +\schemedisplay +(define e (make-record-type "empty" '())) +(record-type-symbol e) ;=> #{empty bdhavk1bwafxyss1-e} + +(define-record #{point bdhavk1bwafxyss1-b} (x y)) +(define p (type-descriptor #{point bdhavk1bwafxyss1-b})) +(record-type-symbol p) ;=> #{point bdhavk1bwafxyss1-b} +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-type-field-names}{\categoryprocedure}{(record-type-field-names \var{rtd})} +\returns a list of field names of the type represented by \var{rtd} +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor. +The field names are symbols. + +\schemedisplay +(define-record triple ((immutable x1) (mutable x2) (immutable x3))) +(record-type-field-names (type-descriptor triple)) ;=> (x1 x2 x3) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-type-field-decls}{\categoryprocedure}{(record-type-field-decls \var{rtd})} +\returns a list of field declarations of the type represented by \var{rtd} +\listlibraries +\endentryheader + +\noindent +\var{rtd} must be a record-type descriptor. +Each field declaration has the following form: + +\schemedisplay +(\var{class} \var{type} \var{field-name}) +\endschemedisplay + +\noindent +where \var{class}, \var{type}, and \var{field-name} are as described +under \scheme{make-record-type}. + +\schemedisplay +(define-record shape (x y)) +(define-record circle shape (radius)) + +(record-type-field-decls + (type-descriptor circle)) ;=> ((mutable ptr x) + ;== (mutable ptr y) + ;== (mutable ptr radius)) +\endschemedisplay + + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record?}{\categoryprocedure}{(record? \var{obj})} +\returns \scheme{#t} if \var{obj} is a record, otherwise \scheme{#f} +\formdef{record?}{\categoryprocedure}{(record? \var{obj} \var{rtd})} +\returns \scheme{#t} if \var{obj} is a record of the given type, otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +If present, \var{rtd} must be a record-type descriptor. + +A record is ``of the given type'' if it is an instance of the record +type or one of its ancestors. +The predicate generated by \scheme{record-predicate} for a +record-type descriptor \var{rtd} is equivalent to the following. + +\schemedisplay +(lambda (x) (record? x \var{rtd})) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{record-type-descriptor}{\categoryprocedure}{(record-type-descriptor \var{rec})} +\returns the record-type descriptor of \var{rec} +\listlibraries +\endentryheader + +\noindent +\var{rec} must be a record. +This procedure is intended for use in the definition of portable printers +and debuggers. +For records created with \scheme{make-record-type}, +it may not be the same as the descriptor returned by +\scheme{make-record-type}. +See the comments about field accessibility and mutability under +\scheme{record-field-accessible?} and +\scheme{record-field-mutable?} above. + +This procedure is equivalent to the Revised$^6$ Report \scheme{record-rtd} +procedure. + +\schemedisplay +(define rtd (make-record-type "frob" '(blit blat))) +rtd ;=> # +(define x ((record-constructor rtd) 1 2)) +(record-type-descriptor x) ;=> # +(eq? (record-type-descriptor x) rtd) ;=> \var{unspecified} +\endschemedisplay + + +\section{Procedures} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{procedure-arity-mask}{\categoryprocedure}{(procedure-arity-mask \var{proc})} +\returns an exact integer bitmask identifying the accepted argument counts of \var{proc} +\listlibraries +\endentryheader + +\noindent +The bitmask is represented as two's complement number with the bit +at each index \var{n} set if and only if \var{proc} accepts \var{n} +arguments. + +The two's complement encoding implies that if \var{proc} accepts +\var{n} or more arguments, the encoding is a negative number, +since all the bits from \var{n} and up are set. For example, if +\var{proc} accepts any number of arguments, the two's complement +encoding of all bits set is \scheme{-1}. + +\schemedisplay +(procedure-arity-mask (lambda () 'none)) ;=> 1 +(procedure-arity-mask car) ;=> 2 +(procedure-arity-mask (case-lambda [() 'none] [(x) x])) ;=> 3 +(procedure-arity-mask (lambda x x)) ;=> -1 +(procedure-arity-mask (case-lambda [() 'none] [(x y . z) x])) ;=> -3 +(procedure-arity-mask (case-lambda)) ;=> 0 +(logbit? 1 (procedure-arity-mask pair?)) ;=> #t +(logbit? 2 (procedure-arity-mask pair?)) ;=> #f +(logbit? 2 (procedure-arity-mask cons)) ;=> #t +\endschemedisplay diff --git a/csug/oop.stex b/csug/oop.stex new file mode 100644 index 0000000..e99f0ec --- /dev/null +++ b/csug/oop.stex @@ -0,0 +1,14 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +% uncomment Thread System Oop Interface section in threads.stex diff --git a/csug/preface.stex b/csug/preface.stex new file mode 100644 index 0000000..135ccf5 --- /dev/null +++ b/csug/preface.stex @@ -0,0 +1,86 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Preface} + +{\ChezScheme} is both a general-purpose programming language and +an implementation of that language, with supporting tools and +documentation. +As a superset of the language described in the Revised$^6$ Report +on Scheme (R6RS), {\ChezScheme} supports all standard features of +Scheme, including first-class procedures, proper treatment of tail +calls, continuations, user-defined records, libraries, exceptions, +and hygienic macro expansion. +{\ChezScheme} supports numerous non-R6RS features. +A few of these are local and top-level modules, +local import, foreign datatypes and procedures, nonblocking I/O, +an interactive top-level, compile-time values and properties, +pretty-printing, and formatted output. + +The implementation includes a compiler that generates native code +for each processor upon which it runs along with a run-time system +that provides automatic storage management, foreign-language +interfaces, source-level debugging, profiling support, and an +extensive run-time library. + +The threaded versions of {\ChezScheme} support native threads, allowing +Scheme programs to take advantage of multiprocessor or multiple-core +systems. +Nonthreaded versions are also available and are faster for +single-threaded applications. +Both 32-bit and 64-bit versions are available for some platforms. +The 64-bit versions support larger heaps, while the 32-bit versions +are faster for some applications. + +{\ChezScheme}'s interactive programming system includes an expression +editor that, like many shells, supports command-line editing, a history +mechanism, and command completion. +Unlike most shells that support command-line editing, the expression +editor properly supports multiline expressions. + +{\ChezScheme} is intended to be as reliable and efficient as possible, +with reliability taking precedence over efficiency if necessary. +Reliability means behaving as designed and documented. +While a {\ChezScheme} program can always fail to work properly +because of a bug in the program, it should never fail because of a +bug in the {\ChezScheme} implementation. +Efficiency means performing at a high level, consuming minimal CPU +time and memory. +Performance should be balanced across features, across run time and +compile time, and across programs and data of different sizes. +These principles guide {\ChezScheme} language and tool design as +well as choice of implementation technique; for example, a language +feature or debugging hook might not exist in {\ChezScheme} because +its presence would reduce reliability, efficiency, or both. + +The compiler has been rewritten for Version~9 and generates +substantially faster code than the earlier compiler at the cost of +greater compile time. +This is the primary difference between Versions~8 and~9. + +This book (CSUG) is a companion to \emph{The Scheme Programming +Language, 4th Edition} (TSPL4). +TSPL4 serves as an introduction to and reference for R6RS, while +CSUG describes {\ChezScheme} features and tools that are not part +of R6RS. +For the reader's convenience, the summary of forms and index at the back +of this book contain entries from both books, with each entry from TSPL4 +marked with a ``t'' in front of its page number. +In the online version, the page numbers given in the summary of forms and +index double as direct links into one of the documents or the other. + +Additional documentation for {\ChezScheme} includes release notes, a +manual page, and a number of published papers and articles that describe +various aspects of the system's design and implementation. + +Thank you for using {\ChezScheme}. diff --git a/csug/priminfo.ss b/csug/priminfo.ss new file mode 100644 index 0000000..02d43a5 --- /dev/null +++ b/csug/priminfo.ss @@ -0,0 +1,62 @@ +;;; priminfo.ss +;;; Copyright 2005-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(module priminfo (primvec get-libraries) + + (define prim-db (make-eq-hashtable)) + + (define primvec + (lambda () + (hashtable-keys prim-db))) + + (define get-libraries + (lambda (name) + (or (eq-hashtable-ref prim-db name #f) + (errorf #f "unknown primitive ~s" name)))) + + (define put-priminfo! + (lambda (prim lib*) + (when (eq-hashtable-contains? prim-db prim) + (warning 'define-symbol-type "extra entry for ~s" prim)) + (eq-hashtable-set! prim-db prim lib*))) + + (define-syntax define-symbol-flags* + (lambda (x) + (syntax-case x (libraries) + [(k ([libraries lib ...] [flags flag ...] ignore ...) entry ...) + (or (memq 'system (datum (flag ...))) + (memq 'system-keyword (datum (flag ...)))) + #'(void)] + [(k ([libraries] ignore ...) entry ...) + #'(k ([libraries (chezscheme)] ignore ...) entry ...)] + [(_ ([libraries lib ...] ignore ...) entry ...) + (if (syntax-case #'(lib ...) (rnrs) + [((rnrs x ...) y ...) #t] + [_ #f]) + #'(void) + (let () + (define do-entry + (lambda (x) + (syntax-case x () + [((prefix prim) ignore ...) + (and (identifier? #'prefix) (identifier? #'prim)) + #'(put-priminfo! 'prim '(lib ...))] + [(prim ignore ...) + (identifier? #'prim) + #'(put-priminfo! 'prim '(lib ...))]))) + #`(begin #,@(map do-entry #'(entry ...)))))]))) + + (include "../s/primdata.ss") +) diff --git a/csug/scheme.hsty b/csug/scheme.hsty new file mode 100644 index 0000000..c8281c8 --- /dev/null +++ b/csug/scheme.hsty @@ -0,0 +1,33 @@ +\def\transerr#1{\raw{}} +\def\transin#1{\raw{}} +\def\transout#1{\raw{}} +\def\endtranserr#1{\raw{}} +\def\endtransin#1{\raw{}} +\def\endtransout#1{\raw{}} + +\def\schemeblankline{{\\\\}} +\def\schemelinestart{} +%%% handle numbered lines in scheme.sty and scheme.hsty +%%% ---have scheme-prep produce only \schemelinestart +% following is probably broken until we have tables, I suspect. +% Actually, the right way to fix this may be to use CSS +\def\schemelinestartnumbered#1{\raw{
    }#1\raw{
    }} + +\def\scheme#1{{\tt #1}} +\def\longcode\schemedisplay{\schemedisplay} +\def\noskip\schemedisplay{\schemedisplay} +\def\schemedisplay{\par\begingroup\tt\hardspaces} +\def\endschemedisplay{\endgroup\par} +\def\schemeindent{} +\def\schatsign{\raw{@}} +\def\schbackslash{\raw{\}} +\def\schcarat{\raw{^}} +\def\schdot{\raw{.}} +\def\schlbrace{\raw{&##123;}} +\def\schrbrace{\raw{&##125;}} +\def\schtilde{\raw{~}} +\def\schunderscore{\raw{_}} +\def\becomes{$\rightarrow$} +\def\is{$\Rightarrow$} +\def\si{\raw{}} +\def\var#1{\emph{#1}} diff --git a/csug/scheme.sty b/csug/scheme.sty new file mode 100644 index 0000000..db437b6 --- /dev/null +++ b/csug/scheme.sty @@ -0,0 +1,89 @@ +\usepackage{color} +\def\transerr#1{\begingroup\slshape} +\def\transin#1{\begingroup\color{red}} +\def\transout#1{\begingroup\color{blue}} +\def\traceout#1{\begingroup\color{blue}} +\def\endtranserr#1{\endgroup} +\def\endtransin#1{\endgroup} +\def\endtransout#1{\endgroup} +\def\endtraceout#1{\endgroup} + +% this didn't work --- screwed up indentation: +\long\def\showinteraction#1#2{\begin{minipage}[t]{4.375in}#1\end{minipage}\hfill\fbox{\begin{minipage}[t]{2in}#2\end{minipage}}} +% so I resorted to this: +\def\startrepl{\begin{minipage}[t]{4.3in}} % was 4.375 and 2 when interactionwindow = 28 +\def\endrepl{\end{minipage}} +\def\startinteraction{\begin{minipage}[t]{2.2in}\vrule\begin{minipage}[t]{2.2in}\hrule\schemeindent=2pt} +\def\endinteraction{\hrule\end{minipage}\vrule\end{minipage}} + +\font\ninefivett=cmtt9 at 9.5pt +\newskip\ttglue +\ttglue=.5em plus .25em minus .15em +\font\tinyvar=cmti7 +\font\smallvar=cmti9 +\font\summarysizevar=cmti9 +\font\indexsizevar=cmti8 +\font\normalvar=cmti10 at 11pt +\def\schemelarge{% + \def\schemelarger{\fontsize{14}{16}}% + \def\schemesmaller{\fontsize{10}{12}}% + \def\tt{\fontsize{12}{14}\ttfamily}% + \def\var##1{{\normalvar##1\/}}} +\def\schemenormal{% + \def\schemelarger{\fontsize{12}{14}}% + \def\schemesmaller{\fontsize{8}{9}}% + \def\tt{\fontsize{10pt}{11pt}\ttfamily\ninefivett}% + \def\var##1{{\smallvar##1\/}}} +\def\schemesmall{% + \def\schemelarger{\fontsize{10}{12}}% + \def\schemesmaller{\fontsize{6}{7}}% + \def\tt{\fontsize{8}{9}\ttfamily}% + \def\var##1{{\smallvar##1\/}}} +\def\schemesummarysize{% + \def\schemelarger{\fontsize{10}{12}}% + \def\schemesmaller{\fontsize{6}{7}}% + \def\tt{\fontsize{8}{9}\ttfamily}% + \def\var##1{{\summarysizevar##1\/}}} +\def\schemeindexsize{% + \def\schemelarger{\fontsize{10}{12}}% + \def\schemesmaller{\fontsize{6}{7}}% + \def\tt{\fontsize{7}{8}\ttfamily}% + \def\var##1{{\indexsizevar##1\/}}} +\schemenormal + +\newskip\schemeindent +\schemeindent=0pt +{\obeyspaces\global\let =\ } +\def\schtilde{\raisebox{-.5ex}{\hbox{\char`\~}}} +\def\schdot{.} +\def\schcarat{\char`\^} +\def\schbackslash{\char`\\} +\def\schatsign{\char`\@} +\def\schunderscore{\char`\_} +\def\schlbrace{\char`\{} +\def\schrbrace{\char`\}} +\def\scheme#1{\mbox{\tt\frenchspacing\spaceskip=\ttglue#1}} + +\def\schemeblankline{\par\penalty-100\vskip .7\baselineskip} +\def\schemelinestart{{\leavevmode\hbox{\hskip \schemeindent\relax}}} +%%% handle numbered lines in scheme.sty and scheme.hsty +%%% ---have scheme-prep produce only \schemelinestart +\def\schemelinestartnumbered#1{{\leavevmode\hbox{\hbox to 1em {\hfil{\rm #1}} \hskip .5\schemeindent\relax}}} + +\def\noskip\schemedisplay{\begingroup% + \parindent=0pt% + \parskip=0pt% + \def\becomes{\hbox to 2em{\hfil$\rightarrow$\hfil}}% + \def\is{\hbox to 2em{\hfil$\Rightarrow$\hfil}}% + \def\si{\hbox to 2em{\hfil}}% + \interlinepenalty=2000% + \tt\obeyspaces\frenchspacing} +\def\schemedisplay{\beforeschemedisplay\noskip\schemedisplay} +\def\longcode\schemedisplay{\penalty-200\vskip 8pt plus 4pt% + \kern3pt\hrule\kern5pt\nobreak\noskip\schemedisplay} +\def\endschemedisplay{\par\endgroup\afterschemedisplay} +\def\var#1{{\normalsize\textrm{\textit{#1}}}} +\def\raw#1{#1} +\def\beforeschemedisplay{\penalty-100\vskip\parskip\vskip5pt} +\def\afterschemedisplay{\penalty-200\vskip5pt} + diff --git a/csug/setup.ss b/csug/setup.ss new file mode 100644 index 0000000..75a8121 --- /dev/null +++ b/csug/setup.ss @@ -0,0 +1 @@ +(reset-handler abort) diff --git a/csug/smgmt.stex b/csug/smgmt.stex new file mode 100644 index 0000000..72fa45d --- /dev/null +++ b/csug/smgmt.stex @@ -0,0 +1,966 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Storage Management\label{CHPTSMGMT}} + +This chapter describes aspects of the storage management system and +procedures that may be used to control its operation. + +\section{Garbage Collection\label{SECTSMGMTGC}} + +Scheme objects such as pairs, strings, procedures, and user-defined +records are never explicitly deallocated by a Scheme program. +Instead, the \index{storage management}storage management system +automatically reclaims the +storage associated with an object once it proves the object is no longer +accessible. +In order to reclaim this storage, {\ChezScheme} employs a +\index{garbage collector}garbage +collector which runs periodically as a program runs. +Starting from a set of known \emph{roots}, e.g., the machine registers, +the garbage collector locates all accessible objects, +copies them (in most cases) in order to eliminate fragmentation +between accessible objects, and reclaims storage occupied by +inaccessible objects. + +Collections are triggered automatically by the default collect-request +handler, which is invoked via a collect-request interrupt that occurs +after approximately $n$ bytes of storage have been allocated, where $n$ is +the value of the parameter +\index{\scheme{collect-trip-bytes}}\scheme{collect-trip-bytes}. +The default collect-request handler causes a collection by calling the +procedure \index{\scheme{collect}}\scheme{collect} without arguments. +The collect-request handler can be redefined by changing the value of the +parameter +\index{\scheme{collect-request-handler}}\scheme{collect-request-handler}. +A program can also cause a collection to occur between collect-request +interrupts by calling \scheme{collect} directly either without or with +arguments. + +{\ChezScheme}'s collector is a \emph{generation-based} collector. +It segregates objects based on their age (roughly speaking, the +number of collections survived) and collects older objects less +frequently than younger objects. +Since younger objects tend to become inaccessible more quickly than +older objects, the result is that most collections take little +time. +The system also maintains a +\index{static generation}\emph{static} generation from +which storage is never reclaimed. +Objects are placed into the static generation only +when a heap is compacted (see +\index{\scheme{Scompact_heap}}\scheme{Scompact_heap} in +Section~\ref{SECTFOREIGNCLIB}) or when an explicitly specified +target-generation is the symbol \scheme{static}. +This is primarily useful after an application's permanent code and data +structures have been loaded and initialized, to reduce the overhead of +subsequent collections. + +Nonstatic generations are numbered starting at zero for the youngest +generation up through the current value of +\index{\scheme{collect-maximum-generation}}\scheme{collect-maximum-generation}. +The storage manager places newly allocated objects into generation 0. + +When \scheme{collect} is invoked without arguments, generation 0 +objects that survive collection move to generation 1, generation 1 +objects that survive move to generation 2, and so on, except that +objects are never moved past the maximum nonstatic generation. +Objects in the maximum nonstatic generation are collected back into +the maximum nonstatic generation. +While generation 0 is collected during each collection, older +generations are collected less frequently. +An internal counter, gc-trip, is maintained to control when each +generation is collected. +Each time \scheme{collect} is called without arguments (as from the default +collect-request handler), gc-trip is incremented by one, and the set of +generations to be collected is determined from the current value of +gc-trip and the value of +\index{\scheme{collect-generation-radix}}\scheme{collect-generation-radix}: +with a collect-generation radix of $r$, the maximum collected generation +is the highest numbered generation $g$ for which gc-trip is a +multiple of $r^g$. +If \scheme{collect-generation-radix} is set to 4, the system thus +collects generation 0 every time, generation 1 every 4 times, +generation 2 every 16 times, and so on. + +When \scheme{collect} is invoked with arguments, the generations to be +collected and their target generations are determined by the arguments. +In addition, the first argument \var{cg} affects the value of gc-trip; +that is, gc-trip is advanced to the next $r^{cg}$ boundary, but +not past the next $r^{cg+1}$ boundary, where $r$ is the +value of \scheme{collect-generation-radix}. + +It is possible to make substantial adjustments in the collector's behavior +by setting the parameters described in this section. +It is even possible to completely override the collector's default strategy for +determining when each generation is collected by redefining the +collect-request handler to call \scheme{collect} with arguments. +For example, the programmer can redefine the handler to treat the +maximum nonstatic generation as a static generation over a long +period of time by calling \scheme{collect} with arguments that +prevent the maximum nonstatic generation from being collected during +that period of time. + +Additional information on {\ChezScheme}'s collector can be found in the +report ``Don't stop the {BiBOP}: Flexible and efficient +storage management for dynamically typed languages''~\cite{Dybvig:sm}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect}{\categoryprocedure}{(collect)} +\formdef{collect}{\categoryprocedure}{(collect \var{cg})} +\formdef{collect}{\categoryprocedure}{(collect \var{cg} \var{max-tg})} +\formdef{collect}{\categoryprocedure}{(collect \var{cg} \var{min-tg} \var{max-tg})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +This procedure causes the storage manager to perform a garbage +collection. +\scheme{collect} is invoked periodically without arguments by the +default collect-request handler, but it may also be called explicitly, +e.g., from a custom collect-request handler, between phases of a +computation when collection is most likely to be successful, or +before timing a computation. +In the threaded versions of {\ChezScheme}, the thread that invokes +\scheme{collect} must be the only active thread. + +When called without arguments, the system determines automatically +which generations to collect and the target generation for each +collected generation as described in the lead-in to this section. + +When called with arguments, the system collects all and only objects +in generations less than or equal to \var{cg} (the maximum collected +generation) into the target generation or generations determined +by \var{min-tg} (the minimum target generation) and \var{max-tg} +(the maximum target generation). +Specifically, the target generation for any object in a collected +generation \var{g} is +$\mbox{min}(\mbox{max}(\mbox{\emph{g}}+1,\mbox{\emph{min-tg}}),\mbox{\emph{max-tg}})$, where +\scheme{static} is taken to have the value one greater +than the maximum nonstatic generation. + +If present, \var{cg} must be a nonnegative fixnum no greater than +the maximum nonstatic generation, i.e., the current value of the +parameter \scheme{collect-maximum-generation}. + +If present, \var{max-tg} must be a nonnegative fixnum or the symbol +\scheme{static} and either equal to \var{cg} or one greater than +\var{cg}, again treating \scheme{static} as having the value one +greater than the maximum nonstatic generation. +If \var{max-tg} is not present (but \var{cg} is), it defaults to +\var{cg} if \var{cg} is equal to the maximum target generation and +to one more than \var{cg} otherwise. + +If present, \var{min-tg} must be a nonnegative fixnum or the symbol +\scheme{static} and no greater than \var{max-tg}, again treating +\scheme{static} as having the value one greater than the maximum +nonstatic generation. +Unless \var{max-cg} is the same as \var{cg}, \var{min-tg} must also +be greater than \var{cg}. +If \var{min-tg} is not present (but \var{cg} is), it defaults to +the same value as \var{max-tg}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-rendezvous}{\categoryprocedure}{(collect-rendezvous)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Requests a garbage collection in the same way as when the system +determines that a collection should occur. All running threads are +coordinated so that one of them calls the collect-request handler, while +the other threads pause until the handler returns. + +Note that if the collect-request handler (see +\scheme{collect-request-handler}) does not call \scheme{collect}, then +\scheme{collect-rendezvous} does not actually perform a garbage +collection. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-notify}{\categoryglobalparameter}{collect-notify} +\listlibraries +\endentryheader + +\noindent +If \scheme{collect-notify} is set to a true value, the collector prints +a message whenever a collection is run. +\scheme{collect-notify} is set to \scheme{#f} by default. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-trip-bytes}{\categoryglobalparameter}{collect-trip-bytes} +\listlibraries +\endentryheader + +\noindent +This parameter determines the approximate amount of storage that is +allowed to be allocated between garbage collections. +Its value must be a positive fixnum. + +{\ChezScheme} allocates memory internally in large chunks and +subdivides these chunks via inline operations for efficiency. +The storage manager determines whether to request a collection only +once per large chunk allocated. +Furthermore, some time may elapse between when a collection is +requested by the storage manager and when the collect request is +honored, especially if interrupts are temporarily disabled via +\index{\scheme{with-interrupts-disabled}}\scheme{with-interrupts-disabled} +or \index{\scheme{disable-interrupts}}\scheme{disable-interrupts}. +Thus, \scheme{collect-trip-bytes} is an approximate measure only. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-generation-radix}{\categoryglobalparameter}{collect-generation-radix} +\listlibraries +\endentryheader + +\noindent +This parameter determines how often each generation is collected +when \scheme{collect} is invoked without arguments, as by the default +collect-request handler. +Its value must be a positive fixnum. +Generations are collected once every $r^g$ times a collection occurs, +where $r$ is the +value of \scheme{collect-generation-radix} and $g$ is the generation +number. + +Setting \scheme{collect-generation-radix} to one forces all generations +to be collected each time a collection occurs. +Setting \scheme{collect-generation-radix} to a very large number +effectively delays collection of older generations indefinitely. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-maximum-generation}{\categoryglobalparameter}{collect-maximum-generation} +\listlibraries +\endentryheader + +This parameter determines the maximum nonstatic generation, hence the +total number of generations, currently in use. +Its value is an exact integer in the range 1 through 254. +When set to 1, only two nonstatic generations are used; when set to 2, +three nonstatic generations are used, and so on. +When set to 254, 255 nonstatic generations are used, plus the single +static generation for a total of 256 generations. +Increasing the number of generations effectively decreases how often old +objects are collected, potentially decreasing collection overhead but +potentially increasing the number of inaccessible objects retained in the +system and thus the total amount of memory required. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-request-handler}{\categoryglobalparameter}{collect-request-handler} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{collect-request-handler} must be a procedure. +The procedure is invoked without arguments whenever the +system determines that a collection should occur, i.e., some time after +an amount of storage determined by the parameter +\scheme{collect-trip-bytes} has been allocated since the last +collection. + +By default, \scheme{collect-request-handler} simply invokes +\scheme{collect} without arguments. + +Automatic collection may be disabled by setting +\scheme{collect-request-handler} to a procedure that does nothing, +e.g.: + +\schemedisplay +(collect-request-handler void) +\endschemedisplay + +Collection can also be temporarily disabled using +\scheme{critical-section}, which prevents any interrupts from +being handled. + +In the threaded versions of {\ChezScheme}, the collect-request +handler is invoked by a single thread with all other threads +temporarily suspended. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{release-minimum-generation}{\categoryglobalparameter}{release-minimum-generation} +\listlibraries +\endentryheader + +This parameter's value must be between 0 and the value of +\scheme{collect-maximum-generation}, inclusive, and defaults to the +value of \scheme{collect-maximum-generation}. + +As new data is allocated and collections occur, the storage-management +system automatically requests additional virtual memory address space +from the operating system. +Correspondingly, in the event the heap shrinks significantly, the system +attempts to return some of the virtual-memory previously obtained from +the operating system back to the operating system. +By default, the system attempts to do so only after a collection that +targets the maximum nonstatic generation. +The system can be asked to do so after collections +targeting younger generations as well by altering the value +\scheme{release-minimum-generation} to something less than the value +of \scheme{collect-maximum-generation}. +When the generation to which the parameter is set, or any older +generation, is the target generation of a collection, the storage +management system attempts to return unneeded virtual memory to the +operating system following the collection. + +When \scheme{collect-maximum-generation} is set to a new value \var{g}, +\scheme{release-minimum-generation} is implicitly set to \var{g} as well +if (a) the two parameters have the same value before the change, or (b) +\scheme{release-minimum-generation} has a value greater than \var{g}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{heap-reserve-ratio}{\categoryglobalparameter}{heap-reserve-ratio} +\listlibraries +\endentryheader + +This parameter determines the approximate amount of memory reserved (not +returned to the O/S as described in the entry for \scheme{release-minimum-generation}) +in proportion to the amount currently occupied, excluding areas +of memory that have been made static. +Its value must be an inexact nonnegative flonum value; if set to an exact +real value, the exact value is converted to an inexact value. +The default value, 1.0, reserves one page of memory for each currently +occupied nonstatic page. +Setting it to a smaller value may result in a smaller average virtual +memory footprint, while setting it to a larger value may result in fewer +calls into the operating system to request and free memory space. + + +\section{Weak Pairs, Ephemeron Pairs, and Guardians\label{SECTGUARDWEAKPAIRS}} + +\index{weak pairs}\index{weak pointers}\emph{Weak pairs} allow programs +to maintain \emph{weak pointers} to objects. +A weak pointer to an object does not prevent the object from being +reclaimed by the storage management system, but it does remain valid as +long as the object is otherwise accessible in the system. + +\index{ephemeron pairs}\emph{Ephemeron pairs} are like weak pairs, but +ephemeron pairs combine two pointers where the second is retained only +as long as the first is retained. + +\index{guardians}\emph{Guardians} +allow programs to protect objects from deallocation +by the garbage collector and to determine when the objects would +otherwise have been deallocated. + +Weak pairs, ephemeron pairs, and guardians allow programs to retain +information about objects in separate data structures (such as hash +tables) without concern that maintaining this information will cause +the objects to remain indefinitely in the system. Ephemeron pairs +allow such data structures to retain key--value combinations +where a value may refer to its key, but the combination +can be reclaimed if neither must be saved otherwise. +In addition, guardians allow objects to be saved from deallocation +indefinitely so that they can be reused or so that clean-up or other +actions can be performed using the data stored within the objects. + +The implementation of guardians and weak pairs used by {\ChezScheme} +is described in~\cite{Dybvig:guardians}. Ephemerons are described +in~\cite{Hayes:ephemerons}, but the implementation in {\ChezScheme} +avoids quadratic-time worst-case behavior. + +%---------------------------------------------------------------------------- +\entryheader\label{desc:weak-cons} +\formdef{weak-cons}{\categoryprocedure}{(weak-cons \var{obj_1} \var{obj_2})} +\returns a new weak pair +\listlibraries +\endentryheader + +\noindent +\var{obj_1} becomes the car and \var{obj_2} becomes the cdr of the +new pair. +Weak pairs are indistinguishable from ordinary pairs in all but two ways: + +\begin{itemize} +\item weak pairs can be distinguished from pairs using the +\scheme{weak-pair?} predicate, and + +\item weak pairs maintain a weak pointer to the object in the +car of the pair. +\end{itemize} + +\noindent +The weak pointer in the car of a weak pair is just like a normal +pointer as long as the object to which it points is accessible through +a normal (nonweak) pointer somewhere in the system. +If at some point the garbage collector recognizes that there are no +nonweak pointers to the object, however, it replaces each weak pointer +to the object with the ``broken weak-pointer'' object, \scheme{#!bwp}, +and discards the object. + +The cdr field of a weak pair is \emph{not} a weak pointer, so +weak pairs may be used to form lists of weakly held objects. +These lists may be manipulated using ordinary list-processing +operations such as \scheme{length}, \scheme{map}, and \scheme{assv}. +(Procedures like \scheme{map} that produce list structure always +produce lists formed from nonweak pairs, however, even when their input +lists are formed from weak pairs.) +Weak pairs may be altered using \scheme{set-car!} and \scheme{set-cdr!}; after +a \scheme{set-car!} the car field contains a weak pointer to the new +object in place of the old object. +Weak pairs are especially useful for building association pairs +in association lists or hash tables. + +Weak pairs are printed in the same manner as ordinary pairs; there +is no reader syntax for weak pairs. +As a result, weak pairs become normal pairs when they are written +and then read. + +\schemedisplay +(define x (cons 'a 'b)) +(define p (weak-cons x '())) +(car p) ;=> (a . b) + +(define x (cons 'a 'b)) +(define p (weak-cons x '())) +(set! x '*) +(collect) +(car p) ;=> #!bwp +\endschemedisplay + +\noindent +The latter example above may in fact return \scheme{(a . b)} if a +garbage collection promoting the pair into an older generation occurs +prior to the assignment of \scheme{x} to \scheme{*}. +It may be necessary to force an older generation collection to allow +the object to be reclaimed. +The storage management system guarantees only that the object +will be reclaimed eventually once all nonweak pointers to it are +dropped, but makes no guarantees about when this will occur. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{weak-pair?}{\categoryprocedure}{(weak-pair? \var{obj})} +\returns \scheme{#t} if obj is a weak pair, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(weak-pair? (weak-cons 'a 'b)) ;=> #t +(weak-pair? (cons 'a 'b)) ;=> #f +(weak-pair? "oops") ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:ephemeron-cons} +\formdef{ephemeron-cons}{\categoryprocedure}{(ephemeron-cons \var{obj_1} \var{obj_2})} +\returns a new ephemeron pair +\listlibraries +\endentryheader + +\noindent +\var{obj_1} becomes the car and \var{obj_2} becomes the cdr of the +new pair. +Ephemeron pairs are indistinguishable from ordinary pairs in all but two ways: + +\begin{itemize} +\item ephemeron pairs can be distinguished from pairs using the +\scheme{ephemeron-pair?} predicate, and + +\item ephemeron pairs maintain a weak pointer to the object in the +car of the pair, and the cdr of the pair is preserved only as long +as the car of the pair is preserved. +\end{itemize} + +\noindent + +An ephemeron pair behaves like a weak pair, but the cdr is treated +specially in addition to the car: the cdr of an ephemeron is set to +\scheme{#!bwp} at the same time that the car is set to \scheme{#!bwp}. +Since the car and cdr fields are set to \scheme{#!bwp} at the same +time, then the fact that the car object may be referenced through the +cdr object does not by itself imply that car must be preserved (unlike +a weak pair); instead, the car must be saved for some reason +independent of the cdr object. + +Like weak pairs and other pairs, ephemeron pairs may be altered using +\scheme{set-car!} and \scheme{set-cdr!}, and ephemeron pairs are +printed in the same manner as ordinary pairs; there is no reader +syntax for ephemeron pairs. + +\schemedisplay +(define x (cons 'a 'b)) +(define p (ephemeron-cons x x)) +(car p) ;=> (a . b) +(cdr p) ;=> (a . b) + +(define x (cons 'a 'b)) +(define p (ephemeron-cons x x)) +(set! x '*) +(collect) +(car p) ;=> #!bwp +(cdr p) ;=> #!bwp + +(define x (cons 'a 'b)) +(define p (weak-cons x x)) ; \var{not an ephemeron pair} +(set! x '*) +(collect) +(car p) ;=> (a . b) +(cdr p) ;=> (a . b) +\endschemedisplay + +\noindent +As with weak pairs, the last two expressions of the middle example +above may in fact return \scheme{(a . b)} if a garbage collection +promoting the pair into an older generation occurs prior to the +assignment of \scheme{x} to \scheme{*}. In the last example above, +however, the results of the last two expressions will always be +\scheme{(a . b)}, because the cdr of a weak pair holds a non-weak +reference, and that non-weak reference prevents the car field from becoming +\scheme{#!bwp}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ephemeron-pair?}{\categoryprocedure}{(ephemeron-pair? \var{obj})} +\returns \scheme{#t} if obj is a ephemeron pair, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(ephemeron-pair? (ephemeron-cons 'a 'b)) ;=> #t +(ephemeron-pair? (cons 'a 'b)) ;=> #f +(ephemeron-pair? (weak-cons 'a 'b)) ;=> #f +(ephemeron-pair? "oops") ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bwp-object?}{\categoryprocedure}{(bwp-object? \var{obj})} +\returns \scheme{#t} if obj is the broken weak-pair object, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(bwp-object? #!bwp) ;=> #t +(bwp-object? 'bwp) ;=> #f + +(define x (cons 'a 'b)) +(define p (weak-cons x '())) +(set! x '*) +(collect (collect-maximum-generation)) +(car p) ;=> #!bwp +(bwp-object? (car p)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-guardian}{\categoryprocedure}{(make-guardian)} +\returns a new guardian +\listlibraries +\endentryheader + +\noindent +Guardians are represented by procedures that encapsulate groups of +objects registered for preservation. +When a guardian is created, the group of registered objects is empty. +An object is registered with a guardian by passing the object as an +argument to the guardian: + +\schemedisplay +(define G (make-guardian)) +(define x (cons 'aaa 'bbb)) +x ;=> (aaa . bbb) +(G x) +\endschemedisplay + +It is also possible to specify a ``representative'' object when +registering an object. +Continuing the above example: + +\schemedisplay +(define y (cons 'ccc 'ddd)) +y ;=> (ccc . ddd) +(G y 'rep) +\endschemedisplay + +The group of registered objects associated with a guardian is logically +subdivided into two disjoint subgroups: a subgroup referred to +as ``accessible'' objects, and one referred to ``inaccessible'' objects. +Inaccessible objects are objects that have been proven to be +inaccessible (except through the guardian mechanism itself or through +the car field of a weak or ephemeron pair), and +accessible objects are objects that have not been proven so. +The word ``proven'' is important here: it may be that some objects in +the accessible group are indeed inaccessible but +that this has not yet been proven. +This proof may not be made in some cases until long after the object +actually becomes inaccessible (in the current implementation, until a +garbage collection of the generation containing the object occurs). + +Objects registered with a guardian are initially placed in the accessible +group and are moved into the inaccessible group at some point after they +become inaccessible. +Objects in the inaccessible group are retrieved by invoking the guardian +without arguments. +If there are no objects in the inaccessible group, the guardian returns +\scheme{#f}. +Continuing the above example: + +\schemedisplay +(G) ;=> #f +(set! x #f) +(set! y #f) +(collect) +(G) ;=> (aaa . bbb) ; \var{this might come out second} +(G) ;=> rep ; \var{and this first} +(G) ;=> #f +\endschemedisplay + +\noindent +The initial call to \scheme{G} returns \scheme{#f}, since the pairs bound +to \scheme{x} and \scheme{y} are the +only object registered with \scheme{G}, and the pairs are still accessible +through those bindings. +When \scheme{collect} is called, the objects shift into the inaccessible group. +The two calls to \scheme{G} therefore return the pair previously bound to +\scheme{x} and the representative of the pair previously bound to \scheme{y}, +though perhaps in the other order from the one shown. +(As noted above for weak pairs, the call to collect may not actually be +sufficient to prove the object inaccessible, if the object has +migrated into an older generation.) + +Although an object registered without a representative and returned from +a guardian has been proven otherwise +inaccessible (except possibly via the car field of a weak or ephemeron pair), it has +not yet been reclaimed by the storage management system and will not be +reclaimed until after the last nonweak pointer to it within or outside +of the guardian system has been dropped. +In fact, objects that have been retrieved from a guardian have no +special status in this or in any other regard. +This feature circumvents the problems that might otherwise arise with +shared or cyclic structure. +A shared or cyclic structure consisting of inaccessible objects is +preserved in its entirety, and each piece registered for preservation +with any guardian is placed in the inaccessible set for that guardian. +The programmer then has complete control over the order in which pieces +of the structure are processed. + +An object may be registered with a guardian more than once, in which +case it will be retrievable more than once: + +\schemedisplay +(define G (make-guardian)) +(define x (cons 'aaa 'bbb)) +(G x) +(G x) +(set! x #f) +(collect) +(G) ;=> (aaa . bbb) +(G) ;=> (aaa . bbb) +\endschemedisplay + +\noindent +It may also be registered with more than one guardian, and guardians +themselves can be registered with other guardians. + +An object that has been registered with a guardian without a +representative and placed in +the car field of a weak or ephemeron pair remains in the car field of the +weak or ephemeron pair until after it has been returned from the guardian and +dropped by the program or until the guardian itself is dropped. + +\schemedisplay +(define G (make-guardian)) +(define x (cons 'aaa 'bbb)) +(define p (weak-cons x '())) +(G x) +(set! x #f) +(collect) +(set! y (G)) +y ;=> (aaa . bbb) +(car p) ;=> (aaa . bbb) +(set! y #f) +(collect 1) +(car p) ;=> #!bwp +\endschemedisplay + +\noindent +(The first collector call above would +promote the object at least into generation~1, requiring the second +collector call to be a generation~1 collection. +This can also be forced by invoking \scheme{collect} several times.) + +On the other hand, if a representative (other than the object itself) +is specified, the guarded object is dropped from the car field of the +weak or ephemeron pair at the same time as the representative becomes available +from the guardian. + +\schemedisplay +(define G (make-guardian)) +(define x (cons 'aaa 'bbb)) +(define p (weak-cons x '())) +(G x 'rep) +(set! x #f) +(collect) +(G) ;=> rep +(car p) ;=> #!bwp +\endschemedisplay + +The following example illustrates that the object is deallocated and +the car field of the weak pair set to \scheme{#!bwp} when the guardian +itself is dropped: + +\schemedisplay +(define G (make-guardian)) +(define x (cons 'aaa 'bbb)) +(define p (weak-cons x '())) +(G x) +(set! x #f) +(set! G #f) +(collect) +(car p) ;=> #!bwp +\endschemedisplay + +The example below demonstrates how guardians might be used to +deallocate external storage, such as storage managed by the C library +``malloc'' and ``free'' operations. + +\schemedisplay +(define malloc + (let ([malloc-guardian (make-guardian)]) + (lambda (size) + ; first free any storage that has been dropped. to avoid long + ; delays, it might be better to deallocate no more than, say, + ; ten objects for each one allocated + (let f () + (let ([x (malloc-guardian)]) + (when x + (do-free x) + (f)))) + ; then allocate and register the new storage + (let ([x (do-malloc size)]) + (malloc-guardian x) + x)))) +\endschemedisplay + +\noindent +\scheme{do-malloc} must return a Scheme object ``header'' encapsulating a pointer to the +external storage (perhaps as an unsigned integer), and all access to the +external storage must be made through this header. +In particular, care must be taken that no pointers to the external storage +exist outside of Scheme after the corresponding header has been +dropped. +\scheme{do-free} must deallocate the external storage using the encapsulated +pointer. +Both primitives can be defined in terms of \scheme{foreign-alloc} +and \scheme{foreign-free} or the C-library ``malloc'' and ``free'' +operators, imported as foreign procedures. (See +Chapter~\ref{CHPTFOREIGN}.) + +If it is undesirable to wait until \scheme{malloc} is called to free dropped +storage previously allocated by \scheme{malloc}, a collect-request handler +can be used instead to check for and free dropped storage, as shown below. + +\schemedisplay +(define malloc) +(let ([malloc-guardian (make-guardian)]) + (set! malloc + (lambda (size) + ; allocate and register the new storage + (let ([x (do-malloc size)]) + (malloc-guardian x) + x))) + (collect-request-handler + (lambda () + ; first, invoke the collector + (collect) + ; then free any storage that has been dropped + (let f () + (let ([x (malloc-guardian)]) + (when x + (do-free x) + (f))))))) +\endschemedisplay + +%% for testing: +% (define do-malloc (lambda (x) (list x))) +% (define do-free (lambda (x) (printf "freeing ~s~%" (car x)))) +% (define a (malloc 1)) +% (malloc 10) +% (let f () (cons f f) (f)) + +With a bit of refactoring, it would be possible to register +the encapsulated foreign address as a representative with +each header, in which \scheme{do-free} would take just the +foreign address as an argument. +This would allow the header to be dropped from the Scheme +heap as soon as it becomes inaccessible. + +Guardians can also be created via +\index{\scheme{ftype-guardian}}\scheme{ftype-guardian}, which +supports reference counting of foreign objects. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{guardian?}{\categoryprocedure}{(guardian? \var{obj})} +\returns \scheme{#t} if obj is a guardian, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(guardian? (make-guardian)) ;=> #t +(guardian? (ftype-guardian iptr)) ;=> #t +(guardian? (lambda x x)) ;=> #f +(guardian? "oops") ;=> #f +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{unregister-guardian}{\categoryprocedure}{(unregister-guardian \var{guardian})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\scheme{unregister-guardian} unregisters the +as-yet unresurrected objects currently registered with the guardian, +with one caveat. + +The caveat, which applies only to threaded versions of {\ChezScheme}, +is that objects registered with the guardian by other threads since +the last garbage collection might not be unregistered. +To ensure that all objects are unregistered in a multithreaded +application, a single thread can be used both to register and +unregister objects. +Alternatively, an application can arrange to define a +\index{\scheme{collect-request-handler}}collect-request +handler that calls \scheme{unregister-guardian} after it calls +\scheme{collect}. + +In any case, \scheme{unregister-guardian} returns a list containing each object +(or its representative, if specified) that it unregisters, with +duplicates as appropriate if the same object is registered more +than once with the guardian. +Objects already resurrected but not yet retrieved from the guardian +are not included in the list but remain retrievable from the +guardian. + +In the current implementation, \scheme{unregister-guardian} takes time proportional +to the number of unresurrected objects currently registered with +all guardians rather than those registered just with +the corresponding guardian. + +The example below assumes no collections occur except for those resulting from +explicit calls to \scheme{collect}. + +\schemedisplay +(define g (make-guardian)) +(define x (cons 'a 'b)) +(define y (cons 'c 'd)) +(g x) +(g x) +(g y) +(g y) +(set! y #f) +(collect 0 0) +(unregister-guardian g) ;=> ((a . b) (a . b)) +(g) ;=> (c . d) +(g) ;=> (c . d) +(g) ;=> #f +\endschemedisplay + +\scheme{unregister-guardian} can also be used to unregister ftype +pointers registered with guardians created by +\index{\scheme{ftype-guardian}}\scheme{ftype-guardian} +(Section~\ref{SECTTHREADFTYPEGUARDIANS}). + + +\section{Locking Objects\label{SECTSMGMTLOCKING}} + +All pointers from C variables or data structures to Scheme objects +should generally be discarded before entry (or reentry) into Scheme. +When this guideline cannot be followed, the object may be +\emph{locked} via \scheme{lock-object} or via the equivalent +C library procedure \index{\scheme{Slock_object}}\scheme{Slock_object} +(Section~\ref{SECTFOREIGNCLIB}). + +%---------------------------------------------------------------------------- +\entryheader +\formdef{lock-object}{\categoryprocedure}{(lock-object \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Locking an object prevents the storage manager from reclaiming or +relocating the object. +Locking should be used sparingly, as it introduces memory fragmentation +and increases storage management overhead. + +Locking can also lead to accidental retention of storage if objects +are not unlocked. +Objects may be unlocked via \scheme{unlock-object} or the equivalent +C library procedure +\index{\scheme{Sunlock_object}}\scheme{Sunlock_object}. + +Locking immediate values, such as fixnums, booleans, and characters, +or objects that have been made static is unnecessary but harmless. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{unlock-object}{\categoryprocedure}{(unlock-object \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +An object may be locked more than once by successive calls to +\scheme{lock-object}, \scheme{Slock_object}, or both, in which case it must +be unlocked by an equal number of calls to +\scheme{unlock-object} or \scheme{Sunlock_object} before it is +truly unlocked. + +An object contained within a locked object, such as an object in the +car of a locked pair, need not also be locked unless a separate C +pointer to the object exists. +That is, if the inner object is accessed only via an indirection of the +outer object, it should be left unlocked so that the collector is free +to relocate it during collection. + +Unlocking immediate values, such as fixnums, booleans, and characters, +or objects that have been made static is unnecessary and ineffective but harmless. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{locked-object?}{\categoryprocedure}{(locked-object? \var{obj})} +\returns \scheme{#t} if \var{obj} is locked, immediate, or static +\listlibraries +\endentryheader + +\noindent +This predicate returns true if \var{obj} cannot be relocated or reclaimed +by the collector, including immediate values, such as fixnums, +booleans, and characters, and objects that have been made static. diff --git a/csug/summary.ss b/csug/summary.ss new file mode 100644 index 0000000..967f49d --- /dev/null +++ b/csug/summary.ss @@ -0,0 +1,65 @@ +(define read-string + (lambda (ip) + (unless (eqv? (read-char ip) #\") + (error 'read-string "no starting double-quote")) + (list->string + (let f () + (let ([c (read-char ip)]) + (cond + [(eqv? c #\") '()] + [(or (eqv? c #\newline) (eof-object? c)) + (error 'read-string "no ending double-quote")] + [else (cons c (f))])))))) + +(define readrol + (lambda (ip) + (let ([c (read-char ip)]) + (if (eq? c #\newline) + '() + (cons c (readrol ip)))))) + +(define read-line + (lambda (ip) + (if (eof-object? (peek-char ip)) + (peek-char ip) + (let ([x (read-string ip)]) + (cons x (readrol ip)))))) + +(define summary-read + (lambda (ip) + (do ([ls '() (cons line ls)] + [line (read-line ip) (read-line ip)]) + ((eof-object? line) (reverse! ls))))) + +(define summary-sort + (lambda (x) + (sort! (lambda (x y) (string 2 + +(let ([f (lambda (x) (+ x 1))]) + (let-syntax ([g (syntax-rules () + [(_ x) (f x)])]) + (fluid-let-syntax ([f (syntax-rules () + [(_ x) x])]) + (g 1)))) ;=> 1 +\endschemedisplay + +\noindent +The two expressions are identical except that the inner +\scheme{let-syntax} form +in the first expression is a \scheme{fluid-let-syntax} form in the second. +In the first expression, the \scheme{f} occurring in the expansion of +\scheme{(g 1)} refers to +the \scheme{let}-bound variable \scheme{f}, whereas in the second it refers +to the keyword \scheme{f} by virtue of the fluid syntax binding for +\scheme{f}. + +\index{integrable procedures}\index{\scheme{define-integrable}}% +The following code employs \scheme{fluid-let-syntax} in the definition +of a \scheme{define-integrable} form that is similar +to \scheme{define} for procedure definitions except that it causes the +code for the procedure to be \emph{integrated}, or inserted, wherever +a direct call to the procedure is found. +No semantic difference is visible between procedures defined with +\scheme{define-integrable} and those defined with \scheme{define}, except that +a top-level \scheme{define-integrable} form must appear before the first +reference to the defined identifier. +Lexical scoping is preserved, the actual parameters +in an integrated call are evaluated once and at the proper time, +integrable procedures may be used as first-class values, and +recursive procedures do not cause indefinite recursive expansion. + +\schemedisplay +(define-syntax define-integrable + (syntax-rules (lambda) + [(_ name (lambda formals form1 form2 ...)) + (begin + (define xname + (fluid-let-syntax ([name (identifier-syntax xname)]) + (lambda formals form1 form2 ...))) + (define-syntax name + (lambda (x) + (syntax-case x () + [_ (identifier? x) #'xname] + [(_ arg (... ...)) + #'((fluid-let-syntax ([name (identifier-syntax xname)]) + (lambda formals form1 form2 ...)) + arg + (... ...))]))))])) +\endschemedisplay + +\noindent +A \scheme{define-integrable} has the following form. + +\schemedisplay +(define-integrable \var{name} \var{lambda-expression}) +\endschemedisplay + +\noindent +A \scheme{define-integrable} form expands into a pair of definitions: a syntax +definition of \var{name} and a variable definition of \scheme{xname}. +The transformer for \var{name} converts apparent calls to +\var{name} into direct calls to \var{lambda-expression}. +Since the resulting forms are merely direct \scheme{lambda} applications +(the equivalent of \scheme{let} expressions), +the actual parameters are evaluated exactly once and before evaluation +of the procedure's body, as required. +All other references to \var{name} are replaced with references to +\scheme{xname}. +The definition of \scheme{xname} binds it to the value of +\var{lambda-expression}. +This allows the procedure to be used as a first-class value. +Because \scheme{xname} is introduced by the transformer, the binding for +\scheme{xname} is not visible anywhere except where references to it +are introduced by the transformer for \var{name}. + +Within \var{lambda-expression}, wherever it appears, \var{name} +is rebound to a transformer that expands all references into references +to \scheme{xname}. +The use of \index{\scheme{fluid-let-syntax}}\scheme{fluid-let-syntax} +for this purpose prevents indefinite +expansion from indirect recursion among integrable procedures. +This allows the procedure to be recursive without causing indefinite +expansion. +Nothing special is done by \scheme{define-integrable} to maintain lexical +scoping, since lexical scoping is maintained automatically by the +expander. + +{\ChezScheme} integrates locally defined procedures automatically when it is +appropriate to do so. +It cannot integrate procedures defined at top-level, +however, since code that assigns top-level variables can be introduced +into the system (via \scheme{eval} or \scheme{load}) at any time. +\scheme{define-integrable} can be used to force the integration of +procedures bound at top-level, even if the integration of locally bound +procedures is left to the compiler. +It can also be used to force the integration of large procedures that +the compiler would not normally integrate. +(The \scheme{expand/optimize} procedure is useful for determining when +integration does or does not take place.) + +\section{Syntax-Rules Transformers\label{SECTSYNTAXRULES}} + +{\ChezScheme} extends \scheme{syntax-rules} to permit clause to include +fenders just like those allowed within \scheme{syntax-case} clauses. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{syntax-rules}{\categorysyntax}{(syntax-rules (\var{literal} \dots) \var{clause} \dots)} +\returns a transformer +\listlibraries +\endentryheader + +\noindent +Each \index{literals}\var{literal} must be an identifier other than +an underscore (~\scheme{_}~) or ellipsis (~\scheme{...}~). +Each clause must take the form below. + +\schemedisplay +(\var{pattern} \var{template}) +(\var{pattern} \var{fender} \var{template}) +\endschemedisplay + +\noindent +The first form is the only form supported by the Revised$^6$ Report. + + +\section{Syntax-Case Transformers\label{SECTSYNTAXCASE}} + +{\ChezScheme} provides several procedures and syntactic forms that may +be used to simplify the coding of certain syntactic abstractions. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{syntax->list}{\categoryprocedure}{(syntax->list \var{syntax-object})} +\returns a list of syntax objects +\listlibraries +\endentryheader + +\noindent +This procedure takes a syntax object representing +a list-structured form and returns a list of syntax objects, each representing +the corresponding subform of the input form. + +%Programmers are encouraged to use this procedure even when the current +%{\ChezScheme} implementation of \scheme{syntax-case} guarantees that +%the output of a \scheme{syntax} form is a list, since future versions of +%{\ChezScheme} may remove these guarantees in the interest of maintaining +%better source information. + +\scheme{syntax->list} may be defined as follows. + +\schemedisplay +(define syntax->list + (lambda (ls) + (syntax-case ls () + [() '()] + [(x . r) (cons #'x (syntax->list #'r))]))) + +#'(a b c) ;=> # +(syntax->list #'(a b c)) ;=> (# # #) +\endschemedisplay + +\scheme{syntax->list} is not required for list structures constructed +from individual pattern variable values or sequences of pattern-variable +values, since such structures are already lists. +For example: + +\schemedisplay +(list? (with-syntax ([x #'a] [y #'b] [z #'c]) #'(x y z)))) ;=> #t +(list? (with-syntax ([(x ...) #'(a b c)]) #'(x ...))) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{syntax->vector}{\categoryprocedure}{(syntax->vector \var{syntax-object})} +\returns a vector of syntax objects +\listlibraries +\endentryheader + +\noindent +This procedure takes a syntax object representing +a vector-structured form and returns a vector of syntax objects, each representing +the corresponding subform of the input form. + +%Programmers are encouraged to use this procedure even when the current +%{\ChezScheme} implementation of \scheme{syntax-case} guarantees that +%the output of a \scheme{syntax} form is a vector, since future versions of +%{\ChezScheme} may remove these guarantees in the interest of maintaining +%better source information. + +\scheme{syntax->vector} may be defined as follows. + +\schemedisplay +(define syntax->vector + (lambda (v) + (syntax-case v () + [#(x ...) (apply vector (syntax->list #'(x ...)))]))) + +#'#(a b c) ;=> # +(syntax->vector #'#(a b c)) ;=> #(# # #) +\endschemedisplay + +\scheme{syntax->vector} is not required for vector structures constructed +from individual pattern variable values or sequences of pattern-variable +values, since such structures are already vectors. +For example: + +\schemedisplay +(vector? (with-syntax ([x #'a] [y #'b] [z #'c]) #'#(x y z)))) ;=> #t +(vector? (with-syntax ([(x ...) #'(a b c)]) #'#(x ...))) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{syntax-object->datum}{\categoryprocedure}{(syntax-object->datum \var{obj})} +\returns \var{obj} stripped of syntactic information +\listlibraries +\endentryheader + +\noindent +\scheme{syntax-object->datum} is identical to the Revised$^6$ Report +\scheme{syntax->datum}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{datum}{\categorysyntax}{(datum \var{template})} +\returns see below +\listlibraries +\endentryheader + +\scheme{(datum \var{template})} is a convenient shorthand syntax for + +\schemedisplay +(syntax->datum (syntax \var{template})) +\endschemedisplay + +\var{datum} may be defined simply as follows. + +\schemedisplay +(define-syntax datum + (syntax-rules () + [(_ t) (syntax->datum #'t)])) + +(with-syntax ((a #'(a b c))) (datum a)) ;=> (a b c) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{datum->syntax-object}{\categoryprocedure}{(datum->syntax-object \var{template-identifier} \var{obj})} +\returns a syntax object +\listlibraries +\endentryheader + +\scheme{datum->syntax-object} is identical to the Revised$^6$ Report +\scheme{datum->syntax}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-implicit}{\categorysyntax}{(with-implicit (\var{id_0} \var{id_1} \dots) \var{body_1} \var{body_2} \dots)} +\returns see below +\listlibraries +\endentryheader + +This form abstracts over the common usage of \scheme{datum->syntax} +for creating implicit identifiers (see above). +The form + +\schemedisplay +(with-implicit (\var{id_0} \var{id_1} \dots) + \var{body_1} \var{body_2} \dots) +\endschemedisplay + +is equivalent to + +\schemedisplay +(with-syntax ([\var{id_1} (datum->syntax #'\var{id_0} '\var{id_1})] \dots) + \var{body_1} \var{body_2} \dots) +\endschemedisplay + +\scheme{with-implicit} can be defined simply as follows. + +\schemedisplay +(define-syntax with-implicit + (syntax-rules () + [(_ (tid id ...) b1 b2 ...) + (with-syntax ([id (datum->syntax #'tid 'id)] ...) + b1 b2 ...)])) +\endschemedisplay + +We can use \scheme{with-implicit} to simplify the (correct version of) +\scheme{loop} above. + +\schemedisplay +(define-syntax loop + (lambda (x) + (syntax-case x () + [(k e ...) + (with-implicit (k break) + #'(call-with-current-continuation + (lambda (break) + (let f () e ... (f)))))]))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{include}{\categorysyntax}{(include \var{path})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{include} expands into a \scheme{begin} expression containing +the forms found in the file named by \var{path}. +For example, if the file \scheme{f-def.ss} contains +% the expression +\scheme{(define f (lambda () x))}, the expression + +\schemedisplay +(let ([x "okay"]) + (include "f-def.ss") + (f)) +\endschemedisplay + +\noindent +evaluates to \scheme{"okay"}. +An include form is treated as a definition if it appears within a +sequence of definitions and the forms on the file named by +\var{path} are all definitions, as in the above example. +If the file contains expressions instead, the \scheme{include} form is +treated as an expression. + +\scheme{include} may be defined portably as follows, although +{\ChezScheme} uses an implementation-dependent definition that allows +it to capture and maintain source information for included code. + +\schemedisplay +(define-syntax include + (lambda (x) + (define read-file + (lambda (fn k) + (let ([p (open-input-file fn)]) + (let f ([x (read p)]) + (if (eof-object? x) + (begin (close-input-port p) '()) + (cons (datum->syntax k x) + (f (read p)))))))) + (syntax-case x () + [(k filename) + (let ([fn (datum filename)]) + (with-syntax ([(exp ...) (read-file fn #'k)]) + #'(begin exp ...)))]))) +\endschemedisplay + +\noindent +The definition of \scheme{include} uses \scheme{datum->syntax} to convert +the objects read from the file into syntax objects in the proper +lexical context, so that identifier references and definitions within +those expressions are scoped where the \scheme{include} form appears. + +In {\ChezScheme}'s implementation of \scheme{include}, +the parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories searched for source files not identified +by absolute path names. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:syntax-error} +\formdef{syntax-error}{\categoryprocedure}{(syntax-error \var{obj} \var{string} \dots)} +\returns does not return +\listlibraries +\endentryheader + +Syntax errors may be reported with \scheme{syntax-error}, which produces +a message by concatenating \scheme{\var{string} \dots} and a printed +representation of \var{obj}. +If no string arguments are provided, the string \scheme{"invalid syntax"} +is used instead. +When \var{obj} is a syntax object, the syntax-object wrapper is +stripped (as with \scheme{syntax->datum}) before the printed representation +is created. +If source file information is present in the syntax-object wrapper, +\scheme{syntax-error} incorporates this information into the error +message. + +\scheme{syntax-case} and \scheme{syntax-rules} call \scheme{syntax-error} +automatically if the input fails to match one of the clauses. + +We can use \scheme{syntax-error} to precisely report the cause +of the errors detected in the following definition of +(unnamed) \scheme{let}. + +\schemedisplay +(define-syntax let + (lambda (x) + (define check-ids! + (lambda (ls) + (unless (null? ls) + (unless (identifier? (car ls)) + (syntax-error (car ls) "let cannot bind non-identifier")) + (check-ids! (cdr ls))))) + (define check-unique! + (lambda (ls) + (unless (null? ls) + (let ([x (car ls)]) + (when (let mem? ([ls (cdr ls)]) + (and (not (null? ls)) + (or (bound-identifier=? x (car ls)) + (mem? (cdr ls))))) + (syntax-error x "let cannot bind two occurrences of"))) + (check-unique! (cdr ls))))) + (syntax-case x () + [(_ ((i e) ...) b1 b2 ...) + (begin + (check-ids! #'(i ...)) + (check-unique! #'(i ...)) + #'((lambda (i ...) b1 b2 ...) e ...))]))) +\endschemedisplay + +With this change, the expression + +\schemedisplay +(let ([a 3] [a 4]) (+ a a)) +\endschemedisplay + +produces the error message ``let cannot bind two occurrences of \scheme{a}.'' + +%---------------------------------------------------------------------------- +\entryheader +\formdef{literal-identifier=?}{\categoryprocedure}{(literal-identifier=? \var{identifier_1} \var{identifier_2})} +\returns see below +\listlibraries +\endentryheader + +This procedure is identical to the Revised$^6$ Report +\scheme{free-identifier=?}, and is provided for backward +compatibility only. + +\section{Compile-time Values and Properties\label{SECTSYNTAXCTVS}} + +When defining sets of dependent macros, it is often convenient to attach +information to identifiers in the same \emph{compile time environment} +that the expander uses to record information about variables, keywords, +module names, etc. +For example, a record-type definition macro, like +\scheme{define-record-type}, might need to attach information to the +record-type name in the compile-time environment for use in handling child +record-type definitions. + +{\ChezScheme} provides two mechanisms for attaching information to +identifiers in the compile-time environment: compile-time values and +compile-time properties. +A compile-time value is a kind of transformer that can be +associated with an identifier via \scheme{define-syntax}, +\scheme{let-syntax}, \scheme{letrec-syntax}, and \scheme{fluid-let-syntax}. +When an identifier is associated with a compile-time value, it cannot +also have any other meaning, and an attempt to reference it as an +ordinary identifier results in a syntax error. +A compile-time property, on the other hand, is maintained alongside +an existing binding, providing additional information about the +binding. +Properties are ignored when ordinary references to an identifier +occur. + +The mechanisms used by a macro to obtain compile-time values and +properties are similar. +In both cases, the macro's transformer returns a procedure \var{p} +rather than a syntax object. +The expander invokes \var{p} with one argument, an environment-lookup +procedure \var{lookup}, which \var{p} can then use to obtain compile-time +values and properties for one or more identifiers before it constructs the +macro's final output. +\var{lookup} accepts one or two identifier arguments. +With one argument, \var{id}, \var{lookup} returns the compile-time +value of \var{id}, or \scheme{#f} if \var{id} has no compile-time value. +With two arguments, \var{id} and \var{key}, \var{lookup} returns the +value of \var{id}'s \var{key} property, or \scheme{#f} if \var{id} +has no \var{key} property. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-compile-time-value}{\categoryprocedure}{(make-compile-time-value \var{obj})} +\returns a compile-time value +\listlibraries +\endentryheader + +A compile time value is a kind of transformer with which a keyword may +be associated by any of the keyword binding constructs, e.g., \scheme{define-syntax} +or \scheme{let-syntax}. +The transformer encapsulates the supplied \var{obj}. +The encapsulated object may be retrieved as described above. + +The following example illustrates how this feature might be used to define +a simple syntactic record-definition mechanism where the record type descriptor +is generated at expansion time. + +\schemedisplay +(define-syntax drt + (lambda (x) + (define construct-name + (lambda (template-identifier . args) + (datum->syntax template-identifier + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string (syntax->datum x)))) + args)))))) + (define do-drt + (lambda (rname fname* prtd) + (with-syntax ([rname rname] + [rtd (make-record-type-descriptor + (syntax->datum rname) prtd #f #f #f + (list->vector + (map (lambda (fname) + `(immutable ,(syntax->datum fname))) + fname*)))] + [make-rname (construct-name rname "make-" rname)] + [rname? (construct-name rname rname "?")] + [(rname-fname ...) + (map (lambda (fname) + (construct-name fname rname "-" fname)) + fname*)] + [(i ...) (enumerate fname*)]) + #'(begin + (define-syntax rname (make-compile-time-value 'rtd)) + (define rcd (make-record-constructor-descriptor 'rtd #f #f)) + (define make-rname (record-constructor rcd)) + (define rname? (record-predicate 'rtd)) + (define rname-fname (record-accessor 'rtd i)) + ...)))) + (syntax-case x (parent) + [(_ rname (fname ...)) + (for-all identifier? #'(rname fname ...)) + (do-drt #'rname #'(fname ...) #f)] + [(_ rname pname (fname ...)) + (for-all identifier? #'(rname pname fname ...)) + (lambda (lookup) + (let ([prtd (lookup #'pname)]) + (unless (record-type-descriptor? prtd) + (syntax-error #'pname "unrecognized parent record type")) + (do-drt #'rname #'(fname ...) prtd)))]))) +\endschemedisplay + +\schemedisplay +(drt prec (x y)) +(drt crec prec (z)) +(define r (make-crec 1 2 3)) +(prec? r) ;=> #t +(prec-x r) ;=> 1 +(crec-z r) ;=> 3 +prec ;=> \var{exception: invalid syntax prec} +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-time-value?}{\categoryprocedure}{(compile-time-value? \var{obj})} +\returns \scheme{#t} if \var{obj} is a compile-time value; \scheme{#f} otherwise +\listlibraries +\endentryheader + +\schemedisplay +(define-syntax x (make-compile-time-value "eggs")) +(compile-time-value? (top-level-syntax 'x)) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-time-value-value}{\categoryprocedure}{(compile-time-value-value \var{ctv})} +\returns the value of a compile-time value +\listlibraries +\endentryheader + +\schemedisplay +(define-syntax x (make-compile-time-value "eggs")) +(compile-time-value-value (top-level-syntax 'x)) ;=> "eggs" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{define-property}{\categorysyntax}{(define-property \var{id} \var{key} \var{expr})} +\returns unspecified +\listlibraries +\endentryheader + +A \scheme{define-property} form attaches a property to an +existing identifier binding without disturbing the existing meaning +of the identifier in the scope of that binding. +It is typically used by one macro to record information about a binding +for use by another macro. +Both \var{id} and \var{key} must be identifiers. +The expression \var{expr} is evaluated when the \scheme{define-property} +form is expanded, and a new property associating \var{key} with the +value of \var{expr} is attached to the existing binding of +\var{id}, which must have a visible local or top-level binding. + +\scheme{define-property} is a definition and can appear anywhere +other definitions can appear. +The scope of a property introduced by \scheme{define-property} is the +entire body in which the \scheme{define-property} form appears or global +if it appears at top level, except +where it is replaced by a property for the same \var{id} and +\var{key} or where the binding to which it is attached is shadowed. +Any number of properties can be attached to the same binding with +different keys. +Attaching a new property with the same name as an property already +attached to a binding shadows the existing property with the new +property. + +The following example defines a macro, \scheme{get-info}, that retrieves +the \scheme{info} property of a binding, defines the variable \scheme{x}, +attaches an \scheme{info} property to the binding of \scheme{x}, retrieves +the property via \scheme{get-info}, references \scheme{x} to show that +its normal binding is still intact, and uses \scheme{get-info} again +within the scope of a different binding of \scheme{x} to show that the +properties are shadowed as well as the outer binding of \scheme{x}. + +\schemedisplay +(define info) +(define-syntax get-info + (lambda (x) + (lambda (lookup) + (syntax-case x () + [(_ q) + (let ([info-value (lookup #'q #'info)]) + #`'#,(datum->syntax #'* info-value))])))) +(define x "x-value") +(define-property x info "x-info") +(get-info x) ;=> "x-info" +x ;=> "x-value" +(let ([x "inner-x-value"]) (get-info x)) ;=> #f +\endschemedisplay + +For debugging, it is often useful to have a form that retrieves +an arbitrary property, given an identifier and a key. +The \index{\scheme{get-property}}\scheme{get-property} macro below does +just that. + +\schemedisplay +(define-syntax get-property + (lambda (x) + (lambda (r) + (syntax-case x () + [(_ id key) + #`'#,(datum->syntax #'* (r #'id #'key))])))) +(get-property x info) ;=> "x-info" +\endschemedisplay + +The bindings for both identifiers must be visible where +\scheme{get-property} is used. + +The version of \scheme{drt} defined below is like the one defined using +\scheme{make-compile-time-value} above, except that it defines the +record name as a macro that raises an exception with a more descriptive +message, while attaching the record type descriptor to the binding as a +separate property. +The variable \scheme{drt-key} defined along with \scheme{drt} is used +only as the key for the property that \scheme{drt} attaches to a record +name. +Both \scheme{drt-key} and \scheme{drt} are defined within a module that +exports only the latter, ensuring that the properties used by \scheme{drt} +cannot be accessed or forged. + +\schemedisplay +(library (drt) (export drt) (import (chezscheme)) + (define drt-key) + (define-syntax drt + (lambda (x) + (define construct-name + (lambda (template-identifier . args) + (datum->syntax template-identifier + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string (syntax->datum x)))) + args)))))) + (define do-drt + (lambda (rname fname* prtd) + (with-syntax ([rname rname] + [rtd (make-record-type-descriptor + (syntax->datum rname) prtd #f #f #f + (list->vector + (map (lambda (fname) + `(immutable ,(syntax->datum fname))) + fname*)))] + [make-rname (construct-name rname "make-" rname)] + [rname? (construct-name rname rname "?")] + [(rname-fname ...) + (map (lambda (fname) + (construct-name fname rname "-" fname)) + fname*)] + [(i ...) (enumerate fname*)]) + #'(begin + (define-syntax rname + (lambda (x) + (syntax-error x "invalid use of record name"))) + (define rcd (make-record-constructor-descriptor 'rtd #f #f)) + (define-property rname drt-key 'rtd) + (define make-rname (record-constructor rcd)) + (define rname? (record-predicate 'rtd)) + (define rname-fname (record-accessor 'rtd i)) + ...)))) + (syntax-case x (parent) + [(_ rname (fname ...)) + (for-all identifier? #'(rname fname ...)) + (do-drt #'rname #'(fname ...) #f)] + [(_ rname pname (fname ...)) + (for-all identifier? #'(rname pname fname ...)) + (lambda (lookup) + (let ([prtd (lookup #'pname #'drt-key)]) + (unless prtd + (syntax-error #'pname "unrecognized parent record type")) + (do-drt #'rname #'(fname ...) prtd)))])))) +\endschemedisplay + +\schemedisplay +(import (drt)) +(drt prec (x y)) +(drt crec prec (z)) +(define r (make-crec 1 2 3)) +(prec? r) ;=> #t +(prec-x r) ;=> 1 +(crec-z r) ;=> 3 +prec ;=> \var{exception: invalid use of record name prec} +\endschemedisplay + +\section{Modules\label{SECTSYNTAXMODULES}} + +\index{modules}Modules are used to help organize programs into separate +parts that interact cleanly via declared interfaces. +Although modular programming is typically used to facilitate the development +of large programs possibly written by many individuals, it may also be +used in {\ChezScheme} at a ``micro-modular'' level, since {\ChezScheme} +module and import forms are definitions and may appear anywhere any other +kind of definition may appear, including within a \scheme{lambda} body +or other local scope. + +Modules control visibility of bindings and can be viewed as extending +lexical scoping to allow more precise control over where bindings are +or are not visible. +Modules export identifier bindings, i.e., variable bindings, keyword +bindings, or module name bindings. +Modules may be \emph{named} or \emph{anonymous}. +Bindings exported from a named module may be made visible via an import +form wherever the module's name is visible. +Bindings exported from an anonymous module are implicitly imported where +the module form appears. +Anonymous modules are useful for hiding some of a set of bindings while +allowing the remaining bindings in the set to be visible. + +Some of the text and examples given in this section are +adapted from the paper +``Extending the scope of syntactic +abstraction''~\cite{waddell:modules}, which describes modules and their +implementation in more detail. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{module}{\categorysyntax}{(module \var{name} \var{interface} \var{defn} \dots \var{init} \dots)} +\formdef{module}{\categorysyntax}{(module \var{interface} \var{defn} \dots \var{init} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{name} is an identifier, \scheme{\var{defn} \dots} +are definitions, and \scheme{\var{init} \dots} are expressions. +\var{interface} is a list of exports \scheme{(\var{export} \dots)}, +where each \var{export} is either an identifier \var{identifier} +or of the form \scheme{(\var{identifier} \var{export} \dots)}. + +The first syntax for \scheme{module} establishes a named scope that +encapsulates a set of identifier bindings. +The exported bindings may be made visible via \scheme{import} or +\scheme{import-only} (Section~\ref{SECTLIBRARYIMPORTEXPORTFORMS}) +anywhere the module name is visible. +The second syntax for \scheme{module} introduces an anonymous module +whose bindings are implicitly imported (as if by \scheme{import} of a +hidden module name) where the module form appears. + +A module consists of a (possibly empty) set of +definitions and a (possibly empty) sequence of initialization expressions. +The identifiers defined within a module are visible within the body +of the module and, if exported, within the scope of an import for the +module. +Each identifier listed in a module's interface must be defined within +or imported into that module. +A \scheme{module} form is a definition and can appear anywhere other +definitions can appear, including +at the top level of a program, nested within the bodies of +\scheme{lambda} expressions, nested within \scheme{library} and +top-level program forms, and nested within other modules. +Also, because module names are scoped like other identifiers, +modules and libraries may export module names as well as variables and keywords. + +When an interface contains an export of the form +\scheme{(\var{identifier} \var{export} \dots)}, only \var{identifier} is +visible in the importing context. +The identifiers within \scheme{\var{export} \dots} are +\emph{indirect imports}, as if declared via an +\scheme{indirect-export} form (Section~\ref{SECTLIBRARYIMPORTEXPORTFORMS}). + +Module names occupy the same namespace as other identifiers and follow +the same scoping rules. +Unless exported, identifiers defined within a module are visible only +within that module. + +Expressions within a module can reference identifiers bound outside of +the module. + +\schemedisplay +(let ([x 3]) + (module m (plusx) + (define plusx (lambda (y) (+ x y)))) + (import m) + (let ([x 4]) + (plusx 5))) ;=> 8 +\endschemedisplay + +\noindent +Similarly, \scheme{import} does not prevent access to identifiers that +are visible where the import form appears, except for those variables +shadowed by the imported identifiers. + +\schemedisplay +(module m (y) (define y 'm-y)) +(let ([x 'local-x] [y 'local-y]) + (import m) + (list x y)) ;=> (local-x m-y) +\endschemedisplay + +On the other hand, use of \scheme{import-only} within a module +establishes an isolated scope in +which the only visible identifiers are those exported by the +imported module. + +\schemedisplay +(module m (y) (define y 'm-y)) +(let ([x 'local-x] [y 'local-y]) + (import-only m) + x) ;=> Error: x is not visible +\endschemedisplay + +\noindent +This is sometimes desirable for static verification that no +identifiers are used except those explicitly imported into a +module or local scope. + +Unless a module imported via \scheme{import-only} exports +\scheme{import} or +\scheme{import-only} and the name of at least one module, subsequent +imports within the scope of the \scheme{import-only} form are not +possible. +To create an isolated scope containing the exports of more than one +module without making \scheme{import} or \scheme{import-only} +visible, all of the modules to be imported must be listed in the +same \scheme{import-only} form. + +Another solution is to create a single module that contains +the exports of each of the other modules. + +\schemedisplay +(module m2 (y) (define y 'y)) +(module m1 (x) (define x 'x)) +(module mega-module (cons x y) + (import m1) + (import m2) + (import scheme)) +(let ([y 3]) + (import-only mega-module) + (cons x y)) ;=> (x . y) +\endschemedisplay + +\bigskip +Before it is compiled, a source program is translated into +a core language program containing no syntactic abstractions, syntactic +definitions, library definitions, module definitions, or import forms. +Translation is performed by a \emph{syntax expander} that +processes the forms in the source program via recursive descent. + +A \scheme{define-syntax} form associates a keyword +with a transformer in a translation-time environment. +When the expander encounters a keyword, it invokes the +associated transformer and reprocesses the resulting form. +A \scheme{module} form associates a module name with an interface. +When the expander encounters an \scheme{import} form, it extracts the +corresponding module interface from the translation-time environment and makes +the exported bindings visible in the scope where the \scheme{import} form +appears. + +Internal definitions and definitions within a \scheme{module} +body are processed from left to right so that a module's definition +and import may appear within the same sequence of definitions. +Expressions appearing within a body and the right-hand sides of variable +definitions, however, are translated +only after the entire set of definitions has been processed, allowing +full mutual recursion among variable and syntactic definitions. + +Module and import forms affect only the visibility of identifiers in +the source program, not their meanings. +In particular, variables are bound to locations whether defined within or +outside of a module, and \scheme{import} does not introduce new locations. +Local variables are renamed as necessary to preserve the scoping +relationships established by both modules and syntactic abstractions. +Thus, the expression: + +\schemedisplay +(let ([x 1]) + (module m (x setter) + (define-syntax x (identifier-syntax z)) + (define setter (lambda (x) (set! z x))) + (define z 5)) + (let ([y x] [z 0]) + (import m) + (setter 3) + (+ x y z))) ;=> 4 +\endschemedisplay + +is equivalent to the following program +in which identifiers have been consistently renamed as indicated by +subscripts. + +\schemedisplay +(let ([x\var{_0} 1]) + (define-syntax x\var{_1} (identifier-syntax z\var{_1})) + (define setter\var{_1} (lambda (x\var{_2}) (set! z\var{_1} x\var{_2}))) + (define z\var{_1} 5) + (let ([y\var{_3} x\var{_0}] [z\var{_3} 0]) + (setter\var{_1} 3) + (+ x\var{_1} y\var{_3} z\var{_3}))) +\endschemedisplay + +Definitions within a top-level \scheme{begin}, \scheme{lambda}, top-level program, +\scheme{library}, or \scheme{module} body +are processed from left to right by the expander at expand time, and the +variable definitions are evaluated from left-to-right at run time. +Initialization expressions appearing within a \scheme{module} body +are evaluated in sequence after the evaluation of the variable +definitions. + +Mutually recursive modules can be defined in several ways. +In the following program, \scheme{a} and \scheme{b} are mutually recursive +modules exported by an anonymous module whose local scope is used to +statically link the two. +For example, +the free variable \scheme{y} within module \scheme{a} refers to +the binding for \scheme{y}, provided by importing \scheme{b}, +in the enclosing module. + +\schemedisplay +(module (a b) + (module a (x) (define x (lambda () y))) + (module b (y) (define y (lambda () x))) + (import a) + (import b)) +\endschemedisplay + +\noindent +The following syntactic abstraction generalizes this pattern to +permit the definition of multiple mutually recursive modules. + +\schemedisplay +(define-syntax rec-modules + (syntax-rules (module) + [(_ (module m (id ...) form ...) ...) + (module (m ...) + (module m (id ...) form ...) ... + (import m) ...)])) +\endschemedisplay + +Because a module can re-export imported bindings, +it is quite easy to provide multiple views on a single +module, as \scheme{s} and \scheme{t} provide for \scheme{r} +below, or to combine several modules into a compound, +as \scheme{r} does. + +\schemedisplay +(module p (x y) + (define x 1) (define y 2)) +(module q (y z) + (define y 3) (define z 4)) +(module r (a b c d) + (import* p (a x) (b y)) + (import* q (c y) (d z))) +(module s (a c) (import r)) +(module t (b d) (import r)) +\endschemedisplay + +To allow interfaces to be separated from implementations, +the following syntactic abstractions support the definition and use of +named interfaces. + +\schemedisplay +(define-syntax define-interface + (syntax-rules () + [(_ name (export ...)) + (define-syntax name + (lambda (x) + (syntax-case x () + [(_ n defs) + (with-implicit (n export ...) + #'(module n (export ...) . + defs))])))])) + +(define-syntax define-module + (syntax-rules () + [(_ name interface defn ...) + (interface name (defn ...))])) +\endschemedisplay + +\noindent +\scheme{define-interface} creates an interface macro that, given a module +name and a list of definitions, expands into a module definition with +a concrete interface. + +\scheme{with-implicit} is used to ensure that the introduced +\scheme{export} identifiers are visible in the same scope as the name of +the module in the \scheme{define-module} form. + +\noindent +\scheme{define-interface} and \scheme{define-module} can be used as +follows. + +\schemedisplay +(define-interface simple (a b)) +(define-module m simple + (define-syntax a (identifier-syntax 1)) + (define b (lambda () c)) + (define c 2)) +(let () (import m) (+ a (b))) ;=> 3 +\endschemedisplay + +The abstract module facility defined below allows a module interface to +be satisfied incrementally when module forms are evaluated. +This permits flexibility in the separation between the interface and +implementation, supports separate compilation of mutually recursive +modules, and permits redefinition of module implementations. + +\schemedisplay +(define-syntax abstract-module + (syntax-rules () + [(_ name (ex ...) (kwd ...) defn ...) + (module name (ex ... kwd ...) + (declare ex) ... + defn ...)])) + +(define-syntax implement + (syntax-rules () + [(_ name form ...) + (module () (import name) form ...)])) +\endschemedisplay + +\noindent +Within an \scheme{abstract-module} form, +each of the exports in the list \scheme{\var{ex} \dots} must be +variables. +The values of these variables are supplied by one or more separate +\scheme{implement} forms. +Since keyword bindings must be present at compile time, +they cannot be satisfied incrementally and are instead listed as +separate exports and defined within the abstract module. + +Within an \scheme{implement} form, +the sequence of forms \scheme{\var{form} \dots} is a sequence of +zero or more definitions followed by a sequence of zero or more +expressions. +Since the module used in the expansion of \scheme{implement} does +not export anything, the definitions are all local to the +\scheme{implement} form. +The expressions may be arbitrary expressions, but should include +one \scheme{satisfy} form for each variable whose definition is +supplied by the \scheme{implement} form. +A \scheme{satisfy} form has the syntax + +\schemedisplay +(satisfy \var{variable} \var{expr}) +\endschemedisplay + +\noindent +\scheme{declare} and \scheme{satisfy} may simply be the equivalents of +\scheme{define} and \scheme{set!}. + +\schemedisplay +(define-syntax declare (identifier-syntax define)) +(define-syntax satisfy (identifier-syntax set!)) +\endschemedisplay + +\noindent +Alternatively, \scheme{declare} can initialize the declared variable to +the value of a flag known only to \scheme{declare} and \scheme{satisfy}, +and \scheme{satisfy} can verify that this flag is still present to insure +that only one attempt to satisfy the value of a given identifier is +made. + +\schemedisplay +(module ((declare cookie) (satisfy cookie)) + (define cookie "chocolate chip") + (define-syntax declare + (syntax-rules () [(_ var) (define var cookie)])) + (define-syntax satisfy + (syntax-rules () + [(_ var exp) + (if (eq? var cookie) + (set! var exp) + (assertion-violationf 'satisfy + "value of variable ~s has already been satisfied" + 'var))]))) +\endschemedisplay + +Using \scheme{abstract-module} and \scheme{implement}, we can define +mutually recursive and separately compilable modules as follows. + +\schemedisplay +(abstract-module e (even?) (pred) + (define-syntax pred + (syntax-rules () [(_ exp) (- exp 1)]))) + +(abstract-module o (odd?) ()) + +(implement e + (import o) + (satisfy even? + (lambda (x) + (or (zero? x) (odd? (pred x)))))) + +(implement o + (import e) + (satisfy odd? + (lambda (x) (not (even? x))))) + +(let () (import-only e) (even? 38)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{only}{\categorysyntax}{only} +\formdef{except}{\categorysyntax}{except} +\formdef{add-prefix}{\categorysyntax}{add-prefix} +\formdef{drop-prefix}{\categorysyntax}{drop-prefix} +\formdef{rename}{\categorysyntax}{rename} +\formdef{alias}{\categorysyntax}{alias} +\listlibraries +\endentryheader + +\noindent +These identifiers are auxiliary keywords for \scheme{import} +and \scheme{import-only}. +It is a syntax violation to reference these identifiers except in +contexts where they are recognized as auxiliary keywords. + +\section{Standalone import and export forms\label{SECTSYNTAXIMPORTEXPORTFORMS}} + +The local import and export forms described in +Section~\ref{SECTLIBRARYIMPORTEXPORTFORMS} can be used +equally well for and within modules. + +\section{Built-in Modules\label{SECTSYNTAXBUILTINMODULES}} + +Five modules are built-in to {\ChezScheme}: \index{\scheme{scheme} module}\scheme{scheme}, +\index{\scheme{r5rs} module}\scheme{r5rs}, \index{\scheme{r5rs-syntax} module}\scheme{r5rs-syntax}, \index{\scheme{ieee} module}\scheme{ieee}, and +\index{\scheme{$system} module}\scheme{$system}. +Each module is immutable, i.e., the exported bindings cannot be +altered. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{scheme}{\categorymodule}{scheme} +\listlibraries +\endentryheader + +\noindent +\scheme{scheme} contains all user-visible top-level bindings +(variables, keywords, and module names) built into {\ChezScheme}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{r5rs}{\categorymodule}{r5rs} +\listlibraries +\endentryheader + +\noindent +\scheme{r5rs} contains all top-level bindings +(variables and keywords) defined in the +Revised$^5$ Report on Scheme. +The bindings exported from \scheme{r5rs} are precisely those that are +available within an expression evaluated via \scheme{eval} with the +environment specifier returned by +\index{\scheme{scheme-report-environment}}\scheme{scheme-report-environment}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{r5rs-syntax}{\categorymodule}{r5rs-syntax} +\listlibraries +\endentryheader + +\noindent +\scheme{r5rs-syntax} contains all top-level keyword bindings +defined in the Revised$^5$ Report on Scheme. +The bindings exported from \scheme{r5rs-syntax} are precisely those that are +available within an expression evaluated via \scheme{eval} with the +environment specifier returned by +\index{\scheme{null-environment}}\scheme{null-environment}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ieee}{\categorymodule}{ieee} +\listlibraries +\endentryheader + +\noindent +\scheme{ieee} contains all top-level bindings +(variables and keywords) defined in the +ANSI/IEEE standard for Scheme. +The bindings exported from \scheme{ieee} are precisely those that are +available within an expression evaluated via \scheme{eval} with the +environment specifier returned by +\index{\scheme{ieee-environment}}\scheme{ieee-environment}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{$system}{\categorymodule}{$system} +\listlibraries +\endentryheader + +\noindent +\scheme{$system} contains all user-visible top-level bindings built +into {\ChezScheme} along with various undocumented system bindings. + + +\section{Meta Definitions\label{SECTSYNTAXMETA}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{meta}{\categorysyntax}{(meta . \var{definition})} +\returns unspecified +\listlibraries +\endentryheader + +The \scheme{meta} keyword is actually a prefix that can be placed in +front of any definition keyword, e.g., + +\schemedisplay +(meta define x 3) +\endschemedisplay + +It tells the expander that any variable definition resulting +from the definition is to be an expand-time definition available only +to the right-hand sides of other meta definitions and, most importantly, +transformer expressions. +It is used to define expand-time helpers and other information for use +by one or more \scheme{syntax-case} transformers. + +% (module count-let (count let) +% (meta define counter 0) +% (define-syntax count (lambda (x) counter)) +% (define-syntax let +% (lambda (x) +% (import scheme) +% (set! counter (+ counter 1)) +% (syntax-case x () [(_ . stuff) #'(let . stuff)])))) + +\schemedisplay +(module M (helper1 a b) + (meta define helper1 + (lambda (---) + ---)) + (meta define helper2 + (lambda (---) + --- (helper2 ---) ---)) + (define-syntax a + (lambda (x) + --- (helper1 ---) ---)) + (define-syntax b + (lambda (x) + --- (helper1 ---) --- + --- (helper2 ---) ---))) +\endschemedisplay + +The right-hand-side expressions of a syntax definition or meta definition +can refer only to identifiers whose values are already available in the +compile-time environment. +Because of the left-to-right expansion order for \scheme{library}, +\scheme{module}, \scheme{lambda}, and similar bodies, this implies a +semantics similar to \scheme{let*} for a sequence of meta definitions, +in which each right-hand side can refer only to the variables defined +earlier in the sequence. +An exception is that the right-hand side of a meta definition can refer +to its own name as long as the reference is not evaluated until after +the value of the expression has been computed. +This permits meta definitions to be self-recursive but not mutually +recursive. +The right-hand side of a meta definition can, however, build syntax +objects containing occurrences of any identifiers defined in the body +in which the meta definition appears. + +Meta definitions propagate through macro expansion, so one can write, +for example: + +\schemedisplay +(module (a) + (meta define-record foo (x)) + (define-syntax a + (let ([q (make-foo #''q)]) + (lambda (x) (foo-x q))))) +a ;=> q +\endschemedisplay + +where define-record is a macro that expands into a set of defines. + +It is also sometimes convenient to write + +\schemedisplay +(meta begin defn \dots) +\endschemedisplay + +or + +\schemedisplay +(meta module {exports} defn \dots) +\endschemedisplay + +or + +\schemedisplay +(meta include "\var{path}") +\endschemedisplay + +to create groups of meta bindings. + +\section{Conditional expansion\label{SECTSYNTAXMETACOND}} + +Expansion-time decisions can be made via \scheme{meta-cond}, which is +similar to \scheme{cond} but evaluates the test expressions at +expansion time and can be used in contexts where definitions are +expected as well as in expression contexts. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{meta-cond}{\categorysyntax}{(meta-cond \var{clause_1} \var{clause_2} \dots)} +\returns see below +\listlibraries +\endentryheader + +Each \var{clause} but the last must take the form: + +\schemedisplay +(\var{test} \var{expr_1} \var{expr_2} \dots) +\endschemedisplay + +The last may take the same form or be an \scheme{else} clause of the form: + +\schemedisplay +(\var{else} \var{expr_1} \var{expr_2} \dots) +\endschemedisplay + +During expansion, the \var{test} expressions are evaluated in order until +one evaluates to a true value or until all of the tests have been +evaluated. +If a \var{test} evaluates to a true value, the \scheme{meta-cond} form +expands to a \scheme{begin} form containing the corresponding +expressions \scheme{\var{expr_1} \var{expr_2} \dots}. +If no \var{test} evaluates to a true value and an \scheme{else} clause +is present, the \scheme{meta-cond} form expands to a \scheme{begin} form +containing the expressions \scheme{\var{expr_1} \var{expr_2} \dots} from +the \scheme{else} clause. +Otherwise the \scheme{meta-cond} expression expands into a call to +the \scheme{void} procedure. + +\scheme{meta-cond} might be defined as follows. + +\schemedisplay +(define-syntax meta-cond + (syntax-rules () + [(_ [a0 a1 a2 ...] [b0 b1 b2 ...] ...) + (let-syntax ([expr (cond + [a0 (identifier-syntax (begin a1 a2 ...))] + [b0 (identifier-syntax (begin b1 b2 ...))] + ...)]) + expr)])) +\endschemedisplay + +\scheme{meta-cond} is used to choose, at expansion time, from among a +set of possible forms. +For example, one might have safe (error-checking) and unsafe +(non-error-checking) versions of a procedure and decide which to +call based on the compile-time optimization level, as shown +below. + +\schemedisplay +(meta-cond + [(= (optimize-level) 3) (unsafe-frob x)] + [else (safe-frob x)]) +\endschemedisplay + +\section{Aliases\label{SECTSYNTAXALIAS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{alias}{\categorysyntax}{(alias \var{id_1} \var{id_2})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{alias} is a definition and can appear anywhere +other definitions can appear. +It is used to transfer the binding from one identifier to +another. + +\schemedisplay +(let ([x 3]) (alias y x) (set! y 4) (list x y)) ;=> (4 4) + +(module lisp (if) + (module (scheme:if) + (import scheme) + (alias scheme:if if)) + (define-syntax if + (syntax-rules () + [(_ e_1 e_2 e_3) + (scheme:if (not (memq e_1 '(#f ()))) e_2 e_3)]))) +(define (length ls) + (import lisp) + (if ls (+ (length (cdr ls)) 1) 0)) +(length '(a b c)) ;=> 3 +\endschemedisplay + +Because of left-to-right expansion order, aliases should appear after +the definition of the right-hand-side identifier, e.g.: + +\schemedisplay +(let () + (import-only (chezscheme)) + (define y 3) + (alias x y) + x) ;=> 3 +\endschemedisplay + +rather than: + +\schemedisplay +(let () + (import-only (chezscheme)) + (alias x y) + (define y 3) + x) ;=> \var{exception: unbound identifier} +\endschemedisplay + + +\section{Annotations\label{SECTSYNTAXANNOTATIONS}} + +\index{annotations}% +When source code is read from a file by \scheme{load}, +\scheme{compile-file}, or variants of these, such as +\scheme{load-library}, the reader attaches \emph{annotations} to each +object read from the file. +These annotations identify the file and the position of the object within +the file. +Annotations are tracked through the compilation process and associated +with compiled code at run time. +The expander and compiler use the annotations to produce syntax errors +and compiler warnings that identify the location of the offending form, +and the inspector uses them to identify the locations of calls and +procedure definitions. +The compiler and run time also use annotations to associate source +positions with profile counts. + +While these annotations are usually maintained ``behind the scenes,'' +the programmer can manipulate them directly via a set +of routines for creating and accessing annotations. + +Annotations are values of a type distinct from other types and have +four components: an expression, possibly with annotated subexpressions, +a \emph{source object}, a stripped version of the expression, and +usage options. +Annotations can be created via +\index{\scheme{make-annotation}}\scheme{make-annotation}, which has +three required arguments corresponding to the first three components +and an optional fourth argument corresponding to the fourth component. +The second argument must be a source object, and the third argument should be a +stripped version of the first argument, i.e., equivalent to the first +argument with each annotation replaced by its expression component. +An annotation is essentially equivalent to its stripped component as a +representation of source code, with the source information attached and +available to the expander or evaluator. +The optional fourth argument, if present, must be an enumeration set over +the symbols \scheme{debug} and \scheme{profile} and defaults to an +enumeration set containing both \scheme{debug} and \scheme{profile}. + +Annotations marked \scheme{debug} are used for compile-time error +reporting and run-time error reporting and inspection; annotations +marked \scheme{profile} are used for profiling. +Annotations created by the Scheme reader are always marked both +\scheme{debug} and \scheme{profile}, but other readers and parsers +might choose to mark some annotations only \scheme{debug} or only +\scheme{profile}. +In particular, it might be useful to annotate multiple +expressions in the output of a parser with the same source object +for debugging purposes and mark only one of them \scheme{profile} +to avoid duplicate counts. +It might also be useful to mark no expressions \scheme{profile} and +instead introduce explicit \scheme{profile} forms +(Section~\ref{SECTMISCPROFILE}) to identify the set of source +locations to be profiled. + +\index{source objects}% +Source objects are also values of a type distinct from other types and +also have three or five components: a \emph{source-file descriptor} (sfd), +a beginning file position (bfp), an ending file position (efp), +an optional beginning line, and an optional beginning +column. The sfd identifies the file from which an expression is read and the +bfp and efp identify the range of character positions occupied by the object +in the file, with the bfp being inclusive and the efp being exclusive. +The line and column are either both numbers or both not present. +A source object can be created via +\index{\scheme{make-source-object}}\scheme{make-source-object}, which +takes either three or five arguments corresponding to these components. +The first argument must be a source-file descriptor, the second and +third must be nonnegative exact integers, the second must not be +greater than the third, and the fourth and fifth (if provided) must +be positive exact integers. + +\index{source-file descriptors}% +Source-file descriptors are also values of a type distinct +from all other types and have two components: the file's path, +represented by a string, and a checksum, represented by a number. +The path might or might not be an absolute path depending on how +the file's path was specified when the source-file descriptor was +created. +The checksum is computed based on the file's length and contents +when the file is created and checked by tools that look for the +source file to make sure that the proper file has been found and +has not been modified. +Source-file descriptors can be created with +\index{\scheme{make-source-file-descriptor}}\scheme{make-source-file-descriptor}, +which accepts two arguments: a string naming the path and a binary +input port, along with an optional third boolean argument, \var{reset?}, +which defaults to false. +\scheme{make-source-file-descriptor} computes a checksum based on +the contents of the port, starting at its current position. +It resets the port, using \scheme{set-port-position!}, after computing +the checksum if \var{reset?} is true; otherwise, it leaves the +port at end-of-file. + +The procedures that create, check for, and access annotations, +source objects, and source-file descriptors are summarized below +and described in more detail later in this section. + +\schemedisplay +(make-annotation \var{obj} \var{source-object} \var{obj}) ;-> \var{annotation} +(annotation? \var{obj}) ;-> \var{boolean} +(annotation-expression \var{annotation}) ;-> \var{obj} +(annotation-source \var{annotation}) ;-> \var{source-object} +(annotation-stripped \var{annotation}) ;-> \var{obj} + +(make-source-object \var{sfd} \var{uint} \var{uint}) ;-> \var{source-object} +(make-source-object \var{sfd} \var{uint} \var{uint} \var{uint} \var{uint}) ;-> \var{source-object} +(source-object? \var{obj}) ;-> \var{boolean} +(source-object-sfd \var{source-object}) ;-> \var{sfd} +(source-object-bfp \var{source-object}) ;-> \var{uint} +(source-object-efp \var{source-object}) ;-> \var{uint} +(source-object-line \var{source-object}) ;-> \var{uint} or #f +(source-object-column \var{source-object}) ;-> \var{uint} or #f + +(make-source-file-descriptor \var{string} \var{binary-input-port}) ;-> \var{sfd} +(make-source-file-descriptor \var{string} \var{binary-input-port} \var{reset?}) ;-> \var{sfd} +(source-file-descriptor? \var{obj}) ;-> \var{boolean} +(source-file-descriptor-checksum \var{sfd}) ;-> \var{obj} +(source-file-descriptor-path \var{sfd}) ;-> \var{obj} +\endschemedisplay + +A program might open a source file with +\scheme{open-file-input-port}, create an sfd using +\index{\scheme{make-source-file-descriptor}}\scheme{make-source-file-descriptor}, +create a textual port from the binary port using transcoded-port, and +create source objects and annotations for each of the objects it reads +from the file. +If a custom reader is not required, the Scheme +reader can be used to read annotations via the +\index{\scheme{get-datum/annotations}}\scheme{get-datum/annotations} +procedure: + +\schemedisplay +(get-datum/annotations \var{textual-input-port} \var{sfd} \var{uint}) ;-> \var{obj}, \var{uint} +\endschemedisplay + +\scheme{get-datum/annotations} is like \scheme{get-datum} but instead of returning +a plain datum, it returns an annotation encapsulating a datum (possibly with nested +annotations), a source object, and the plain (stripped) datum. +It also returns a second value, the position of the first character beyond the +object in the file. +Character positions are accepted and returned by +\scheme{get-datum/annotations} so that the textual port need not support +\scheme{port-position} and need not report positions in characters +if it does support \scheme{port-position}. +(Positions are usually reported in bytes.) +The bfp and efp positions recorded in the annotations returned by +\scheme{get-datum/annotations} are correct only if the positions supplied +to it are correct. + +Once read, an annotation can be passed to the expander, interpreter, or +compiler. +The procedures \scheme{eval}, \scheme{expand}, \scheme{interpret}, +and \scheme{compile} all accept annotated or unannotated input. + +Two additional procedures complete the set of annotation-related primitives: + +\schemedisplay +(open-source-file \var{sfd}) ;-> #f or \var{port} +(syntax->annotation \var{obj}) ;-> #f or \var{annotation} +\endschemedisplay + +\index{\scheme{open-source-file}}\scheme{open-source-file} attempts to +locate and open the source file identified by \var{sfd}. +It returns a textual input port, positioned at the beginning of the file, +if successful, and \scheme{#f} otherwise. + +\index{\scheme{syntax->annotation}}\scheme{syntax->annotation} accepts +a syntax object. +If the syntax object's expression is annotated, it returns the +annotation; otherwise, it returns \scheme{#f}. +It can be used by a macro to extract source information, when +available, from an input form. + +The procedure \scheme{datum->syntax} accepts either an +annotated or unannotated input datum. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-annotation}{\categoryprocedure}{(make-annotation \var{obj} \var{source-object} \var{stripped-obj})} +\formdef{make-annotation}{\categoryprocedure}{(make-annotation \var{obj} \var{source-object} \var{stripped-obj} \var{options})} +\returns an annotation +\listlibraries +\endentryheader + +The annotation is formed with \var{obj} as its expression component, +\var{source-object} as its source-object component, and \var{stripped-obj} +as its stripped component. +\var{obj} should represent an expression, possibly with embedded +annotations. +\var{stripped-obj} should be a stripped version of \var{obj}, i.e., +equivalent to \var{obj} with each annotation replaced by its +expression component. +\var{options}, if present must be an enumeration set over +the symbols \scheme{debug} and \scheme{profile}, and defaults to an +enumeration set containing both \scheme{debug} and \scheme{profile}. +Annotations marked \scheme{debug} are used for compile-time error +reporting and run-time error reporting and inspection; annotations +marked \scheme{profile} are used for profiling. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{annotation?}{\categoryprocedure}{(annotation? \var{obj})} +\returns \scheme{#t} if \var{obj} is an annotation, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{annotation-expression}{\categoryprocedure}{(annotation-expression \var{annotation})} +\returns the expression component of \var{annotation} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{annotation-source}{\categoryprocedure}{(annotation-source \var{annotation})} +\returns the source-object component of \var{annotation} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{annotation-stripped}{\categoryprocedure}{(annotation-stripped \var{annotation})} +\returns the stripped component of \var{annotation} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{annotation-options}{\categoryprocedure}{(annotation-options \var{annotation})} +\returns the options enumeration set of \var{annotation} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-source-object}{\categoryprocedure}{(make-source-object \var{sfd} \var{bfp} \var{efp})} +\formdef{make-source-object}{\categoryprocedure}{(make-source-object \var{sfd} \var{bfp} \var{efp} \var{line} \var{column})} +\returns a source object +\listlibraries +\endentryheader + +\var{sfd} must be a source-file descriptor. +\var{bfp} and \var{efp} must be exact nonnegative integers, and \var{bfp} +should not be greater than \var{efp}. +\var{line} and \var{column} must be exact positive integers. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-object?}{\categoryprocedure}{(source-object? \var{obj})} +\returns \scheme{#t} if \var{obj} is a source object, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-object-sfd}{\categoryprocedure}{(source-object-sfd \var{source-object})} +\returns the sfd component of \var{source-object} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-object-bfp}{\categoryprocedure}{(source-object-bfp \var{source-object})} +\returns the bfp component of \var{source-object} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-object-efp}{\categoryprocedure}{(source-object-efp \var{source-object})} +\returns the efp component of \var{source-object} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-object-line}{\categoryprocedure}{(source-object-line \var{source-object})} +\returns the line component of \var{source-object} if present, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-object-column}{\categoryprocedure}{(source-object-column \var{source-object})} +\returns the column component of \var{source-object} if present, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-make-source-object}{\categorythreadparameter}{current-make-source-object} +\listlibraries +\endentryheader + +\noindent +\scheme{current-make-source-object} is used by the reader to construct +a source object for an annotation. \scheme{current-make-source-object} +is initially bound to \scheme{make-source-object}, and the reader always +calls the function bound to the parameter with three arguments. + +Adjust this parameter to, for example, eagerly convert a position integer +to a file-position object, instead of delaying the conversion to +\scheme{locate-source}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{string} \var{binary-input-port})} +\formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{string} \var{binary-input-port} \var{reset?})} +\returns a source-file descriptor +\listlibraries +\endentryheader + +To compute the checksum encapsulated in the source-file descriptor, +this procedure must read all of the data from +\var{binary-input-port}. +If \var{reset?} is present and \scheme{#t}, the port is reset to its +original position, as if via \scheme{port-position}. +Otherwise, it is left pointing at end-of-file. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-file-descriptor?}{\categoryprocedure}{(source-file-descriptor? \var{obj})} +\returns \scheme{#t} if \var{obj} is a source-file descriptor, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-file-descriptor-checksum}{\categoryprocedure}{(source-file-descriptor-checksum \var{sfd})} +\returns the checksum component of \var{sfd} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-file-descriptor-path}{\categoryprocedure}{(source-file-descriptor-path \var{sfd})} +\returns the path component of \var{sfd} +\listlibraries +\endentryheader + +\var{sfd} must be a source-file descriptor. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-file-descriptor}{\categoryprocedure}{(source-file-descriptor \var{path} \var{checksum})} +\returns a new source-file-descriptor +\listlibraries +\endentryheader + +\var{path} must be a string, and \var{checksum} must be an exact nonnegative integer. +This procedure can be used to construct custom source-file descriptors or to reconstitute +source-file descriptors from the \var{path} and \var{checksum} components. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{annotation-option-set}{\categorysyntax}{(annotation-option-set \var{symbol} \dots)} +\returns an annotation-options enumeration set +\listlibraries +\endentryheader + +\noindent +Annotation-options enumeration sets may be passed to \scheme{make-annotation} to +control whether the annotation is used for debugging, profiling, both, or neither. +Accordingly, each \var{symbol} must be either \var{debug} or \scheme{profile}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{syntax->annotation}{\categoryprocedure}{(syntax->annotation \var{obj})} +\returns an annotation or \scheme{#f} +\listlibraries +\endentryheader + +If \var{obj} is an annotation or syntax-object encapsulating an annotation, +the annotation is returned. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-datum/annotations}{\categoryprocedure}{(get-datum/annotations \var{textual-input-port} \var{sfd} \var{bfp})} +\returns see below +\listlibraries +\endentryheader + +\var{sfd} must be a source-file descriptor. +\var{bfp} must be an exact nonnegative integer and should be the +character position of the next character to be read from +\var{textual-input-port}. + +This procedure returns two values: an annotated object and an ending +file position. +In most cases, \var{bfp} should be 0 for the first call +to \scheme{get-datum/annotation} at the start of a file, +and it should be the second return value of the preceding +call to \scheme{get-datum/annotation} for each subsequent +call. +This protocol is necessary to handle files containing multiple-byte +characters, since file positions do not necessarily correspond +to character positions. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{open-source-file}{\categoryprocedure}{(open-source-file \var{sfd})} +\returns a port or \scheme{#f} +\listlibraries +\endentryheader + +\var{sfd} must be a source-file descriptor. +This procedure attempts to locate and open the source file identified +by \var{sfd}. +It returns a textual input port, positioned at the beginning of the file, +if successful, and \scheme{#f} otherwise. +It can fail even if a file with the correct name exists in one of +the source directories when the file's checksum does not match the +checksum recorded in \var{sfd}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{locate-source}{\categoryprocedure}{(locate-source \var{sfd} \var{pos})} +\formdef{locate-source}{\categoryprocedure}{(locate-source \var{sfd} \var{pos} \var{use-cache?})} +\returns see below +\listlibraries +\endentryheader + +\var{sfd} must be a source-file descriptor, and \var{pos} must be an +exact nonnegative integer. + +This procedure either uses cached information from a previous +request for \var{sfd} (only when \var{use-cache?} is provided as true) +or attempts to locate and open the source file identified +by \var{sfd}. +If successful, it returns three values: a string \var{path}, an exact +nonnegative integer \var{line}, and an exact nonnegative integer \var{char} +representing the absolute pathname, line, and character position within +the line represented by the specified source-file descriptor and file +position. +If unsuccessful, it returns zero values. +It can fail even if a file with the correct name exists in one of +the source directories when the file's checksum does not match the +checksum recorded in \var{sfd}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{locate-source-object-source}{\categoryprocedure}{(locate-source-object-source \var{source-object} \var{get-start?} \var{use-cache?})} +\returns see below +\listlibraries +\endentryheader + +This procedure is similar to \scheme{locate-source}, but instead of +taking an sfd and a position, it takes a source object plus a request +for either the start or end location. + +If \var{get-start?} is true and \var{source-object} has a line and column, +this procedure returns the path in +\var{source-objects}'s sfd, \var{source-object}'s line, and +\var{source-objects}'s column. + +If \var{source-object} has no line and column, then +this procedure calls \scheme{locate-source} on +\var{source-object}'s sfd, either \var{source-object}'s bfp or efp +depending on \var{get-start?}, and \var{use-cache?}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-locate-source-object-source}{\categorythreadparameter}{current-locate-source-object-source} +\listlibraries +\endentryheader + +\noindent + +\scheme{current-locate-source-object-source} determines the +source-location lookup function that is used by the system to report +errors based on source objects. This parameter is initially bound to +\scheme{locate-source-object-object}. + +Adjust this parameter to control the way that source locations are +extracted from source objects, possibly using recorded information, +caches, and the filesystem in a way different from +\scheme{locate-source-object-object}. + + +\section{Source Tables\label{SECTSYNTAXSOURCETABLES}} + +Source tables provide an efficient way to associate information +with source objects both in memory and on disk, such as the coverage information +saved to \scheme{.covin} files when +\index{\scheme{generate-covin-files}}\scheme{generate-covin-files} is +set to \scheme{#t} +and the profile counts associated with source objects by +\index{\scheme{with-profile-tracker}}\scheme{with-profile-tracker} +(Section~\ref{SECTMISCPROFILE}). + +Source tables are manipulated via hashtable-like accessors and setters +(Section~\ref{SECTMISCHASHTABLES}, {\TSPLFOUR} Section~\ref{TSPL:SECTHASHTABLES}), e.g., +\index{\scheme{source-table-ref}}\scheme{source-table-ref} and \index{\scheme{source-table-set!}}\scheme{source-table-set!}. +They can be saved to files via +\index{\scheme{put-source-table}}\scheme{put-source-table} +and restored via +\index{\scheme{get-source-table!}}\scheme{get-source-table!}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-source-table}{\categoryprocedure}{(make-source-table)} +\returns a source table +\listlibraries +\endentryheader + +A source table contains associations between source objects and arbitrary +values. For purposes of the source-table operations described below, two +source objects are the same if they have the same source-file descriptor, +equal beginning file positions and equal ending file positions. +Two source-file descriptors are the same if they have the same path and +checksum. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table?}{\categoryprocedure}{(source-table? \var{obj})} +\returns \scheme{#t} if \var{obj} is a source-table; \scheme{#f} otherwise +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-set!}{\categoryprocedure}{(source-table-set! \var{source-table} \var{source-object} \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{source-table-set!} associates \var{source-object} +with \var{obj} in \var{source-table}, replacing the +existing association, if any. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-ref}{\categoryprocedure}{(source-table-ref \var{source-table} \var{source-object} \var{default})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{default} may be any Scheme value. + +\scheme{source-table-ref} returns the value +associated with \var{source-object} in \var{source-table}. +If no value is associated with \var{source-object} in \var{source-table}, +\scheme{source-table-ref} returns \var{default}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-contains?}{\categoryprocedure}{(source-table-contains? \var{source-table} \var{source-object})} +\returns \scheme{#t} if an association for \var{source-object} exists in \var{source-table}, \scheme{#f} otherwise +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-cell}{\categoryprocedure}{(source-table-cell \var{source-table} \var{source-object} \var{default})} +\returns a pair (see below) +\listlibraries +\endentryheader + +\noindent +\var{default} may be any Scheme value. + +If no value is associated with \var{source-object} in \var{source-table}, +\scheme{source-table-cell} modifies \var{source-table} to associate \var{source-object} with +\var{default}. +Regardless, it returns a pair whose car is \var{source-object} and whose cdr is +the associated value. +Changing the cdr of this pair effectively updates the table to +associate \var{source-object} with a new value. +The car field of the pair should not be modified. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-delete!}{\categoryprocedure}{(source-table-delete! \var{source-table} \var{source-object})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{source-table-delete!} drops the association +for \var{source-object} from \var{source-table}, if +one exists. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-size}{\categoryprocedure}{(source-table-size \var{source-table})} +\returns the number of entries in \var{source-table} +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{put-source-table}{\categoryprocedure}{(put-source-table \var{textual-output-port} \var{source-table})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +This procedure writes a representation of the information stored in \var{source-table} to the port. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-source-table!}{\categoryprocedure}{(get-source-table! \var{textual-input-port} \var{source-table})} +\formdef{get-source-table!}{\categoryprocedure}{(get-source-table! \var{textual-input-port} \var{source-table} \var{combine})} +\returns unspecified +\listlibraries +\endentryheader + +The port must be positioned at a representation of source-table +information written by some previous call to \scheme{put-source-table}, +which reads the information and merges it into \scheme{source-table}. + +If present and non-false, \var{combine} must be a procedure and +should accept two arguments. +It is called whenever associations for the same source object are +present both in \var{source-table} and in the information read from +the port. +In this case, \var{combine} is passed two arguments: the associated +value from \var{source-table} and the associated value from the +port (in that order) and must return one value, which is recorded +as the new associated value for the source object in \var{source-table}. + +If \var{combine} is not present, \var{combine} is \scheme{#f}, or +no association for a source object read from the port already exists +in \var{source-table}, the value read from the port is recorded as +the associated value of the source object in \var{source-table}. + +\schemedisplay +(define st (make-source-table)) +(call-with-port (open-input-file "profile.out1") + (lambda (ip) (get-source-table! ip st))) +(call-with-port (open-input-file "profile.out2") + (lambda (ip) (get-source-table! ip st +))) +\endschemedisplay diff --git a/csug/system.stex b/csug/system.stex new file mode 100644 index 0000000..c09419a --- /dev/null +++ b/csug/system.stex @@ -0,0 +1,5343 @@ +% Copyright 2005-2018 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{System Operations\label{CHPTSYSTEM}} + +This chapter describes operations for +handling exceptions, interrupts, environments, +compilation and evaluation, profiling, +controlling the operation of the system, +timing and statistics, +defining and setting parameters, +and +querying the operating system environment. + +\schemeinit +(load "docond.ss") +\endschemeinit + +\section{Exceptions\label{SECTSYSTEMEXCEPTIONS}} + +\index{exception handling}{\ChezScheme} provides some extensions to the +Revised$^6$ Report exception-handling mechanism, including mechanisms +for producing formatted error messages, displaying conditions, +and redefining the base exception handler. +These extensions are described in this section. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{warning}{\categoryprocedure}{(warning \var{who} \var{msg} \var{irritant} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{warning} raises a continuable exception with condition type +\scheme{&warning} and should be used to describe situations for which the +\scheme{&warning} condition type is appropriate, typically a situation +that should not prevent the program from continuing but might result +in a more serious problem at some later point. + +The continuation object with which the exception is raised also includes +a \scheme{&who} condition whose who field is \var{who} if \var{who} is +not \scheme{#f}, a \scheme{&message} condition whose message field is +\var{msg}, and an \scheme{&irritants} condition whose irritants field +is \scheme{(\var{irritant} \dots)}. + +\var{who} must be a string, a symbol, or \scheme{#f} identifying the procedure +or syntactic form reporting the warning. +It is usually best to identify a procedure the programmer has called rather +than some other procedure the programmer may not be aware is involved in +carrying out the operation. +\var{msg} must be a string and should describe the exceptional situation. +The irritants may be any Scheme objects and should include values that may +have caused or been materially involved in the exceptional situation. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{assertion-violationf}{\categoryprocedure}{(assertion-violationf \var{who} \var{msg} \var{irritant} \dots)} +\returns does not return +\formdef{errorf}{\categoryprocedure}{(errorf \var{who} \var{msg} \var{irritant} \dots)} +\returns does not return +\formdef{warningf}{\categoryprocedure}{(warningf \var{who} \var{msg} \var{irritant} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\index{formatted error messages}% +These procedures are like \scheme{assertion-violation}, \scheme{error}, +and \scheme{warning} except +that \var{msg} is assumed to be a format string, as if in a call to +\scheme{format} (Section~\ref{SECTFORMAT}), with +\scheme{\var{irritant} \dots} treated as the additional arguments to +\scheme{format}. +This allows programs to control the appearance of the error message, at +least when the default exception handler is in place. + +For each of these procedures, the continuation object with which the exception +is raised includes a \scheme{&format} condition to signify that the string +contained in the condition object's \scheme{&message} condition is a +\scheme{format} string and the objects contained in the condition object's +\scheme{&irritants} condition should be treated as the additional +\scheme{format} arguments. + +%---------------------------------------------------------------------------- +\entryheader +\conditionformdef{(define-condition-type &format &condition + make-format-condition format-condition?)} +\endentryheader + +\noindent +Presence of this condition type within a compound condition indicates +that the string provided by the \scheme{&message} condition, if +present, is a \scheme{format} string and the list of objects provided by +the \scheme{&irritants} condition, if present, should be treated as +additional \scheme{format} arguments. +\showit + + +%---------------------------------------------------------------------------- +\entryheader +\conditionformdef{(define-condition-type &source &condition + make-source-condition source-condition? + (form source-condition-form))} +\endentryheader + +\noindent +This condition type can be included within a compound condition when a +source expression can be identified in situations in which a +\scheme{&syntax} condition would be inappropriate, such as when a +run-time assertion violation is detected. +The \scheme{form} argument should be an s-expression or syntax object +representing the source expression. +\showit + + +%---------------------------------------------------------------------------- +\entryheader +\conditionformdef{(define-condition-type &continuation &condition + make-continuation-condition continuation-condition? + (continuation condition-continuation))} +\endentryheader + +\noindent +This condition type can be included within a compound condition to indicate +the current continuation at the point where the exception described by the +condition occurred. +The continuation of a failed \scheme{assert} or a call to +\scheme{assertion-violation}, \scheme{assertion-violationf}, +\scheme{error}, \scheme{errorf}, or \scheme{syntax-error} is now included +via this condition type in the conditions passed to \scheme{raise}. +The \scheme{continuation} argument should be a continuation. +\showit + +%---------------------------------------------------------------------------- +\entryheader +\formdef{display-condition}{\categoryprocedure}{(display-condition \var{obj})} +\formdef{display-condition}{\categoryprocedure}{(display-condition \var{obj} \var{textual-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +If \var{textual-output-port} is not supplied, it defaults to the current output port. +This procedure displays a message to the effect that an exception +has occurred with value \var{obj}. +If \var{obj} is a condition (Chapter~\ref{TSPL:CHPTEXCEPTIONS} of +{\TSPLFOUR}), it displays information encapsulated within the condition, +handling messages, \var{who} conditions, irritants, source information, +etc., as appropriate. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-exception-handler}{\categoryprocedure}{(default-exception-handler \var{obj})} +\returns unspecified +\listlibraries +\endentryheader + +This procedure is the default value of the \scheme{base-exception-handler} +parameter called on a condition when no other exception handler has been +defined or when all dynamically established exception handlers have chosen +not to handle the condition. +It first displays \var{obj}, as if with \scheme{display-condition}, to the +console error port. +For non-serious warning conditions, it returns immediately after displaying +the condition. + +For serious or other non-warning conditions, it +saves the condition in the parameter \scheme{debug-condition}, where +\scheme{debug} (Section~\ref{SECTDEBUGINTERACTIVE}) can retrieve it and +allow it to be inspected. +If the \scheme{debug-on-exception} parameter is set to \scheme{#f} (the +default unless the \index{\scheme{--debug-on-exception} command-line +option}\scheme{--debug-on-exception} command-line option is provided), the +handler prints a message instructing the user to type \scheme{(debug)} to +enter the debugger, then resets to the current caf\'e. +Otherwise, the handler invokes \scheme{debug} directly and resets if +\scheme{debug} returns. + +If an I/O exception occurs while attempting to display the condition, +the default exception handler resets (as if by calling \scheme{reset}). +The intent is to avoid an infinite regression (ultimately ending +in exhaustion of memory) in which the process repeatedly recurs +back to the default exception handler trying to write to a console-error +port (typically stderr) that is no longer writable, e.g., due to +the other end of a pipe or socket having been closed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{debug-on-exception}{\categoryglobalparameter}{debug-on-exception} +\listlibraries +\endentryheader + +The value of this parameter determines whether the default exception handler +immediately enters the debugger immediately when it receives a serious or +non-warning condition. +If the \index{\scheme{--debug-on-exception} command-line option}\scheme{--debug-on-exception} +command-line option (Section~\ref{SECTUSEINTERACTION}) has been provided, the +initial value of this parameter is \scheme{#t}. +Otherwise, the initial value is \scheme{#f}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{base-exception-handler}{\categorythreadparameter}{base-exception-handler} +\listlibraries +\endentryheader + +The value of this parameter must be a procedure, and the procedure +should accept one argument. +The default value of \scheme{base-exception-handler} is +the procedure \scheme{default-exception-handler}. + +The value of this parameter is invoked whenever no exception handler +established by a program has chosen to handle an exception. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{debug-condition}{\categorythreadparameter}{debug-condition} +\listlibraries +\endentryheader + +This parameter is used by the default exception handler to hold the +last serious or non-warning condition received by the handler, where +it can be inspected via the \scheme{debug} procedure +(Section~\ref{SECTDEBUGINTERACTIVE}). +It can also be invoked by user code to store or retrieve a +condition. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-exception-state}{\categorythreadparameter}{current-exception-state} +\listlibraries +\endentryheader + +\scheme{current-exception-state} may be used to get or set +the current exception state. +When called without arguments, \scheme{current-exception-state} returns +an \emph{exception state} comprising the current stack of handlers established +by \scheme{with-exception-handler} and \scheme{guard}. +When called with a single argument, which must be an exception state, +\scheme{current-exception-state} sets the exception state. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{create-exception-state}{\categoryprocedure}{(create-exception-state)} +\formdef{create-exception-state}{\categoryprocedure}{(create-exception-state \var{procedure})} +\listlibraries +\endentryheader + +\scheme{create-exception-state} creates an exception +state whose stack of exception handlers is empty except for, in effect, +an infinite number of occurrences of \emph{handler} at its +base. +\var{handler} must be a procedure, and should accept one argument. +If not provided, \var{handler} defaults to a procedure equivalent +to the value of the following expression. + +\schemedisplay +(lambda (x) ((base-exception-handler) x)) +\endschemedisplay + +\section{Interrupts\label{SECTSYSTEMINTERRUPTS}} + +\index{interrupts}{\ChezScheme} allows programs to control +the action of the Scheme system when various events +occur, including an interrupt from the +keyboard, the expiration of an internal timer set by \scheme{set-timer}, +a breakpoint caused by a call to \scheme{break}, or a request from the +storage manager to initiate a garbage collection. +These mechanisms are described in this section, except for the +collect request mechanism, which is described in Section~\ref{SECTSMGMTGC}. + +Timer, keyboard, and collect-request interrupts are supported via a counter +that is decremented approximately once for each call to a nonleaf procedure. +(A leaf procedure is one that does not itself make any calls.) +When no timer is running, this counter is set to a default value (1000 +in Version~9) when a program starts or after an interrupt occurs. +If a timer is set (via \scheme{set-timer}), the counter is set to the +minimum of the default value and the number of ticks to which the timer is +set. +When the counter reaches zero, the system looks to see if the timer +is set and has expired or if a keyboard or collect request interrupt +has occurred. +If so, the current procedure call is pended (``put on hold'') while the +appropriate interrupt handler is invoked to handle the interrupt. +When (if) the interrupt handler returns, the pended call takes place. +Thus, timer, keyboard, and collect-request interrupts effectively occur +synchronously with respect to the procedure call mechanism, and +keyboard and collect request interrupts may be delayed by a number +of calls equal to the default timer value. + +Calls to the break handler occur immediately +whenever \scheme{break} is called. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{break}{\categoryprocedure}{(break \var{who} \var{msg} \var{irritant} \dots)} +\formdef{break}{\categoryprocedure}{(break \var{who})} +\formdef{break}{\categoryprocedure}{(break)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +The arguments to \scheme{break} follow the protocol described above for +\scheme{errorf}. +The default break handler (see \scheme{break-handler}) displays a message and +invokes the \index{debugger}debugger. +The format string and objects may be omitted, in which case the +message issued by the default break handler identifies the break +using the \var{who} argument but provides no more information +about the break. +If the \var{who} argument is omitted as well, no message is generated. +The default break handler returns normally if the debugger +exits normally. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{break-handler}{\categorythreadparameter}{break-handler} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a procedure. +The current break handler is called by \scheme{break}, which passes +along its arguments. +See \scheme{break} for a description of the default break +handler. +The example below shows how to disable breaks. + +\schemedisplay +(break-handler (lambda args (void))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{keyboard-interrupt-handler}{\categorythreadparameter}{keyboard-interrupt-handler} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a procedure. +The keyboard-interrupt handler is called (with no arguments) when +a keyboard interrupt occurs. +The default keyboard-interrupt handler invokes the interactive +\index{debugger}debugger. +If the debugger exits normally the interrupted computation is +resumed. +The example below shows how to install a keyboard-interrupt handler +that resets without invoking the debugger. + +\schemedisplay +(keyboard-interrupt-handler + (lambda () + (newline (console-output-port)) + (reset))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:set-timer} +\formdef{set-timer}{\categoryprocedure}{(set-timer \var{n})} +\returns previous current timer value +\listlibraries +\endentryheader + +\noindent +\index{timer interrupts}\var{n} must be a nonnegative integer. +When \var{n} is nonzero, \scheme{set-timer} starts an internal timer with +an initial value of \var{n}. +When \var{n} ticks elapse, a timer interrupt occurs, resulting in +invocation of the timer interrupt handler. +Each tick corresponds roughly to one nonleaf procedure call (see the +introduction to this section); thus, ticks are not +uniform time units but instead depend heavily on how much work is done +by each procedure call. + +When \var{n} is zero, \scheme{set-timer} turns the timer off. + +The value returned in either case is the value of the timer before the +call to \scheme{set-timer}. +A return value of 0 should not be taken to imply that the timer was not on; +the return value may also be 0 if the timer was just about to fire when +the call to \scheme{set-timer} occurred. + +The engine mechanism (Section~\ref{SECTENGINES}) is built on top of the +timer interrupt so timer interrupts should not be used with engines. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{timer-interrupt-handler}{\categorythreadparameter}{timer-interrupt-handler} +\listlibraries +\endentryheader + +\noindent +\index{timer interrupts}The value of this parameter must be a procedure. +The timer interrupt handler is called by the system when the internal timer +(set by \scheme{set-timer}) expires. +The default handler raises an exception with condition type \scheme{&assertion} +to say that the handler has not +been defined; any program that uses the timer should redefine the +handler before setting the timer. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{disable-interrupts}{\categoryprocedure}{(disable-interrupts)} +\formdef{enable-interrupts}{\categoryprocedure}{(enable-interrupts)} +\returns disable count +\listlibraries +\endentryheader + +\noindent +\scheme{disable-interrupts} disables the handling of interrupts, +including timer, keyboard, and collect request interrupts. +\scheme{enable-interrupts} re-enables these interrupts. +The system maintains a disable count that starts at zero; when zero, +interrupts are enabled. +Each call to \scheme{disable-interrupts} increments the count, +effectively disabling interrupts. +Each call to \scheme{enable-interrupts} decrements the count, if +not already zero, effectively enabling interrupts. +For example, two calls to \scheme{disable-interrupts} followed by one call to +\scheme{enable-interrupts} leaves interrupts disabled. +Calls to \scheme{enable-interrupts} when the count is already zero +(and interrupts are enabled) have no effect. +The value returned by either procedure is the number of calls to +\scheme{enable-interrupts} required to enable interrupts. + +Great care should be exercised when using these procedures, since disabling +interrupts inhibits the normal processing of keyboard interrupts, +timer interrupts, and, perhaps most importantly, collect request interrupts. +Since garbage collection does not happen automatically when interrupts are +disabled, it is possible for the storage allocator to run out of space +unnecessarily should interrupts be disabled for a long period of time. + +The \scheme{with-interrupts-disabled} syntactic form should be used instead of +these more primitive procedures whenever possible, +since \scheme{with-interrupts-disabled} ensures that interrupts are re-enabled +whenever a nonlocal exit occurs, such as when an exception is handled by +the default exception handler. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-interrupts-disabled}{\categorysyntax}{(with-interrupts-disabled \var{body_1} \var{body_2} \dots)} +\formdef{critical-section}{\categorysyntax}{(critical-section \var{body_1} \var{body_2} \dots)} +\returns the values of the body \scheme{\var{body_1} \var{body_2} \dots} +\listlibraries +\endentryheader + +\noindent +\scheme{with-interrupts-disabled} evaluates the body +\scheme{\var{body_1} \var{body_2} \dots} with interrupts disabled. +That is, upon entry, interrupts are disabled, and +upon exit, interrupts are re-enabled. +Thus, \scheme{with-interrupts-disabled} allows the implementation of indivisible +operations in nonthreaded versions of {\ChezScheme} or within a single thread +in threaded versions of {\ChezScheme}. +\scheme{critical-section} is the same as \scheme{with-interrupts-disabled} and +is provided for backward compatibility. + +\scheme{with-interrupts-disabled} can be defined as follows. + +\schemedisplay +(define-syntax with-interrupts-disabled + (syntax-rules () + [(_ b1 b2 ...) + (dynamic-wind + disable-interrupts + (lambda () b1 b2 ...) + enable-interrupts)])) +\endschemedisplay + +\noindent +The use of \scheme{dynamic-wind} ensures that interrupts are +disabled whenever the body of the \scheme{with-interrupts-disabled} expression +is active and re-enabled whenever it is not. +Since calls to \scheme{disable-interrupts} are counted (see the +discussion under \scheme{disable-interrupts} and +\scheme{enable-interrupts} above), \scheme{with-interrupts-disabled} +expressions may be nested with the desired effect. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{register-signal-handler}{\categoryprocedure}{(register-signal-handler \var{sig} \var{procedure})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{register-signal-handler} is used to +establish a signal handler for a given low-level signal. +\var{sig} must be an exact integer identifying a valid signal, and +\var{procedure} should accept one argument. +See your host system's \scheme{} or documentation for a list +of valid signals and their numbers. +After a signal handler for a given signal has been registered, receipt +of the specified signal results in a call to the handler. +The handler is passed the signal number, allowing the same handler to +be used for different signals while differentiating among them. + +Signals handled in this fashion are treated like keyboard interrupts in +that the handler is not called immediately when the signal is delivered +to the process, but rather at some procedure call boundary after the +signal is delivered. +It is generally not a good idea, therefore, to establish handlers for +memory faults, illegal instructions, and the like, since the code that +causes the fault or illegal instruction will continue to execute +(presumably erroneously) for some time before the handler is invoked. +A finite amount of storage is used to buffer as-yet unhandled +signals, after which additional signals are dropped. + +\scheme{register-signal-handler} is supported only on Unix-based +systems. + + +\section{Environments\label{SECTMISCENVIRONMENTS}} + +Environments are first-class objects containing identifier bindings. +They are similar to modules but, unlike modules, may be manipulated +at run time. +Environments may be provided as optional arguments to \scheme{eval}, +\scheme{expand}, and the procedures that define, assign, or +reference top-level values. + +There are several built-in environments, and new environments can +be created by copying existing environments or selected bindings +from existing environments. + +Environments can be mutable or immutable. +A mutable environment can be extended with new bindings, its +existing bindings can be modified, and its variables can be assigned. +An immutable environment cannot be modified in any of these ways. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{environment?}{\categoryprocedure}{(environment? \var{obj})} +\returns \scheme{#t} if \var{obj} is an environment, otherwise \scheme{#f} +\listlibraries +\endnoskipentryheader + +\schemedisplay +(environment? (interaction-environment)) ;=> #t +(environment? 'interaction-environment) ;=> #f +(environment? (copy-environment (scheme-environment))) ;=> #t +(environment? (environment '(prefix (rnrs) $rnrs-))) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{environment-mutable?}{\categoryprocedure}{(environment-mutable? \var{env})} +\returns \scheme{#t} if \var{env} is mutable, otherwise \scheme{#f} +\listlibraries +\endnoskipentryheader + +\schemedisplay +(environment-mutable? (interaction-environment)) ;=> #t +(environment-mutable? (scheme-environment)) ;=> #f +(environment-mutable? (copy-environment (scheme-environment))) ;=> #t +(environment-mutable? (environment '(prefix (rnrs) $rnrs-))) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{scheme-environment}{\categoryprocedure}{(scheme-environment)} +\returns an environment +\listlibraries +\endentryheader + +\noindent +\scheme{scheme-environment} returns an environment containing +the initial top-level bindings. +This environment corresponds to the \scheme{scheme} module. + +The environment returned by this procedure is immutable. + +\schemedisplay +(define cons 3) +(top-level-value 'cons (scheme-environment)) ;=> # +(set-top-level-value! 'cons 3 (scheme-environment)) ;=> \var{exception} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{ieee-environment}{\categoryprocedure}{(ieee-environment)} +\returns an IEEE/ANSI standard compatibility environment +\listlibraries +\endentryheader + +\noindent +\scheme{ieee-environment} returns an environment containing +bindings for the keywords and variables whose meanings are +defined by the IEEE/ANSI Standard for Scheme~\cite{IEEE:1178}. + +The bindings for each of the identifiers in the IEEE environment are those +of the corresponding Revised$^6$ Report library, so this does not provide +full backward compatibility. + +The environment returned by this procedure is immutable. + +\schemedisplay +(define cons 3) +(top-level-value 'cons (ieee-environment)) ;=> # +(set-top-level-value! 'cons 3 (ieee-environment)) ;=> \var{exception} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{interaction-environment}{\categorythreadparameter}{interaction-environment} +\listlibraries +\endentryheader + +\noindent +The original value of \scheme{interaction-environment} is the default +top-level environment. +It is initially set to a mutable copy of +\scheme{(scheme-environment)} and which may be extended or otherwise +altered by top-level definitions and assignments. +It may be set to any environment, mutable or not, to change the +default top-level evaluation environment. + +An expression's top-level bindings resolve to the environment that is +in effect when the expression is expanded, and changing the value +of this parameter has no effect on running code. +Changes affect only code that is subsequently expanded, e.g., as the +result of a call to \scheme{eval}, \scheme{load}, or +\scheme{compile-file}. + +\schemedisplay +(define cons 3) +cons ;=> 3 +(top-level-value 'cons (interaction-environment)) ;=> 3 + +(interaction-environment (scheme-environment)) +cons ;=> # +(set! cons 3) ;=> \var{exception: attempt to assign immutable variable} +(define cons 3) ;=> \var{exception: invalid definition in immutable environment} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{copy-environment}{\categoryprocedure}{(copy-environment \var{env})} +\formdef{copy-environment}{\categoryprocedure}{(copy-environment \var{env} \var{mutable?})} +\formdef{copy-environment}{\categoryprocedure}{(copy-environment \var{env} \var{mutable?} \var{syms})} +\returns a new environment +\listlibraries +\endentryheader + +\scheme{copy-environment} returns a copy of \var{env}, i.e., a new +environment that contains the same bindings as \var{env}. + +The environment is mutable if \var{mutable?} is omitted or true; +if \var{mutable?} is false, the environment is immutable. + +The set of bindings copied from \var{env} to the new environment +is determined by \var{syms}, which defaults to the value of +\scheme{(environment-symbols \var{env})}. +The binding, if any, for each element of \var{syms} is copied to the +new environment, and no other bindings are present in the new +environment. + +In the current implementation, the storage space used by an environment +is never collected, so repeated use of \scheme{copy-environment} will +eventually cause the system to run out of memory. + +\schemedisplay +(define e (copy-environment (scheme-environment))) +(eval '(define cons +) e) +(eval '(cons 3 4) e) ;=> 7 +(eval '(cons 3 4) (scheme-environment)) ;=> (3 . 4) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{environment-symbols}{\categoryprocedure}{(environment-symbols \var{env})} +\returns a list of symbols +\listlibraries +\endentryheader + +This procedure returns a list of symbols representing the identifiers +bound in environment \var{env}. +It is primarily useful in building the list of symbols to be copied +from one environment to another. + +\schemedisplay +(define listless-environment + (copy-environment + (scheme-environment) + #t + (remq 'list (environment-symbols (scheme-environment))))) +(eval '(let ([x (cons 3 4)]) x) listless-environment) ;=> (3 . 4) +(eval '(list 3 4) listless-environment) ;=> \var{exception} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{apropos-list}{\categoryprocedure}{(apropos-list \var{s})} +\formdef{apropos-list}{\categoryprocedure}{(apropos-list \var{s} \var{env})} +\returns see below +\listlibraries +\endentryheader + +This procedure returns a selected list of symbols and pairs. +Each symbol in the list represents an identifier bound in \var{env}. +Each pair represents a set of identifiers exported by a +predefined library or a library previously defined or loaded +into the system. +The car of the pair is the library name, and the cdr is a list +of symbols. +If \var{s} is a string, only entries whose names have \var{s} as a +substring are included, and if \var{s} is a symbol, only those whose names +have the name of \var{s} as a substring are selected. +If no environment is provided, it defaults to the value of +\scheme{interaction-environment}. + +\schemedisplay +(library (a) (export a-vector-sortof) (import (rnrs)) + (define a-vector-sortof '(vector 1 2 3))) +(apropos-list 'vector-sort) ;=> + (vector-sort vector-sort! + ((a) a-vector-sortof) + ((chezscheme) vector-sort vector-sort!) + ((rnrs) vector-sort vector-sort!) + ((rnrs sorting) vector-sort vector-sort!) + ((scheme) vector-sort vector-sort!)) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{apropos}{\categoryprocedure}{(apropos \var{s})} +\formdef{apropos}{\categoryprocedure}{(apropos \var{s} \var{env})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{apropos} is like \scheme{apropos-list} except the information is +displayed to the current output port, as shown in the following +transcript. + +\schemedisplay +> (library (a) (export a-vector-sortof) (import (rnrs)) + (define a-vector-sortof '(vector 1 2 3))) +> (apropos 'vector-sort) +interaction environment: + vector-sort, vector-sort! +(a): + a-vector-sortof +(chezscheme): + vector-sort, vector-sort! +(rnrs): + vector-sort, vector-sort! +(rnrs sorting): + vector-sort, vector-sort! +(scheme): + vector-sort, vector-sort! +\endschemedisplay + +\section{Compilation, Evaluation, and Loading\label{SECTMISCCOMPILEEVAL}} + + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{eval}{\categoryprocedure}{(eval \var{obj})} +\formdef{eval}{\categoryprocedure}{(eval \var{obj} \var{env})} +\returns value of the Scheme form represented by \var{obj} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{eval} treats \var{obj} as the representation of an expression. +It evaluates the expression in environment \var{env} and returns +its value. +If no environment is provided, it defaults to the environment +returned by \scheme{interaction-environment}. + +Single-argument \scheme{eval} is a {\ChezScheme} extension. +{\ChezScheme} also permits \var{obj} to be the representation of a +nonexpression form, i.e., a definition, whenever the environment +is mutable. +{\ChezScheme} further allows \var{obj} to be an annotation +(Section~\ref{SECTSYNTAXANNOTATIONS}), and the default evaluators +make use of annotations to incorporate source-file +information in error messages and associate source-file +information with compiled code. + +In {\ChezScheme}, \scheme{eval} is actually a wrapper that simply +passes its arguments to the current evaluator. +(See \scheme{current-eval}.) +The default evaluator is \scheme{compile}, which expands the +expression via the current expander (see +\scheme{current-expand}), compiles it, +executes the resulting code, and returns its value. +If the environment argument, \var{env}, is present, +\scheme{compile} passes it along to the current expander, +which is \scheme{sc-expand} by default. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-eval}{\categorythreadparameter}{current-eval} +\listlibraries +\endentryheader + +\noindent +\scheme{current-eval} determines the evaluation procedure used by the +procedures \index{\scheme{eval}}\scheme{eval}, \scheme{load}, and +\scheme{new-cafe}. +\scheme{current-eval} is initially bound to the value of +\index{\scheme{compile}}\scheme{compile}. +(In {\PetiteChezScheme}, it is initially bound to the value of +\index{\scheme{interpret}}\scheme{interpret}.) +The evaluation procedure should expect one or two arguments: an object +to evaluate and an optional environment. +The second argument might be an annotation +(Section~\ref{SECTSYNTAXANNOTATIONS}). + +\schemedisplay +(current-eval interpret) +(+ 1 1) ;=> 2 + +(current-eval (lambda (x . ignore) x)) +(+ 1 1) ;=> (+ 1 1) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile}{\categoryprocedure}{(compile \var{obj})} +\formdef{compile}{\categoryprocedure}{(compile \var{obj} \var{env})} +\returns value of the Scheme form represented by \var{obj} +\listlibraries +\endentryheader + +\noindent +\var{obj}, which can be an annotation (Section~\ref{SECTSYNTAXANNOTATIONS}) +or unannotated value, is treated as a Scheme expression, expanded with the +current expander (the value of \scheme{current-expand}) in the specified +environment (or the interaction environment, if no environment +is provided), compiled to machine code, and executed. +\scheme{compile} is the default value of the \scheme{current-eval} +parameter. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{interpret}{\categoryprocedure}{(interpret \var{obj})} +\formdef{interpret}{\categoryprocedure}{(interpret \var{obj} \var{env})} +\returns value of the Scheme form represented by \var{obj} +\listlibraries +\endentryheader + +\noindent +\scheme{interpret} is like \scheme{compile}, except that the expression +is interpreted rather than compiled. +\scheme{interpret} may be used as a replacement for \scheme{compile}, +with the following caveats: + +\begin{itemize} +\item +Interpreted code runs significantly slower. + +\item +Inspector information is not generated for +interpreted code, so the inspector is not as useful for interpreted +code as it is for compiled code. + +\item +Foreign procedure expressions cannot be +interpreted, so the interpreter invokes the compiler for all +foreign procedure expressions (this is done transparently). +\end{itemize} + +\noindent +\scheme{interpret} is sometimes faster than \scheme{compile} when the +form to be evaluated is short running, since it avoids some of the +work done by \scheme{compile} prior to evaluation. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{load}{\categoryprocedure}{(load \var{path})} +\formdef{load}{\categoryprocedure}{(load \var{path} \var{eval-proc})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{load} reads and evaluates the contents of the file specified by +\var{path}. +The file may contain source or object code. +By default, \scheme{load} employs \scheme{eval} to evaluate each source +expression found in a source file. +If \var{eval-proc} is specified, \scheme{load} uses this procedure instead. +\var{eval-proc} must accept one argument, the expression to evaluate. +The expression passed to \var{eval-proc} might be an annotation +(Section~\ref{SECTSYNTAXANNOTATIONS}) or an unannotated value. + +The \var{eval-proc} argument +facilitates the implementation of embedded Scheme-like languages +and the use of alternate +evaluation mechanisms to be used for Scheme programs. +\var{eval-proc} can be put to other uses as well. +For example, + +\schemedisplay +(load "myfile.ss" + (lambda (x) + (pretty-print + (if (annotation? x) + (annotation-stripped x) + x)) + (newline) + (eval x))) +\endschemedisplay + +\noindent +pretty-prints each expression before evaluating it. + +\index{\scheme{source-directories}}% +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories searched for source files not identified +by absolute path names. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{load-library}{\categoryprocedure}{(load-library \var{path})} +\formdef{load-library}{\categoryprocedure}{(load-library \var{path} \var{eval-proc})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{load-library} is identical to \scheme{load} except +that it treats the input file as if it were prefixed by an implicit +\scheme{#!r6rs}. +This effectively disables any non-R6RS lexical +syntax except where subsequently overridden by \scheme{#!chezscheme}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{load-program}{\categoryprocedure}{(load-program \var{path})} +\formdef{load-program}{\categoryprocedure}{(load-program \var{path} \var{eval-proc})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{load-program} reads and evaluates the contents of the file specified by +\var{path}. +The file may contain source or object code. +If it contains source code, \scheme{load-program} wraps +the code in a \scheme{top-level-program} form so that the file's +content is treated as an RNRS top-level program +(Section~\ref{TSPL:SECTLIBPROGRAMS} of {\TSPLFOUR}). +By default, \scheme{load-program} employs \scheme{eval} to evaluate each source +expression found in the file. +If \var{eval-proc} is specified, \scheme{load-program} uses this procedure instead. +\var{eval-proc} must accept one argument, the expression to evaluate. +The expression passed to \var{eval-proc} might be an annotation +(Section~\ref{SECTSYNTAXANNOTATIONS}) or an unannotated value. + +\index{\scheme{source-directories}}% +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories searched for source files not identified +by absolute path names. + +%---------------------------------------------------------------------------- + +\entryheader +\formdef{verify-loadability}{\categoryprocedure}{(verify-loadability \var{situation} \var{input} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{situation} must be one of the symbols \scheme{visit}, \scheme{revisit}, or \scheme{load}. +Each \var{input} must be a string pathname or a pair of a string pathname and a library search path. +Each of the pathnames should name a file containing object code for a set of libraries and +top-level programs, such as would be produced by +\index{\scheme{compile-program}}\scheme{compile-program}, +\index{\scheme{compile-library}}\scheme{compile-library}, +\index{\scheme{compile-whole-program}}\scheme{compile-whole-program}, +or +\index{\scheme{compile-whole-library}}\scheme{compile-whole-library}. +A library search path must be a suitable argument for +\index{\scheme{library-directories}}\scheme{library-directories}. + +\scheme{verify-loadability} verifies, without actually loading any +code or defining any libraries, whether the object files named +by the specified pathnames and their library dependencies, direct +or indirect, are present, readable, and mutually compatible. +The type of dependencies for each named object file is determined +by the \var{situation} argument: compile-time dependencies for +\var{visit}, run-time dependencies for \var{revisit} and both for +\var{load}. + +For each input pathname that is paired with a search path, +the \scheme{library-directories} parameter is parameterized to the +library search path during the recursive search for dependencies +of the programs and libraries found in the object file named by the +pathname. + +If \scheme{verify-loadability} finds a problem, such as a missing +library dependency or compilation-instance mismatch, it raises an +exception with an appropriate condition. +Otherwise, it returns an unspecified value. + +Since \scheme{verify-loadability} does not load or run any code +from the files it processes, it cannot determine whether errors +unrelated to missing or unreadable files or mutual compatibility +will occur when the files are actually loaded. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{load-compiled-from-port}{\categoryprocedure}{(load-compiled-from-port \var{input-port})} +\returns result of the last compiled expression +\listlibraries +\endentryheader + +\noindent +\scheme{load-compiled-from-port} reads and evaluates the object-code contents +of \var{input-port} as previously created by functions like \scheme{compile-file}, +\scheme{compile-script}, \scheme{compile-library}, and +\scheme{compile-to-port}. + +The return value is the value of the last expression whose compiled +form is in \var{input-port}. If \var{input-port} is empty, then the +result value is unspecified. +The port is left at end-of-file but is not closed. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{visit-compiled-from-port}{\categoryprocedure}{(visit-compiled-from-port \var{input-port})} +\returns result of the last compiled expression processed +\listlibraries +\endentryheader + +\noindent +\scheme{visit-compiled-from-port} reads and evaluates the object-code contents +of \var{input-port} as previously created by functions like \scheme{compile-file}, +\scheme{compile-script}, \scheme{compile-library}, and +\scheme{compile-to-port}. In the process, it skips any revisit (run-time-only) code. + +The return value is the value of the last expression whose last non-revisit compiled +form is in \var{input-port}. If there are no such forms, then the +result value is unspecified. +The port is left at end-of-file but is not closed. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{revisit-compiled-from-port}{\categoryprocedure}{(revisit-compiled-from-port \var{input-port})} +\returns result of the last compiled expression processed +\listlibraries +\endentryheader + +\noindent +\scheme{revisit-compiled-from-port} reads and evaluates the object-code contents +of \var{input-port} as previously created by functions like \scheme{compile-file}, +\scheme{compile-script}, \scheme{compile-library}, and +\scheme{compile-to-port}. In the process, it skips any visit (compile-time-only) code. + +The return value is the value of the last expression whose last non-visit compiled +form is in \var{input-port}. If there are no such forms, then the +result value is unspecified. +The port is left at end-of-file but is not closed. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{visit}{\categoryprocedure}{(visit \var{path})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{visit} reads the named file, which must contain compiled object +code compatible with the current machine type and version, and it +runs those portions of the compiled object code that +establish compile-time information or correspond to expressions +identified as ``visit'' time by \scheme{eval-when} forms contained in +the original source file. + +For example, assume the file \scheme{t1.ss} contains the following +forms: + +\schemedisplay +(define-syntax a (identifier-syntax 3)) +(module m (x) (define x 4)) +(define y 5) +\endschemedisplay + +If \scheme{t1.ss} is compiled to \scheme{t1.so}, applying \scheme{load} +to \scheme{t1.so} has the effect of defining all three identifiers. +Applying \scheme{visit} to \scheme{t1.so}, however, has the effect of +installing the transformer for \scheme{a}, installing the interface for +\scheme{m} (for use by \scheme{import}), and recording \scheme{y} as +a variable. +\scheme{visit} is useful when separately compiling one file that depends +on bindings defined in another without actually loading and evaluating +the code in the supporting file. + +\index{\scheme{source-directories}}% +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories searched for source files not identified +by absolute path names. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{revisit}{\categoryprocedure}{(revisit \var{path})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{revisit} reads the named file, which must contain compiled object +code compatible with the current machine type and version, and it +runs those portions of the compiled object code that compute +run-time values or correspond to expressions identified as ``revisit'' time by +\scheme{eval-when} forms contained in the original source file. + +Continuing the example given for \scheme{visit} above, +applying \scheme{revisit} to the object file, \scheme{t1.so}, has +the effect of establishing the values of the variable \scheme{x} +exported from \scheme{m} and the top-level variable \scheme{y}, +without installing either the interface for \scheme{m} or +the transformer for \scheme{a}. + +\scheme{revisit} is useful for loading compiled application code without +loading unnecessary compile-time information. +Care must be taken when using this feature if the application calls +\scheme{eval} or uses \scheme{top-level-value}, +\scheme{set-top-level-value!}, or \scheme{top-level-syntax} to access +top-level bindings at run-time, since these procedures use compile-time +information to resolve top-level bindings. + +\index{\scheme{source-directories}}% +The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE}) +determines the set of directories searched for source files not identified +by absolute path names. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-file}{\categoryprocedure}{(compile-file \var{input-filename})} +\formdef{compile-file}{\categoryprocedure}{(compile-file \var{input-filename} \var{output-filename})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{input-filename} and \var{output-filename} must be strings. +\var{input-filename} must name an existing, readable file. +It must contain a sequence of zero or more source expressions; +if this is not the case, \scheme{compile-file} raises an exception +with condition type \scheme{&syntax}. + +The normal evaluation process proceeds in two steps: \index{compilation}compilation and +execution. +\scheme{compile-file} performs the compilation process for an entire source +file, producing an object file. +When the object file is subsequently loaded (see \index{\scheme{load}}\scheme{load}), the +compilation process is not necessary, and the file typically loads +several times faster. + +If the optional \var{output-filename} argument is omitted, the +actual input and output filenames are determined as follows. +If \var{input-filename} has no extension, the input filename +is \var{input-filename} followed by \scheme{.ss} and the +output filename is \var{input-filename} followed by \scheme{.so}. +If \var{input-filename} has the extension \scheme{.so}, the +input filename is \var{input-filename} and the output filename +is \var{input-filename} followed by \scheme{.so}. +Otherwise, the input filename is \var{input-filename} and the +output filename is \var{input-filename} without its extension, +followed by \scheme{.so}. +For example, \scheme{(compile-file "myfile")} produces an object file +with the name \scheme{"myfile.so"} from the source file named +\scheme{"myfile.ss"}, \scheme{(compile-file "myfile.sls")} produces an +object file with the name \scheme{"myfile.so"} from the source file named +\scheme{"myfile.sls"}, and +\scheme{(compile-file "myfile1" "myfile2")} produces an object file with +the name \scheme{"myfile2"} from the source file name \scheme{"myfile1"}. + +Before compiling a file, \scheme{compile-file} saves the values of the +following parameters: + +\schemedisplay +optimize-level +debug-level +run-cp0 +cp0-effort-limit +cp0-score-limit +cp0-outer-unroll-limit +generate-inspector-information +generate-procedure-source-information +compile-profile +generate-covin-files +generate-interrupt-trap +enable-cross-library-optimization +\endschemedisplay + +It restores the values after the file has been compiled. +This allows the programmer to control the values of these parameters on +a per-file basis, e.g., via an \scheme{eval-when} with situation +\scheme{compile} embedded in the source file. +For example, if + +\schemedisplay +(eval-when (compile) (optimize-level 3)) +\endschemedisplay + +appears at the top of a source file, the optimization level is set +to 3 just while the remainder of file is compiled. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-script}{\categoryprocedure}{(compile-script \var{input-filename})} +\formdef{compile-script}{\categoryprocedure}{(compile-script \var{input-filename} \var{output-filename})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{input-filename} and \var{output-filename} must be strings. + +\scheme{compile-script} is like \scheme{compile-file} but differs in +that it copies the leading \scheme{#!} line from the +source-file script into the object file. + +\scheme{compile-script} permits compiled script files to be created from +source script to reduce script load time. +As with source-code scripts, compiled scripts may be run with the +\index{\scheme{--script} command-line option}\scheme{--script} +command-line option. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-library}{\categoryprocedure}{(compile-library \var{input-filename})} +\formdef{compile-library}{\categoryprocedure}{(compile-library \var{input-filename} \var{output-filename})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{input-filename} and \var{output-filename} must be strings. + +\scheme{compile-library} is identical to \scheme{compile-file} except +that it treats the input file as if it were prefixed by an implicit +\scheme{#!r6rs}. +This effectively disables any non-R6RS lexical +syntax except where subsequently overridden by \scheme{#!chezscheme}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-program}{\categoryprocedure}{(compile-program \var{input-filename})} +\formdef{compile-program}{\categoryprocedure}{(compile-program \var{input-filename} \var{output-filename})} +\returns a list of libraries invoked by the program +\listlibraries +\endentryheader + +\noindent +\var{input-filename} and \var{output-filename} must be strings. + +\scheme{compile-program} is like \scheme{compile-script} but differs in +that it implements the semantics of RNRS top-level programs, while +\scheme{compile-script} implements the semantics of the interactive +top-level. +The resulting compiled program will also run faster than if compiled +via \scheme{compile-file} or \scheme{compile-script}. + +\scheme{compile-program} returns a list of libraries directly +invoked by the compiled top-level program, excluding built-in +libraries like \scheme{(rnrs)} and \scheme{(chezscheme)}. +The procedure \scheme{library-requirements} may be used to determine +the indirect requirements, i.e., additional libraries required by +the directly invoked libraries. +When combined with \scheme{library-object-filename}, this information can +be used to determine the set of files that must be distributed with the +compiled program file. + +A program invokes a library only if it references one or more variables +exported from the library. +The set of libraries invoked by a top-level program, and hence +loaded when the program is loaded, might be smaller than the set +imported by the program, and it might be larger than the set +directly imported by the program. + +As with source-code top-level programs, compiled top-level programs may be +run with the +\index{\scheme{--program} command-line option}\scheme{--program} +command-line option. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{maybe-compile-file}{\categoryprocedure}{(maybe-compile-file \var{input-filename})} +\formdef{maybe-compile-file}{\categoryprocedure}{(maybe-compile-file \var{input-filename} \var{output-filename})} +\formdef{maybe-compile-library}{\categoryprocedure}{(maybe-compile-library \var{input-filename})} +\formdef{maybe-compile-library}{\categoryprocedure}{(maybe-compile-library \var{input-filename} \var{output-filename})} +\formdef{maybe-compile-program}{\categoryprocedure}{(maybe-compile-program \var{input-filename})} +\formdef{maybe-compile-program}{\categoryprocedure}{(maybe-compile-program \var{input-filename} \var{output-filename})} +\returns see below +\listlibraries +\endentryheader + +These procedures are like their non-\scheme{maybe} counterparts but +compile the source file only if the object file is out-of-date. +An object file \var{X} is considered out-of-date if it does not exist or +if it is older than the source file or any files included (via \scheme{include}) +when \var{X} was created. +When the value of the parameter \scheme{compile-imported-libraries} +is \scheme{#t}, \var{X} is also considered out-of-date if the object +file for any library imported when \var{X} was compiled is out-of-date. +If \scheme{maybe-compile-file} determines that compilation is necessary, +it compiles the source file by passing \scheme{compile-file} the +input and output filenames. +\scheme{compile-library} does so by similarly invoking the value of the +\scheme{compile-library-handler} parameter, and +\scheme{compile-program} does so by similarly invoking the value of the +\scheme{compile-program-handler} parameter. + +When \var{output-filename} is not specified, the input and output +filenames are determined in the same manner as for \scheme{compile-file}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-library-handler}{\categorythreadparameter}{compile-library-handler} +\listlibraries +\endentryheader + +This parameter must be set to a procedure, and the procedure should +accept two string arguments naming a source file and an object file. +The procedure should typically invoke \scheme{compile-library} and +pass it the two arguments, but it can also use one of the other +file or port compilation procedures. +For example, it might read the source file using its own parser and +use \index{\scheme{compile-to-file}}\scheme{compile-to-file} to finish +the compilation process. +The procedure can perform other actions as well, such as parameterizing +compilation parameters, establishing guards, or gathering statistics. +The default value of this parameter simply invokes +\scheme{compile-library} on the two string arguments without taking +any other action. + +The value of this parameter is called by \scheme{maybe-compile-library} +when the object file is out-of-date. +It is also called by the expander to compile an +imported library when \scheme{compile-imported-libraries} is \scheme{#t} +and the expander determines the object file is out-of-date. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-program-handler}{\categorythreadparameter}{compile-program-handler} +\listlibraries +\endentryheader + +This parameter must be set to a procedure, and the procedure should +accept two string arguments naming a source file and an object file. +The procedure should typically invoke \scheme{compile-program} and +pass it the two arguments, but it can also use one of the other +file or port compilation procedures. +For example, it might read the source file using its own parser and +use \index{\scheme{compile-to-file}}\scheme{compile-to-file} to finish +the compilation process. +The procedure can perform other actions as well, such as parameterizing +compilation parameters, establishing guards, or gathering statistics. +The default value of this parameter simply invokes +\scheme{compile-program} on the two string arguments without taking +any other action and returns the list of libraries returned by +\scheme{compile-program}. + +The value of this parameter is called by \scheme{maybe-compile-program} +when the object file is out-of-date. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-whole-program}{\categoryprocedure}{(compile-whole-program \var{input-filename} \var{output-filename})} +\formdef{compile-whole-program}{\categoryprocedure}{(compile-whole-program \var{input-filename} \var{output-filename} \var{libs-visible?})} +\returns a list of libraries left to be loaded at run time +\listlibraries +\endentryheader + +\scheme{compile-whole-program} accepts as input a filename naming +a ``whole program optimization'' (wpo) file for a top-level program +and produces an object file incorporating the program and each +library upon which it depends, provided that a wpo file for the +library can be found. + +If a wpo file for a required library cannot be found, but an object +file for the library can, the library is not incorporated in the +resulting object file. +Such libraries are left to be loaded at run time. +\scheme{compile-whole-program} returns a list of such libraries. +If there are no such libraries, the resulting object file is +self-contained and \scheme{compile-whole-program} returns the empty +list. + +The libraries incorporated into the resulting object file are visible (for +use by \scheme{environment} and \scheme{eval}) if the \var{libs-visible?} +argument is supplied and non-false. +Any library incorporated into the resulting object file and required by +an object file left to be loaded at run time is also visible, as are any +libraries the object file depends upon, regardless of the value of +\var{libs-visible?}. + +\scheme{compile-whole-program} linearizes the initialization code for the +set of incorporated libraries in a way that respects static +dependencies among the libraries but not necessary dynamic dependencies +deriving from initialization-time uses of \scheme{environment} +or \scheme{eval}. +Additional static dependencies can be added in most cases to force +an ordering that allows the dynamic imports to succeed, +though not in general since a different order might be required each +time the program is run. +Adding a static dependency of one library on a second requires +adding an import of the second in the first as well as a run-time +reference to one of the variables exported by the second in the +body of the first. + +\var{input-filename} and \var{output-filename} must be strings. +\var{input-filename} must identify a wpo file, and a wpo or object +file must also be present for each required library somewhere in +the directories specified by the \scheme{library-directories} +parameter. + +To the extent possible given the specified set of visible libraries +and requirements of libraries to be loaded at run time, +\scheme{compile-whole-program} discards unused code and optimizes +across program and library boundaries, potentially reducing program +load time, run time, and memory requirements. +Some optimization also occurs even across the boundaries of libraries +that are not incorporated into the output, though this optimization +is limited in nature. + +\index{\scheme{generate-wpo-files}}% +The procedures \scheme{compile-file}, \scheme{compile-program}, \scheme{compile-library}, +\scheme{compile-script}, and \scheme{compile-whole-library} produce wpo files as well as ordinary +object files when the \scheme{generate-wpo-files} parameter is set +to \scheme{#t} (the default is \scheme{#f}). +\scheme{compile-port} and \scheme{compile-to-port} do so when passed +an optional wpo port. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-whole-library}{\categoryprocedure}{(compile-whole-library \var{input-filename} \var{output-filename})} +\returns a list of libraries left to be loaded at run time +\listlibraries +\endentryheader + +\scheme{compile-whole-library} is like \scheme{compile-whole-program}, +except \var{input-filename} must specify a wpo file for a library, +all libraries are automatically made visible, and a new wpo file is +produced (when \scheme{generate-wpo-files} is \scheme{#t}) as well +as an object file for the resulting combination of libraries. + +The comment in the description of \scheme{compile-whole-program} +about the effect of initialization-code linearization on dynamic +dependencies applies to \scheme{compile-whole-library} as well. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port})} +\formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port} \var{sfd})} +\formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port} \var{sfd} \var{wpo-port})} +\formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port} \var{sfd} \var{wpo-port} \var{covop})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{input-port} must be a textual input port. +\var{output-port} and, if present and non-false, \var{wpo-port} must be binary output ports. +If present and non-false, \var{sfd} must be a source-file descriptor. +If present and non-false, \var{covop} must be a textual output port. + +\scheme{compile-port} is like \scheme{compile-file} except that it takes +input from an arbitrary textual input port and sends output to an arbitrary +binary output port. +If \var{sfd} is supplied, it is passed to the reader so that source information +can be associated with the expressions read from \var{input-port}. +It is also used to associate block-profiling information with the input +file name encapsulated within \var{sfd}. +If \var{wpo-port} is supplied, \scheme{compile-port} sends whole-program optimization information +to \var{wpo-port} for use by \scheme{compile-whole-program}, as if +(and regardless of whether) \scheme{generate-wpo-files} is set. +If \var{covop} is supplied, \scheme{compile-port} sends coverage information to +\var{covop}, as if (and regardless of whether) \scheme{generate-covin-files} is set. + +The ports are closed automatically after compilation under the assumption +the program that opens the ports and invokes \scheme{compile-port} +will take care of closing the ports. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port})} +\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd})} +\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port})} +\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{obj-list} must be a list containing a sequence of +objects that represent syntactically valid expressions, each possibly +annotated (Section~\ref{SECTSYNTAXANNOTATIONS}). +If any of the objects does not represent a syntactically valid +expression, \scheme{compile-to-port} raises an exception with +condition type \scheme{&syntax}. +\var{output-port} and, if present, \var{wpo-port} must be binary output ports. +If present, \var{sfd} must be a source-file descriptor. + +\scheme{compile-to-port} is like \scheme{compile-file} except that it takes +input from a list of objects and sends output to an arbitrary binary +output port. +\var{sfd} is used to associate block-profiling information with the +input file name encapsulated within \var{sfd}. +If \var{wpo-port} is present, \var{compile-to-port} sends whole-program optimization information +to \var{wpo-port} for use by \scheme{compile-whole-program}, as if +(and regardless of whether) \scheme{generate-wpo-files} is set. +If \var{covop} is present, \var{compile-to-port} sends coverage information to +\var{covop}, as if (and regardless of whether) \scheme{generate-covin-files} is set. + +The ports are not closed automatically after compilation under the assumption +the program that opens the port and invokes \scheme{compile-to-port} +will take care of closing the port. + +When \var{obj-list} contains a single list-structured element whose +first-element is the symbol \scheme{top-level-program}, +\scheme{compile-to-port} returns a list of the libraries the top-level +program requires at run time, as with \scheme{compile-program}. +Otherwise, the return value is unspecified. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-to-file}{\categoryprocedure}{(compile-to-file \var{obj-list} \var{output-file})} +\formdef{compile-to-file}{\categoryprocedure}{(compile-to-file \var{obj-list} \var{output-file} \var{sfd})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{obj-list} must be a list containing a sequence of +objects that represent syntactically valid expressions, each possibly +annotated (Section~\ref{SECTSYNTAXANNOTATIONS}). +If any of the objects does not represent a syntactically valid +expression, \scheme{compile-to-file} raises an exception with +condition type \scheme{&syntax}. +\var{output-file} must be a string. +If present, \var{sfd} must be a source-file descriptor. + +\scheme{compile-to-file} is like \scheme{compile-file} except that it takes +input from a list of objects. +\var{sfd} is used to associate block-profiling information with the +input file name encapsulated within \var{sfd}. + +When \var{obj-list} contains a single list-structured element whose +first-element is the symbol \scheme{top-level-program}, +\scheme{compile-to-file} returns a list of the libraries the top-level +program requires at run time, as with \scheme{compile-program}. +Otherwise, the return value is unspecified. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{concatenate-object-files}{\categoryprocedure}{(concatenate-object-files \var{out-file} \var{in-file_1} \var{in-file_2} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\var{out-file} and each \var{in-file} must be strings. + +\scheme{concatenate-object-files} combines the header information +contained in the object files named by each \var{in-file}. It then +writes the combined header information to the file named by +\var{out-file}, followed by the remaining object code from each +input file in turn. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-boot-file}{\categoryprocedure}{(make-boot-file \var{output-filename} \var{base-boot-list} \var{input-filename} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +\var{output-filename}, \var{input-filename}, and the elements of +\var{base-boot-list} must be strings. + +\scheme{make-boot-file} writes a boot header to the file named by +\var{output-filename}, followed by the object code for each +\var{input-filename} in turn. +If an input file is not already compiled, \scheme{make-boot-file} compiles +the file as it proceeds. + +The boot header identifies the elements of \var{base-boot-list} as +alternative boot files upon which the new boot file depends. +If the list of strings naming base boot files is empty, the first named +input file should be a base boot file, i.e., petite.boot or some boot file +derived from petite.boot. + +\index{\scheme{--boot} command-line option}% +\index{\scheme{-b} command-line option}% +Boot files are loaded explicitly via the \scheme{--boot} or \scheme{-b} +command-line options or implicitly based on the name of the executable +(Section~\ref{SECTUSECOMMANDLINE}). + +See Section~\ref{SECTUSEAPPLICATIONS} for more information on boot files +and the use of \scheme{make-boot-file}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-boot-header}{\categoryprocedure}{(make-boot-header \var{output-filename} \var{base-boot_1} \var{base-boot_2}\dots)} +\returns unspecified +\listlibraries +\endentryheader + +This procedure has been subsumed by \scheme{make-boot-file} and is provided for +backward compatibility. +The call + +\schemedisplay +(make-boot-header \var{output-filename} \var{base-boot_1} \var{base-boot_2} \dots) +\endschemedisplay + +is equivalent to + +\schemedisplay +(make-boot-file \var{output-filename} '(\var{base-boot_1} \var{base-boot_2} \dots)) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{strip-fasl-file}{\categoryprocedure}{(strip-fasl-file \var{input-path} \var{output-path} \var{options})} +\returns unspecified +\listlibraries +\endentryheader + +\var{input-path} and \var{output-path} must be strings. +\var{input-path} must name an existing, readable file containing +object code produced by \scheme{compile-file}, one of the other +file-compiling procedures, or an earlier run of \scheme{strip-fasl-file}. +\var{options} must be an enumeration set over the symbols constituting +valid strip options, as described in the \scheme{fasl-strip-options} +entry below. + +The new procedure \scheme{strip-fasl-file} allows the removal of +source information of various sorts from a compiled object (fasl) +file produced by \scheme{compile-file} or one of the other file +compiling procedures. +It also allows removal of library visit code from object files +containing compiled libraries. +Visit code is the code for macro transformers and meta definitions +required to compile (but not run) dependent libraries. + +On most platforms, the input and output paths can be the same, +in which case the input file is replaced with a new file containing +the stripped object code. +Using the same path will likely fail on Windows file systems, +which do not generally permit an open file to be removed. + +If \var{options} is empty, the output file is effectively equivalent +to the input file, though it will not necessarily be identical. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{fasl-strip-options}{\categorysyntax}{(fasl-strip-options \var{symbol} \dots)} +\returns a fasl-strip-options enumeration set +\listlibraries +\endentryheader + +\noindent +Fasl-strip-options enumeration sets are passed to \scheme{strip-fasl-file} +to determine what is stripped. +The available options are described below. + +\begin{description} +\item[\scheme{inspector-source}:] +Strip inspector source information. +This includes source expressions that might otherwise be available +for procedures and continuations with the ``code'' and ``call'' +commands and messages in the interactive and object inspectors. +It also includes filename and position information that might +otherwise be available for the same via the ``file'' command and +``source'' messages. + +\item[\scheme{source-annotations}:] +Strip source annotations, which typically appear only on syntax objects, +e.g., identifiers, in the templates of macro transformers. + +\item[\scheme{profile-source}:] +Strip source file and character position information from profiled +code objects. +This does not remove the profile counters or eliminate the overhead +for incrementing them at run time. + +\item[\scheme{compile-time-information}: ] +This strips compile-time information from compiled libraries, potentially +reducing the size of the resulting file but making it impossible to +use the file to compile dependent code. +This option is useful for creating smaller object files to ship +as part of a binary-only package. +\end{description} + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{machine-type}{\categoryprocedure}{(machine-type)} +\returns the current machine type +\listlibraries +\endentryheader + +\noindent +Consult the release notes for the current version of {\ChezScheme} +for a list of supported machine types. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:expand} +\formdef{expand}{\categoryprocedure}{(expand \var{obj})} +\formdef{expand}{\categoryprocedure}{(expand \var{obj} \var{env})} +\returns expansion of the Scheme form represented by \var{obj} +\listlibraries +\endentryheader + +\noindent +\scheme{expand} treats \var{obj} as the representation of an expression. +It expands the expression in environment \var{env} and returns +an object representing the expanded form. +If no environment is provided, it defaults to the environment +returned by \scheme{interaction-environment}. + +\var{obj} can be an annotation +(Section~\ref{SECTSYNTAXANNOTATIONS}), and the default expander +makes use of annotations to incorporate source-file +information in error messages. + +\scheme{expand} actually passes its arguments to the current expander +(see \scheme{current-expand}), initially \scheme{sc-expand}. + +\index{\scheme{expand-output}}% +See also \scheme{expand-output} (page~\pageref{desc:expand-output}) +which can be used to request that the compiler or interpreter show +expander output. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-expand}{\categorythreadparameter}{current-expand} +\listlibraries +\endentryheader + +\noindent +\scheme{current-expand} determines the expansion procedure used by +the compiler, interpreter, and direct calls to +\index{\scheme{expand}}\scheme{expand} +to expand syntactic extensions. +\scheme{current-expand} is initially bound to the value of +\index{\scheme{sc-expand}}\scheme{sc-expand}. + +It may be set another procedure, but since the format of +expanded code expected by the compiler and interpreter is not publicly +documented, only \scheme{sc-expand} produces correct output, so the +other procedure must ultimately be defined in terms of +\scheme{sc-expand}. + +The first argument to the expansion procedure represents the input +expression. +It can be an annotation (Section~\ref{SECTSYNTAXANNOTATIONS}) or an +unannotated value. +the second argument is an environment. +Additional arguments might be passed to the expansion procedure +by the compiler, interpreter, and \scheme{expand}; their number +and roles are unspecified. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sc-expand}{\categoryprocedure}{(sc-expand \var{obj})} +\formdef{sc-expand}{\categoryprocedure}{(sc-expand \var{obj} \var{env})} +\returns the expanded form of \var{obj} +\listlibraries +\endentryheader + + +\noindent +The procedure +\scheme{sc-expand} is used to expand programs written using +\scheme{syntax-case} macros. +\scheme{sc-expand} is the default expander, i.e., the initial +value of \scheme{current-expand}. +\var{obj} represents the program to be expanded, and +\var{env} must be an environment. +\var{obj} can be an annotation (Section~\ref{SECTSYNTAXANNOTATIONS}) +or unannotated value. +If not provided, \var{env} defaults to the environment returned by +\scheme{interaction-environment}. + +%---------------------------------------------------------------------------- +\entryheader\label{desc:expand/optimize} +\formdef{expand/optimize}{\categoryprocedure}{(expand/optimize \var{obj})} +\formdef{expand/optimize}{\categoryprocedure}{(expand/optimize \var{obj} \var{env})} +\returns result of expanding and optimizing form represented by \var{obj} +\listlibraries +\endentryheader + +\scheme{expand/optimize} treats \var{obj} as the representation of +an expression. +\var{obj} can be an annotation (Section~\ref{SECTSYNTAXANNOTATIONS}) +or unannotated value. +\scheme{expand/optimize} expands the expression in environment \var{env} +and passes the expression through the source optimizer \scheme{cp0} +(unless \scheme{cp0} is disabled via \scheme{run-cp0}). +It also simplifies \scheme{letrec} and \scheme{letrec*} expressions within +the expression and makes their undefined checks explicit. +It returns an object representing the expanded, simplified, and optimized form. +If no environment is provided, it defaults to the environment +returned by \scheme{interaction-environment}. + +\scheme{expand/optimize} is primarily useful for understanding what +\scheme{cp0} does and does not optimize. +Many optimizations are performed later in the compiler, +so \scheme{expand/optimize} does not give a complete picture of +optimizations performed. + +\schemedisplay +(expand/optimize + '(let ([y '(3 . 4)]) + (+ (car y) (cdr y)))) ;=> 7 + +(print-gensym #f) +(expand/optimize + '(let ([y '(3 . 4)]) + (lambda (x) + (* (+ (car y) (cdr y)) x)))) ;=> (lambda (x) (#2%* 7 x)) + +(expand/optimize + '(let ([n (expt 2 10)]) + (define even? + (lambda (x) (or (zero? x) (not (odd? x))))) + (define odd? + (lambda (x) (not (even? (- x 1))))) + (define f + (lambda (x) + (lambda (y) + (lambda (z) + (if (= z 0) (omega) (+ x y z)))))) + (define omega + (lambda () + ((lambda (x) (x x)) (lambda (x) (x x))))) + (let ([g (f 1)] [m (f n)]) + (let ([h (if (> ((g 2) 3) 5) + (lambda (x) (+ x 1)) + odd?)]) + (h n))))) ;=> 1025 +\endschemedisplay + +\index{\scheme{expand/optimize-output}}% +See also \scheme{expand/optimize-output} (page~\pageref{desc:expand/optimize-output}) +which can be used to request that the compiler or interpreter show +source-optimizer output. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eval-when}{\categorysyntax}{(eval-when \var{situations} \var{form_1} \var{form_2} \dots)} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{situations} must be a list containing some combination of the symbols +\scheme{eval}, \scheme{compile}, \scheme{load}, \scheme{visit}, and +\scheme{revisit}. + +When source files are loaded (see \scheme{load}), the forms in the file +are read, compiled, and executed sequentially, so that each form in +the file is fully evaluated before the next one is read. +When a source file is compiled (see \scheme{compile-file}), however, the +forms are read and compiled, \emph{but not executed}, in sequence. +This distinction matters only when the execution of one +form in the file affects the compilation of later forms, e.g., +when the form results in the definition of a module or syntactic form or +sets a compilation parameter such as \scheme{optimize-level} or +\scheme{case-sensitive}. + +For example, assume that a file contains the following two forms: + +\schemedisplay +(define-syntax reverse-define + (syntax-rules () + [(_ e x) (define x e)])) + +(reverse-define 3 three) +\endschemedisplay + +Loading this from source has the effect of defining +\scheme{reverse-define} as a syntactic form and binding the identifier +\scheme{three} to 3. +The situation may be different if the file is compiled with +\scheme{compile-file}, however. +Unless the system or programmer takes steps to assure that the first +form is fully executed before the second expression is compiled, +the syntax expander will not recognize \scheme{reverse-define} as a syntactic +form and will generate code for a procedure call to \scheme{reverse-define} +instead of generating code to define \scheme{three} to be 3. +When the object file is subsequently loaded, the attempt to reference +either \scheme{reverse-define} or \scheme{three} will fail. + +As it happens, when a \scheme{define-syntax}, \scheme{module}, +\scheme{import}, or \scheme{import-only} form appears at top level, as in the +example above, the compiler does indeed arrange to evaluate it before +going on to compile the remainder of the file. +If the compiler encounters a variable definition for an identifier that +was previously something else, it records that fact as well. +The compiler also generates the +appropriate code so that the bindings will be present as well when +the object file is subsequently loaded. +This solves most, but not all, problems of this nature, since most are +related to the use of \scheme{define-syntax} and modules. +Some problems are not so straightforwardly handled, however. +For example, assume that the file contains the following definitions +for \index{\scheme{nodups?}}\scheme{nodups?} and \index{\scheme{mvlet}}\scheme{mvlet}. + +\schemedisplay +(define nodups? + (lambda (ids) + (define bound-id-member? + (lambda (id ids) + (and (not (null? ids)) + (or (bound-identifier=? id (car ids)) + (bound-id-member? id (cdr ids)))))) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (nodups? (cdr ids)))))) + +(define-syntax mvlet + (lambda (x) + (syntax-case x () + [(_ ((x ...) expr) b1 b2 ...) + (and (andmap identifier? #'(x ...)) + (nodups? #'(x ...))) + #'(call-with-values + (lambda () expr) + (lambda (x ...) b1 b2 ...))]))) + +(mvlet ((a b c) (values 1 2 3)) + (list (* a a) (* b b) (* c c))) +\endschemedisplay + +\noindent +When loaded directly, this results in the definition of +\scheme{nodups?} as a procedure and \scheme{mvlet} as a syntactic +abstraction before evaluation of the \scheme{mvlet} expression. +Because \scheme{nodups?} is defined before the \scheme{mvlet} +expression is expanded, the call to \scheme{nodups?} during the +expansion of \scheme{mvlet} causes no difficulty. +If instead this file were compiled, using \scheme{compile-file}, the +compiler would arrange to define \scheme{mvlet} before continuing +with the expansion and evaluation of the \scheme{mvlet} expression, +but it would not arrange to define \scheme{nodups?}. +Thus the expansion of the \scheme{mvlet} expression would fail. + +In this case it does not help to evaluate the syntactic extension alone. +A solution in this case would be to move the definition of +\scheme{nodups?} inside the definition for \scheme{mvlet}, just as +the definition for \scheme{bound-id-member?} is placed within +\scheme{nodups?}, but this does not work for help routines shared +among several syntactic definitions. +Another solution is to label the \scheme{nodups?} definition a +``meta'' definition (see Section~\ref{SECTSYNTAXMETA}) but this +does not work for helpers that are used both by syntactic +abstractions and by run-time code. + +A somewhat simpler problem occurs when setting parameters that affect +compilation, such as \scheme{optimize-level} and +\scheme{case-sensitive?}. +If not set prior to compilation, their settings usually will not have +the desired effect. + +\scheme{eval-when} offers a solution to these problems by allowing the +programmer to explicitly control what forms should or should not +be evaluated during compilation. +\scheme{eval-when} is a syntactic form and is handled directly by the +expander. +The action of \scheme{eval-when} depends upon the \var{situations} argument +and whether or not the forms \scheme{\var{form_1} \var{form_2} \dots} +are being compiled via \scheme{compile-file} or are being evaluated +directly. +Let's consider each of the possible situation specifiers +\scheme{eval}, \scheme{compile}, \scheme{load}, \scheme{visit}, and +\scheme{revisit} in turn. + +\begin{description} +\item[\scheme{eval}:] +The \scheme{eval} specifier is relevant only when the \scheme{eval-when} +form is being +evaluated directly, i.e., if it is typed at the keyboard or loaded from a +source file. +Its presence causes \scheme{\var{form_1} \var{form_2} \dots} to be +expanded and this expansion to be included in the expansion of the +\scheme{eval-when} form. +Thus, the forms will be evaluated directly as if not contained within an +\scheme{eval-when} form. + +\item[\scheme{compile}:] +The \scheme{compile} specifier is relevant only when the \scheme{eval-when} +form appears in a file currently being compiled. +(Its presence is simply ignored otherwise.) +Its presence forces \scheme{\var{form_1} \var{form_2} \dots} to be +expanded and evaluated immediately. + +\item[\scheme{load}:] +The \scheme{load} specifier is also relevant only when the \scheme{eval-when} +form appears +in a file currently being compiled. +Its presence causes \scheme{\var{form_1} \var{form_2} \dots} to be +expanded and this expansion to be included in the expansion of the +\scheme{eval-when} form. +Any code necessary to record binding information and evaluate syntax +transformers for definitions contained in the forms is marked for +execution when the file is ``visited,'' and any code necessary to +compute the values of variable definitions and the expressions contained +within the forms is marked for execution when the file is ``revisited.'' + +\item[\scheme{visit}:] +The \scheme{visit} specifier is also relevant only when the \scheme{eval-when} +form appears +in a file currently being compiled. +Its presence causes \scheme{\var{form_1} \var{form_2} \dots} to be +expanded and this expansion to be included in the expansion of the +\scheme{eval-when} form, with an annotation that the forms are to be +executed when the file is ``visited.'' + +\item[\scheme{revisit}:] +The \scheme{revisit} specifier is also relevant only when the \scheme{eval-when} +form appears +in a file currently being compiled. +Its presence causes \scheme{\var{form_1} \var{form_2} \dots} to be +expanded and this expansion to be included in the expansion of the +\scheme{eval-when} form, with an annotation that the forms are to be +executed when the file is ``revisited.'' +\end{description} + +\noindent +A file is considered ``visited'' when it is brought in by either +\scheme{load} or \scheme{visit} and ``revisited'' when it is brought in +by either \scheme{load} or \scheme{revisit}. + +Top-level expressions are treated as if they are wrapped in an +\scheme{eval-when} with situations \scheme{load} and \scheme{eval}. +This means that, by default, forms typed at the keyboard or +loaded from a source file are evaluated, and forms appearing in a +file to be compiled are not evaluated directly but are compiled for +execution when the resulting object file is subsequently loaded. + +The treatment of top-level definitions is slightly more involved. +All definitions result in changes to the compile-time environment. +For example, an identifier defined by \scheme{define} is recorded +as a variable, and an identifier defined by \scheme{define-syntax} +is recorded as a keyword and associated with the value of its +right-hand-side (transformer) expression. +These changes are made at eval, compile, and load +time as if the definitions were wrapped in an \scheme{eval-when} with +situations \scheme{eval}, \scheme{load}, and \scheme{compile}. +(This behavior can be altered by changing the value of the +parameter \scheme{eval-syntax-expanders-when}.) +Some definitions also result in changes to the run-time environment. +For example, a variable is associated with the value of its +right-hand-side expression. +These changes are made just at evaluation and load time as if the +definitions were wrapped in an \scheme{eval-when} with situations +\scheme{eval} and \scheme{load}. + +The treatment of local expressions or definitions (those not at top level) +that are wrapped in an \scheme{eval-when} depends only upon whether the +situation \scheme{eval} is present in the list of situations. +If the situation \scheme{eval} is present, the definitions and expressions +are evaluated as if they were not wrapped in an \scheme{eval-when} form, +i.e., the \scheme{eval-when} form is treated as a \scheme{begin} form. +If the situation \scheme{eval} is not present, the forms are ignored; +in a definition context, the \scheme{eval-when} form is treated as an +empty \scheme{begin}, and in an expression context, the \scheme{eval-when} +form is treated as a constant with an unspecified value. + +Since top-level syntax bindings are established, by default, at compile +time as well as eval and load time, top-level variable bindings needed +by syntax transformers should be wrapped in an \scheme{eval-when} form +with situations \scheme{compile}, \scheme{load}, and \scheme{eval}. +We can thus \scheme{nodups?} problem above by enclosing the definition +of \scheme{nodups?} in an \scheme{eval-when} as follows. + +\schemedisplay +(eval-when (compile load eval) + (define nodups? + (lambda (ids) + (define bound-id-member? + (lambda (id ids) + (and (not (null? ids)) + (or (bound-identifier=? id (car ids)) + (bound-id-member? id (cdr ids)))))) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (nodups? (cdr ids))))))) +\endschemedisplay + +\noindent +This forces it to be evaluated before it is needed during the expansion +of the \scheme{mvlet} expression. + +Just as it is useful to add \scheme{compile} to the default +\scheme{load} and \scheme{eval} situations, omitting options is also +useful. +Omitting one or more of \scheme{compile}, \scheme{load}, and +\scheme{eval} has the effect of preventing the evaluation at the given +time. +Omitting all of the options has the effect of inhibiting evaluation +altogether. + +One common combination of situations is \scheme{(compile eval)}, which by the +inclusion of \scheme{compile} causes the expression to be evaluated at +compile time, and by the omission of \scheme{load} inhibits the generation +of code by the compiler for execution when the file is subsequently loaded. +This is typically used for the definition of syntactic extensions used only +within the file in which they appear; in this case their presence in the +object file is not necessary. +It is also used to set compilation parameters that are intended to be in +effect whether the file is loaded from source or compiled via +\scheme{compile-file} + +\schemedisplay +(eval-when (compile eval) (case-sensitive #t)) +\endschemedisplay + +Another common situations list is \scheme{(compile)}, which might be +used to set compilation options to be used only when the file is +compiled via \scheme{compile-file}. + +\schemedisplay +(eval-when (compile) (optimize-level 3)) +\endschemedisplay + +Finally, one other common combination is \scheme{(load eval)}, which might +be useful for inhibiting the double evaluation (during the compilation of +a file and again when the resulting object file is loaded) of syntax +definitions when the syntactic extensions are not needed within +the file in which their definitions appear. + +The behavior of \scheme{eval-when} is usually intuitive but can be +understood precisely as follows. +The \scheme{syntax-case} expander, which handles \scheme{eval-when} +forms, maintains two state sets, one for compile-time forms and +one for run-time forms. +The set of possible states in each set are ``L'' for \scheme{load}, +``C'' for \scheme{compile}, ``V'' for \scheme{visit}, ``R'' for +\scheme{revisit}, and ``E'' for \scheme{eval}. + +When compiling a file, the compile-time set initially contains ``L'' +and ``C'' and the run-time set initially contains only ``L.'' +When not compiling a file (as when a form is evaluated by the +read-eval-print loop or loaded from a source file), both sets +initially contain only ``E.'' +The subforms of an \scheme{eval-when} form at top level are expanded with +new compile- and run-time sets determined by the current sets and +the situations listed in the \scheme{eval-when} form. +Each element of the current set contributes zero or more elements to the +new set depending upon the given situations according to the following +table. + +\begin{tabular}{cccccc} + & \scheme{load}~ & ~\scheme{compile}~ & ~\scheme{visit}~ & ~\scheme{revisit}~ & ~\scheme{eval}\\ +L & L & C & V & R & --- \\ +C & --- & --- & --- & --- & C \\ +V & V & C & V & --- & --- \\ +R & R & C & --- & R & --- \\ +E & --- & --- & --- & --- & E \\ +\end{tabular} + +For example, if the current compile-time state set is \{L\} +and the situations are \scheme{load} and \scheme{compile}, the new compile-time +state set is \{L,~C\}, since L/\scheme{load} +contributes ``L'' and L/\scheme{compile} contributes ``C.'' + +The state sets determine how forms are treated by the expander. +Compile-time forms such as syntax definitions are evaluated at a time +or times determined by the compile-time state set, and run-time forms +are evaluated at a time or times determined by the run-time state set. +A form is evaluated immediately if ``C'' is in the state set. +Code is generated to evaluate the form at visit or revisit +time if ``V'' or ``R'' is present. +If ``L'' is present in the compile-time set, it is treated as ``V;'' +likewise, if ``L'' is present in the run-time set, it is treated as +``R.'' +If more than one of states is present in the state set, the +form is evaluated at each specified time. + +``E'' can appear in the state set only when not compiling a file, i.e., +when the expander is invoked from an evaluator such as \scheme{compile} +or \scheme{interpret}. +When it does appear, the expanded form is returned from the expander to be +processed by the evaluator, e.g., \scheme{compile} or \scheme{interpret}, +that invoked the expander. + +The value of the parameter \scheme{eval-syntax-expanders-when} actually determines +the initial compile-time state set. +The parameter is bound to a list of situations, which defaults to +\scheme{(compile load eval)}. +When compiling a file, \scheme{compile} contributes ``C'' to the +state set, \scheme{load} contributes ``L,'' \scheme{visit} contributes +``V,'' \scheme{revisit} contributes ``R,'' and \scheme{eval} +contributes nothing. +When not compiling a file, \scheme{eval} contributes ``E'' to the +state set, and the other situations contribute nothing. +There is no corresponding parameter for controlling the initial value +of the run-time state set. + +\label{eval-when-tlp}% +For RNRS top-level programs, \scheme{eval-when} is essentially ineffective. +The entire program is treated as a single expression, so \scheme{eval-when} +becomes a local \scheme{eval-when} for which only the \scheme{eval} +situation has any relevance. +As for any local \scheme{eval-when} form, the subforms are ignored if +the \scheme{eval} situation is not present; otherwise, they are treated as +if the \scheme{eval-when} wrapper were absent. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{eval-syntax-expanders-when}{\categorythreadparameter}{eval-syntax-expanders-when} +\listlibraries +\endentryheader + +\noindent +This parameter must be set to a list representing a set of +\scheme{eval-when} situations, e.g., a list containing at most one +occurrence of each of the symbols \scheme{eval}, \scheme{compile}, +\scheme{load}, \scheme{visit}, and \scheme{revisit}. +It is used to determine the evaluation time of syntax +definitions, module forms, and import forms are expanded. +(See the discussion of \scheme{eval-when} above.) +The default value is \scheme{(compile load eval)}, which causes +compile-time information in a file to be established when the file is +loaded from source, when it is compiled via \scheme{compile-file}, +and when a compiled version of the file is loaded via \scheme{load} +or \scheme{visit}. + +\section{Source Directories and Files\label{SECTSYSTEMSOURCE}} + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-directories}{\categoryglobalparameter}{source-directories} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{source-directories} must be a list of strings, each +of which names a directory path. +\scheme{source-directories} determines the set of directories searched +for source or object files when a file is loaded via \scheme{load}, \scheme{load-library}, +\scheme{load-program}, \scheme{include}, +\scheme{visit}, or \scheme{revisit}, +when a syntax error occurs, or when a source +file is opened in the interactive inspector. + +The default value is the list \scheme{(".")}, which means source files +will be found only in or relative to the current directory, unless named +with an absolute path. + +This parameter is never altered by the system, with one exception. +The expander temporarily adds (via \scheme{parameterize}) the directory +in which a library file resides to the front of the \scheme{source-directories} +list when it compiles (when \scheme{compile-imported-libraries} is true) or loads the library from source, which it does +only if the library is not already defined. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-source-path}{\categoryprocedure}{(with-source-path \var{who} \var{name} \var{procedure})} +\listlibraries +\endentryheader + +\noindent +The procedure \scheme{with-source-path} searches through the current +source-directories path, in order, for a file with the specified +\var{name} and invokes \var{procedure} on the result. +If no such file is found, an exception is raised with condition types +\scheme{&assertion} and \scheme{&who} with \var{who} as +who value. + +If \var{name} is an absolute pathname or one beginning with \scheme{./} +(or \scheme{.\} under Windows) or \scheme{../} (or \scheme{..\} under +Windows), or if the list of source directories +contains only \scheme{"."}, the default, or \scheme{""}, which is +equivalent to \scheme{"."}, no searching is performed and \var{name} is +returned. + +\var{who} must be a symbol, \var{name} must be a string, and +\var{procedure} should accept one argument. + +The following examples assumes that the file ``pie'' exists +in the directory ``../spam'' but not in ``../ham'' or the current +directory. + +\schemedisplay +(define find-file + (lambda (fn) + (with-source-path 'find-file fn values))) + +(find-file "pie") ;=> "pie" + +(source-directories '("." "../ham")) +(find-file "pie") ;=> \var{exception in find-file: pie not found} + +(source-directories '("." "../spam")) +(find-file "pie") ;=> "../spam/pie" + +(source-directories '("." "../ham")) +(find-file "/pie") ;=> "/pie" + +(source-directories '("." "../ham")) +(find-file "./pie") ;=> "./pie" + +(source-directories '("." "../spam")) +(find-file "../pie") ;=> "../ham/pie" +\endschemedisplay + +\section{Compiler Controls\label{SECTMISCOPTIMIZE}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{optimize-level}{\categorythreadparameter}{optimize-level} +\listlibraries +\endnoskipentryheader + +\noindent +This parameter can take on one of the four values 0, 1, 2, and 3. + +In theory, this parameter controls the amount of optimization +performed by the compiler. +In practice, it does so only indirectly, and the only difference +is between optimize level 3, at which the compiler generates +``unsafe'' code, and optimize levels 0--2, at which the compiler +generates ``safe'' code. +Safe code performs full type and bounds checking so that, for example, +an attempt to apply a non-procedure, an attempt to take the car of a +non-pair, or an attempt to reference beyond the end of a vector each +result in an exception being raised. +With unsafe code, the same situations may result in invalid memory +references, corruption of the Scheme heap (which may cause +seemingly unrelated problems later), system crashes, or other undesirable +behaviors. +Unsafe code is typically faster, but optimize-level 3 should be used with +caution and only on sections of well-tested code that must run as quickly +as possible. + +While the compiler produces the same code for optimize levels 0--2, +user-defined macro transformers can differentiate among the different +levels if desired. + +One way to use optimize levels is on a per-file +basis, using \index{\scheme{eval-when}}\scheme{eval-when} to force the use of a particular +optimize level at compile time. +For example, placing: + +\schemedisplay +(eval-when (compile) (optimize-level 3)) +\endschemedisplay + +\noindent +at the front of a file will cause all of the forms in the file to be +compiled at optimize level 3 when the file is compiled (using +\index{\scheme{compile-file}}\scheme{compile-file}) but does not affect the optimize level used +when the file is loaded from source. +Since \scheme{compile-file} parameterizes \scheme{optimize-level} (see \scheme{parameterize}), +the above +expression does not permanently alter the optimize level in the +system in which the \scheme{compile-file} is performed. + +The optimize level can also be set via the +\index{\scheme{--optimize-level} command-line option}\scheme{--optimize-level} +command-line option (Section~\ref{SECTUSECOMMANDLINE}). +This option is particularly useful for running RNRS top-level programs +at optimize-level~3 via the +\index{\scheme{--program} command-line option}\scheme{--program} command-line option, +since \scheme{eval-when} is ineffective for RNRS top-level programs as described +on page~\pageref{eval-when-tlp}. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:hash-primitive} +\xformdef{$primitive (~#%~)}{$primitive (~#%~)@\scheme{$primitive} (~\scheme{#%}~)}{\categorysyntax}{($primitive \var{variable})} +\xformdef{!L#% ($primitive)}{#% ($primitive)@\scheme{#%} (\scheme{$primitive})}{\categorysyntax}{#%\var{variable}} +\xformdef{$primitive (~#2%~)}{$primitive (~#2%~)@\scheme{$primitive} (~\scheme{#2%}~)}{\categorysyntax}{($primitive 2 \var{variable})} +\xformdef{!M#2% ($primitive)}{#% ($primitive)@\scheme{#2%} (\scheme{$primitive})}{\categorysyntax}{#2%\var{variable}} +\xformdef{$primitive (~#3%~)}{$primitive (~#3%~)@\scheme{$primitive} (~\scheme{#3%}~)}{\categorysyntax}{($primitive 3 \var{variable})} +\xformdef{!N#3% ($primitive)}{#% ($primitive)@\scheme{#3%} (\scheme{$primitive})}{\categorysyntax}{#3%\var{variable}} +\returns the primitive value for \var{variable} +\libraryexport{$primitive}\listlibraries +\endentryheader + +\noindent +\var{variable} must name a primitive procedure. +The \scheme{$primitive} syntactic form allows control over the +optimize level at the granularity of individual primitive references, +and it can be used to access the original value +of a primitive, regardless of the lexical context or the current +top-level binding for the variable originally bound to the primitive. + +The expression \scheme{($primitive \var{variable})} may +be abbreviated as \scheme{#%\var{variable}}. +The reader expands \scheme{#%} followed by an object +into a \scheme{$primitive} expression, much as it expands \scheme{'\var{object}} +into a \scheme{quote} expression. + +If a \scheme{2} or \scheme{3} appears in the form or between the +\scheme{#} and \scheme{%} in the abbreviated form, the compiler treats +an application of the primitive as if it were compiled +at the corresponding optimize level (see the \scheme{optimize-level} +parameter). +If no number appears in the form, an application of the primitive is +treated as an optimize-level 3 application if the current optimize +level is 3; +otherwise, it is treated as an optimize-level 2 application. + +\schemedisplay +(#%car '(a b c)) ;=> a +(let ([car cdr]) (car '(a b c))) ;=> (b c) +(let ([car cdr]) (#%car '(a b c))) ;=> a +(begin (set! car cdr) (#%car '(a b c))) ;=> a +\endschemedisplay + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{debug-level}{\categorythreadparameter}{debug-level} +\listlibraries +\endnoskipentryheader + +\noindent +This parameter can take on one of the four values 0, 1, 2, and 3. +It is used to tell the compiler how important the preservation of +debugging information is, with 0 being least important and 3 being +most important. +The default value is 1. +As of Version~9.0, it is used solely to determine whether an +error-causing call encountered in nontail position is treated as +if it were in tail position (thus causing the caller's frame not +to appear in a stack backtrace); this occurs at debug levels below~2. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{generate-interrupt-trap}{\categorythreadparameter}{generate-interrupt-trap} +\listlibraries +\endentryheader + +\noindent +To support interrupts, including keyboard, timer, and collect request +interrupts, the compiler inserts a short sequence of instructions at the +entry to each nonleaf procedure (Section~\ref{SECTSYSTEMINTERRUPTS}). +This small overhead may be eliminated by setting +\scheme{generate-interrupt-trap} to \scheme{#f}. +The default value of this parameter is \scheme{#t}. + +It is rarely a good idea to compile code without interrupt trap +generation, since a tight loop in the generated code may completely +prevent interrupts from being serviced, including the collect request +interrupt that causes garbage collections to occur automatically. +Disabling trap generation may be useful, however, for routines that act +simply as ``wrappers'' for other routines for which code is presumably +generated with interrupt trap generation enabled. +It may also be useful for short performance-critical routines with +embedded loops or recursions that are known to be short running and +that make no other calls. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-interpret-simple}{\categorythreadparameter}{compile-interpret-simple} +\listlibraries +\endentryheader + +\noindent +At all optimize levels, when the value of +\scheme{compile-interpret-simple} is set to a true value (the default), +\index{\scheme{compile}}\scheme{compile} interprets simple +expressions. +A simple expression is one that creates no procedures. +This can save a significant amount of time over the course of many +calls to \scheme{compile} or \scheme{eval} (with \scheme{current-eval} +set to \scheme{compile}, its default value). +When set to false, \scheme{compile} compiles all expressions. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:generate-inspector-information} +\formdef{generate-inspector-information}{\categorythreadparameter}{generate-inspector-information} +\listlibraries +\endentryheader + +\noindent +When this parameter is set to a true value (the default), information +about the source and contents of procedures and continuations is +generated during compilation and retained in tables associated with +each code segment. +This information allows the inspector to provide more complete +information, at the expense of using more memory and producing +larger object files (via \scheme{compile-file}). +Although compilation and loading may be slower when inspector +information is generated, the speed of the compiled code is not +affected. +If this parameter is changed during the compilation of a file, the +original value will be restored. +For example, if: + +\schemedisplay +(eval-when (compile) (generate-inspector-information #f)) +\endschemedisplay + +\noindent +is included in a file, generation of inspector information will be +disabled only for the remainder of that particular file. + +%---------------------------------------------------------------------------- +\entryheader\label{desc:generate-procedure-source-information} +\formdef{generate-procedure-source-information}{\categorythreadparameter}{generate-procedure-source-information} +\listlibraries +\endentryheader + +\noindent +When \scheme{generate-inspector-information} is set to \scheme{#f} and +this parameter is set to \scheme{#t}, then a source location is preserved +for a procedure, even though other inspector information is not preserved. +Source information provides a small amount of debugging support at a +much lower cost in memory and object-file size than full inspector information. +If this parameter is changed during the compilation of a file, the +original value will be restored. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{enable-cross-library-optimization}{\categorythreadparameter}{enable-cross-library-optimization} +\listlibraries +\endentryheader + +This parameter controls whether information is included with the +object code for a compiled library to enable propagation of constants +and inlining of procedures defined in the library into dependent +libraries. +When set to \scheme{#t} (the default), this information is included; +when set to \scheme{#f}, the information is not included. +Setting the parameter to \scheme{#f} potentially reduces the sizes +of the resulting object files and the exposure of near-source +information via the object file. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{generate-wpo-files}{\categorythreadparameter}{generate-wpo-files} +\listlibraries +\endentryheader + +\index{\scheme{compile-whole-program}}% +When this parameter is set to \scheme{#t} (the default is \scheme{#f}), +\scheme{compile-file}, \scheme{compile-library}, \scheme{compile-program}, +and \scheme{compile-script} produce whole-program optimization (wpo) +files for use by \scheme{compile-whole-program}. +The name of the \scheme{wpo} file is derived from the output-file +name by replacing the object-file extension (normally \scheme{.so}) +with \scheme{.wpo}, or adding the extension \scheme{.wpo} if the +object filename has no extension or has the extension \scheme{.wpo}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-file-message}{\categorythreadparameter}{compile-file-message} +\listlibraries +\endentryheader + +\noindent +When this parameter is set to true, the default, \scheme{compile-file}, +\scheme{compile-library}, \scheme{compile-program}, and +\scheme{compile-script} print a message of the form: + +\schemedisplay +compiling \var{input-path} with output to \var{output-path} +\endschemedisplay + +When the parameter is set to \scheme{#f}, the message is not printed. + +%---------------------------------------------------------------------------- +\entryheader\label{desc:run-cp0} +\formdef{run-cp0}{\categorythreadparameter}{run-cp0} +\formdef{cp0-effort-limit}{\categorythreadparameter}{cp0-effort-limit} +\formdef{cp0-score-limit}{\categorythreadparameter}{cp0-score-limit} +\formdef{cp0-outer-unroll-limit}{\categorythreadparameter}{cp0-outer-unroll-limit} +\listlibraries +\endentryheader + +\noindent +These parameters control the operation of \scheme{cp0}, a source +optimization pass that runs after macro expansion and prior +to most other compiler passes. +\scheme{cp0} performs procedure inlining, in which the code of one +procedure is inlined at points where it is called by other procedures, +as well as copy propagation, constant folding, useless code +elimination, and several related optimizations. +The algorithm used by the optimizer is described in detail in the paper +``Fast and effective procedure inlining''~\cite{waddell:sas97}. + +When \scheme{cp0} is enabled, the programmer can count on the compiler +to fold constants, eliminate unnecessary \scheme{let} bindings, and +eliminate unnecessary and inaccessible code. +This is particularly useful when writing macros, since the programmer +can usually handle only the general case and let the compiler simplify +the code when possible. +For example, the programmer can define \scheme{case} as follows: + +\schemedisplay +(define-syntax case + (syntax-rules () + [(_ e [(k ...) a1 a2 ...] ... [else b1 b2 ...]) + (let ([t e]) + (cond + [(memv t '(k ...)) a1 a2 ...] + ... + [else b1 b2 ...]))] + [(_ e [(k ...) a1 a2 ...] ...) + (let ([t e]) + (cond + [(memv t '(k ...)) a1 a2 ...] + ...))])) +\endschemedisplay + +and count on the introduce \scheme{let} expression to be eliminated +if \scheme{e} turns out to be an unassigned variable, and count on +the entire \scheme{case} expression to be folded if \scheme{e} turns +out to be a constant. + +It is possible to see what \scheme{cp0} does with an expression +via the procedure \index{\scheme{expand/optimize}}\scheme{expand/optimize}, +which expands its argument and passes the result through \scheme{cp0}, as +illustrated by the following transcript. + +\schemedisplay +> (print-gensym #f) +> (expand/optimize + '(lambda (x) + (case x [(a) 1] [(b c) 2] [(d) 3] [else 4]))) +(lambda (x) + (if (#2%memv x '(a)) + 1 + (if (#2%memv x '(b c)) 2 (if (#2%memv x '(d)) 3 4)))) +> (expand/optimize + '(+ (let ([f (lambda (x) + (case x [(a) 1] [(b c) 2] [(d) 3] [else 4]))]) + (f 'b)) + 15)) +17 +\endschemedisplay + +In the first example, the \scheme{let} expression produced by \scheme{case} +is eliminated, and in the second, the entire expression is optimized down +to the constant \scheme{17}. +Although not shown by \scheme{expand/optimize}, the \scheme{memv} calls +in the output code for the first example will be replaced by calls to the +less expensive \scheme{eq?} by a later pass of the compiler. +Additional examples are given in the description +of \scheme{expand/optimize}. + +The value of \scheme{run-cp0} must be a procedure. +Whenever the compiler is invoked on a Scheme form, the value \var{p} +of this parameter is called to determine whether and how +\scheme{cp0} is run. +\var{p} receives two arguments: \var{cp0}, the entry point into +\scheme{cp0}, and \var{x}, the form being compiled. +The default value of \scheme{run-cp0} simply invokes \var{cp0} on +\var{x}, then \var{cp0} again on the result. +The second run is useful in some cases because the first run +may not eliminate bindings for certain variables that appear to be +referenced but are not actually referenced after inlining. +The marginal benefit of the second run is usually minimal, but so is the +cost. + +\noindent +Interesting variants include + +\schemedisplay +(run-cp0 (lambda (cp0 x) x)) +\endschemedisplay + +\noindent +which bypasses (disables) \scheme{cp0}, and + +\schemedisplay +(run-cp0 (lambda (cp0 x) (cp0 x))) +\endschemedisplay + +\noindent +which runs \scheme{cp0} just once. + +The value of \scheme{cp0-effort-limit} determines the maximum amount +of effort spent on each inlining attempt. +The time spent optimizing a program is a linear function of this limit and the +number of calls in the program's source, so small values for this parameter +enforce a tighter bound on compile time. +When set to zero, inlining is disabled except when the name of a procedure +is referenced only once. +The value of \scheme{cp0-score-limit} determines the maximum amount of +code produced per inlining attempt. +Small values for this parameter limit the amount of overall code expansion. +These parameters must be set to nonnegative fixnum values. + +The parameter \scheme{cp0-outer-unroll-limit} +controls the amount of inlining performed by the optimizer for +recursive procedures. +With the parameter's value set to the default value of \scheme{0}, recursive +procedures are not inlined. +A nonzero value for the outer unroll limit allows calls external to +a recursive procedure to be inlined. +For example, the expression + +\schemedisplay +(letrec ([fact (lambda (x) (if (zero? x) 1 (* x (fact (- x 1)))))]) + (fact 10)) +\endschemedisplay + +\noindent +would be left unchanged with the outer unroll limit set to zero, but would +be converted into + +\schemedisplay +(letrec ([fact (lambda (x) (if (zero? x) 1 (* x (fact (- x 1)))))]) + (* 10 (fact 9))) +\endschemedisplay + +\noindent +with the outer unroll limit set to one. + +Interesting effects can be had by varying several of these parameters at +once. +For example, setting the +effort and outer unroll limits to large values and the score limit +to \scheme{1} has the effect of inlining even complex recursive procedures +whose values turn out to be constant at compile time without risking +any code expansion. +For example, + +\schemedisplay +(letrec ([fact (lambda (x) (if (zero? x) 1 (* x (fact (- x 1)))))]) + (fact 10)) +\endschemedisplay + +\noindent +would be reduced to \scheme{3628800}, but + +\schemedisplay +(letrec ([fact (lambda (x) (if (zero? x) 1 (* x (fact (- x 1)))))]) + (fact z)) +\endschemedisplay + +\noindent +would be left unchanged, although the optimizer may take a while to +reach this decision if the effort and outer unroll limits are large. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{commonization-level}{\categorythreadparameter}{commonization-level} +\listlibraries +\endentryheader + +After running the main source optimization pass (cp0) for the last time, the +compiler optionally runs a \emph{commonization} pass. +The pass commonizes the code for lambda expressions that have +identical structure by abstracting differences at certain leaves +of the program, namely constants, references to unassigned variables, +and references to primitives. +The parameter \scheme{commonization-level} controls whether commonization +is run and, if so, how aggressive it is. +Its value must be a nonnegative exact integer ranging from 0 through 9. +When the parameter is set to 0, the default, commonization is not run. +Otherwise, higher values result in more commonization. + +Commonization can undo some of the effects of cp0's inlining, can +add run-time overhead, and can complicate debugging, particularly +at higher commonization levels, which is why it is disabled by +default. +On the other hand, for macros or other meta programs that can +generate large, mostly similar lambda expressions, enabling +commonization can result in significant savings in object-code size +and even reduce run-time overhead by making more efficient use of +instruction caches. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{undefined-variable-warnings}{\categorythreadparameter}{undefined-variable-warnings} +\listlibraries +\endentryheader + +When \scheme{undefined-variable-warnings} is set to \scheme{#t}, the +compiler issues a warning message whenever it cannot determine that +a variable bound by \scheme{letrec}, \scheme{letrec*}, or an internal +definition will not be referenced before it is defined. +The default value is \scheme{#f}. + +Regardless of the setting of this parameter, the compiler inserts code +to check for the error, except at optimize level 3. +The check is fairly inexpensive and does not typically inhibit inlining +or other optimizations. +In code that must be carefully tuned, however, it is sometimes useful +to reorder bindings or make other changes to eliminate the checks. +Enabling undefined-variable warnings can facilitate this process. + +The checks are also visible in the output of \scheme{expand/optimize}. + +%---------------------------------------------------------------------------- +\entryheader\label{desc:expand-output}\label{desc:expand/optimize-output} +\formdef{expand-output}{\categorythreadparameter}{expand-output} +\formdef{expand/optimize-output}{\categorythreadparameter}{expand/optimize-output} +\listlibraries +\endentryheader + +The parameters \scheme{expand-output} and \scheme{expand/optimize-output} +can be used to request that the compiler and interpreter print +expander and source-optimizer output produced during the compilation or +interpretation process. +Each parameter must be set to either \scheme{#f} (the default) or a +textual output port. + +When \scheme{expand-output} is set to a textual output port, the output +of the expander is printed to the port as a side effect of running +\scheme{compile}, \scheme{interpret}, or any of the file compiling +primitives, e.g., \scheme{compile-file} or \scheme{compile-library}. +Similarly, when \scheme{expand/optimize-output} is set to a textual +output port, the output of the source optimizer is printed. + +\index{\scheme{expand}}\index{\scheme{expand/optimize}}% +See also \scheme{expand} (page~\pageref{desc:expand}) and +\scheme{expand-optimize} (page~\pageref{desc:expand/optimize}), which +can be used to run the expander or the expander and source optimizer +directly on an individual form. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{pariah}{\categorysyntax}{(pariah \var{expr_1} \var{expr_2} \dots)} +\returns the values of the last subexpression +\listlibraries +\endentryheader + +A \scheme{pariah} expression is just like a \scheme{begin} expression +except that it informs the compiler that the code is expected to +be executed infrequently. +The compiler uses this information to optimize code layout, register +assignments, and other aspects of the generated code. +The \scheme{pariah} form can be used in performance-critical code +to mark the branches of a conditional (e.g., \scheme{if}, \scheme{cond}, +or \scheme{case}) that are less likely to be executed than the +others. + + +\section{Profiling\label{SECTMISCPROFILE}} + +\index{profiling}\index{block profiling}\index{source profiling}% +{ChezScheme} supports two forms of profiling: source profiling and +block profiling. +With source profiling enabled, the compiler instruments the code +it produces to count the number of times each source-code expression +is executed. +This information can be +displayed in HTML format, or it can be packaged in a list or +source table for arbitrary user-defined processing. +It can also be dumped to a file to be loaded subsequently into the +compiler's database of profile information for use in source-level +optimizations, such as reordering the clauses of a \scheme{case} +or \scheme{exclusive-cond} form. +In connection with coverage-information (covin) files generated by the +compiler when +\index{\scheme{generate-covin-files}}\scheme{generate-covin-files} +is \scheme{#t}, profile information can also be used to gauge coverage +of a source-code base by a set of tests. + +The association between source-code expressions and profile counts +is usually established via annotations produced by the reader and +present in the input to the expander (Section~\ref{SECTSYNTAXANNOTATIONS}). +It is also possible to explicitly identify source positions +to be assigned profile counts via \scheme{profile} expressions. +A \scheme{profile} expression has one subform, a source object, and +returns an unspecified value. +Its only effect is to cause the number of times the expression is +executed to be accounted to the source object. + +In cases where source positions explicitly identified by \scheme{profile} +forms are the only ones whose execution counts should be tracked, +the parameter \scheme{generate-profile-forms} can be set to \scheme{#f} +to inhibit the expander's implicit generation of \scheme{profile} forms +for all annotated source expressions. +It is also possible to obtain finer control over implicit generation of +\scheme{profile} forms by marking which annotations that should and +should not be used for profiling (Section~\ref{SECTSYNTAXANNOTATIONS}). + +With block profiling enabled, the compiler similarly instruments the +code it produces to count the number of times each ``basic block'' +in the code it produces is executed. +Basic blocks are the building blocks of the code produced by many +compilers, including {\ChezScheme}'s compiler, and are sequences +of straight-line code entered only at the top and exited only at +the bottom. +Counting the number of times each basic block is executed is +equivalent to counting the number of times each instruction is +executed, but more efficient. +Block-profile information cannot be viewed, but it can be dumped +to a file to be loaded subsequently into the compiler's database of +profile information for use in block- and instruction-level +optimizations. +These optimizations include reordering blocks to push less frequently +used sequences of code out-of-line, so they will not occupy space +in the instruction cache, and giving registers to variables that are +used in more frequently executed instructions. + +Source profiling involves at least the following steps: + +\begin{itemize} +\item compile the code with source profiling enabled, +\item run the compiled code to generate source-profile information, and +\item dump the profile information. +\end{itemize} + +\index{\scheme{compile-profile}}% +Source profiling is enabled by setting the parameter +\scheme{compile-profile} to the symbol \scheme{source} +or to the boolean value \scheme{#t}. +The profile information can be dumped via: + +\begin{description} +\item[\scheme{profile-dump-html}]\index{\scheme{profile-dump-html}} +in HTML format to allow the programmer to visualize how +often each expression is executed using a color-coding system that +makes it easy to spot ``hot spots,'' +\item[\scheme{profile-dump-list}]\index{\scheme{profile-dump-list}} +in a form suitable for user-defined post-processing, +\item[\scheme{profile-dump}]\index{\scheme{profile-dump}} +in a form suitable for off-line processing by one of the methods +above or by some custom means, or +\item[\scheme{profile-dump-data}]\index{\scheme{profile-dump-data}} +in a form suitable for loading into the compiler's database. +\end{description} + +If the information is intended to be fed back into the compiler for +optimization, the following additional steps are required, either +in the same or a different Scheme process: + +\begin{itemize} +\item load the profile information into the compiler's profile +database, and +\item recompile the code. +\end{itemize} + +\index{\scheme{profile-load-data}}% +Profile information dumped by \scheme{profile-dump-data} is loaded +into the compiler's profile database via \scheme{profile-load-data}. +Profiling information is \emph{not} available to the compiler unless +it is explicitly dumped via \scheme{profile-dump-data} and loaded +via \scheme{profile-load-data}. + +When block-profile information is to be used for optimization, +the steps are similar: + +\begin{itemize} +\item compile the code with block profiling enabled, +\item run the code to generate block-profile information, +\item dump the profile information, +\item load the profile information, and +\item recompile the code. +\end{itemize} + +\index{\scheme{profile-dump-data}}% +\index{\scheme{profile-load-data}}% +Block profiling is enabled by setting the parameter +\scheme{compile-profile} to the symbol \scheme{block} +or to the boolean value \scheme{#t}. +The profile information must be dumped via \scheme{profile-dump-data} +and loaded via \scheme{profile-load-data}. +As with source profile information, block profile information can be +loaded in the same or in a different Scheme process as the one that +dumped the information. + +For block optimization, the code to be recompiled must be identical. +In general, this means the files involved must not have been modified, +and nothing else can change that indirectly affects the code produced +by the compiler, e.g., settings for compiler parameters such as +\scheme{optimize-level} or the contents of configuration files read +by macros at compile time. +Otherwise, the set of blocks or the instructions within them might +be different, in which case the block profile information will not +line up properly and the compiler will raise an exception. + +For the same reason, when both source profiling and block profiling +information is to be used for optimization, the source information +must be gathered first and loaded before both the first and second +compilation runs involved in block profiling. +That is, the following steps must be used: + +\begin{itemize} +\item[1] compile the code with source profiling enabled, +\item[2] run the code to generate source-profile information, +\item[2] dump the source-profile information, +\item[3] load the source-profile information, +\item[3] recompile the code with block profiling enabled, +\item[4] run the code to generate block-profile information, +\item[4] dump the block-profile information, +\item[5] load the source- and block-profile information, and +\item[5] recompile the code. +\end{itemize} + +The numbers labeling each step indicate both the order of the steps +and those that must be performed in the same Scheme process. +(All of the steps can be performed in the same Scheme process, if +desired.) + +Both source and block profiling are disabled when \scheme{compile-profile} +is set to \scheme{#f}, its default value. + +The following example highlights the use of source profiling for +identifying hot spots in the code. +Let's assume that the file /tmp/fatfib/fatfib.ss contains the +following source code. + +\schemedisplay +(define fat+ + (lambda (x y) + (if (zero? y) + x + (fat+ (1+ x) (1- y))))) + +(define fatfib + (lambda (x) + (if (< x 2) + 1 + (fat+ (fatfib (1- x)) (fatfib (1- (1- x))))))) +\endschemedisplay + +We can load fatfib.ss with profiling enabled as follows. + +\schemedisplay +(parameterize ([compile-profile 'source]) + (load "/tmp/fatfib/fatfib.ss")) +\endschemedisplay + +We then run the application as usual. + +\schemedisplay +(fatfib 20) ;=> 10946 +\endschemedisplay + +After the run (or multiple runs), we +dump the profile information as a set of html files using +\scheme{profile-dump-html}. + +\schemedisplay +(profile-dump-html) +\endschemedisplay + +This creates a file named profile.html containing a summary of the profile +information gathered during the run. +If we view this file in a browser, we should see something like the +following. + +\iflatex +\begin{center} +\includegraphics[width=.9\textwidth]{canned/profilehtml} +\end{center} +\fi +\ifhtml +\raw{\raw{profile.html listing}} +\fi + +The most frequently executed code is highlighted in colors closer to +red in the visible spectrum, while +the least frequently executed code is highlighted in colors closer to +violet. +Each of the entries in the lists of files and hot spots are links into +additional generated files, one per source file (provided +\scheme{profile-dump-html} was able to locate an unmodified copy of +the source file). +In this case, there is only one, fatfib.ss.html. +If we move to that file, we should see something like this: + +\iflatex +\begin{center} +\includegraphics[width=.9\textwidth]{canned/fatfibhtml} +\end{center} +\fi +\ifhtml +\raw{\raw{fatfib.html listing}} +\fi + +As in the summary, the code is color-coded according to frequency +of execution. +Hovering over a color-coded section of code should cause a pop-up +box to appear with the starting position and count of the source +expression. +If a portion of source code is not color-coded or is identified +via the starting position as having inherited its color from some +enclosing expression, it may have been recognized as dead code by +the compiler or garbage collector and discarded, or the expander +might not have been able to track it through the macro-expansion +process. + +\scheme{profile-dump} and \scheme{profile-dump-list} may be used to +generate a list of profile entries, which may then be analyzed manually +or via a custom profile-viewing application. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{compile-profile}{\categorythreadparameter}{compile-profile} +\listlibraries +\endentryheader + +When this parameter is set to the symbol \scheme{source} or the +boolean value \scheme{#t}, the compiler instruments the code it +generates with instructions that count the number of times each +section of source code is executed. +When set to the symbol \scheme{block}, the compiler similarly +instruments the code it generates with instructions that count the +number of times each block of code is executed. +When set to \scheme{#f} (the default), the compiler does not insert +these instructions. + +The general description of profiling above describes how the source +and block profile information can be viewed or used for optimization. + +The code generated when \scheme{compile-profile} is non-false is +larger and less efficient, so this parameter should be set only +when profile information is needed. + +The profile counters for code compiled when profile instrumentation +is enabled are retained indefinitely, even if the code with which +they are associated is reclaimed by the garbage collector. +This results in more complete and accurate profile data but can lead +to space leaks in programs that dynamically generate or load code. +Such programs can avoid the potential space leak by releasing the +counters explicitly via the procedure +\index{\scheme{profile-release-counters}}\scheme{profile-release-counters}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{generate-covin-files}{\categorythreadparameter}{generate-covin-files} +\listlibraries +\endentryheader + +When this parameter is set to \scheme{#t}, the compiler generates +``coverage-information'' (covin) files that can be used in connection with +profile information to measure coverage of a source-code base by a +set of tests. +One covin file is created for each object file, with the object-file +extension replaced by the extension \scheme{.covin}. +Each covin file contains the printed representation of a source table +(Section~\ref{SECTSYNTAXSOURCETABLES}), compressed using the compression +format and level specified by \scheme{compress-format} and +\scheme{compress-level}. +This information can be read via +\index{\scheme{get-source-table!}}\scheme{get-source-table!} and used +as a universe of source expressions to identify source expressions +that are not evaluated during the running of a set of tests. + + +\entryheader +\formdef{profile}{\categorysyntax}{(profile \var{source-object})} +\returns unspecified +\listlibraries +\endentryheader + +A \scheme{profile} form has the effect of accounting to the source +position identified by \var{source-object} the number of times the +\scheme{profile} form is executed. +Profile forms are generated implicitly by the expander for source +expressions in annotated input, e.g., input read by the compiler or +interpreter from a Scheme source file, so this form is typically +useful only when unannotated source code is produced by the front +end for some language that targets Scheme. + +\entryheader +\formdef{generate-profile-forms}{\categorythreadparameter}{(generate-profile-forms)} +\listlibraries +\endentryheader + +When this parameter is set to \scheme{#t}, the default, the expander +implicitly introduces \scheme{profile} forms for each annotated input +expression, unless the annotation has not been marked for use in +profiling (Section~\ref{SECTSYNTAXANNOTATIONS}). +It can be set to \scheme{#f} to inhibit the expander's implicit +generation of \scheme{profile} forms, typically when explicit +\scheme{profile} forms are already present for all source positions +that should be profiled. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-clear}{\categoryprocedure}{(profile-clear)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Calling this procedure causes profile information to be cleared, i.e., +the counts associated with each section of code are set to zero. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-release-counters}{\categoryprocedure}{(profile-release-counters)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Calling this procedure causes profile information associated with reclaimed +code objects to be dropped. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-dump}{\categoryprocedure}{(profile-dump)} +\returns a list of pairs of source-object and count +\listlibraries +\endentryheader + +This procedure produces a dump of all +profile information gathered since startup or the last call to +\scheme{profile-clear}. +It returns a list of pairs, where the car of each pair +is a source object (Section~\ref{SECTSYNTAXANNOTATIONS}) and the +cdr is an exact nonnegative integer count. + +The list might contain more than one entry per source object due +to macro expansion and procedure inlining, and it might contain +more than one (non-eq) source object per file and source position +due to separate compilation. +In such cases, the counts are not overlapping and can be summed +together to obtain the full count. + +The advantage of \scheme{profile-dump} over \scheme{profile-dump-list} +is that \scheme{profile-dump} performs only minimal processing and +preserves complete source objects, including their embedded source-file +descriptors. +It might be used, for example, to dump profile information to a +fasl file on one machine for subsequent processing on another. + +\index{\scheme{with-profile-tracker}}\scheme{with-profile-tracker} +can be used to obtain the same set of counts as a source table. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-profile-tracker}{\categoryprocedure}{(with-profile-tracker \var{thunk})} +\formdef{with-profile-tracker}{\categoryprocedure}{(with-profile-tracker \var{preserve-existing?} \var{thunk})} +\returns a source table and the values returned by \var{thunk} +\listlibraries +\endentryheader + +\var{thunk} must be a procedure and should accept zero arguments. +It may return any number of values. + +\scheme{with-profile-tracker} invokes \var{thunk} without arguments. +If \var{thunk} returns $n$ values \scheme{\var{x_1}, \var{x_2}, \dots, \var{x_n}}, \scheme{with-profile-tracker} +returns $n+1$ values \scheme{\var{st}, \var{x_1}, \var{x_2}, \dots, \var{x_n}}, where \var{st} is a +source table associating source objects with profile counts. +If \var{preserve-existing?} is absent or \scheme{#f}, each count +represents the number of times the source expression represented +by the associated source object is evaluated during the invocation +of \var{thunk}. +Otherwise, each count represents the number of times the source +expression represented by the associated source object is evaluated +before or during the invocation of \var{thunk}. + +Profile data otherwise cleared by a call to +\index{\scheme{profile-clear}}\scheme{profile-clear} or +\index{\scheme{profile-release-counters}}\scheme{profile-release-counters} +during the invocation of \var{thunk} is included in the +resulting table. +That is, invoking these procedures while \var{thunk} is running has +no effect on the resulting counts. +On the other hand, profile data cleared before \scheme{with-profile-tracker} +is invoked is not included in the resulting table. + +The idiom \scheme{(with-profile-tracker #t values)} can be used to obtain +the current set of profile counts as a source table. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{source-table-dump}{\categoryprocedure}{(source-table-dump \var{source-table})} +\returns a list of pairs of source objects and their associated values in \var{source-table} +\listlibraries +\endentryheader + +This procedure can be used to convert a source-table produced by +\index{\scheme{with-profile-tracker}}\scheme{with-profile-tracker} or some other mechanism into the form returned +by \index{\scheme{profile-dump}}\scheme{profile-dump} for use as an argument to +\index{\scheme{profile-dump-html}}\scheme{profile-dump-html}, +\index{\scheme{profile-dump-list}}\scheme{profile-dump-list}, +or +\index{\scheme{profile-dump-data}}\scheme{profile-dump-data}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-dump-html}{\categoryprocedure}{(profile-dump-html)} +\formdef{profile-dump-html}{\categoryprocedure}{(profile-dump-html \var{prefix})} +\formdef{profile-dump-html}{\categoryprocedure}{(profile-dump-html \var{prefix} \var{dump})} +\returns unspecified +\listlibraries +\endentryheader + +This procedure produces one or more HTML files, including +profile.html, which contains color-coded summary information, +and one file \var{source}.html for each source +file \var{source} containing a color-coded copy of the +source code, as described in the lead-in to this section. +If \var{prefix} is specified, it must be a string and is prepended +to the names of the generated HTML files. +For example, if \var{prefix} is \scheme{"/tmp/"}, the generated +files are placed in the directory /tmp. +The raw profile information is obtained from \var{dump}, which +defaults to the value returned by \scheme{profile-dump}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-palette}{\categorythreadparameter}{(profile-palette)} +\listlibraries +\endentryheader + +This value of this parameter must be a nonempty vector of at least +three pairs. +The car of each pair is a background color and the cdr is a foreground +(text) color. +Each color must be a string, and each string should contain an HTML +cascading style sheet (CSS) color specifier. +The first pair is used for unprofiled code, and the second is used +for unexecuted profiled code. +The third is used for code that is executed least frequently, the fourth +for code executed next-least frequently, and so on, with the last +being used for code that is executed most frequently. +Programmers may wish to supply their own palette to enhance visibility +or to change the number of colors used. + +By default, a black background is used for unprofiled code, and a gray +background is used for unexecuted profiled code. +Background colors ranging from purple to red are used for executed +profiled code, depending on frequency of execution, with red for the most +frequently executed code. + +\schemedisplay +(profile-palette) ;=> + #(("#111111" . "white") ("#607D8B" . "white") + ("#9C27B0" . "black") ("#673AB7" . "white") + ("#3F51B5" . "white") ("#2196F3" . "black") + ("#00BCD4" . "black") ("#4CAF50" . "black") + ("#CDDC39" . "black") ("#FFEB3B" . "black") + ("#FFC107" . "black") ("#FF9800" . "black") + ("#F44336" . "white")) +(profile-palette + ; set palette with rainbow colors and black text + ; for all but unprofiled or unexecuted code + '#(("#000000" . "white") ; black + ("#666666" . "white") ; gray + ("#8B00FF" . "black") ; violet + ("#6600FF" . "black") ; indigo + ("#0000FF" . "black") ; blue + ("#00FF00" . "black") ; green + ("#FFFF00" . "black") ; yellow + ("#FF7F00" . "black") ; orange + ("#FF0000" . "black"))) ; red +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-line-number-color}{\categorythreadparameter}{(profile-line-number-color)} +\listlibraries +\endentryheader + +This value of this parameter must be a string or \scheme{#f}. +If it is a string, the string should contain an HTML cascading style sheet (CSS) +color specifier. +If the parameter is set to a string, \scheme{profile-dump-html} includes line numbers +in its html rendering of each source file, using the specified color. +If the parameter is set to \scheme{#f}, no line numbers are included. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-dump-list}{\categoryprocedure}{(profile-dump-list)} +\formdef{profile-dump-list}{\categoryprocedure}{(profile-dump-list \var{warn?})} +\formdef{profile-dump-list}{\categoryprocedure}{(profile-dump-list \var{warn?} \var{dump})} +\returns a list of profile entries (see below) +\listlibraries +\endentryheader + +This procedure produces a dump of all +profile information present in \var{dump}, which defaults to +the value returned by \scheme{profile-dump}. +It returns a list of entries, each of which is itself a list containing the +following elements identifying one block of code and how many times it +has been executed. + +\begin{itemize} + \item execution count + \item pathname + \item beginning file position in characters (inclusive) + \item ending file position in characters (exclusive) + \item line number of beginning file position + \item character position of beginning file position +\end{itemize} + +\scheme{profile-dump-list} may be unable to locate an unmodified copy +of the file in the current source directories +or at the absolute address, if an absolute address was used when +the file was compiled or loaded. +If this happens, the line number and character position of the beginning +file position are \scheme{#f} and the pathname is the pathname originally +used. +A warning is also issued (an exception with condition type +\scheme{&warning} is raised) unless the \scheme{warn?} argument is provided +and is false. + +Otherwise, the pathname is the path to an unmodified copy of the source +and the line and character positions are set to exact nonnegative integers. + +In either case, the execution count, beginning file position, and ending +file position are all exact nonnegative integers, and the pathname is a string. + +For source positions in files that cannot be found, the list might +contain more than one entry per position due to macro expansion, +procedure inlining, and separate compilation. +In such cases, the counts are not overlapping and can be summed +together to obtain the full count. + +The information returned by \scheme{profile-dump-list} can be used to +implement a custom viewer or used as input for offline analysis of +profile information. + +The advantage of \scheme{profile-dump-list} over \scheme{profile-dump} +is that it attempts to determine the line number and character +position for each source point and, if successful, aggregates +multiple counts for the source point into a single entry. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-dump-data}{\categoryprocedure}{(profile-dump-data \var{path})} +\formdef{profile-dump-data}{\categoryprocedure}{(profile-dump-data \var{path} \var{dump})} +\returns unspecified +\listlibraries +\endentryheader + +\var{path} must be a string. + +This procedure writes, in a machine-readable form consumable by +\scheme{profile-load-data}, profile counts represented by \var{dump} +to the file named by \var{path}, replacing the file if it already exists. +\var{dump} defaults to the value returned by \scheme{profile-dump}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-load-data}{\categoryprocedure}{(profile-load-data \var{path} \dots)} +\returns unspecified +\listlibraries +\endentryheader + +Each \var{path} must be a string. + +This procedure reads profile information from the files named by +\scheme{\var{path} \dots} and stores it in the compiler's internal +database of profile information. +The contents of the files must have been created originally by +\scheme{profile-dump-data} using the same version of {\ChezScheme}. + +The database stores a weight for each source expression or block +rather than the actual count. +When a single file is loaded into the database, the weight is the +proportion of the actual count over the maximum count for all +expressions or blocks represented in the file. +When more than one file is loaded, either by one or multiple calls +to \scheme{profile-load-data}, the weights are averaged. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-query-weight}{\categoryprocedure}{(profile-query-weight \var{obj})} +\returns \var{obj}'s profile weight, or \scheme{#f} if \var{obj} is not in the database +\listlibraries +\endentryheader + +The compiler's profile database maps source objects +(Section~\ref{SECTSYNTAXANNOTATIONS}) to weights. +If \var{obj} is a source object, the \scheme{profile-query-weight} returns +the weight associated with the source object or \scheme{#f} if the database +does not have a weight recorded for the source object. +\var{obj} can also be an annotation or syntax object, in which case +\scheme{profile-query-weight} first extracts the source object, if any, +using \scheme{syntax->annotation} and \scheme{annotation-source}, +returning \scheme{#f} if no source-object is found. + +A weight is a flonum in the range 0.0 to 1.0, inclusive, and denotes the +ratio of the actual count to the maximum count as described in the +description of \scheme{profile-load-data}. + +\scheme{profile-query-weight} can be used by a macro to determine +the relative frequency with which its subexpressions were executed +in the run or runs that generated the information in the database. +This information can be used to guide the generation of code that +is likely to be more efficient. +For example, the \scheme{case} macro uses profile information, when +available, to order the clauses so that those whose keys matched +more frequently are tested before those whose keys matched less +frequently. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-clear-database}{\categoryprocedure}{(profile-clear-database)} +\returns unspecified +\listlibraries +\endentryheader + +This procedure clears the compiler's profile database. +It has no impact on the counts associated with individual sections +of instrumented code; \scheme{profile-clear} can be used to reset +those counts. + +\section{Waiter Customization\label{SECTMISCWAITERS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{new-cafe}{\categoryprocedure}{(new-cafe)} +\formdef{new-cafe}{\categoryprocedure}{(new-cafe \var{eval-proc})} +\returns see below +\listlibraries +\endnoskipentryheader + +\noindent +\index{waiter}\index{cafe@caf\'e}{\ChezScheme} interacts with the user +through a \emph{waiter}, or read-eval-print loop (REPL). +The waiter operates within a context called a \emph{caf\'e}. +When the system starts up, the user is placed in a caf\'e and +given a waiter. +\scheme{new-cafe} opens a new Scheme caf\'e, stacked on top of the old one. +In addition to starting the waiter, \scheme{new-cafe} sets up the caf\'e's +reset and exit handlers (see \scheme{reset-handler} and \scheme{exit-handler}). +Exiting a caf\'e resumes the continuation of the call +to \scheme{new-cafe} that created the caf\'e. +Exiting from the initial caf\'e leaves Scheme altogether. +A caf\'e may be exited from either by an explicit call to \scheme{exit} or +by receipt of end-of-file (``control-D'' on Unix systems) in response +to the waiter's prompt. +In the former case, any values passed to \scheme{exit} are returned from +\scheme{new-cafe}. + +If the optional \var{eval-proc} argument is specified, \var{eval-proc} +is used to evaluate forms entered from the console. +Otherwise, the value of the parameter \scheme{current-eval} is used. +\var{eval-proc} must accept one argument, the expression to evaluate. + +Interesting values for \var{eval-proc} include \index{\scheme{expand}}\scheme{expand}, +which causes the macro expanded value of each expression entered to +be printed and \scheme{(lambda (x) x)}, which simply causes each expression +entered to be printed. +An arbitrary procedure of one argument may be used to facilitate +testing of a program on a series of input values. + +\schemedisplay +> (new-cafe (lambda (x) x)) +>> 3 +3 +>> (a . (b . (c . ()))) +(a b c) +\endschemedisplay + +\schemedisplay +(define sum + (lambda (ls) + (if (null? ls) + 0 + (+ (car ls) (sum (cdr ls)))))) +> (new-cafe sum) +>> (1 2 3) +6 +\endschemedisplay + +The default waiter reader (see \scheme{waiter-prompt-and-read}) displays +the current waiter prompt (see \scheme{waiter-prompt-string}) +to the current value of \index{\scheme{console-output-port}}\scheme{console-output-port} and +reads +from the current value of \index{\scheme{console-input-port}}\scheme{console-input-port}. +The default waiter printer (see \scheme{waiter-write}) sends output +to the current value of \index{\scheme{console-output-port}}\scheme{console-output-port}. +These parameters, along with \scheme{current-eval}, +can be modified to change the behavior of the waiter. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{waiter-prompt-string}{\categorythreadparameter}{waiter-prompt-string} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{waiter-prompt-string} must be a string. +It is used by the default waiter prompter (see the parameter +\scheme{waiter-prompt-and-read}) to print a prompt. +Nested caf\'es +are marked by repeating the prompt string once for each nesting level. + +\schemedisplay +> (waiter-prompt-string) +">" +> (waiter-prompt-string "%") +% (waiter-prompt-string) +"%" +% (new-cafe) +%% (waiter-prompt-string) +"%" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{waiter-prompt-and-read}{\categorythreadparameter}{waiter-prompt-and-read} +\listlibraries +\endentryheader + +\noindent +\scheme{waiter-prompt-and-read} must be set to a procedure. +It is used by the waiter to +print a prompt and read an expression. +The value of \scheme{waiter-prompt-and-read} is called by the waiter with a +positive integer that indicates the caf\'e nesting level. +It should return an expression to be evaluated by the current +evaluator (see \scheme{new-cafe} and \scheme{current-eval}). + +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-prompt-and-read}{\categoryprocedure}{(default-prompt-and-read \var{level})} +\listlibraries +\endentryheader + +\var{level} must be a positive integer indicating the cafe\'e nesting +level as described above. + +This procedure is the default value of the \scheme{waiter-prompt-and-read} +parameter whenever the expression editor +(Section~\ref{SECTUSEEXPEDITOR}, Chapter~\ref{CHPTEXPEDITOR}) is +\emph{not} enabled. +It might be defined as follows. + +\schemedisplay +(define default-prompt-and-read + (lambda (n) + (unless (and (integer? n) (>= n 0)) + (assertion-violationf 'default-prompt-and-read + "~s is not a nonnegative integer" + n)) + (let ([prompt (waiter-prompt-string)]) + (unless (string=? prompt "") + (do ([n n (- n 1)]) + ((= n 0) + (write-char #\space (console-output-port)) + (flush-output-port (console-output-port))) + (display prompt (console-output-port)))) + (let ([x (read (console-input-port))]) + (when (and (eof-object? x) (not (string=? prompt ""))) + (newline (console-output-port)) + (flush-output-port (console-output-port))) + x)))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{waiter-write}{\categorythreadparameter}{waiter-write} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{waiter-write} must be a procedure. +The waiter uses the value of \scheme{waiter-write} to print the results +of each expression read and evaluated by the waiter. +The following example installs a procedure equivalent to the default +\scheme{waiter-write}: + +\schemedisplay +(waiter-write + (lambda (x) + (unless (eq? x (void)) + (pretty-print x (console-output-port))) + (flush-output-port (console-output-port)))) +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{reset}{\categoryprocedure}{(reset)} +\returns does not return +\listlibraries +\endentryheader + +\noindent +\scheme{reset} invokes the current reset handler (see \scheme{reset-handler}) +without arguments. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{reset-handler}{\categorythreadparameter}{reset-handler} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a procedure and should accept zero +arguments. +The current reset handler is called by \scheme{reset}. +The default reset handler resets to the current caf\'e. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{exit}{\categoryprocedure}{(exit \var{obj} \dots)} +\returns does not return +\listlibraries +\endentryheader + +\noindent +\scheme{exit} invokes the current exit handler (see +\scheme{exit-handler}), passing along its arguments, if any. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{exit-handler}{\categorythreadparameter}{exit-handler} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a procedure and should accept any +number of arguments. +The current exit handler is called by \scheme{exit}. + +The default exit handler exits from the current caf\'e, +returning its arguments as the values of the call to +\scheme{new-cafe} that created the current caf\'e. +If the current caf\'e is the original caf\'e, or if \scheme{exit} +is called from a script, \scheme{exit} exits from Scheme. +In this case, the exit code for the Scheme process is 0 if +no arguments were supplied or if the first argument is void, +the value of the first argument cast to a C int if +it is an exact integer of the host machine's bit width, and 1 otherwise. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{abort}{\categoryprocedure}{(abort)} +\formdef{abort}{\categoryprocedure}{(abort \var{obj})} +\returns does not return +\listlibraries +\endentryheader + +\noindent +\scheme{abort} invokes the current abort handler (see \scheme{abort-handler}), +passing along its argument, if any. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{abort-handler}{\categorythreadparameter}{abort-handler} +\listlibraries +\endentryheader + +\noindent +The value of this parameter must be a procedure and should accept either +zero arguments or one argument. +The current abort handler is called by \scheme{abort}. + +The default abort handler exits the Scheme process. +The exit code for the Scheme process is -1 if no arguments were supplied, +0 if the first argument is void, the value of the first argument if it is +a 32-bit exact integer, and -1 otherwise. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{scheme-start}{\categoryglobalparameter}{scheme-start} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{scheme-start} is a procedure that determines the +system's action upon start-up. +The procedure receives zero or more arguments, which are strings +representing the file names (or command-line arguments not recognized +by the Scheme executable) after given on the command line. +The default value first loads the files named by the arguments, then +starts up the initial caf\'e: + +\schemedisplay +(lambda fns + (for-each load fns) + (new-cafe)) +\endschemedisplay + +\noindent +\scheme{scheme-start} may be altered to start up an application or to +perform customization prior to normal system start-up. + +To have any effect, this parameter must be set within a boot file. +(See Chapter~\ref{CHPTUSE}.) + +%---------------------------------------------------------------------------- +\entryheader +\formdef{scheme-script}{\categoryglobalparameter}{scheme-script} +\listlibraries +\endentryheader + +\noindent +\index{\scheme{--script} command-line option}% +\index{\scheme{command-line}}% +\index{\scheme{command-line-arguments}}% +The value of \scheme{scheme-script} is a procedure that determines the +system's action upon start-up, +when the \scheme{--script} option is used. +The procedure receives one or more arguments. +The first is a string identifying the script filename and the remainder +are strings representing the remaining file names (or command-line +arguments not recognized by the Scheme executable) given on the command +line. +The default value of this parameter is a procedure that sets the +\scheme{command-line} and \scheme{command-line-arguments} parameters, +loads the script using \scheme{load}, and returns void, which is +translated into a 0 exit status for the script process. + +\schemedisplay +(lambda (fn . fns) + (command-line (cons fn fns)) + (command-line-arguments fns) + (load fn)) +\endschemedisplay + +\noindent +\scheme{scheme-script} may be altered to start up an application or to +perform customization prior to normal system start-up. + +To have any effect, this parameter must be set within a boot file. +(See Chapter~\ref{CHPTUSE}.) + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{scheme-program}{\categoryglobalparameter}{scheme-program} +\listlibraries +\endentryheader + +\noindent +\index{\scheme{--program} command-line option}% +\index{\scheme{command-line}}% +\index{\scheme{command-line-arguments}}% +The value of \scheme{scheme-program} is a procedure that determines the +system's action upon start-up +when the \scheme{--program} (RNRS top-level program) option is used. +The procedure receives one or more arguments. +The first is a string identifying the program filename and the remainder +are strings representing the remaining file names (or command-line +arguments not recognized by the Scheme executable) given on the command +line. +The default value of this parameter is a procedure that sets the +\scheme{command-line} and \scheme{command-line-arguments} parameters, +loads the program using \scheme{load-program}, and returns void, which is +translated into a 0 exit status for the script process. + +\schemedisplay +(lambda (fn . fns) + (command-line (cons fn fns)) + (command-line-arguments fns) + (load-program fn)) +\endschemedisplay + +\noindent +\scheme{scheme-program} may be altered to start up an application or to +perform customization prior to normal system start-up. + +To have any effect, this parameter must be set within a boot file. +(See Chapter~\ref{CHPTUSE}.) + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{command-line}{\categoryglobalparameter}{command-line} +\listlibraries +\endentryheader + +\index{\scheme{--script} command-line option}% +This parameter is set by the default values of \scheme{scheme-script} +and \scheme{scheme-program} +to a list representing the command line, with the script name followed +by the command-line arguments, when the \scheme{--script} or +\scheme{--program} option is used on system startup. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{command-line-arguments}{\categoryglobalparameter}{command-line-arguments} +\listlibraries +\endentryheader + +\index{\scheme{--script} command-line option}% +This parameter is set by the default values of \scheme{scheme-script} +and \scheme{scheme-program} +to a list of the command-line arguments when the \scheme{--script} +or \scheme{--program} option is used on system startup. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{suppress-greeting}{\categoryglobalparameter}{suppress-greeting} +\listlibraries +\endentryheader + +\noindent +The value of \scheme{suppress-greeting} is a boolean value that determines +whether {\ChezScheme} prints an identifying banner and copyright notice. +The parameter defaults to \scheme{#f} but may be set to \scheme{#t} for +use in batch processing applications where the banner would be disruptive. + +To have any effect, this parameter must be set within a boot file. +(See Chapter~\ref{CHPTUSE}.) + + +\section{Transcript Files\label{SECTMISCTRANSCRIPTS}} + +A \index{transcript}transcript file is a record of an interactive session. +It is also useful as a ``quick-and-dirty'' alternative to opening an +output file and using explicit output operations. + + +%---------------------------------------------------------------------------- +\entryheader\label{desc:transcript-on} +\formdef{transcript-on}{\categoryprocedure}{(transcript-on \var{path})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. + +\scheme{transcript-on} opens the file named by \var{path} for output, +and it copies to this file all input from the current input port and +all output to the current output port. +An exception is raised with condition-type \scheme{i/o-filename} if the +file cannot be opened for output. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{transcript-off}{\categoryprocedure}{(transcript-off)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\scheme{transcript-off} ends transcription and closes the transcript file. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{transcript-cafe}{\categoryprocedure}{(transcript-cafe \var{path})} +\listlibraries +\endentryheader + +\noindent +\var{path} must be a string. +\scheme{transcript-cafe} opens a transcript file as with +\scheme{transcript-on} and +enters a new caf\'e; exiting +from this caf\'e (see \scheme{exit}) also ends transcription and closes the +transcript file. +Invoking \scheme{transcript-off} while in a transcript caf\'e ends transcription +and closes the transcript file but does not cause an exit from the +caf\'e. + + +\section{Times and Dates\label{SECTSYSTEMTIMESNDATES}} + +This section documents procedures for handling times and dates. Most of +the procedures described here are proposed in +\hyperlink{http://srfi.schemers.org/srfi-19/srfi-19.html}{SRFI~19}: +Time Data Types and Procedures, by Will Fitzgerald. + +Times are represented by time objects. +Time objects record the nanosecond and second of a particular time +or duration, along with a \emph{time type} that identifies the nature +of the time object. +The time type is one of the following symbols: + +\begin{description} +\item[\scheme{time-utc}:] +The time elapsed since the ``epoch:'' 00:00:00 UTC, January 1, 1970, +subject to adjustment, e.g., to correct for leap seconds. + +\item[\scheme{time-monotonic}:] +The time elapsed since some arbitrary point in the past, ideally +not subject to adjustment. + +\item[\scheme{time-duration}:] +The time elapsed between two times. +When used as an argument to \scheme{current-time}, it behaves like +\scheme{time-monotonic}, but may also used to represent the result +of subtracting two time objects. + +\item[\scheme{time-process}:] +The amount of CPU time used by the current process. + +\item[\scheme{time-thread}:] +The amount of CPU time used by the current thread. +It is the same as \scheme{time-process} if +not running threaded or if the system does not allow individual +thread times to be determined. + +\item[\scheme{time-collector-cpu}:] +The portion of the current process's CPU time consumed by the +garbage collector. + +\item[\scheme{time-collector-real}:] +The portion of the current process's real time consumed by the +garbage collector. +\end{description} + +A time-object second is an exact integer (possibly negative), +and a nanosecond is an exact nonnegative integer less than $10^9$. +The second and nanosecond of a time object may be converted to +an aggregate nanosecond value by scaling the +seconds by $10^9$ and adding the nanoseconds. +Thus, if the second and nanosecond of a time object are 5 and 10, +the time object represents 5000000010 nanoseconds (5.000000010 seconds). +If the second and nanosecond are -5 and 10, the time object +represents -4999999990 nanoseconds (-4.999999990 seconds). + +Dates are represented by date objects. +A date object records the nanosecond, second, minute, hour, day, month, +and year of a particular date, along with an offset that identifies the +time zone. + +As for time objects, a nanosecond is an exact integer less than $10^9$. +A date-object second is, however, an exact nonnegative integer +less than 62. +(The values 61 and 62 allow for leap seconds.) +A minute is an exact nonnegative integer less than 60, and +an hour is an exact nonnegative integer less than 24. +A day is an exact nonnegative integer in ranging from 1 representing +the first day of the month to $n$, where $n$ is the number of +days in the date's month and year. +A month is an exact nonnegative integer ranging from 1 through 12, +where 1 represents January, 2 represents February, and so on. +A year must be an exact integer. +Years less than 1970 or greater than 2038 may not be supported +depending on limitations of the underlying implementation. +A time-zone offset represents the time-zone offset, in seconds, from UTC. +It is an exact integer in the range $-86400$ to $+86400$, inclusive. +For example, Eastern Standard Time (EST), which is 5 hours east, has +offset $5\times 3600 = -18000$. +The offset for Eastern Daylight Time (EDT) is $-14400$. +UTC is represented by offset zero. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-time}{\categoryprocedure}{(current-time)} +\formdef{current-time}{\categoryprocedure}{(current-time \var{time-type})} +\returns a time object representing the current time +\listlibraries +\endentryheader + +\var{time-type} must be one of the time-type symbols listed above +and defaults to \scheme{time-utc}. + +\schemedisplay +(current-time) ;=> # +(current-time 'time-process) ;=> # +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-time}{\categoryprocedure}{(make-time \var{type} \var{nsec} \var{sec})} +\returns a time object +\listlibraries +\endentryheader + +\var{type} must be one of the time-type symbols listed above. +\var{nsec} represents nanoseconds and must be an exact nonnegative +integer less than $10^9$. +\var{sec} represents seconds and must be an exact integer. + +\schemedisplay +(make-time 'time-utc 787511000 1198783214) +(make-time 'time-duration 10 5) +(make-time 'time-duration 10 -5) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{time?}{\categoryprocedure}{(time? \var{obj})} +\returns \scheme{#t} if \var{obj} is a time object, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(time? (current-time)) ;=> #t +(time? (make-time 'time-utc 0 0)) ;=> #t +(time? "1400 hours") ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{time-type}{\categoryprocedure}{(time-type \var{time})} +\returns the time type of \var{time} +\formdef{time-nanosecond}{\categoryprocedure}{(time-nanosecond \var{time})} +\returns the nanosecond of \var{time} +\formdef{time-second}{\categoryprocedure}{(time-second \var{time})} +\returns the second of \var{time} +\listlibraries +\endentryheader + +\var{time} must be a time object. + +\schemedisplay +(time-type (current-time)) ;=> time-utc +(time-type (current-time 'time-process)) ;=> time-process +(time-type (make-time 'time-duration 0 50)) ;=> time-duration +(time-second (current-time)) ;=> 1198816497 +(time-nanosecond (current-time)) ;=> 2399000 +(time-second (make-time 'time-duration 10 -5)) ;=> -5 +(time-nanosecond (make-time 'time-duration 10 -5)) ;=> 10 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-time-type!}{\categoryprocedure}{(set-time-type! \var{time} \var{type})} +\returns unspecified +\formdef{set-time-nanosecond!}{\categoryprocedure}{(set-time-nanosecond! \var{time} \var{nsec})} +\returns unspecified +\formdef{set-time-second!}{\categoryprocedure}{(set-time-second! \var{time} \var{sec})} +\returns unspecified +\listlibraries +\endentryheader + +\var{time} must be a time object. +\var{type} must be one of the time-type symbols listed above. +\var{nsec} represents nanoseconds and must be an exact nonnegative +integer less than $10^9$. +\var{sec} represents seconds and must be an exact integer. + +Each of these procedures modifies the time object, changing one aspect +while leaving the others unaffected. +For example, \scheme{set-time-nanosecond!} changes the nanosecond of +\var{time} without changing the second or type. +In particular, no conversion of values is performed when the type of a time +object is changed. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{time=?}{\categoryprocedure}{(time=? \var{time_1} \var{time_2})} +\formdef{time=?}{\categoryprocedure}{(time>=? \var{time_1} \var{time_2})} +\formdef{time>?}{\categoryprocedure}{(time>? \var{time_1} \var{time_2})} +\returns \scheme{#t} if the relation holds, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\var{time_1} and \var{time_2} must be time objects and must have +the same type. + +\schemedisplay +(let ([t (current-time)]) + (time=? t t)) ;=> #t +(let ([t (current-time)]) + (let loop () + (when (time=? (current-time) t)) + (loop)) + (time>? (current-time) t)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{copy-time}{\categoryprocedure}{(copy-time \var{time})} +\returns a copy of \var{time} +\listlibraries +\endentryheader + +\schemedisplay +(define t1 (current-time)) +(define t2 (copy-time t1)) +(eq? t2 t1) ;=> #f +(eqv? (time-second t2) (time-second t1)) ;=> #t +(eqv? (time-nanosecond t2) (time-nanosecond t1)) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{time-difference}{\categoryprocedure}{(time-difference \var{time_1} \var{time_2})} +\returns the result of subtracting \var{time_2} from \var{time_1} +\formdef{time-difference!}{\categoryprocedure}{(time-difference! \var{time_1} \var{time_2})} +\returns the result of subtracting \var{time_2} from \var{time_1} +\formdef{add-duration}{\categoryprocedure}{(add-duration \var{time} \var{time_d})} +\returns the result of adding \var{time_d} to \scheme{time} +\formdef{add-duration!}{\categoryprocedure}{(add-duration! \var{time} \var{time_d})} +\returns the result of adding \var{time_d} to \scheme{time} +\formdef{subtract-duration}{\categoryprocedure}{(subtract-duration \var{time} \var{time_d})} +\returns the result of subtracting \var{time_d} from \scheme{time} +\formdef{subtract-duration!}{\categoryprocedure}{(subtract-duration! \var{time} \var{time_d})} +\returns the result of subtracting \var{time_d} from \scheme{time} +\listlibraries +\endentryheader + +For \scheme{time-difference}, \var{time_1} and \var{time_2} must +have the same time type, and the result is a time object with +time type \scheme{time-duration}. +For \scheme{add-duration}, \scheme{add-duration!}, +\scheme{subtract-duration}, and \scheme{subtract-duration!}, +\var{time_d} must have time type \scheme{time-duration}, +and the result is a time object with the same time type as +\var{time}. +\scheme{time-difference!}, \scheme{add-duration!}, and +\scheme{subtract-duration!} are potentially destructive, i.e., each +might modify and return its first argument, or it might allocate a +new time object. + +\schemedisplay +(let ([delay (make-time 'time-duration 0 1)]) + (let ([t1 (current-time 'time-monotonic)]) + (sleep delay) + (let ([t2 (current-time 'time-monotonic)]) + (let ([t3 (time-difference t2 t1)]) + (and + (eq? (time-type t3) 'time-duration) + (time>=? t3 delay) + (time=? (add-duration t1 t3) t2) + (time=? (subtract-duration t2 t3) t1)))))) ;=> #t +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-date}{\categoryprocedure}{(current-date)} +\formdef{current-date}{\categoryprocedure}{(current-date \var{offset})} +\returns a date object representing the current date +\listlibraries +\endentryheader + +\var{offset} represents the time-zone offset in seconds east of UTC, +as described above. +It must be an exact integer in the range $-86400$ to +$+86400$, inclusive and defaults to the local time-zone offset. +UTC may be obtained by passing an offset of zero. + +If \var{offset} is not provided, then the current time zone's offset +is used, and \scheme{date-dst?} and \scheme{date-zone-name} report +information about the time zone. If \var{offset} is provided, then +\scheme{date-dst?} and \scheme{date-zone-name} on the resulting date +object produce \scheme{#f}. + +The following examples assume the local time zone is EST. + +\schemedisplay +(current-date) ;=> # +(current-date 0) ;=> # + +(date-zone-name (current-date)) ;=> "EST" \var{or other system-provided string} +(date-zone-name (current-date 0)) ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-date}{\categoryprocedure}{(make-date \var{nsec} \var{sec} \var{min} \var{hour} \var{day} \var{mon} \var{year})} +\formdef{make-date}{\categoryprocedure}{(make-date \var{nsec} \var{sec} \var{min} \var{hour} \var{day} \var{mon} \var{year} \var{offset})} +\returns a date object +\listlibraries +\endentryheader + +\var{nsec} represents nanoseconds and must be an exact nonnegative integer +less than $10^9$. +\var{sec} represents seconds and must be an exact nonnegative integer +less than 62. +\var{min} represents minutes and must be an exact nonnegative integer +less than 60. +\var{hour} must be an exact nonnegative integer less than 24. +\var{day} must be an exact integer, $1\leq day\leq 31$. +(The actual upper limit may be less depending on the month and year.) +\var{mon} represents the month must be an exact integer, $1\leq mon\leq 12$. +\var{year} must be an exact integer. +It should be at least 1970. +\var{offset} represents the time-zone offset in seconds east of UTC, +as described above. +It must be an exact integer in the range $-86400$ to $+86400$, inclusive. +UTC may be specified by passing an offset of zero. + +If \var{offset} is not provided, then the current time zone's offset +is used, and \scheme{date-dst?} and \scheme{date-zone-name} report +information about the time zone. If \var{offset} is provided, then +\scheme{date-dst?} and \scheme{date-zone-name} on the resulting date +object produce \scheme{#f}. + +\schemedisplay +(make-date 0 0 0 0 1 1 1970 0) ;=> # +(make-date 0 30 7 9 23 9 2007 -14400) ;=> # + +(date-zone-name (make-date 0 30 7 9 23 9 2007 -14400)) ;=> #f +(string? (date-zone-name (make-date 0 30 7 9 23 9 2007))) ;=> #t +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{date?}{\categoryprocedure}{(date? \var{obj})} +\returns \scheme{#t} if \var{obj} is a date object, \scheme{#f} otherwise +\listlibraries +\endentryheader + +\noskip\schemedisplay +(date? (current-date)) +(date? (make-date 0 30 7 9 23 9 2007 -14400)) +(date? "Sun Sep 23 09:07:30 2007") ;=> #f +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{date-nanosecond}{\categoryprocedure}{(date-nanosecond \var{date})} +\returns the nanosecond of \var{date} +\formdef{date-second}{\categoryprocedure}{(date-second \var{date})} +\returns the second of \var{date} +\formdef{date-minute}{\categoryprocedure}{(date-minute \var{date})} +\returns the minute of \var{date} +\formdef{date-hour}{\categoryprocedure}{(date-hour \var{date})} +\returns the hour of \var{date} +\formdef{date-day}{\categoryprocedure}{(date-day \var{date})} +\returns the day of \var{date} +\formdef{date-month}{\categoryprocedure}{(date-month \var{date})} +\returns the month of \var{date} +\formdef{date-year}{\categoryprocedure}{(date-year \var{date})} +\returns the year of \var{date} +\formdef{date-zone-offset}{\categoryprocedure}{(date-zone-offset \var{date})} +\returns the time-zone offset of \var{date} +\listlibraries +\endentryheader + +\var{date} must be a date object. + +\schemedisplay +(define d (make-date 0 30 7 9 23 9 2007 -14400)) +(date-nanosecond d) ;=> 0 +(date-second d) ;=> 30 +(date-minute d) ;=> 7 +(date-hour d) ;=> 9 +(date-day d) ;=> 23 +(date-month d) ;=> 9 +(date-year d) ;=> 2007 +(date-zone-offset d) ;=> -14400 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{date-week-day}{\categoryprocedure}{(date-week-day \var{date})} +\returns the week-day of \var{date} +\formdef{date-year-day}{\categoryprocedure}{(date-year-day \var{date})} +\returns the year-day of \var{date} +\listlibraries +\endentryheader + +These procedures allow the day-of-week or day-of-year to be determined for +the date represented by \var{date}. +A week-day is an exact nonnegative integer less than 7, where +0 represents Sunday, 1 represents Monday, and so on. +A year-day is an exact nonnegative integer less than 367, where +0 represents the first day of the year (January 1), 1 the +second day, 2 the third, and so on. + +\schemedisplay +(define d1 (make-date 0 0 0 0 1 1 1970 -18000)) +d1 ;=> # +(date-week-day d1) ;=> 4 +(date-year-day d1) ;=> 0 + +(define d2 (make-date 0 30 7 9 23 9 2007 -14400)) +d2 ;=> # +(date-week-day d2) ;=> 0 +(date-year-day d2) ;=> 265 +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{date-dst?}{\categoryprocedure}{(date-dst? \var{date})} +\returns whether \var{date} is in Daylight Saving Time +\formdef{date-zone-name}{\categoryprocedure}{(date-zone-name \var{date})} +\returns \scheme{#f} or a string naming the time zone of \var{date} +\listlibraries +\endentryheader + +These procedures report time-zone information for +the date represented by \var{date} for a date object that +is constructed without an explicit time-zone offset. When +a date object is created instead with explicit time-zone offset, +these procedures produce \scheme{#f}. + +Daylight Saving Time status for the current time zone and a name +string for the time zone are computed using platform-specific routines. +In particular, the format of the zone name is platform-specific. + +\schemedisplay +(define d (make-date 0 30 7 9 23 9 2007)) +(date-zone-offset d) ;=> -14400 \var{assuming Eastern U.S. time zone} +(date-dst? d) ;=> #t +(date-zone-name d) ;=> "EDT" \var{or some system-provided string} +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{time-utc->date}{\categoryprocedure}{(time-utc->date \var{time})} +\formdef{time-utc->date}{\categoryprocedure}{(time-utc->date \var{time} \var{offset})} +\returns a date object corresponding to \var{time} +\formdef{date->time-utc}{\categoryprocedure}{(date->time-utc \var{date})} +\returns a time object corresponding to \var{date} +\listlibraries +\endnoskipentryheader + +These procedures are used to convert between time and date objects. +The \var{time} argument to \scheme{time-utc->date} must have time-type +\scheme{utc}, and \scheme{date->time-utc} always returns a time +object with time-type \scheme{utc}. + +For \scheme{time-utc->date}, +\var{offset} represents the time-zone offset in seconds east of UTC, +as described at the beginning of this section. +It must be an exact integer in the range $-86400$ to +$+86400$, inclusive and defaults to the local time-zone offset. +UTC may be obtained by passing an offset of zero. + +If \var{offset} is not provided to \scheme{time-utc->date}, then the current time zone's offset +is used, and \scheme{date-dst?} and \scheme{date-zone-name} report +information about the time zone. If \var{offset} is provided, then +\scheme{date-dst?} and \scheme{date-zone-name} on the resulting date +object produce \scheme{#f}. + +\schemedisplay +(define d (make-date 0 30 7 9 23 9 2007 -14400)) +(date->time-utc d) ;=> # +(define t (make-time 'time-utc 0 1190552850)) +(time-utc->date t) ;=> # +(time-utc->date t 0) ;=> # +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{date-and-time}{\categoryprocedure}{(date-and-time)} +\formdef{date-and-time}{\categoryprocedure}{(date-and-time \var{date})} +\returns a string giving the current date and time +\listlibraries +\endnoskipentryheader + +The string is always in the format illustrated by the examples below and +always has length 24. + +\schemedisplay +(date-and-time) ;=> "Fri Jul 13 13:13:13 2001" +(define d (make-date 0 0 0 0 1 1 2007 0)) +(date-and-time d) ;=> "Mon Jan 01 00:00:00 2007" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sleep}{\categoryprocedure}{(sleep \var{time})} +\returns unspecified +\listlibraries +\endnoskipentryheader + +\var{time} must be a time object with type \scheme{time-duration}. +\var{sleep} causes the invoking thread to suspend operation for +approximately the amount of time indicated by the time object, unless +the process receives a signal that interrupts the sleep operation. +The actual time slept depends on the granularity of the system clock +and how busy the system is running other threads and processes. + + +\section{Timing and Statistics\label{SECTMISCSTATISTICS}} + +This section documents procedures for timing computations. +The \scheme{current-time} procedure described in +Section~\ref{SECTSYSTEMTIMESNDATES} may also be used to +time computations. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{time}{\categorysyntax}{(time \var{expr})} +\returns the values of \var{expr} +\listlibraries +\endnoskipentryheader + +\noindent +\scheme{time} evaluates \var{expr} and, as a side-effect, prints (to the +console-output port) the amount of cpu time, the amount of real time, +the number of bytes allocated, and the amount of collection overhead +associated with evaluating \var{expr}. + +\schemedisplay +> (time (collect)) +(time (collect)) + 1 collection + 1 ms elapsed cpu time, including 1 ms collecting + 1 ms elapsed real time, including 1 ms collecting + 160 bytes allocated, including 8184 bytes reclaimed +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{display-statistics}{\categoryprocedure}{(display-statistics)} +\formdef{display-statistics}{\categoryprocedure}{(display-statistics \var{textual-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +This procedure displays a running total of the amount of +cpu time, real time, bytes allocated, and collection overhead. +If \var{textual-output-port} is not supplied, it defaults to the current output port. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cpu-time}{\categoryprocedure}{(cpu-time)} +\returns the amount of cpu time consumed since system start-up +\listlibraries +\endentryheader + +\noindent +The amount is in milliseconds. +The amount includes ``system'' as well as ``user'' time, i.e., time +spent in the kernel on behalf of the process as well as time spent in +the process itself. + +See also \scheme{current-time}, which returns more precise information. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{real-time}{\categoryprocedure}{(real-time)} +\returns the amount of real time that has elapsed since system start-up +\listlibraries +\endentryheader + +\noindent +The amount is in milliseconds. + +See also \scheme{current-time}, which returns more precise information. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytes-allocated}{\categoryprocedure}{(bytes-allocated)} +\formdef{bytes-allocated}{\categoryprocedure}{(bytes-allocated \var{g})} +\returns the number of bytes currently allocated +\listlibraries +\endentryheader + +If \var{g} is supplied, \scheme{bytes-allocated} returns the number of +bytes currently allocated for Scheme objects in the specified generation. +\var{g} must be a nonnegative exact integer no greater than the +maximum nonstatic generation, i.e., the +value returned by \scheme{collect-maximum-generation}, or the symbol +\scheme{static}. +If \var{g} is not supplied, \scheme{bytes-allocated} returns the total +number of bytes allocated in all generations. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{initial-bytes-allocated}{\categoryprocedure}{(initial-bytes-allocated)} +\returns the total number of bytes allocated after loading boot files +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{bytes-deallocated}{\categoryprocedure}{(bytes-deallocated)} +\returns the total number of bytes deallocated by the garbage collector +\listlibraries +\endentryheader + +The total number of bytes allocated by the current process, whether +still in use or not, can be obtained by summing +\scheme{(bytes-deallocated)} and \scheme{(bytes-allocated)} +and possibly subtracting \scheme{(initial-bytes-allocated)}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{current-memory-bytes}{\categoryprocedure}{(current-memory-bytes)} +\returns the total number of bytes currently allocated, including overhead +\listlibraries +\endentryheader + +\scheme{current-memory-bytes} returns the total size of the heap +in bytes, including not only the bytes occupied for Scheme objects +but also various forms of overhead, including fragmentation and +reserved but not currently occupied memory, and is thus an accurate +measure of the amount of heap memory currently reserved from the +operating system for the current process. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{maximum-memory-bytes}{\categoryprocedure}{(maximum-memory-bytes)} +\returns the maximum number of bytes ever allocated, including overhead +\listlibraries +\endentryheader + +\scheme{maximum-memory-bytes} returns the maximum size of the heap +in bytes, i.e., the maximum value that \scheme{current-memory-bytes} +returned or could have returned, since the last call to +\scheme{reset-maximum-memory-bytes!} or, if there has been no such +call, since the process started. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{reset-maximum-memory-bytes!}{\categoryprocedure}{(reset-maximum-memory-bytes!)} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{reset-maximum-memory-bytes!} resets the maximum recorded size +of the heap to the current size of the heap. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{collections}{\categoryprocedure}{(collections)} +\returns the number garbage collections so far +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{statistics}{\categoryprocedure}{(statistics)} +\returns a sstats record containing current statistics +\listlibraries +\endentryheader + +\noindent +\scheme{statistics} packages together various timing and allocation +statistics into a single \scheme{sstats} record. +A \scheme{sstats} record has the following fields: + +\begin{description} +\item[\scheme{cpu},] the cpu time consumed, +\item[\scheme{real},] the elapsed real time, +\item[\scheme{bytes},] the number of bytes allocated, +\item[\scheme{gc-count},] the number of collections, +\item[\scheme{gc-cpu},] the cpu time consumed during collections, +\item[\scheme{gc-real},] the elapsed real time during collections, and +\item[\scheme{gc-bytes},] the number of bytes reclaimed by the collector. +\end{description} + +\noindent +All values are computed since system start-up. +The time values are time objects (Section~\ref{SECTSYSTEMTIMESNDATES}), +and the bytes and count values are exact integers. + +\scheme{statistics} might be defined as follows: + +\schemedisplay +(define statistics + (lambda () + (make-sstats + (current-time 'time-thread) + (current-time 'time-monotonic) + (- (+ (bytes-allocated) (bytes-deallocated)) + (initial-bytes-allocated)) + (collections) + (current-time 'time-collector-cpu) + (current-time 'time-collector-real) + (bytes-deallocated)))) +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-sstats}{\categoryprocedure}{(make-sstats \var{cpu} \var{real} \var{bytes} \var{gc-count} \var{gc-cpu} \var{gc-real} \var{gc-bytes})} +\returns a sstats record +\listlibraries +\endentryheader + +The time arguments (\var{cpu}, \var{real}, \var{gc-cpu}, and \var{gc-real}) must be time objects. +The other arguments must be exact integers. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sstats?}{\categoryprocedure}{(sstats? \var{obj})} +\returns \scheme{#t} if \var{obj} is a sstats record, otherwise \scheme{#f} +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sstats-cpu}{\categoryprocedure}{(sstats-cpu \var{s})} +\formdef{sstats-real}{\categoryprocedure}{(sstats-real \var{s})} +\formdef{sstats-bytes}{\categoryprocedure}{(sstats-bytes \var{s})} +\formdef{sstats-gc-count}{\categoryprocedure}{(sstats-gc-count \var{s})} +\formdef{sstats-gc-cpu}{\categoryprocedure}{(sstats-gc-cpu \var{s})} +\formdef{sstats-gc-real}{\categoryprocedure}{(sstats-gc-real \var{s})} +\formdef{sstats-gc-bytes}{\categoryprocedure}{(sstats-gc-bytes \var{s})} +\returns the value of the corresponding field of \var{s} +\listlibraries +\endentryheader + +\noindent +\var{s} must be a sstats record. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-sstats-cpu!}{\categoryprocedure}{(set-sstats-cpu! \var{s} \var{new-value})} +\formdef{set-sstats-real!}{\categoryprocedure}{(set-sstats-real! \var{s} \var{new-value})} +\formdef{set-sstats-bytes!}{\categoryprocedure}{(set-sstats-bytes! \var{s} \var{new-value})} +\formdef{set-sstats-gc-count!}{\categoryprocedure}{(set-sstats-gc-count! \var{s} \var{new-value})} +\formdef{set-sstats-gc-cpu!}{\categoryprocedure}{(set-sstats-gc-cpu! \var{s} \var{new-value})} +\formdef{set-sstats-gc-real!}{\categoryprocedure}{(set-sstats-gc-real! \var{s} \var{new-value})} +\formdef{set-sstats-gc-bytes!}{\categoryprocedure}{(set-sstats-gc-bytes! \var{s} \var{new-value})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{s} must be a sstats record, the \var{new-value} arguments for the time fields +(\var{cpu}, \var{real}, \var{gc-cpu}, and \var{gc-real}) +must be time objects, and +the other \var{new-value} arguments must be exact integers. +Each procedure sets the value of the corresponding field of \var{s} to +\var{new-value}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sstats-difference}{\categoryprocedure}{(sstats-difference \var{s_1} \var{s_2})} +\returns a sstats record representing the difference between \var{s_1} and \var{s_2} +\listlibraries +\endentryheader + +\noindent +\var{s_1} and \var{s_2} must be sstats records. +\scheme{sstats-difference} subtracts each field of \var{s_2} from the +corresponding field of \var{s_1} to produce the resulting \scheme{sstats} +record. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{sstats-print}{\categoryprocedure}{(sstats-print \var{s})} +\formdef{sstats-print}{\categoryprocedure}{(sstats-print \var{s} \var{textual-output-port})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{s} must be a \scheme{sstats} record. +If \var{textual-output-port} is not supplied, it defaults to the current output port. +\scheme{sstats-print} displays the fields of \scheme{s} in a manner similar +to \scheme{display-statistics} and \scheme{time}. + +%---------------------------------------------------------------------------- + +\entryheader +\formdef{enable-object-counts}{\categoryglobalparameter}{enable-object-counts} +\listlibraries +\endentryheader + +The value of \scheme{enable-object-counts} is a boolean value that +determines whether the collector records object counts as it runs and +hence whether the object counts returned by the procedure +\scheme{object-counts} are accurate. +The parameter is set to \scheme{#f} by default, since enabling object +counts adds overhead to collection. + +Counts for the static generation are always correct. +Counts for a nonstatic generation $n$ are correct immediately after a +collection of generation $m\ge n$ (regardless of whether the target +generation is $m$ or $m+1$) if \scheme{enable-object-counts} +was set to \scheme{#t} during the collection. + +One strategy for collecting object counts with minimal overhead is +to enable object counts only while collecting the maximum nonstatic +generation and to obtain the object counts immediately after that +collection. + +\entryheader +\formdef{object-counts}{\categoryprocedure}{(object-counts)} +\returns see below +\listlibraries +\endentryheader + +The procedure \scheme{object-counts} returns a nested association list +representing object counts and bytes allocated for each heap-allocated +primitive type and record type with at least one live instance in one +or more generations. +(Heap-allocated primitive types include, e.g., pairs and vectors, but +not, e.g., fixnums or characters.) +Object counts are gathered by the collector only when +\scheme{enable-object-counts} is \scheme{#t}. +The description of \scheme{enable-object-counts} details the +circumstances under which the counts are accurate. + +The association list returned by \scheme{object-counts} has the following +structure: + +\schemedisplay +((\var{type} (\var{generation} \var{count} . \var{bytes}) \dots) \dots) +\endschemedisplay + +\var{type} is either the name of a primitive type, represented as a +symbol, e.g., \scheme{pair}, or a record-type descriptor (rtd). +\var{generation} is a nonnegative fixnum between 0 and the value +of \scheme{(collect-maximum-generation)}, inclusive, or the symbol +\scheme{static} representing the static generation. +\var{count} and \var{bytes} are nonnegative fixnums. + +\schemedisplay +(collect-request-handler void) +(enable-object-counts #t) +(define-record-type frob (fields x)) +(define x (make-frob (make-frob #f))) +(collect 3 3) +(cdr (assoc 3 + (cdr (assoc (record-type-descriptor frob) + (object-counts))))) ;=> (2 . 16) +\endschemedisplay + +\section{Cost Centers\label{SECTMISCCOSTCENTERS}} + +Cost centers are used to track the bytes allocated, instructions executed, +and/or cpu time elapsed while evaluating selected sections of code. +Cost centers are created via the procedure \scheme{make-cost-center}, and +costs are tracked via the procedure \scheme{with-cost-center}. + +Allocation and instruction counts are tracked only for code instrumented +for that purpose. +This instrumentation is controlled by two parameters: \scheme{generate-allocation-counts} +and \scheme{generate-instruction-counts}. +Instrumentation is disabled by default. +Built in procedures are not instrumented, nor is interpreted code or +non-Scheme code. +Elapsed time is tracked only when the optional \scheme{timed?} argument to +\scheme{with-cost-center} is provided and is not false. + +The \scheme{with-cost-center} procedure accurately tracks costs, subject +to the caveats above, even when reentered with the same cost center, used +simultaneously in multiple threads, and exited or reentered one or more +times via continuation invocation. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{generate-allocation-counts}{\categorythreadparameter}{generate-allocation-counts} +\listlibraries +\endnoskipentryheader + +When this parameter has a true value, the compiler inserts a short sequence of +instructions at each allocation point in generated code to track the amount of +allocation that occurs. +This parameter is initially false. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{generate-instruction-counts}{\categorythreadparameter}{generate-instruction-counts} +\listlibraries +\endnoskipentryheader + +When this parameter has a true value, the compiler inserts a short +sequence of instructions in each block of generated code to track the +number of instructions executed by that block. +This parameter is initially false. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-cost-center}{\categoryprocedure}{(make-cost-center)} +\returns a new cost center +\listlibraries +\endentryheader + +The recorded costs of the new cost center are initialized to zero. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cost-center?}{\categoryprocedure}{(cost-center? \var{obj})} +\returns \scheme{#t} if \var{obj} is a cost center, otherwise \scheme{#f} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-cost-center}{\categoryprocedure}{(with-cost-center \var{cost-center} \var{thunk})} +\formdef{with-cost-center}{\categoryprocedure}{(with-cost-center \var{timed?} \var{cost-center} \var{thunk})} +\returns see below +\listlibraries +\endentryheader + +\var{thunk} must be a procedure that accepts zero arguments. +\scheme{with-cost-center} invokes \var{thunk} without arguments and +returns its values. +It also tracks, dynamically, the bytes allocated, instructions executed, +and cpu time elapsed while evaluating the invocation of \var{thunk} and +adds the tracked costs to the cost center's running record of these costs. + +As described above, allocation counts are tracked only for code +compiled with the parameter \scheme{generate-allocation-counts} set +to true, and instruction counts are tracked only for code compiled +with \scheme{generate-instruction-counts} set to true. +Cpu time is tracked only if \var{timed?} is provided and not false and +includes cpu time spent in instrumented, uninstrumented, and non-Scheme +code. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cost-center-instruction-count}{\categoryprocedure}{(cost-center-instruction-count \var{cost-center})} +\returns the number of instructions tracked by \var{cost-center} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cost-center-allocation-count}{\categoryprocedure}{(cost-center-allocation-count \var{cost-center})} +\returns the number of allocated bytes tracked by \var{cost-center} +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{cost-center-time}{\categoryprocedure}{(cost-center-time \var{cost-center})} +\returns the cpu time tracked by \var{cost-center} +\listlibraries +\endentryheader + +The cpu time is returned as a time object with time-type \scheme{time-duration}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{reset-cost-center!}{\categoryprocedure}{(reset-cost-center! \var{cost-center})} +\returns unspecified +\listlibraries +\endentryheader + +This procedure resets the costs recorded by \var{cost-center} to zero. + + +\section{Parameters\label{SECTPARAMETERS}} + +This section describes mechanisms for creating and manipulating parameters. +New parameters may be created conveniently with \scheme{make-parameter}. +Nothing distinguishes parameters from other +procedures, however, except for their behavior. +If more complicated actions must be taken when a parameter is invoked +than can be accommodated easily through the \scheme{make-parameter} mechanism, +the parameter may be defined directly with \scheme{case-lambda}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{make-parameter}{\categoryprocedure}{(make-parameter \var{object})} +\formdef{make-parameter}{\categoryprocedure}{(make-parameter \var{object} \var{procedure})} +\returns a parameter (procedure) +\listlibraries +\endentryheader + +\noindent +\scheme{make-parameter} accepts one or two arguments. +The first argument is the initial value of the internal variable, and +the second, if present, is a \emph{filter} applied to the initial value +and all subsequent values. +The filter should accept one argument. +If the value is not appropriate, the filter should raise an exception or +convert the value into a more appropriate form. + +For example, the default value of \scheme{print-length} is defined as +follows: + +\schemedisplay +(define print-length + (make-parameter + #f + (lambda (x) + (unless (or (not x) (and (fixnum? x) (fx>= x 0))) + (assertion-violationf 'print-length + "~s is not a positive fixnum or #f" + x)) + x))) +\endschemedisplay + +\schemedisplay +(print-length) ;=> #f +(print-length 3) +(print-length) ;=> 3 +(format "~s" '(1 2 3 4 5 6)) ;=> "(1 2 3 ...)" +(print-length #f) +(format "~s" '(1 2 3 4 5 6)) ;=> "(1 2 3 4 5 6)" +\endschemedisplay + +The definition of \scheme{make-parameter} is straightforward using +\index{\scheme{case-lambda}}\scheme{case-lambda}: + +\schemedisplay +(define make-parameter + (case-lambda + [(init guard) + (let ([v (guard init)]) + (case-lambda + [() v] + [(u) (set! v (guard u))]))] + [(init) + (make-parameter init (lambda (x) x))])) +\endschemedisplay + +In threaded versions of {\ChezScheme}, \scheme{make-parameter} creates +global parameters. +The procedure \scheme{make-thread-parameter}, described in +Section~\ref{SECTTHREADPARAMETERS}, may be used to make thread +parameters. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{parameterize}{\categorysyntax}{(parameterize ((\var{param} \var{expr}) \dots) \var{body_1} \var{body_2} \dots)} +\returns the values of the body \scheme{\var{body_1} \var{body_2} \dots} +\listlibraries +\endentryheader + +\noindent +Using the syntactic form \scheme{parameterize}, the values of parameters can +be changed in a manner analogous to \scheme{fluid-let} for ordinary variables. +Each \var{param} is set to the value of the corresponding +\var{expr} while the body is evaluated. +When control leaves the body by normal return or by the invocation of a +continuation created outside of the body, the parameters are restored to +their original values. +If control returns to the body via a continuation created during the +execution of the body, the parameters are again set to their temporary +values. + +\schemedisplay +(define test + (make-parameter 0)) +(test) ;=> 0 +(test 1) +(test) ;=> 1 +(parameterize ([test 2]) + (test)) ;=> 2 +(test) ;=> 1 +(parameterize ([test 2]) + (test 3) + (test)) ;=> 3 +(test) ;=> 1 +(define k (lambda (x) x)) +(begin (set! k (call/cc k)) + 'k) ;=> k +(parameterize ([test 2]) + (test (call/cc k)) + (test)) ;=> k +(test) ;=> 1 +(k 3) ;=> 3 +(test) ;=> 1 +\endschemedisplay + +The definition of \scheme{parameterize} is similar to the definition of +\scheme{fluid-let} (page~\pageref{defn:fluid-let}): + +\schemedisplay +(define-syntax parameterize + (lambda (x) + (syntax-case x () + [(_ () b1 b2 ...) #'(begin b1 b2 ...)] + [(_ ((x e) ...) b1 b2 ...) + (with-syntax ([(p ...) (generate-temporaries #'(x ...))] + [(y ...) (generate-temporaries #'(x ...))]) + #'(let ([p x] ... [y e] ...) + (let ([swap (lambda () + (let ([t (p)]) (p y) (set! y t)) + ...)]) + (dynamic-wind swap (lambda () b1 b2 ...) swap))))]))) +\endschemedisplay + +\section{Virtual registers\label{SECTVIRTUALREGISTERS}} + +A limited set of \emph{virtual registers} is supported by the compiler +for use by programs that require high-speed, global, and mutable storage +locations. +Referencing or assigning a virtual register is potentially faster and +never slower than accessing an assignable local or global variable, +and the code sequences for doing so are generally smaller. +Assignment is potentially significantly faster because there is no need +to track pointers from the virtual registers to young objects, as there +is for variable locations that might reside in older generations. +On threaded versions of the system, virtual registers are ``per thread'' +and thus serve as thread-local storage in a manner that is less expensive +than thread parameters. + +The interface consists of three procedures: \scheme{virtual-register-count}, +which returns the number of virtual registers, \scheme{set-virtual-register!}, +which sets the value of a specified virtual register, and +\scheme{virtual-register}, which retrieves the value of a specified +virtual register. + +A virtual register is specified by a nonnegative fixnum index less than +the number of virtual registers. +To get optimal performance for \scheme{set-virtual-register!} +and \scheme{virtual-register}, the index should be a constant +embedded right in the call (or propagatable via optimization to the +call). +To avoid putting these constants in the source code, programmers should +consider using identifier macros to give names to virtual registers, e.g.: + +\schemedisplay +(define-syntax current-state + (identifier-syntax + [id (virtual-register 0)] + [(set! id e) (set-virtual-register! 0 e)])) +(set! current-state 'start) +current-state ;=> start +\endschemedisplay + +A more elaborate macro could dole out indices at compile time and complain +when no more indices are available. + +Virtual-registers must be treated as an application-level resource, i.e., +libraries intended to be used by multiple applications should generally +not use virtual registers to avoid conflicts with an application's use of +the registers. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{virtual-register-count}{\categoryprocedure}{(virtual-register-count)} +\returns the number of virtual registers +\listlibraries +\endentryheader + +As of Version~9.0, the number of virtual registers is set at 16. +It cannot be changed except by recompiling {\ChezScheme} from +source. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{set-virtual-register!}{\categoryprocedure}{(set-virtual-register! \var{k} \var{x})} +\returns unspecified +\listlibraries +\endentryheader + +\scheme{set-virtual-register!} stores \var{x} in virtual register \var{k}. +\var{k} must be a nonnegative fixnum less than the value of +\scheme{(virtual-register-count)}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{virtual-register}{\categoryprocedure}{(virtual-register \var{k})} +\returns see below +\listlibraries +\endentryheader + +\scheme{virtual-register} returns the value most recently +stored in virtual register \var{k} (on the current thread, in +threaded versions of the system). + + +\section{Environmental Queries and Settings\label{SECTSYSTEMENV}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{scheme-version}{\categoryprocedure}{(scheme-version)} +\returns a version string +\listlibraries +\endentryheader + +The version string is in the form + +\schemedisplay +"Chez Scheme Version \var{version}" +\endschemedisplay + +for {\ChezScheme}, and + +\schemedisplay +"Petite Chez Scheme Version \var{version}" +\endschemedisplay + +for {\PetiteChezScheme}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{scheme-version-number}{\categoryprocedure}{(scheme-version-number)} +\returns three values: the major, minor, and sub-minor version numbers +\listlibraries +\endentryheader + +Each of the three return values is a nonnegative fixnum. + +In {\ChezScheme} Version 7.9.4: + +\schemedisplay +(scheme-version-number) ;=> 7 + ;== 9 + ;== 4 +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{petite?}{\categoryprocedure}{(petite?)} +\returns \scheme{#t} if called in {\PetiteChezScheme}, \scheme{#f} otherwise +\listlibraries +\endentryheader + +The only difference between {\PetiteChezScheme} and {\ChezScheme} is that +the compiler is not available in the former, so this predicate can serve as +a way to determine if the compiler is available. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{threaded?}{\categoryprocedure}{(threaded?)} +\returns \scheme{#t} if called in a threaded version of the system, \scheme{#f} otherwise +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{interactive?}{\categoryprocedure}{(interactive?)} +\returns \scheme{#t} if system is run interactively, \scheme{#f} otherwise +\listlibraries +\endentryheader + +This predicate returns \scheme{#t} if the Scheme process's +stdin and stdout are connected to a tty (Unix-based systems) or console +(Windows). +Otherwise, it returns \scheme{#f}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-process-id}{\categoryprocedure}{(get-process-id)} +\returns the operating system process id of the current process +\listlibraries +\endentryheader + + + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{getenv}{\categoryprocedure}{(getenv \var{key})} +\returns environment value of \var{key} or \scheme{#f} +\listlibraries +\endnoskipentryheader + +\noindent +\var{key} must be a string. +\scheme{getenv} returns the operating system shell's environment value +associated with \var{key}, or \scheme{#f} if no environment value +is associated with \var{key}. + +\schemedisplay +(getenv "HOME") ;=> "/u/freddy" +\endschemedisplay + +%---------------------------------------------------------------------------- +\entryheader +\formdef{putenv}{\categoryprocedure}{(putenv \var{key} \var{value})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{key} and \var{value} must be strings. + +\scheme{putenv} stores the \var{key}, \var{value} pair in the +environment of the process, +where it is available to the current process (e.g., via \var{getenv}) +and any spawned processes. + +\schemedisplay +(putenv "SCHEME" "rocks!") +(getenv "SCHEME") ;=> "rocks!" +\endschemedisplay + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-registry}{\categoryprocedure}{(get-registry \var{key})} +\returns registry value of \var{key} or \scheme{#f} +\formdef{put-registry!}{\categoryprocedure}{(put-registry! \var{key} \var{val})} +\formdef{remove-registry!}{\categoryprocedure}{(remove-registry! \var{key})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{key} and \var{val} must be strings. + +\scheme{get-registry} returns a string containing the registry +value of \var{key} if the value exists. +If no registry value for \var{key} exists, \scheme{get-registry} returns +\scheme{#f}. + +\scheme{put-registry!} sets the registry +value of \var{key} to \var{val}. +It raises an exception with condition type \scheme{&assertion} if the +value cannot be set, which may happen if +the user has insufficient access. + +\scheme{remove-registry!} removes the registry +key or value named by \var{key}. +It raises an exception with condition type \scheme{&assertion} if the +value cannot be removed. +Reasons for failure include the key not being present, the user having +insufficient access, or \var{key} being a key with subkeys. + +These routines are defined for Windows only. + +\schemedisplay +(get-registry "hkey_local_machine\\Software\\North\\South") ;=> #f +(put-registry! "hkey_local_machine\\Software\\North\\South" "east") +(get-registry "hkey_local_machine\\Software\\North\\South") ;=> "east" +(remove-registry! "hkey_local_machine\\Software\\North") +(get-registry "hkey_local_machine\\Software\\North\\South") ;=> #f +\endschemedisplay + + +\section{Subset Modes\label{SECTMISCSUBSETMODE}} + +\noskipentryheader +\formdef{subset-mode}{\categorythreadparameter}{subset-mode} +\listlibraries +\endnoskipentryheader + +\noindent +The value of this parameter +must be \scheme{#f} (the default) or the symbol \scheme{system}. +Setting \scheme{subset-mode} to \scheme{system} allows the manipulation +of various undocumented system variables, data structures, and +settings. +It is typically used only for system debugging. diff --git a/csug/threads.stex b/csug/threads.stex new file mode 100644 index 0000000..2fae720 --- /dev/null +++ b/csug/threads.stex @@ -0,0 +1,967 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Thread System\label{CHPTTHREADS}} + +\index{threads}This chapter describes the \emph{Chez Scheme} thread-system procedures +and syntactic forms. +With the exception of locks, locked increment, and locked decrement, +the features of the thread system are implemented on top of the Posix +thread system (pthreads) on non-Windows-based system and directly using +the Windows API on Windows-based systems. +Consult the appropriate documentation on your system for basic details +of thread creation and interaction. + +Most primitive Scheme procedures are \index{thread-safe primitives}\emph{thread-safe}, meaning +that they can be called concurrently from multiple threads. +This includes allocation operations like \var{cons} and \scheme{make-string}, +accessors like \scheme{car} and \scheme{vector-ref}, +numeric operators like \scheme{+} and \scheme{sqrt}, and nondestructive +higher-level primitive operators like \scheme{append} and \scheme{map}. + +Simple mutation operators, like \scheme{set-car!}, \scheme{vector-set!}, +and record field mutators are thread-safe. +Likewise, assignments to local variables, including assignments to +(unexported) library and top-level program variables are thread-safe. + +Other destructive operators are thread safe only if they are used to +operate on different objects from those being read or modified by other +threads. +For example, assignments to global variables are thread-safe only as +long as one thread does not assign the same variable another thread +references or assigns. +Similarly, \scheme{putprop} can be called in one thread while another +concurrently calls \scheme{putprop} or \scheme{getprop} if the symbols +whose property lists are being modified or accessed differ. + +In this context, most I/O operations should be considered destructive, +since they might modify a port's internal structure; see also +Section~\ref{SECTTHREADSBUFFEREDIO} for information on buffered ports. + +Use of operators that are not thread-safe without proper synchronization +can corrupt the objects upon which they operate. +This corruption can lead to incorrect behavior, memory faults, and even +unrecoverable errors that cause the system to abort. + +The compiler and interpreter are thread-safe to the extent that user code +evaluated during the compilation and evaluation process is thread-safe or +properly synchronized. +Thus, two or more threads +can call any of the compiler or interpreter entry points, i.e., +\scheme{compile}, \scheme{compile-file}, \scheme{compile-program}, \scheme{compile-script}, +\scheme{compile-port}, or \scheme{interpret} at the same time. +Naturally, the object-file targets of two file compilation operations that +run at the same time should be different. +The same is true for \scheme{eval} and \scheme{load} as long as +the default evaluator is used or is set explicitly to \scheme{compile}, +\scheme{interpret}, or some other thread-safe evaluator. + +One restriction should be observed when one of multiple threads creates or +loads compiled code, however, which is that only that thread or +subsequently created children, or children of subsequently created +children, etc., should run the code. +This is because multiple-processor systems upon which threaded code may +run might not guarantee that the data and instruction caches are +synchronized across processors. + +\section{Thread Creation} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{fork-thread}{\categoryprocedure}{(fork-thread \var{thunk})} +\returns a thread object +\listlibraries +\endnoskipentryheader + +\noindent +\var{thunk} must be a procedure that accepts zero arguments. + +\scheme{fork-thread} invokes \var{thunk} in a new thread and returns +a thread object. + +Nothing can be done with the thread object returned by +\scheme{fork-thread}, other than to print it. + +Threads created by foreign code using some means other than +\scheme{fork-thread} must call \scheme{Sactivate_thread} +(Section~\ref{SECTFOREIGNCLIB}) before touching any Scheme data +or calling any Scheme procedures. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{thread?}{\categoryprocedure}{(thread? \var{obj})} +\returns \scheme{#t} if \var{obj} is a thread object, \scheme{#f} otherwise +\listlibraries +\endentryheader + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{get-thread-id}{\categoryprocedure}{(get-thread-id)} +\returns the thread id of the current thread +\listlibraries +\endentryheader + +The thread id is a thread number assigned by thread id, and has no +relationship to the process id returned by +\index{\scheme{get-process-id}}\scheme{get-process-id}, which is the same +in all threads. + + +\section{Mutexes} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{make-mutex}{\categoryprocedure}{(make-mutex)} +\formdef{make-mutex}{\categoryprocedure}{(make-mutex \var{name})} +\returns a new mutex object +\listlibraries +\endnoskipentryheader + +\noindent +\var{name}, if supplied, must be a symbol which identifies the mutex, or +\scheme{#f} for no name. The name is printed every time the mutex is +printed, which is useful for debugging. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutex?}{\categoryprocedure}{(mutex? \var{obj})} +\returns \scheme{#t} if \var{obj} is a mutex, \scheme{#f} otherwise +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutex-acquire}{\categoryprocedure}{(mutex-acquire \var{mutex})} +\formdef{mutex-acquire}{\categoryprocedure}{(mutex-acquire \var{mutex} \var{block?})} +\returns see below +\listlibraries +\endentryheader + +\noindent +\var{mutex} must be a mutex. + +\var{mutex-acquire} acquires the mutex identified by \var{mutex}. +The optional boolean argument \var{block?} defaults to +\scheme{#t} and specifies whether the thread should block +waiting for the mutex. +If \var{block?} is omitted or is true, the thread +blocks until the mutex has been acquired, and an unspecified +value is returned. + +If \scheme{block?} is false and the mutex currently belongs +to a different thread, the current thread does not block. +Instead, \scheme{mutex-acquire} returns +immediately with the value \scheme{#f} to +indicate that the mutex is not available. +If \var{block?} is false and the mutex is successfully +acquired, \scheme{mutex-acquire} returns \scheme{#t}. + +Mutexes are \emph{recursive} in Posix threads terminology, which +means that the calling thread can use \scheme{mutex-acquire} to +(re)acquire a mutex it already has. +In this case, an equal number of \scheme{mutex-release} calls +is necessary to release the mutex. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutex-release}{\categoryprocedure}{(mutex-release \var{mutex})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{mutex} must be a mutex. + +\scheme{mutex-release} releases the mutex identified by \var{mutex}. +Unpredictable behavior results if the mutex is not owned by the +calling thread. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{with-mutex}{\categorysyntax}{(with-mutex \var{mutex} \var{body_1} \var{body_2} \dots)} +\returns the values of the body \scheme{\var{body_1} \var{body_2} \dots} +\listlibraries +\endentryheader + +\noindent +\scheme{with-mutex} evaluates the expression \var{mutex}, which must +evaluate to a mutex, acquires the mutex, evaluates the body +\scheme{\var{body_1} \var{body_2} \dots}, and releases the mutex. +The mutex is released whether the body returns normally or +via a control operation (that is, throw to a continuation, perhaps because +of an error) that results in +a nonlocal exit from the \scheme{with-mutex} form. +If control subsequently returns to the body via a +continuation invocation, the mutex is reacquired. + +Using \scheme{with-mutex} is generally more convenient and safer than using +\scheme{mutex-acquire} and \scheme{mutex-release} directly. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{mutex-name}{\categoryprocedure}{(mutex-name \var{mutex})} +\returns the name associated with \var{mutex}, if any; otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\var{mutex} must be a mutex. + +\section{Conditions} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{make-condition}{\categoryprocedure}{(make-condition)} +\formdef{make-condition}{\categoryprocedure}{(make-condition \var{name})} +\returns a new condition object +\listlibraries +\endnoskipentryheader + +\noindent +\var{name}, if supplied, must be a symbol which identifies the condition +object, or \scheme{#f} for no name. The name is printed every time the +condition is printed, which is useful for debugging. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{thread-condition?}{\categoryprocedure}{(thread-condition? \var{obj})} +\returns \scheme{#t} if \var{obj} is a condition object, \scheme{#f} otherwise +\listlibraries +\endentryheader + +%---------------------------------------------------------------------------- +\entryheader +\formdef{condition-wait}{\categoryprocedure}{(condition-wait \var{cond} \var{mutex})} +\formdef{condition-wait}{\categoryprocedure}{(condition-wait \var{cond} \var{mutex} \var{timeout})} +\returns \scheme{#t} if the calling thread was awakened by the condition, \scheme{#f} if the calling thread timed out waiting +\listlibraries +\endentryheader + +\noindent +\var{cond} must be a condition object, and +\var{mutex} must be a mutex. +The optional argument \var{timeout} is a time record of type +\scheme{time-duration} or \scheme{time-utc}, or \scheme{#f} for no +timeout. It defaults to \scheme{#f}. + +\scheme{condition-wait} waits up to the specified \var{timeout} for +the condition identified by the condition object \var{cond}. +The calling thread must have acquired the mutex identified by the mutex +\var{mutex} at the time \scheme{condition-wait} is +called. +\var{mutex} is released as a side effect of the call to +\scheme{condition-wait}. +When a thread is later released from the condition variable by one of +the procedures described below or the timeout expires, \var{mutex} is +reacquired and \scheme{condition-wait} returns. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{condition-signal}{\categoryprocedure}{(condition-signal \var{cond})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{cond} must be a condition object. + +\scheme{condition-signal} releases one of the threads waiting for the +condition identified by \var{cond}. + + +%---------------------------------------------------------------------------- +\entryheader +\formdef{condition-broadcast}{\categoryprocedure}{(condition-broadcast \var{cond})} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +\var{cond} must be a condition object. + +\scheme{condition-broadcast} releases all of the threads waiting for the +condition identified by \var{cond}. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{condition-name}{\categoryprocedure}{(condition-name \var{condition})} +\returns the name associated with \var{condition}, if any; otherwise \scheme{#f} +\listlibraries +\endentryheader + +\noindent +\var{condition} must be a condition. + +\section{Locks\label{SECTTHREADLOCKS}} + +\index{locks}% +Locks are more primitive but more flexible and efficient than mutexes +and can be used in situations where the added mutex functionality +is not needed or desired. +They can also be used independently of the thread system +(including in nonthreaded versions of {\ChezScheme}) +to synchronize operations running in separate Scheme processes +as long as the lock is allocated in memory shared by the processes. + +A lock is simply a word-sized integer, i.e., an \scheme{iptr} or +\scheme{uptr} foreign type (Section~\ref{SECTFOREIGNDATA}) with the native +endianness of the target machine, possibly part of a larger structure +defined using \scheme{define-ftype} (page~\pageref{defn:define-ftype}). +It must be explicitly allocated in memory that resides outside the Scheme +heap and, when appropriate, explicitly deallocated. +When just threads are involved (i.e., when multiple processes are not +involved), the memory can be allocated via \scheme{foreign-alloc}. +When multiple processes are involved, the lock should be allocated in +some area shared by the processes that will interact with the lock. + +Once initialized using \scheme{ftype-init-lock!}, a process or thread +can attempt to lock the lock via \scheme{ftype-lock!} or \scheme{ftype-spin-lock!}. +Once the lock has been locked and before it is unlocked, further +attempts to lock the lock fail, even by the process or thread that +most recently locked it. +Locks can be unlocked, via \scheme{ftype-unlock!}, by any process or thread, +not just by the process or thread that most recently locked the lock. + +The lock mechanism provides little structure, and mistakes +in allocation and use can lead to memory faults, deadlocks, +and other problems. +Thus, it is usually advisable to use locks only as part of a +higher-level abstraction that ensures locks are used in a +disciplined manner. + +\schemedisplay +(define lock + (make-ftype-pointer uptr + (foreign-alloc (ftype-sizeof uptr)))) + +(ftype-init-lock! uptr () lock) +(ftype-lock! uptr () lock) ;=> #t +(ftype-lock! uptr () lock) ;=> #f +(ftype-unlock! uptr () lock) +(ftype-spin-lock! uptr () lock) +(ftype-lock! uptr () lock) ;=> #f +(ftype-unlock! uptr () lock) +\endschemedisplay + +\entryheader +\formdef{ftype-init-lock!}{\categorysyntax}{(ftype-init-lock! \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-init-lock!}{\categorysyntax}{(ftype-init-lock! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns unspecified +\formdef{ftype-lock!}{\categorysyntax}{(ftype-lock! \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-lock!}{\categorysyntax}{(ftype-lock! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns \scheme{#t} if the lock is not already locked, \scheme{#f} otherwise +\formdef{ftype-spin-lock!}{\categorysyntax}{(ftype-spin-lock! \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-spin-lock!}{\categorysyntax}{(ftype-spin-lock! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns unspecified +\formdef{ftype-unlock!}{\categorysyntax}{(ftype-unlock! \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-unlock!}{\categorysyntax}{(ftype-unlock! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns unspecified +\listlibraries +\endentryheader + +Each of these has a syntax like and behaves similarly to +\scheme{ftype-set!} (page~\pageref{defn:ftype-set!}), though with an implicit +\var{val-expr}. +In particular, the restrictions on and handling of \var{fptr-expr} +and the accessors \scheme{\var{a} \dots} is similar, with one important +restriction: the field specified by the last accessor, upon which +the form operates, must be a word-size integer, i.e., an +\scheme{iptr}, \scheme{uptr}, or the equivalent, with the native +endianness. + +\scheme{ftype-init-lock!} should be used to initialize the lock prior +to the use of any of the other operators; if this is not done, the +behavior of the other operators is undefined. + +\scheme{ftype-lock!} can be used to lock the lock. +If it finds the lock unlocked at the time of the operation, it locks +the lock and returns \scheme{#t}; if it finds the lock already locked, +it returns \scheme{#f} without changing the lock. + +\scheme{ftype-spin-lock!} can also be used to lock the lock. +If it finds the lock unlocked at the time of the operation, it locks the +lock and returns; if it finds the lock already locked, it waits until +the lock is unlocked, then locks the lock and returns. +If no other thread or process unlocks the lock, the operation does +not return and cannot be interrupted by normal means, including by the +storage manager for the purpose of initiating a garbage collection. +There are also no guarantees of fairness, so a process might hang +indefinitely even if other processes are actively locking and unlocking +the lock. + +\scheme{ftype-unlock!} is used to unlock a lock. +If it finds the lock locked, it unlocks the lock and returns. +Otherwise, it returns without changing the lock. + +\section{Locked increment and decrement\label{SECTTHREADLOCKEDINCRDECR}} + +The locked operations described here can be used when just an atomic +increment or decrement is required. + +\entryheader +\formdef{ftype-locked-incr!}{\categorysyntax}{(ftype-locked-incr! \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-locked-incr!}{\categorysyntax}{(ftype-locked-incr! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns \scheme{#t} if the updated value is 0, \scheme{#f} otherwise +\formdef{ftype-locked-decr!}{\categorysyntax}{(ftype-locked-decr! \var{ftype-name} (\var{a} ...) \var{fptr-expr})} +\formdef{ftype-locked-decr!}{\categorysyntax}{(ftype-locked-decr! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})} +\returns \scheme{#t} if the updated value is 0, \scheme{#f} otherwise +\listlibraries +\endentryheader + +Each of these has a syntax like and behaves similarly to +\scheme{ftype-set!} (page~\pageref{defn:ftype-set!}), though with an implicit +\var{val-expr}. +In particular, the restrictions on and handling of \var{fptr-expr} +and the accessors \scheme{\var{a} \dots} is similar, with one important +restriction: the field specified by the last accessor, upon which +the form operates, must be a word-size integer, i.e., an +\scheme{iptr}, \scheme{uptr}, or the equivalent, with the native +endianness. + +\scheme{ftype-locked-incr!} atomically reads the value of the specified +field, adds $1$ to the value, and writes the new value back into the +field. +Similarly, \scheme{ftype-locked-decr!} atomically reads the value of +the specified field, subtracts $1$ from the value, and writes the new +value back into the field. +Both return \scheme{#t} if the new value is 0, otherwise \scheme{#f}. + +\section{Reference counting with ftype guardians\label{SECTTHREADFTYPEGUARDIANS}} + +\index{\scheme{ftype-guardian}}% +Applications that manage memory outside the Scheme heap can leverage +the Scheme storage management system to help perform reference +counting via \emph{ftype guardians}. +In a reference-counted memory management system, each object holds +a count of pointers to it. +The count is incremented when a new pointer is created and decremented +when a pointer is dropped. +When the count reaches zero, the object is no longer needed and the +memory it formerly occupied can be made available for some other +purpose. + +Ftype guardians are similar to guardians created by +\index{\scheme{make-guardian}}\scheme{make-guardian} +(Section~\ref{SECTGUARDWEAKPAIRS}). +The \index{\scheme{guardian?}}\scheme{guardian?} procedure returns +true for both, and the +\index{\scheme{unregister-guardian}}\scheme{unregister-guardian} +procedure can be used to unregister objects registered with either. + +\entryheader +\formdef{ftype-guardian}{\categorysyntax}{(ftype-guardian \var{ftype-name})} +\returns a new ftype guardian +\listlibraries +\endentryheader + +\var{ftype-name} must name an ftype. +The first base field of the ftype (or one of the first base fields +in the case of unions) must be a word-sized integer (iptr or uptr) +with native endianness. +This field is assumed to hold a reference count. + +The return value is a new ftype guardian \var{g}, with which +ftype-pointers of type \var{ftype-name} (or some subtype of +\var{ftype-name}) can be registered. +An ftype pointer is registered with \var{g} by invoking \var{g} +with the ftype pointer as an argument. + +An ftype guardian does not automatically protect from collection +the ftype pointers registered with it, as a normal guardian would +do. +Instead, for each registered ftype pointer that becomes inaccessible +via normal (non-weak, non-guardian pointers), the guardian decrements +the reference count of the object to which the ftype pointer points. +If the resulting reference-count value is zero, the ftype pointer +is preserved and can be retrieved from the guardian. +If the resulting reference-count value is non-zero, however, the +ftype pointer is not preserved. +Objects retrieved from an ftype guardian (by calling it without +arguments) are guaranteed to have zero reference counts, assuming +reference counts are maintained properly by code outside the +collector. + +The collector decrements the reference count using the equivalent +of \index{\scheme{ftype-locked-decr!}}\scheme{ftype-locked-decr!} +to support systems in which non-Scheme objects are stored in memory +shared by multiple processes. +In such systems, programs should themselves use +\index{\scheme{ftype-locked-incr!}}\scheme{ftype-locked-incr!} and +\scheme{ftype-locked-decr!} or non-Scheme equivalents (e.g., the C +\index{\scheme{LOCKED_INCR}}\scheme{LOCKED_INCR} and +\index{\scheme{LOCKED_INCR}}\scheme{LOCKED_DECR} macros in scheme.h, +which are described in Section~\ref{SECTFOREIGNCLIB}) to maintain +reference counts. + +The following example defines a simple ftype and an allocator for +objects of that ftype that frees any objects of that ftype that were +previously allocated and no longer accessible. + +\schemedisplay +(module (A make-A free-dropped-As) + (define-ftype A + (struct + [refcount uptr] + [data int])) + (define g (ftype-guardian A)) + (define free-dropped-As + (lambda () + (let ([a (g)]) + (when a + (printf "freeing ~s\n" (ftype-ref A (data) a)) + (foreign-free (ftype-pointer-address a)) + (free-dropped-As))))) + (define make-A + (lambda (n) + (free-dropped-As) + (let ([a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))]) + (ftype-set! A (refcount) a 1) + (ftype-set! A (data) a n) + (g a) + a)))) +\endschemedisplay + +We can test this by allocating, dropping, and immediately collecting +ftype pointers to A. + +\schemedisplay +> (do ([i 10 (fx- i 1)]) + ((fx= i 0)) + (make-A i) + (collect)) +freeing 10 +freeing 9 +freeing 8 +freeing 7 +freeing 6 +freeing 5 +freeing 4 +freeing 3 +freeing 2 +> (free-dropped-As) +freeing 1 +\endschemedisplay + +Objects guarded by an ftype guardian might contain pointers to other +objects whose reference counts should also be incremented upon +allocation of the containing object and decremented upon freeing +of the containing object. + + +\section{Thread Parameters\label{SECTTHREADPARAMETERS}} + +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{make-thread-parameter}{\categoryprocedure}{(make-thread-parameter \var{object})} +\formdef{make-thread-parameter}{\categoryprocedure}{(make-thread-parameter \var{object} \var{procedure})} +\returns a new thread parameter +\listlibraries +\endnoskipentryheader + +\noindent +See Section~\ref{SECTPARAMETERS} for a general +discussion of parameters and the use of the optional second argument. + +When a thread parameter is created, a separate location is set aside +in each current and future thread to hold the value of the parameter's +internal state variable. +(This location may be eliminated by the storage manager when the +parameter becomes inaccessible.) +Changes to the thread parameter in one thread are not seen by any +other thread. + +When a new thread is created (see \scheme{fork-thread}), +the current value (not location) of each +thread parameter is inherited from the forking thread by the new thread. +Similarly, when a thread created by some other means is activated for the +first time (see \scheme{Sactivate_thread} in +Section~\ref{SECTFOREIGNCLIB}), the current value (not location) of each +thread parameter is inherited from the main (original) thread by the new +thread. + +Most built-in parameters are thread parameters, but some are global. +All are marked as global or thread where they are defined. +There is no distinction between built-in global and thread parameters +in the nonthreaded versions of the system. + + +\section{Buffered I/O\label{SECTTHREADSBUFFEREDIO}} + +Chez Scheme buffers file I/O operations for efficiency, but buffered +I/O is not thread safe. +Two threads that write to or read from the same buffered port concurrently +can corrupt the port, resulting in buffer overruns and, ultimately, +invalid memory references. + +Buffering on binary output ports can be disabled when opened with +buffer-mode \scheme{none}. +Buffering on input ports cannot be completely disabled, however, due to +the need to support lookahead, and buffering on textual ports, even +textual output ports, cannot be disabled completely because the +transcoders that convert between characters and bytes sometimes +require some lookahead. + +Two threads should thus \emph{never} read from or write to the same port +concurrently, except in the special case of a binary output port +opened buffer-mode \scheme{none}. +Alternatives include appointing one thread to perform all I/O for a +given port and providing a per-thread generic-port wrapper that +forwards requests to the port only after acquiring a mutex. + +The initial console and current input and output ports are thread-safe, +as are transcript ports, so it is safe for multiple threads to print error +and/or debugging messages to the console. +The output may be interleaved, even within the same line, but the port +will not become corrupted. +Thread safety for these ports is accomplished at the high cost of +acquiring a mutex for each I/O operation. + + +\section{Example: Bounded Queues} + +The following code, taken from the article +``A Scheme for native threads~\cite{Dybvig:mitchfest-threads},'' +implements a bounded queue using many of the +thread-system features. +A bounded queue has a fixed number of available slots. +Attempting to enqueue when the queue is full causes the calling thread +to block. +Attempting to dequeue from an empty queue causes the calling thread +to block. + +%%% from thread article + +\schemedisplay +(define-record-type bq + (fields + (immutable data) + (mutable head) + (mutable tail) + (immutable mutex) + (immutable ready) + (immutable room)) + (protocol + (lambda (new) + (lambda (bound) + (new (make-vector bound) 0 0 (make-mutex) + (make-condition) (make-condition)))))) + +(define dequeue! + (lambda (q) + (with-mutex (bq-mutex q) + (let loop () + (let ([head (bq-head q)]) + (cond + [(= head (bq-tail q)) + (condition-wait (bq-ready q) (bq-mutex q)) + (loop)] + [else + (bq-head-set! q (incr q head)) + (condition-signal (bq-room q)) + (vector-ref (bq-data q) head)])))))) + +(define enqueue! + (lambda (item q) + (with-mutex (bq-mutex q) + (let loop () + (let* ([tail (bq-tail q)] [tail^ (incr q tail)]) + (cond + [(= tail^ (bq-head q)) + (condition-wait (bq-room q) (bq-mutex q)) + (loop)] + [else + (vector-set! (bq-data q) tail item) + (bq-tail-set! q tail^) + (condition-signal (bq-ready q))])))))) + +(define incr + (lambda (q i) + (modulo (+ i 1) (vector-length (bq-data q))))) +\endschemedisplay + +\noindent +The code below demonstrates the use of the bounded queue abstraction +with a set of threads that act as consumers and producers of the +data in the queue. + +\schemedisplay +(define job-queue) +(define die? #f) + +(define make-job + (let ([count 0]) + (define fib + (lambda (n) + (if (< n 2) + n + (+ (fib (- n 2)) (fib (- n 1)))))) + (lambda (n) + (set! count (+ count 1)) + (printf "Adding job #~s = (lambda () (fib ~s))\n" count n) + (cons count (lambda () (fib n)))))) + +(define make-producer + (lambda (n) + (rec producer + (lambda () + (printf "producer ~s posting a job\n" n) + (enqueue! (make-job (+ 20 (random 10))) job-queue) + (if die? + (printf "producer ~s dying\n" n) + (producer)))))) + +(define make-consumer + (lambda (n) + (rec consumer + (lambda () + (printf "consumer ~s looking for a job~%" n) + (let ([job (dequeue! job-queue)]) + (if die? + (printf "consumer ~s dying\n" n) + (begin + (printf "consumer ~s executing job #~s~%" n (car job)) + (printf "consumer ~s computed: ~s~%" n ((cdr job))) + (consumer)))))))) + +(define (bq-test np nc) + (set! job-queue (make-bq (max nc np))) + (do ([np np (- np 1)]) + ((<= np 0)) + (fork-thread (make-producer np))) + (do ([nc nc (- nc 1)]) + ((<= nc 0)) + (fork-thread (make-consumer nc)))) +\endschemedisplay + +\noindent +Here are a possible first several lines of output from a sample run of the example program. + +\schemedisplay +> (begin + (bq-test 3 4) + (system "sleep 3") + (set! die? #t)) +producer 3 posting a job +Adding job #1 = (lambda () (fib 29)) +producer 3 posting a job +Adding job #2 = (lambda () (fib 26)) +producer 3 posting a job +Adding job #3 = (lambda () (fib 22)) +producer 3 posting a job +Adding job #4 = (lambda () (fib 21)) +producer 2 posting a job +Adding job #5 = (lambda () (fib 29)) +producer 1 posting a job +Adding job #6 = (lambda () (fib 29)) +consumer 4 looking for a job +producer 3 posting a job +Adding job #7 = (lambda () (fib 24)) +consumer 4 executing job #1 +consumer 3 looking for a job +producer 2 posting a job +Adding job #8 = (lambda () (fib 26)) +consumer 3 executing job #2 +consumer 3 computed: 121393 +consumer 3 looking for a job +producer 1 posting a job +Adding job #9 = (lambda () (fib 26)) +... +\endschemedisplay + +Additional examples, including definitions of suspendable threads and +threads that automatically terminate when they become inaccessible, are +given in ``A Scheme for native threads~\cite{Dybvig:mitchfest-threads}.'' + + +% \section{Thread System OOP Interface} +% +% The thread system OOP interface consists of one new form, +% \scheme{define-threaded-class}. +% This form provides a high-level interface for acquiring mutexes +% and waiting for conditions. +% A \scheme{define-threaded-class} form has the following general +% syntax: +% +% \schemedisplay +% (define-threaded-class (\var{name} \var{fmls}) (\var{parent} \var{expr} \dots) +% (state [\var{ivar} \var{init}] \dots) +% (init \var{expr} \dots) +% (conditions +% [\var{cname} \var{pred}] +% \dots) +% (methods +% [locked \var{mname} \var{mfmls} \var{body}] +% \dots)) +% \endschemedisplay +% +% \noindent +% Each of the labeled sections (\scheme{state}, \scheme{init}, +% \scheme{conditions}, and \scheme{methods}) is optional, as is +% the \scheme{locked} keyword. +% The \scheme{locked} keyword may be applied to all, none, or +% some of the methods in a threaded-class definition. +% +% The \scheme{conditions} subform and the \scheme{locked} keyword are +% extensions to the \scheme{define-class} syntax. +% If no \scheme{conditions} subform is given and no \scheme{locked} keywords are +% present, \scheme{define-threaded-class} is identical to +% \scheme{define-class}, both in syntax and semantics. +% +% If any methods are annotated with the \scheme{locked} keyword, a +% mutex is associated with each instance of the class, and those +% methods automatically acquire and release the mutex as if the +% body were wrapped in a \scheme{with-mutex} form. +% The following definition of a \scheme{stack} class demonstrates +% the \scheme{locked} keyword. +% +% \schemedisplay +% (define-threaded-class () () +% (state [pdl '()]) +% (methods +% [locked push (v) +% (set! pdl (cons v pdl))] +% [locked pop (default) +% (if (null? pdl) +% default +% (let ([v (car pdl)]) +% (set! pdl (cdr pdl)) +% v))])) +% \endschemedisplay +% +% \noindent +% The \scheme{push} method adds an item to the top of the stack. +% The \scheme{pop} method removes an item from the top of the +% stack and returns it, unless the stack is empty, in which case +% it returns the default value passed in by the caller. +% +% This may seem like an unnecessarily complex version of \scheme{pop}. +% A simpler and more familiar approach would be to provide an +% \scheme{empty?} method for determining if the contains any items +% and to remove this test form \scheme{pop} as follows. +% +% \schemedisplay +% (define-threaded-class () () +% (state [pdl '()]) +% (methods +% [empty (v) (null? pdl)] +% [locked push (v) +% (set! pdl (cons v pdl))] +% [locked pop () +% (let ([v (car pdl)]) +% (set! pdl (cdr pdl)) +% v)])) +% \endschemedisplay +% +% \noindent +% Because it does not update the stack, \scheme{empty?} need not be +% locked. +% Unfortunately, \scheme{empty?} is not useful in a threaded environment, +% because another thread may pop the stack in between the time +% \scheme{empty?} and \scheme{pop} are called. +% In general, the entire operation to be performed, including +% any questions to be asked and any mutations to +% be performed, must be encapsulated within a single locked +% method. +% +% It is possible to have a useful method that need not be locked. +% The following version of \scheme{} maintains a count of +% objects pushed onto the stack over time, and the +% \scheme{count} method is used to retrieve this count. +% +% \schemedisplay +% (define-threaded-class () () +% (state [pdl '()] [count 0]) +% (methods +% [count () count] +% [locked push (v) +% (set! count (+ count 1)) +% (set! pdl (cons v pdl))] +% [locked pop (default) +% (if (null? pdl) +% default +% (let ([v (car pdl)]) +% (set! pdl (cdr pdl)) +% v))])) +% \endschemedisplay +% +% \noindent +% Although \scheme{count} may be out of date as soon as the caller +% receives it, the value returned is guaranteed to be a valid +% count at some time after the method call is made and before the +% method call returns. +% +% A condition variable +% is associated with each instance of the class. +% for each \scheme{(\var{cname} \var{pred})} pair in the +% \scheme{conditions} subform. +% The identifiers \scheme{\var{cname} \dots} name the associated +% conditions within the methods of the class. +% The predicate \var{pred} associated with a condition is an +% expression that should evaluate to a true value if and only +% if the condition is considered satisfied. +% The predicate expression may refer to the instance variables +% of the class. +% +% A method waits for a condition to be satisfied using the +% \scheme{require} form, which is valid only within the locked +% methods of the class. +% +% \schemedisplay +% (require \var{cname} \var{body}) +% \endschemedisplay +% +% \noindent +% When a thread evaluates a \scheme{require} form, it evaluates +% the predicate associated with \var{cname}. +% If the predicate returns a true value, the thread proceeds to +% evaluate \var{body}. +% If the predicate returns false, it waits for the associated +% condition variable, as if with an explicit call to condition wait, +% Upon being released from the condition variable (by a signal +% or broadcast from another thread), the thread loops back to +% check the predicate again. +% Control thus does not reach the body of the \scheme{require} +% form until the predicate evaluates to a true value. +% +% Waiting threads may be released from a condition by applying +% either \scheme{condition-signal} or \scheme{condition-broadcast} +% to the value of the corresponding \var{cname}. +% %%% [Question: must the signaling thread be locked?] +% +% Here is a \scheme{} test that redefines the bounded queue. +% Compare this with the earlier definitions of the \scheme{}, +% \scheme{enqueue!}, and \scheme{dequeue!}. +% +% \schemedisplay +% (define-threaded-class ( i) () +% (state [i i] [vec (make-vector i)]) +% (conditions +% [ready (not (= i (vector-length vec)))] +% [room (not (= i 0))]) +% (methods +% [locked enqueue! (item) +% (require room +% (set! i (- i 1)) +% (vector-set! vec i item) +% (condition-signal ready))] +% [locked dequeue! () +% (require ready +% (let ([item (vector-ref vec i)]) +% (set! i (+ i 1)) +% (condition-signal room) +% item))])) +% \endschemedisplay +% +% diff --git a/csug/title.stex b/csug/title.stex new file mode 100644 index 0000000..bc50feb --- /dev/null +++ b/csug/title.stex @@ -0,0 +1,37 @@ +% Copyright 2005-2017 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\iflatex +\thispagestyle{empty} + +\leftline{} +\vskip 6pc + +{\titlefont\hbox to \textwidth{Chez Scheme Version 9\hfil}} +\vskip 10pt +{\titlefont\hbox to \textwidth{User's Guide\hfil}} + +% \vskip 9pc + +\vfill\vfill + +\begingroup\large +\begin{flushright} +\includegraphics[width=1.25in]{canned/cisco-logo-large}\\[10pt] +Cisco Systems, Inc.\\ +www.cisco.com +\end{flushright} +\endgroup + +\pagebreak +\fi diff --git a/csug/tspl.bst b/csug/tspl.bst new file mode 100644 index 0000000..2dc0c5e --- /dev/null +++ b/csug/tspl.bst @@ -0,0 +1,1101 @@ +% like plain, except that edition appears immediately after title, not +% after publisher + +ENTRY + { address + author + booktitle + chapter + edition + editor + howpublished + institution + journal + key + month + note + number + organization + pages + publisher + school + series + title + type + url + verbatimurl + volume + year + } + {} + { label } + +INTEGERS { output.state before.all mid.sentence after.sentence after.block } + +FUNCTION {init.state.consts} +{ #0 'before.all := + #1 'mid.sentence := + #2 'after.sentence := + #3 'after.block := +} + +STRINGS { s t } + +FUNCTION {output.nonnull} +{ 's := + output.state mid.sentence = + { ", " * write$ } + { output.state after.block = + { add.period$ write$ + newline$ + "\newblock " write$ + } + { output.state before.all = + 'write$ + { add.period$ " " * write$ } + if$ + } + if$ + mid.sentence 'output.state := + } + if$ + s +} + +FUNCTION {output} +{ duplicate$ empty$ + 'pop$ + 'output.nonnull + if$ +} + +FUNCTION {output.check} +{ 't := + duplicate$ empty$ + { pop$ "empty " t * " in " * cite$ * warning$ } + 'output.nonnull + if$ +} + +FUNCTION {output.bibitem} +{ newline$ + "\bibitem{" write$ + cite$ write$ + "}" write$ + newline$ + "" + before.all 'output.state := +} + +FUNCTION {fin.entry} +{ add.period$ + write$ + newline$ + url missing$ + 'skip$ + { " " write$ "\emph{" write$ url write$ "}." write$ } + if$ + verbatimurl missing$ + 'skip$ + { " " write$ "\verb'" write$ verbatimurl write$ "'." write$ } + if$ +} + + +FUNCTION {new.block} +{ output.state before.all = + 'skip$ + { after.block 'output.state := } + if$ +} + +FUNCTION {new.sentence} +{ output.state after.block = + 'skip$ + { output.state before.all = + 'skip$ + { after.sentence 'output.state := } + if$ + } + if$ +} + +FUNCTION {not} +{ { #0 } + { #1 } + if$ +} + +FUNCTION {and} +{ 'skip$ + { pop$ #0 } + if$ +} + +FUNCTION {or} +{ { pop$ #1 } + 'skip$ + if$ +} + +FUNCTION {new.block.checka} +{ empty$ + 'skip$ + 'new.block + if$ +} + +FUNCTION {new.block.checkb} +{ empty$ + swap$ empty$ + and + 'skip$ + 'new.block + if$ +} + +FUNCTION {new.sentence.checka} +{ empty$ + 'skip$ + 'new.sentence + if$ +} + +FUNCTION {new.sentence.checkb} +{ empty$ + swap$ empty$ + and + 'skip$ + 'new.sentence + if$ +} + +FUNCTION {field.or.null} +{ duplicate$ empty$ + { pop$ "" } + 'skip$ + if$ +} + +FUNCTION {emphasize} +{ duplicate$ empty$ + { pop$ "" } + { "\emph{" swap$ * "}" * } + if$ +} + +INTEGERS { nameptr namesleft numnames } + +FUNCTION {format.names} +{ 's := + #1 'nameptr := + s num.names$ 'numnames := + numnames 'namesleft := + { namesleft #0 > } + { s nameptr "{ff~}{vv~}{ll}{, jj}" format.name$ 't := + nameptr #1 > + { namesleft #1 > + { ", " * t * } + { numnames #2 > + { "," * } + 'skip$ + if$ + t "others" = + { " et~al." * } + { " and " * t * } + if$ + } + if$ + } + 't + if$ + nameptr #1 + 'nameptr := + namesleft #1 - 'namesleft := + } + while$ +} + +FUNCTION {format.authors} +{ author empty$ + { "" } + { author format.names } + if$ +} + +FUNCTION {format.editors} +{ editor empty$ + { "" } + { editor format.names + editor num.names$ #1 > + { ", editors" * } + { ", editor" * } + if$ + } + if$ +} + +FUNCTION {format.title} +{ title empty$ + { "" } + { title "t" change.case$ } + if$ +} + +FUNCTION {n.dashify} +{ 't := + "" + { t empty$ not } + { t #1 #1 substring$ "-" = + { t #1 #2 substring$ "--" = not + { "--" * + t #2 global.max$ substring$ 't := + } + { { t #1 #1 substring$ "-" = } + { "-" * + t #2 global.max$ substring$ 't := + } + while$ + } + if$ + } + { t #1 #1 substring$ * + t #2 global.max$ substring$ 't := + } + if$ + } + while$ +} + +FUNCTION {format.date} +{ year empty$ + { month empty$ + { "" } + { "there's a month but no year in " cite$ * warning$ + month + } + if$ + } + { month empty$ + 'year + { month " " * year * } + if$ + } + if$ +} + +FUNCTION {format.btitle} +{ title emphasize +} + +FUNCTION {tie.or.space.connect} +{ duplicate$ text.length$ #3 < + { "~" } + { " " } + if$ + swap$ * * +} + +FUNCTION {either.or.check} +{ empty$ + 'pop$ + { "can't use both " swap$ * " fields in " * cite$ * warning$ } + if$ +} + +FUNCTION {format.bvolume} +{ volume empty$ + { "" } + { "volume" volume tie.or.space.connect + series empty$ + 'skip$ + { " of " * series emphasize * } + if$ + "volume and number" number either.or.check + } + if$ +} + +FUNCTION {format.number.series} +{ volume empty$ + { number empty$ + { series field.or.null } + { output.state mid.sentence = + { "number" } + { "Number" } + if$ + number tie.or.space.connect + series empty$ + { "there's a number but no series in " cite$ * warning$ } + { " in " * series * } + if$ + } + if$ + } + { "" } + if$ +} + +FUNCTION {format.edition} +{ edition empty$ + { "" } + { output.state mid.sentence = + { edition "l" change.case$ " edition" * } + { edition "t" change.case$ " edition" * } + if$ + } + if$ +} + +INTEGERS { multiresult } + +FUNCTION {multi.page.check} +{ 't := + #0 'multiresult := + { multiresult not + t empty$ not + and + } + { t #1 #1 substring$ + duplicate$ "-" = + swap$ duplicate$ "," = + swap$ "+" = + or or + { #1 'multiresult := } + { t #2 global.max$ substring$ 't := } + if$ + } + while$ + multiresult +} + +FUNCTION {format.pages} +{ pages empty$ + { "" } + { pages multi.page.check + { "" pages n.dashify tie.or.space.connect } + { "page" pages tie.or.space.connect } + if$ + } + if$ +} + +FUNCTION {format.vol.num.pages} +{ volume field.or.null + number empty$ + 'skip$ + { "(" number * ")" * * + volume empty$ + { "there's a number but no volume in " cite$ * warning$ } + 'skip$ + if$ + } + if$ + pages empty$ + 'skip$ + { duplicate$ empty$ + { pop$ format.pages } + { ":" * pages n.dashify * } + if$ + } + if$ +} + +FUNCTION {format.chapter.pages} +{ chapter empty$ + 'format.pages + { type empty$ + { "chapter" } + { type "l" change.case$ } + if$ + chapter tie.or.space.connect + pages empty$ + 'skip$ + { ", " * format.pages * } + if$ + } + if$ +} + +FUNCTION {format.in.ed.booktitle} +{ booktitle empty$ + { "" } + { editor empty$ + { "In " booktitle emphasize * } + { "In " format.editors * ", " * booktitle emphasize * } + if$ + } + if$ +} + +FUNCTION {empty.misc.check} +{ author empty$ title empty$ howpublished empty$ + month empty$ year empty$ note empty$ + and and and and and + key empty$ not and + { "all relevant fields are empty in " cite$ * warning$ } + 'skip$ + if$ +} + +FUNCTION {format.thesis.type} +{ type empty$ + 'skip$ + { pop$ + type "t" change.case$ + } + if$ +} + +FUNCTION {format.tr.number} +{ type empty$ + { "Technical Report" } + 'type + if$ + number empty$ + { "t" change.case$ } + { number tie.or.space.connect } + if$ +} + +FUNCTION {format.article.crossref} +{ key empty$ + { journal empty$ + { "need key or journal for " cite$ * " to crossref " * crossref * + warning$ + "" + } + { "In \emph{" journal * "\/}" * } + if$ + } + { "In " key * } + if$ + " \cite{" * crossref * "}" * +} + +FUNCTION {format.crossref.editor} +{ editor #1 "{vv~}{ll}" format.name$ + editor num.names$ duplicate$ + #2 > + { pop$ " et~al." * } + { #2 < + 'skip$ + { editor #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" = + { " et~al." * } + { " and " * editor #2 "{vv~}{ll}" format.name$ * } + if$ + } + if$ + } + if$ +} + +FUNCTION {format.book.crossref} +{ volume empty$ + { "empty volume in " cite$ * "'s crossref of " * crossref * warning$ + "In " + } + { "Volume" volume tie.or.space.connect + " of " * + } + if$ + editor empty$ + editor field.or.null author field.or.null = + or + { key empty$ + { series empty$ + { "need editor, key, or series for " cite$ * " to crossref " * + crossref * warning$ + "" * + } + { "\emph{" * series * "\/}" * } + if$ + } + { key * } + if$ + } + { format.crossref.editor * } + if$ + " \cite{" * crossref * "}" * +} + +FUNCTION {format.incoll.inproc.crossref} +{ editor empty$ + editor field.or.null author field.or.null = + or + { key empty$ + { booktitle empty$ + { "need editor, key, or booktitle for " cite$ * " to crossref " * + crossref * warning$ + "" + } + { "In \emph{" booktitle * "\/}" * } + if$ + } + { "In " key * } + if$ + } + { "In " format.crossref.editor * } + if$ + " \cite{" * crossref * "}" * +} + +FUNCTION {article} +{ output.bibitem + format.authors "author" output.check + new.block + format.title "title" output.check + new.block + crossref missing$ + { journal emphasize "journal" output.check + format.vol.num.pages output + format.date "year" output.check + } + { format.article.crossref output.nonnull + format.pages output + } + if$ + new.block + note output + fin.entry +} + +FUNCTION {book} +{ output.bibitem + author empty$ + { format.editors "author and editor" output.check } + { format.authors output.nonnull + crossref missing$ + { "author and editor" editor either.or.check } + 'skip$ + if$ + } + if$ + new.block + format.btitle "title" output.check + format.edition output + crossref missing$ + { format.bvolume output + new.block + format.number.series output + new.sentence + publisher "publisher" output.check + address output + } + { new.block + format.book.crossref output.nonnull + } + if$ + format.date "year" output.check + new.block + note output + fin.entry +} + +FUNCTION {booklet} +{ output.bibitem + format.authors output + new.block + format.title "title" output.check + howpublished address new.block.checkb + howpublished output + address output + format.date output + new.block + note output + fin.entry +} + +FUNCTION {inbook} +{ output.bibitem + author empty$ + { format.editors "author and editor" output.check } + { format.authors output.nonnull + crossref missing$ + { "author and editor" editor either.or.check } + 'skip$ + if$ + } + if$ + new.block + format.btitle "title" output.check + format.edition output + crossref missing$ + { format.bvolume output + format.chapter.pages "chapter and pages" output.check + new.block + format.number.series output + new.sentence + publisher "publisher" output.check + address output + } + { format.chapter.pages "chapter and pages" output.check + new.block + format.book.crossref output.nonnull + } + if$ + format.date "year" output.check + new.block + note output + fin.entry +} + +FUNCTION {incollection} +{ output.bibitem + format.authors "author" output.check + new.block + format.title "title" output.check + new.block + crossref missing$ + { format.in.ed.booktitle "booktitle" output.check + format.bvolume output + format.number.series output + format.chapter.pages output + new.sentence + publisher "publisher" output.check + address output + format.edition output + format.date "year" output.check + } + { format.incoll.inproc.crossref output.nonnull + format.chapter.pages output + } + if$ + new.block + note output + fin.entry +} + +FUNCTION {inproceedings} +{ output.bibitem + format.authors "author" output.check + new.block + format.title "title" output.check + new.block + crossref missing$ + { format.in.ed.booktitle "booktitle" output.check + format.bvolume output + format.number.series output + format.pages output + address empty$ + { organization publisher new.sentence.checkb + organization output + publisher output + format.date "year" output.check + } + { address output.nonnull + format.date "year" output.check + new.sentence + organization output + publisher output + } + if$ + } + { format.incoll.inproc.crossref output.nonnull + format.pages output + } + if$ + new.block + note output + fin.entry +} + +FUNCTION {conference} { inproceedings } + +FUNCTION {manual} +{ output.bibitem + author empty$ + { organization empty$ + 'skip$ + { organization output.nonnull + address output + } + if$ + } + { format.authors output.nonnull } + if$ + new.block + format.btitle "title" output.check + format.edition output + author empty$ + { organization empty$ + { address new.block.checka + address output + } + 'skip$ + if$ + } + { organization address new.block.checkb + organization output + address output + } + if$ + format.date output + new.block + note output + fin.entry +} + +FUNCTION {mastersthesis} +{ output.bibitem + format.authors "author" output.check + new.block + format.title "title" output.check + new.block + "Master's thesis" format.thesis.type output.nonnull + school "school" output.check + address output + format.date "year" output.check + new.block + note output + fin.entry +} + +FUNCTION {misc} +{ output.bibitem + format.authors output + title howpublished new.block.checkb + format.title output + howpublished new.block.checka + howpublished output + format.date output + new.block + note output + fin.entry + empty.misc.check +} + +FUNCTION {phdthesis} +{ output.bibitem + format.authors "author" output.check + new.block + format.btitle "title" output.check + new.block + "PhD thesis" format.thesis.type output.nonnull + school "school" output.check + address output + format.date "year" output.check + new.block + note output + fin.entry +} + +FUNCTION {proceedings} +{ output.bibitem + editor empty$ + { organization output } + { format.editors output.nonnull } + if$ + new.block + format.btitle "title" output.check + format.bvolume output + format.number.series output + address empty$ + { editor empty$ + { publisher new.sentence.checka } + { organization publisher new.sentence.checkb + organization output + } + if$ + publisher output + format.date "year" output.check + } + { address output.nonnull + format.date "year" output.check + new.sentence + editor empty$ + 'skip$ + { organization output } + if$ + publisher output + } + if$ + new.block + note output + fin.entry +} + +FUNCTION {techreport} +{ output.bibitem + format.authors "author" output.check + new.block + format.title "title" output.check + new.block + format.tr.number output.nonnull + institution "institution" output.check + address output + format.date "year" output.check + new.block + note output + fin.entry +} + +FUNCTION {unpublished} +{ output.bibitem + format.authors "author" output.check + new.block + format.title "title" output.check + new.block + note "note" output.check + format.date output + fin.entry +} + +FUNCTION {default.type} { misc } + +MACRO {jan} {"January"} + +MACRO {feb} {"February"} + +MACRO {mar} {"March"} + +MACRO {apr} {"April"} + +MACRO {may} {"May"} + +MACRO {jun} {"June"} + +MACRO {jul} {"July"} + +MACRO {aug} {"August"} + +MACRO {sep} {"September"} + +MACRO {oct} {"October"} + +MACRO {nov} {"November"} + +MACRO {dec} {"December"} + +MACRO {acmcs} {"ACM Computing Surveys"} + +MACRO {acta} {"Acta Informatica"} + +MACRO {cacm} {"Communications of the ACM"} + +MACRO {ibmjrd} {"IBM Journal of Research and Development"} + +MACRO {ibmsj} {"IBM Systems Journal"} + +MACRO {ieeese} {"IEEE Transactions on Software Engineering"} + +MACRO {ieeetc} {"IEEE Transactions on Computers"} + +MACRO {ieeetcad} + {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"} + +MACRO {ipl} {"Information Processing Letters"} + +MACRO {jacm} {"Journal of the ACM"} + +MACRO {jcss} {"Journal of Computer and System Sciences"} + +MACRO {scp} {"Science of Computer Programming"} + +MACRO {sicomp} {"SIAM Journal on Computing"} + +MACRO {tocs} {"ACM Transactions on Computer Systems"} + +MACRO {tods} {"ACM Transactions on Database Systems"} + +MACRO {tog} {"ACM Transactions on Graphics"} + +MACRO {toms} {"ACM Transactions on Mathematical Software"} + +MACRO {toois} {"ACM Transactions on Office Information Systems"} + +MACRO {toplas} {"ACM Transactions on Programming Languages and Systems"} + +MACRO {tcs} {"Theoretical Computer Science"} + +READ + +FUNCTION {sortify} +{ purify$ + "l" change.case$ +} + +INTEGERS { len } + +FUNCTION {chop.word} +{ 's := + 'len := + s #1 len substring$ = + { s len #1 + global.max$ substring$ } + 's + if$ +} + +FUNCTION {sort.format.names} +{ 's := + #1 'nameptr := + "" + s num.names$ 'numnames := + numnames 'namesleft := + { namesleft #0 > } + { nameptr #1 > + { " " * } + 'skip$ + if$ + s nameptr "{vv{ } }{ll{ }}{ ff{ }}{ jj{ }}" format.name$ 't := + nameptr numnames = t "others" = and + { "et al" * } + { t sortify * } + if$ + nameptr #1 + 'nameptr := + namesleft #1 - 'namesleft := + } + while$ +} + +FUNCTION {sort.format.title} +{ 't := + "A " #2 + "An " #3 + "The " #4 t chop.word + chop.word + chop.word + sortify + #1 global.max$ substring$ +} + +FUNCTION {author.sort} +{ author empty$ + { key empty$ + { "to sort, need author or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { author sort.format.names } + if$ +} + +FUNCTION {author.editor.sort} +{ author empty$ + { editor empty$ + { key empty$ + { "to sort, need author, editor, or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { editor sort.format.names } + if$ + } + { author sort.format.names } + if$ +} + +FUNCTION {author.organization.sort} +{ author empty$ + { organization empty$ + { key empty$ + { "to sort, need author, organization, or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { "The " #4 organization chop.word sortify } + if$ + } + { author sort.format.names } + if$ +} + +FUNCTION {editor.organization.sort} +{ editor empty$ + { organization empty$ + { key empty$ + { "to sort, need editor, organization, or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { "The " #4 organization chop.word sortify } + if$ + } + { editor sort.format.names } + if$ +} + +FUNCTION {presort} +{ type$ "book" = + type$ "inbook" = + or + 'author.editor.sort + { type$ "proceedings" = + 'editor.organization.sort + { type$ "manual" = + 'author.organization.sort + 'author.sort + if$ + } + if$ + } + if$ + " " + * + year field.or.null sortify + * + " " + * + title field.or.null + sort.format.title + * + #1 entry.max$ substring$ + 'sort.key$ := +} + +ITERATE {presort} + +SORT + +STRINGS { longest.label } + +INTEGERS { number.label longest.label.width } + +FUNCTION {initialize.longest.label} +{ "" 'longest.label := + #1 'number.label := + #0 'longest.label.width := +} + +FUNCTION {longest.label.pass} +{ number.label int.to.str$ 'label := + number.label #1 + 'number.label := + label width$ longest.label.width > + { label 'longest.label := + label width$ 'longest.label.width := + } + 'skip$ + if$ +} + +EXECUTE {initialize.longest.label} + +ITERATE {longest.label.pass} + +FUNCTION {begin.bib} +{ preamble$ empty$ + 'skip$ + { preamble$ write$ newline$ } + if$ + "\begin{thebibliography}{" longest.label * "}" * write$ newline$ +} + +EXECUTE {begin.bib} + +EXECUTE {init.state.consts} + +ITERATE {call.type$} + +FUNCTION {end.bib} +{ newline$ + "\end{thebibliography}" write$ newline$ +} + +EXECUTE {end.bib} diff --git a/csug/tspl4-prep.stex b/csug/tspl4-prep.stex new file mode 100644 index 0000000..9811768 --- /dev/null +++ b/csug/tspl4-prep.stex @@ -0,0 +1,131 @@ +%%% tspl4-prep.stex +%%% Copyright (c) 1998 R, Kent Dybvig +%%% +%%% Permission is hereby granted, free of charge, to any person obtaining a +%%% copy of this software and associated documentation files (the "Software"), +%%% to deal in the Software without restriction, including without limitation +%%% the rights to use, copy, modify, merge, publish, distribute, sublicense, +%%% and/or sell copies of the Software, and to permit persons to whom the +%%% Software is furnished to do so, subject to the following conditions: +%%% +%%% The above copyright notice and this permission notice shall be included in +%%% all copies or substantial portions of the Software. +%%% +%%% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +%%% IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +%%% FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +%%% THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +%%% LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +%%% FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +%%% DEALINGS IN THE SOFTWARE. + +\schemeinit +(define false #f) +(define true #t) +(define names '()) +(define listlibraries-seen? false) +\endschemeinit + +\xdef\entryheader{\schemeinit +(unless (null? names) (errorf 'entryheader "name list is not empty ~s" names)) +(set! listlibraries-seen? false) +\endschemeinit% +\xedef\entrylab{\genlab}\raw{\entryheader}\label{\entrylab}} + +\xdef\noskipentryheader{\schemeinit +(unless (null? names) (errorf 'entryheader "name list is not empty ~s" names)) +(set! listlibraries-seen? false) +\endschemeinit% +\xedef\entrylab{\genlab}\raw{\noskipentryheader}\label{\entrylab}} + +\xdef\endentryheader{\schemeinit +(unless listlibraries-seen? (errorf 'endentryheader "no \\listlibraries seen")) +(unless (null? names) (errorf 'endentryheader "name list is not empty ~s" names)) +\endschemeinit% +\raw{\endentryheader + +}} + +% \formdef{primitive name}{\categorytype}{form} +\xdef\formdef#1#2#3{\schemeinit +(set! names (cons "#1" names))\endschemeinit% + \hindex{\entrylab}{\scheme{#1}|emph}% + \raw{\formdef}{#2}{\scheme{#3}}% + \formsummary{\raw{#1}}{#2}{\scheme{#3}}{\entrylab}} + +% \xformdef{sort key}{index entry}{type}{form} +\xdef\xformdef#1#2#3#4{\hindex{\entrylab}{#2|emph}% + \raw{\formdef}{#3}{\scheme{#4}}% + \formsummary{\raw{#1}}{#3}{\scheme{#4}}{\entrylab}} + +% \suppress\formdef{primitive name}{\categorytype}{form} +\xdef\suppress\formdef#1#2#3{\schemeinit +(set! names (cons "#1" names))(set! listlibraries-seen? false)\endschemeinit% + \hindex{\entrylab}{\scheme{#1}|emph}% + \formsummary{\raw{#1}}{#2}{\scheme{#3}}{\entrylab}} + +\xdef\conditionformdef#1{\generated +(docond '#1)\endgenerated\xdef\showit{This condition type might be defined as follows. +\schemedisplay +#1 +\endschemedisplay}} + +\xdef\libraryexport#1{\schemeinit +(set! names (cons "#1" names))\endschemeinit} + +\xdef\exercise{\xedef\anslab{\genlab}\raw{\exercise}{\label{\anslab}}} + +\xdef\answer#1{\raw{\answer}{#1}{\anslab}} + +\schemeinit +(module (list-libraries) + (define libht (make-eq-hashtable)) + (define (list-libraries) + (define (getlibs x) + (or (hashtable-ref libht (string->symbol x) #f) + (errorf 'list-libraries "no libraries for ~a defined" x))) + (when (null? names) (errorf 'list-libraries "name list is empty")) + (let ([libs (getlibs (car names))]) + (for-each + (lambda (name) + (unless (equal? (getlibs name) libs) + (errorf 'list-libraries "libs ~s for ~a don't match libs ~s for ~a" libs (car names) (getlibs name) name))) + (cdr names)) + (with-output-to-file "libslisted" + (lambda () (for-each (lambda (x) (printf "~a\n" x)) names)) + 'append) + (let f ([libs libs] [sep " "]) + (unless (null? libs) + (printf "~a\\scheme{~a}" sep (car libs)) + (f (cdr libs) ", "))))) + (call-with-output-file "libsrecorded" + (lambda (op) + (include "priminfo.ss") + (import priminfo) + (define (record-libs name libs) + (unless (null? libs) + (when (hashtable-ref libht name #f) + (errorf 'record-libs "libs already defined for ~s" name)) + (fprintf op "~a\n" name) + (hashtable-set! libht name + (sort (lambda (x y) + (or (> (length x) (length y)) + (and (= (length x) (length y)) + (ormap (lambda (x y) + (stringstring x) (symbol->string y))) + x y)))) + libs)))) + (vector-for-each + (lambda (prim) (record-libs prim (get-libraries prim))) + (primvec))) + 'replace)) +\endschemeinit + +\xdef\listlibraries{\raw{\libraries}\generated +(list-libraries)(set! names '())(set! listlibraries-seen? true) +\endgenerated +} +\xdef\nolistlibraries{\generated +(set! names '())(set! listlibraries-seen? true) +\endgenerated +} diff --git a/csug/tspl4/answers.aux b/csug/tspl4/answers.aux new file mode 100644 index 0000000..bdcdb55 --- /dev/null +++ b/csug/tspl4/answers.aux @@ -0,0 +1,20 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{Answers to Selected Exercises}{435}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{listapply}{{2}{437}} +\newlabel{cdrapply}{{4}{437}} +\@setckpt{answers}{ +\setcounter{page}{454} +\setcounter{equation}{0} +\setcounter{enumi}{8} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{32} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{12} +\setcounter{section}{11} +\setcounter{exercise}{7} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/bibliography.aux b/csug/tspl4/bibliography.aux new file mode 100644 index 0000000..bc0632c --- /dev/null +++ b/csug/tspl4/bibliography.aux @@ -0,0 +1,52 @@ +\relax +\bibstyle{tspl} +\bibdata{tspl} +\bibcite{adams:equal}{1} +\bibcite{ashley:mvalues}{2} +\bibcite{bawden:pepm99}{3} +\bibcite{Briggs:dft}{4} +\bibcite{Burger:floatprinting}{5} +\bibcite{Clocksin:prolog}{6} +\bibcite{Daniel:prolog-fft}{7} +\bibcite{UnicodeUAX29}{8} +\bibcite{Dybvig:csug8}{9} +\bibcite{Dybvig:engines}{10} +\bibcite{Dybvig:lambdastar}{11} +\bibcite{Dybvig:syntactic}{12} +\bibcite{Friedman:lisper}{13} +\@writefile{toc}{\contentsline {chapter}{References}{431}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\bibcite{Friedman:devils}{14} +\bibcite{Haynes:abstracting}{15} +\bibcite{Haynes:obtaining}{16} +\bibcite{Hieb:representing}{17} +\bibcite{IEEE:1178}{18} +\bibcite{Kernighan:C}{19} +\bibcite{RFC4122}{20} +\bibcite{Naur:algol}{21} +\bibcite{Plaisted:sets}{22} +\bibcite{Robinson:unification}{23} +\bibcite{r6rs}{24} +\bibcite{r6rsapps}{25} +\bibcite{r6rslibs}{26} +\bibcite{Steele:common}{27} +\bibcite{Steele:scheme}{28} +\bibcite{Sussman-Steele:HOSC98}{29} +\bibcite{Unicode}{30} +\bibcite{waddell:fixing-letrec}{31} +\bibcite{Wand:HOSC99}{32} +\@setckpt{bibliography}{ +\setcounter{page}{434} +\setcounter{equation}{0} +\setcounter{enumi}{3} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{32} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{12} +\setcounter{section}{11} +\setcounter{exercise}{7} +\setcounter{alphacount}{3} +} diff --git a/csug/tspl4/binding.aux b/csug/tspl4/binding.aux new file mode 100644 index 0000000..8068dc2 --- /dev/null +++ b/csug/tspl4/binding.aux @@ -0,0 +1,73 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {4}Procedures and Variable Bindings}{89}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTBINDING}{{4}{89}} +\newlabel{./binding:s0}{{4}{91}} +\newlabel{./binding:s1}{{4}{91}} +\newlabel{SECTVARREF}{{4.1}{91}} +\@writefile{toc}{\contentsline {section}{\numberline {4.1}Variable References}{91}} +\newlabel{./binding:s2}{{4.1}{91}} +\newlabel{SECTLAMBDA}{{4.2}{92}} +\@writefile{toc}{\contentsline {section}{\numberline {4.2}Lambda}{92}} +\newlabel{./binding:s3}{{4.2}{92}} +\newlabel{./binding:s4}{{4.2}{92}} +\newlabel{./binding:s5}{{4.2}{92}} +\newlabel{./binding:s6}{{4.2}{92}} +\newlabel{./binding:s7}{{4.2}{92}} +\newlabel{./binding:s8}{{4.2}{92}} +\newlabel{SECTOPTARGS}{{4.3}{93}} +\@writefile{toc}{\contentsline {section}{\numberline {4.3}Case-Lambda}{93}} +\newlabel{./binding:s9}{{4.3}{93}} +\newlabel{./binding:s10}{{4.3}{93}} +\citation{Dybvig:lambdastar} +\newlabel{./binding:s11}{{4.3}{94}} +\newlabel{./binding:s12}{{4.3}{94}} +\newlabel{./binding:s13}{{4.3}{94}} +\newlabel{./binding:s14}{{4.3}{94}} +\newlabel{./binding:s15}{{4.3}{95}} +\newlabel{SECTLOCALBINDING}{{4.4}{95}} +\@writefile{toc}{\contentsline {section}{\numberline {4.4}Local Binding}{95}} +\newlabel{./binding:s16}{{4.4}{95}} +\newlabel{./binding:s17}{{4.4}{95}} +\newlabel{./binding:s18}{{4.4}{96}} +\newlabel{./binding:s19}{{4.4}{96}} +\newlabel{defn:let*}{{4.4}{97}} +\newlabel{./binding:s20}{{4.4}{97}} +\newlabel{./binding:s21}{{4.4}{97}} +\citation{waddell:fixing-letrec} +\newlabel{./binding:s22}{{4.4}{98}} +\newlabel{desc:letrec*}{{4.4}{98}} +\newlabel{SECTLETVALUES}{{4.5}{99}} +\@writefile{toc}{\contentsline {section}{\numberline {4.5}Multiple Values}{99}} +\newlabel{./binding:s23}{{4.5}{99}} +\newlabel{desc:let-values}{{4.5}{99}} +\newlabel{SECTDEFINITIONS}{{4.6}{100}} +\@writefile{toc}{\contentsline {section}{\numberline {4.6}Variable Definitions}{100}} +\newlabel{./binding:s24}{{4.6}{100}} +\newlabel{./binding:s25}{{4.6}{100}} +\newlabel{./binding:s26}{{4.6}{101}} +\newlabel{multi-define-syntax}{{4.6}{101}} +\newlabel{./binding:s27}{{4.6}{101}} +\newlabel{SECTASSIGNMENTS}{{4.7}{102}} +\@writefile{toc}{\contentsline {section}{\numberline {4.7}Assignment}{102}} +\newlabel{./binding:s28}{{4.7}{102}} +\newlabel{./binding:s29}{{4.7}{102}} +\newlabel{./binding:s30}{{4.7}{102}} +\newlabel{./binding:s31}{{4.7}{102}} +\newlabel{./binding:s32}{{4.7}{102}} +\newlabel{./binding:s33}{{4.7}{102}} +\@setckpt{binding}{ +\setcounter{page}{104} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{4} +\setcounter{section}{7} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/contents.aux b/csug/tspl4/contents.aux new file mode 100644 index 0000000..49cad1a --- /dev/null +++ b/csug/tspl4/contents.aux @@ -0,0 +1,15 @@ +\relax +\@setckpt{contents}{ +\setcounter{page}{9} +\setcounter{equation}{0} +\setcounter{enumi}{0} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{0} +\setcounter{section}{0} +\setcounter{exercise}{0} +\setcounter{alphacount}{0} +} diff --git a/csug/tspl4/control.aux b/csug/tspl4/control.aux new file mode 100644 index 0000000..11f2169 --- /dev/null +++ b/csug/tspl4/control.aux @@ -0,0 +1,130 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {5}Control Operations}{105}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTCONTROL}{{5}{105}} +\newlabel{./control:s0}{{5}{107}} +\newlabel{SECTAPPLICATION}{{5.1}{107}} +\@writefile{toc}{\contentsline {section}{\numberline {5.1}Procedure Application}{107}} +\newlabel{./control:s1}{{5.1}{107}} +\newlabel{./control:s2}{{5.1}{107}} +\newlabel{./control:s3}{{5.1}{107}} +\newlabel{desc:apply}{{5.1}{107}} +\newlabel{SECTSEQUENCING}{{5.2}{108}} +\@writefile{toc}{\contentsline {section}{\numberline {5.2}Sequencing}{108}} +\newlabel{./control:s4}{{5.2}{108}} +\newlabel{./control:s5}{{5.2}{108}} +\newlabel{./control:s6}{{5.2}{108}} +\newlabel{./control:s7}{{5.2}{109}} +\newlabel{SECTCONDITIONALS}{{5.3}{109}} +\@writefile{toc}{\contentsline {section}{\numberline {5.3}Conditionals}{109}} +\newlabel{./control:s8}{{5.3}{109}} +\newlabel{./control:s9}{{5.3}{109}} +\newlabel{./control:s10}{{5.3}{110}} +\newlabel{./control:s11}{{5.3}{110}} +\newlabel{./control:s12}{{5.3}{110}} +\newlabel{./control:s13}{{5.3}{111}} +\newlabel{./control:s14}{{5.3}{111}} +\newlabel{./control:s15}{{5.3}{111}} +\newlabel{./control:s16}{{5.3}{112}} +\newlabel{./control:s17}{{5.3}{112}} +\newlabel{./control:s18}{{5.3}{113}} +\newlabel{./control:s19}{{5.3}{113}} +\newlabel{SECTRECURSION}{{5.4}{114}} +\@writefile{toc}{\contentsline {section}{\numberline {5.4}Recursion and Iteration}{114}} +\newlabel{./control:s20}{{5.4}{114}} +\newlabel{./control:s21}{{5.4}{114}} +\newlabel{./control:s22}{{5.4}{114}} +\newlabel{./control:s23}{{5.4}{114}} +\newlabel{./control:s24}{{5.4}{115}} +\newlabel{./control:s25}{{5.4}{115}} +\newlabel{./control:s26}{{5.4}{115}} +\newlabel{./control:s27}{{5.4}{116}} +\newlabel{./control:s28}{{5.4}{116}} +\newlabel{./control:s29}{{5.4}{116}} +\@writefile{toc}{\contentsline {section}{\numberline {5.5}Mapping and Folding}{117}} +\newlabel{./control:s30}{{5.5}{117}} +\newlabel{./control:s31}{{5.5}{117}} +\newlabel{./control:s32}{{5.5}{117}} +\newlabel{./control:s33}{{5.5}{118}} +\newlabel{desc:for-each}{{5.5}{118}} +\newlabel{./control:s34}{{5.5}{118}} +\newlabel{./control:s35}{{5.5}{118}} +\newlabel{./control:s36}{{5.5}{119}} +\newlabel{./control:s37}{{5.5}{119}} +\newlabel{./control:s38}{{5.5}{120}} +\newlabel{./control:s39}{{5.5}{120}} +\newlabel{./control:s40}{{5.5}{120}} +\newlabel{./control:s41}{{5.5}{121}} +\newlabel{./control:s42}{{5.5}{121}} +\newlabel{./control:s43}{{5.5}{121}} +\newlabel{./control:s44}{{5.5}{121}} +\newlabel{./control:s45}{{5.5}{121}} +\newlabel{./control:s46}{{5.5}{121}} +\newlabel{./control:s47}{{5.5}{122}} +\newlabel{./control:s48}{{5.5}{122}} +\newlabel{./control:s49}{{5.5}{122}} +\newlabel{./control:s50}{{5.5}{122}} +\newlabel{./control:s51}{{5.5}{122}} +\newlabel{./control:s52}{{5.5}{122}} +\newlabel{SECTCONTINUATIONS}{{5.6}{122}} +\@writefile{toc}{\contentsline {section}{\numberline {5.6}Continuations}{122}} +\newlabel{./control:s53}{{5.6}{122}} +\citation{Friedman:devils} +\citation{Sussman-Steele:HOSC98} +\citation{Haynes:obtaining} +\citation{Dybvig:engines} +\citation{Wand:HOSC99} +\citation{Hieb:representing} +\newlabel{./control:s54}{{5.6}{123}} +\newlabel{./control:s55}{{5.6}{123}} +\newlabel{./control:s56}{{5.6}{124}} +\newlabel{desc:dynamic-wind}{{5.6}{124}} +\newlabel{./control:s57}{{5.6}{124}} +\newlabel{./control:s58}{{5.6}{124}} +\newlabel{./control:s59}{{5.6}{124}} +\newlabel{./control:s60}{{5.6}{124}} +\newlabel{./control:s61}{{5.6}{125}} +\newlabel{./control:s62}{{5.6}{126}} +\newlabel{./control:s63}{{5.6}{127}} +\newlabel{SECTDELAYED}{{5.7}{127}} +\@writefile{toc}{\contentsline {section}{\numberline {5.7}Delayed Evaluation}{127}} +\newlabel{./control:s64}{{5.7}{127}} +\newlabel{./control:s65}{{5.7}{128}} +\newlabel{./control:s66}{{5.7}{128}} +\newlabel{./control:s67}{{5.7}{129}} +\newlabel{SECTMRVS}{{5.8}{130}} +\@writefile{toc}{\contentsline {section}{\numberline {5.8}Multiple Values}{130}} +\newlabel{./control:s68}{{5.8}{130}} +\newlabel{./control:s69}{{5.8}{130}} +\newlabel{./control:s70}{{5.8}{131}} +\newlabel{./control:s71}{{5.8}{131}} +\newlabel{./control:s72}{{5.8}{131}} +\newlabel{./control:s73}{{5.8}{132}} +\newlabel{./control:s74}{{5.8}{132}} +\newlabel{./control:s75}{{5.8}{132}} +\newlabel{./control:s76}{{5.8}{133}} +\newlabel{./control:s77}{{5.8}{133}} +\newlabel{./control:s78}{{5.8}{134}} +\newlabel{./control:s79}{{5.8}{134}} +\newlabel{defn:call-with-port}{{5.8}{135}} +\citation{ashley:mvalues} +\newlabel{SECTEVAL}{{5.9}{136}} +\@writefile{toc}{\contentsline {section}{\numberline {5.9}Eval}{136}} +\newlabel{./control:s80}{{5.9}{136}} +\newlabel{./control:s81}{{5.9}{137}} +\newlabel{./control:s82}{{5.9}{137}} +\@setckpt{control}{ +\setcounter{page}{138} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{5} +\setcounter{section}{9} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/copyright.aux b/csug/tspl4/copyright.aux new file mode 100644 index 0000000..7a93de1 --- /dev/null +++ b/csug/tspl4/copyright.aux @@ -0,0 +1,15 @@ +\relax +\@setckpt{copyright}{ +\setcounter{page}{5} +\setcounter{equation}{0} +\setcounter{enumi}{0} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{0} +\setcounter{section}{0} +\setcounter{exercise}{0} +\setcounter{alphacount}{0} +} diff --git a/csug/tspl4/examples.aux b/csug/tspl4/examples.aux new file mode 100644 index 0000000..21d18dc --- /dev/null +++ b/csug/tspl4/examples.aux @@ -0,0 +1,165 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {12}Extended Examples}{379}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTEXAMPLES}{{12}{379}} +\citation{Kernighan:C} +\newlabel{./examples:s0}{{12}{381}} +\newlabel{SECTEXMATMUL}{{12.1}{381}} +\@writefile{toc}{\contentsline {section}{\numberline {12.1}Matrix and Vector Multiplication}{381}} +\newlabel{./examples:s1}{{12.1}{381}} +\newlabel{./examples:s2}{{12.1}{382}} +\newlabel{./examples:s3}{{12.1}{383}} +\newlabel{./examples:s4}{{12.1.1}{386}} +\newlabel{./examples:s5}{{12.1.2}{386}} +\newlabel{exercise:reliable}{{12.1.2}{386}} +\newlabel{./examples:s6}{{12.1.3}{386}} +\newlabel{./examples:s7}{{12.1.4}{386}} +\newlabel{./examples:s8}{{12.1.5}{386}} +\newlabel{SECTEXSORTMERGE}{{12.2}{387}} +\@writefile{toc}{\contentsline {section}{\numberline {12.2}Sorting}{387}} +\newlabel{./examples:s9}{{12.2}{387}} +\newlabel{./examples:s10}{{12.2}{387}} +\newlabel{./examples:s11}{{12.2}{387}} +\newlabel{./examples:s12}{{12.2.1}{388}} +\newlabel{./examples:s13}{{12.2.2}{388}} +\newlabel{./examples:s14}{{12.2.3}{388}} +\citation{Plaisted:sets} +\newlabel{SECTEXSETS}{{12.3}{389}} +\@writefile{toc}{\contentsline {section}{\numberline {12.3}A Set Constructor}{389}} +\newlabel{./examples:s15}{{12.3}{389}} +\newlabel{./examples:s16}{{12.3}{389}} +\newlabel{./examples:s17}{{12.3}{389}} +\newlabel{./examples:s18}{{12.3}{389}} +\citation{Kernighan:C} +\newlabel{./examples:s19}{{12.3.1}{392}} +\newlabel{./examples:s20}{{12.3.2}{392}} +\newlabel{./examples:s21}{{12.3.2}{392}} +\newlabel{./examples:s22}{{12.3.3}{392}} +\newlabel{SECTEXWORDFREQ}{{12.4}{393}} +\@writefile{toc}{\contentsline {section}{\numberline {12.4}Word Frequency Counting}{393}} +\newlabel{./examples:s23}{{12.4}{393}} +\newlabel{./examples:s24}{{12.4}{393}} +\citation{r6rsapps} +\newlabel{./examples:s25}{{12.4.1}{396}} +\newlabel{./examples:s26}{{12.4.2}{396}} +\newlabel{./examples:s27}{{12.4.3}{396}} +\newlabel{./examples:s28}{{12.4.4}{396}} +\newlabel{./examples:s29}{{12.4.5}{396}} +\newlabel{./examples:s30}{{12.4.6}{397}} +\newlabel{SECTEXPRINTER}{{12.5}{397}} +\@writefile{toc}{\contentsline {section}{\numberline {12.5}Scheme Printer}{397}} +\newlabel{./examples:s31}{{12.5}{397}} +\newlabel{./examples:s32}{{12.5}{397}} +\newlabel{./examples:s33}{{12.5}{397}} +\newlabel{./examples:s34}{{12.5.1}{400}} +\newlabel{./examples:s35}{{12.5.2}{400}} +\newlabel{EXOBJTOSTR}{{12.5.2}{400}} +\newlabel{./examples:s36}{{12.5.3}{400}} +\newlabel{SECTEXPRINTF}{{12.6}{401}} +\@writefile{toc}{\contentsline {section}{\numberline {12.6}Formatted Output}{401}} +\newlabel{./examples:s37}{{12.6}{401}} +\newlabel{./examples:s38}{{12.6}{401}} +\newlabel{./examples:s39}{{12.6}{401}} +\newlabel{./examples:s40}{{12.6.1}{402}} +\newlabel{./examples:s41}{{12.6.2}{402}} +\newlabel{./examples:s42}{{12.6.3}{403}} +\newlabel{./examples:s43}{{12.6.4}{403}} +\newlabel{./examples:s44}{{12.6.5}{403}} +\newlabel{./examples:s45}{{12.6.6}{403}} +\newlabel{SECTEXINTERPRET}{{12.7}{404}} +\@writefile{toc}{\contentsline {section}{\numberline {12.7}A Meta-Circular Interpreter for Scheme}{404}} +\newlabel{./examples:s46}{{12.7}{404}} +\newlabel{./examples:s47}{{12.7}{404}} +\newlabel{./examples:s48}{{12.7}{404}} +\newlabel{./examples:s49}{{12.7}{404}} +\newlabel{./examples:s50}{{12.7}{404}} +\newlabel{./examples:s51}{{12.7}{404}} +\newlabel{./examples:s52}{{12.7.1}{407}} +\newlabel{./examples:s53}{{12.7.2}{407}} +\newlabel{./examples:s54}{{12.7.3}{407}} +\newlabel{./examples:s55}{{12.7.4}{407}} +\newlabel{./examples:s56}{{12.7.5}{407}} +\newlabel{./examples:s57}{{12.7.5}{407}} +\newlabel{./examples:s58}{{12.7.5}{408}} +\newlabel{./examples:s59}{{12.7.5}{408}} +\newlabel{SECTEXOBJECTS}{{12.8}{408}} +\@writefile{toc}{\contentsline {section}{\numberline {12.8}Defining Abstract Objects}{408}} +\newlabel{./examples:s60}{{12.8}{408}} +\newlabel{./examples:s61}{{12.8}{408}} +\newlabel{./examples:s62}{{12.8}{408}} +\newlabel{./examples:s63}{{12.8}{408}} +\citation{Briggs:dft} +\newlabel{./examples:s64}{{12.8.1}{412}} +\newlabel{./examples:s65}{{12.8.2}{412}} +\newlabel{./examples:s66}{{12.8.3}{412}} +\newlabel{./examples:s67}{{12.8.3}{412}} +\newlabel{./examples:s68}{{12.8.4}{412}} +\newlabel{SECTEXFFT}{{12.9}{412}} +\@writefile{toc}{\contentsline {section}{\numberline {12.9}Fast Fourier Transform}{412}} +\newlabel{./examples:s69}{{12.9}{412}} +\newlabel{./examples:s70}{{12.9}{412}} +\citation{Daniel:prolog-fft} +\citation{Daniel:prolog-fft} +\newlabel{./examples:s71}{{12.9.1}{416}} +\citation{Robinson:unification} +\citation{Clocksin:prolog} +\newlabel{./examples:s72}{{12.9.2}{417}} +\newlabel{./examples:s73}{{12.9.3}{417}} +\newlabel{./examples:s74}{{12.9.4}{417}} +\newlabel{./examples:s75}{{12.9.5}{417}} +\newlabel{SECTEXUNIFY}{{12.10}{417}} +\@writefile{toc}{\contentsline {section}{\numberline {12.10}A Unification Algorithm}{417}} +\newlabel{./examples:s76}{{12.10}{417}} +\newlabel{./examples:s77}{{12.10}{418}} +\newlabel{./examples:s78}{{12.10}{418}} +\citation{Dybvig:engines} +\citation{Haynes:abstracting} +\newlabel{./examples:s79}{{12.10.1}{420}} +\newlabel{./examples:s80}{{12.10.2}{420}} +\newlabel{./examples:s81}{{12.10.3}{420}} +\newlabel{SECTEXENGINES}{{12.11}{421}} +\@writefile{toc}{\contentsline {section}{\numberline {12.11}Multitasking with Engines}{421}} +\newlabel{./examples:s82}{{12.11}{421}} +\newlabel{./examples:s83}{{12.11}{421}} +\newlabel{./examples:s84}{{12.11}{421}} +\newlabel{./examples:s85}{{12.11}{421}} +\newlabel{./examples:s86}{{12.11}{421}} +\newlabel{./examples:s87}{{12.11}{421}} +\newlabel{./examples:s88}{{12.11}{421}} +\newlabel{./examples:s89}{{1}{421}} +\newlabel{./examples:s90}{{2}{421}} +\newlabel{./examples:s91}{{3}{421}} +\newlabel{./examples:s92}{{12.11}{422}} +\newlabel{./examples:s93}{{12.11}{423}} +\newlabel{./examples:s94}{{12.11}{423}} +\newlabel{./examples:s95}{{12.11}{424}} +\newlabel{./examples:s96}{{12.11}{424}} +\newlabel{./examples:s97}{{12.11}{425}} +\newlabel{./examples:s98}{{12.11}{425}} +\newlabel{./examples:s99}{{12.11}{426}} +\newlabel{./examples:s100}{{12.11}{426}} +\newlabel{./examples:s101}{{12.11.1}{428}} +\newlabel{./examples:s102}{{12.11.2}{428}} +\citation{Dybvig:engines} +\newlabel{./examples:s103}{{12.11.3}{429}} +\newlabel{./examples:s104}{{12.11.4}{429}} +\newlabel{./examples:s105}{{12.11.5}{429}} +\newlabel{./examples:s106}{{12.11.5}{429}} +\newlabel{./examples:s107}{{12.11.6}{429}} +\newlabel{./examples:s108}{{12.11.7}{429}} +\newlabel{./examples:s109}{{12.11.7}{429}} +\@setckpt{examples}{ +\setcounter{page}{430} +\setcounter{equation}{0} +\setcounter{enumi}{3} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{12} +\setcounter{section}{11} +\setcounter{exercise}{7} +\setcounter{alphacount}{3} +} diff --git a/csug/tspl4/exceptions.aux b/csug/tspl4/exceptions.aux new file mode 100644 index 0000000..f8d2abe --- /dev/null +++ b/csug/tspl4/exceptions.aux @@ -0,0 +1,69 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {11}Exceptions and Conditions}{355}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTEXCEPTIONS}{{11}{355}} +\newlabel{./exceptions:s0}{{11}{357}} +\newlabel{./exceptions:s1}{{11}{357}} +\newlabel{./exceptions:s2}{{11}{357}} +\@writefile{toc}{\contentsline {section}{\numberline {11.1}Raising and Handling Exceptions}{357}} +\newlabel{./exceptions:s3}{{11.1}{357}} +\newlabel{./exceptions:s4}{{11.1}{358}} +\newlabel{./exceptions:s5}{{11.1}{359}} +\newlabel{./exceptions:s6}{{11.1}{359}} +\newlabel{./exceptions:s7}{{11.1}{360}} +\newlabel{./exceptions:s8}{{11.1}{361}} +\@writefile{toc}{\contentsline {section}{\numberline {11.2}Defining Condition Types}{361}} +\newlabel{./exceptions:s9}{{11.2}{361}} +\newlabel{./exceptions:s10}{{11.2}{361}} +\newlabel{./exceptions:s11}{{11.2}{362}} +\newlabel{./exceptions:s12}{{11.2}{362}} +\newlabel{./exceptions:s13}{{11.2}{362}} +\newlabel{./exceptions:s14}{{11.2}{362}} +\newlabel{./exceptions:s15}{{11.2}{362}} +\newlabel{./exceptions:s16}{{11.2}{363}} +\newlabel{./exceptions:s17}{{11.2}{364}} +\newlabel{./exceptions:s18}{{11.2}{365}} +\newlabel{SECTEXCCONDTYPES}{{11.3}{366}} +\@writefile{toc}{\contentsline {section}{\numberline {11.3}Standard Condition Types}{366}} +\newlabel{./exceptions:s19}{{11.3}{366}} +\newlabel{./exceptions:s20}{{11.3}{366}} +\newlabel{./exceptions:s21}{{11.3}{366}} +\newlabel{./exceptions:s22}{{11.3}{367}} +\newlabel{./exceptions:s23}{{11.3}{367}} +\newlabel{./exceptions:s24}{{11.3}{368}} +\newlabel{./exceptions:s25}{{11.3}{368}} +\newlabel{./exceptions:s26}{{11.3}{369}} +\newlabel{./exceptions:s27}{{11.3}{369}} +\newlabel{./exceptions:s28}{{11.3}{369}} +\newlabel{./exceptions:s29}{{11.3}{370}} +\newlabel{./exceptions:s30}{{11.3}{370}} +\newlabel{./exceptions:s31}{{11.3}{371}} +\newlabel{./exceptions:s32}{{11.3}{371}} +\newlabel{./exceptions:s33}{{11.3}{372}} +\newlabel{./exceptions:s34}{{11.3}{372}} +\newlabel{./exceptions:s35}{{11.3}{372}} +\newlabel{./exceptions:s36}{{11.3}{373}} +\newlabel{./exceptions:s37}{{11.3}{373}} +\newlabel{./exceptions:s38}{{11.3}{374}} +\newlabel{./exceptions:s39}{{11.3}{374}} +\newlabel{./exceptions:s40}{{11.3}{374}} +\newlabel{./exceptions:s41}{{11.3}{375}} +\newlabel{./exceptions:s42}{{11.3}{375}} +\newlabel{./exceptions:s43}{{11.3}{376}} +\newlabel{./exceptions:s44}{{11.3}{376}} +\newlabel{./exceptions:s45}{{11.3}{377}} +\@setckpt{exceptions}{ +\setcounter{page}{378} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{11} +\setcounter{section}{3} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/further.aux b/csug/tspl4/further.aux new file mode 100644 index 0000000..b73f22b --- /dev/null +++ b/csug/tspl4/further.aux @@ -0,0 +1,132 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {3}Going Further}{57}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTGOINGFURTHER}{{3}{57}} +\newlabel{SECTGFSYNTAX}{{3.1}{59}} +\@writefile{toc}{\contentsline {section}{\numberline {3.1}Syntactic Extension}{59}} +\newlabel{./further:s0}{{3.1}{59}} +\newlabel{./further:s1}{{3.1}{59}} +\newlabel{./further:s2}{{3.1}{59}} +\newlabel{./further:s3}{{3.1}{59}} +\newlabel{./further:s4}{{3.1}{59}} +\newlabel{./further:s5}{{3.1}{59}} +\newlabel{./further:s6}{{3.1}{59}} +\newlabel{./further:s7}{{3.1}{59}} +\newlabel{./further:s8}{{3.1}{59}} +\newlabel{./further:s9}{{3.1}{60}} +\newlabel{./further:s10}{{3.1}{60}} +\newlabel{./further:s11}{{3.1}{60}} +\newlabel{./further:s12}{{3.1}{60}} +\newlabel{./further:s13}{{3.1}{61}} +\newlabel{./further:s14}{{3.1}{61}} +\newlabel{./further:s15}{{3.1}{61}} +\newlabel{./further:s16}{{3.1}{61}} +\newlabel{./further:s17}{{3.1}{61}} +\newlabel{./further:s18}{{3.1}{61}} +\newlabel{./further:s19}{{3.1}{61}} +\newlabel{./further:s20}{{3.1}{61}} +\newlabel{./further:s21}{{3.1}{61}} +\newlabel{./further:s22}{{3.1}{62}} +\newlabel{defn:and}{{3.1}{62}} +\newlabel{./further:s23}{{3.1}{63}} +\newlabel{defn:or}{{3.1}{63}} +\newlabel{./further:s24}{{3.1}{63}} +\newlabel{./further:s25}{{3.1.1}{64}} +\newlabel{./further:s26}{{3.1.2}{64}} +\newlabel{./further:s27}{{3.1.3}{64}} +\newlabel{./further:s28}{{3.1.3}{64}} +\newlabel{./further:s29}{{3.1.4}{64}} +\newlabel{./further:s30}{{3.1.4}{64}} +\newlabel{./further:s31}{{3.1.4}{64}} +\newlabel{SECTGFMORERECURSION}{{3.2}{65}} +\@writefile{toc}{\contentsline {section}{\numberline {3.2}More Recursion}{65}} +\newlabel{./further:s32}{{3.2}{65}} +\newlabel{./further:s33}{{3.2}{65}} +\newlabel{./further:s34}{{3.2}{65}} +\newlabel{./further:s35}{{3.2}{65}} +\newlabel{./further:s36}{{3.2}{66}} +\newlabel{./further:s37}{{3.2}{66}} +\newlabel{./further:s38}{{3.2}{66}} +\newlabel{defn:even?/odd?}{{3.2}{66}} +\newlabel{./further:s39}{{3.2}{66}} +\newlabel{./further:s40}{{3.2}{66}} +\newlabel{defn:list?}{{3.2}{67}} +\newlabel{./further:s41}{{3.2}{67}} +\newlabel{./further:s42}{{3.2}{67}} +\newlabel{./further:s43}{{3.2}{68}} +\newlabel{./further:s44}{{3.2}{68}} +\newlabel{./further:s45}{{3.2}{68}} +\newlabel{./further:s46}{{3.2}{68}} +\newlabel{fibonacci}{{3.2}{69}} +\newlabel{./further:s47}{{3.2}{69}} +\newlabel{./further:s48}{{3.2}{69}} +\newlabel{./further:s49}{{3.2}{70}} +\newlabel{./further:s50}{{3.2}{71}} +\newlabel{./further:s51}{{3.2}{71}} +\newlabel{./further:s52}{{3.2.1}{72}} +\newlabel{./further:s53}{{3.2.2}{72}} +\newlabel{./further:s54}{{3.2.2}{72}} +\newlabel{./further:s55}{{3.2.3}{72}} +\newlabel{./further:s56}{{3.2.4}{72}} +\newlabel{./further:s57}{{3.2.5}{73}} +\newlabel{./further:s58}{{3.2.6}{73}} +\newlabel{ex:incorrect-or}{{3.2.6}{73}} +\newlabel{./further:s59}{{3.2.7}{73}} +\newlabel{./further:s60}{{3.2.7}{73}} +\newlabel{SECTGFCONTINUATIONS}{{3.3}{73}} +\@writefile{toc}{\contentsline {section}{\numberline {3.3}Continuations}{73}} +\newlabel{./further:s61}{{3.3}{73}} +\newlabel{./further:s62}{{3.3}{74}} +\newlabel{./further:s63}{{3.3}{74}} +\newlabel{defn:product-call/cc}{{3.3}{75}} +\newlabel{./further:s64}{{3.3}{75}} +\newlabel{./further:s65}{{3.3}{75}} +\newlabel{retry}{{3.3}{75}} +\newlabel{./further:s66}{{3.3.1}{77}} +\newlabel{./further:s67}{{3.3.2}{77}} +\newlabel{./further:s68}{{3.3.3}{77}} +\newlabel{./further:s69}{{3.3.4}{77}} +\newlabel{./further:s70}{{3.3.5}{77}} +\newlabel{SECTGFCPS}{{3.4}{78}} +\@writefile{toc}{\contentsline {section}{\numberline {3.4}Continuation Passing Style}{78}} +\newlabel{./further:s71}{{3.4}{78}} +\newlabel{./further:s72}{{3.4}{78}} +\newlabel{./further:s73}{{3.4}{79}} +\newlabel{./further:s74}{{3.4}{80}} +\newlabel{./further:s75}{{3.4.1}{80}} +\newlabel{./further:s76}{{3.4.1}{80}} +\newlabel{./further:s77}{{3.4.2}{80}} +\newlabel{./further:s78}{{3.4.2}{80}} +\newlabel{./further:s79}{{3.4.3}{80}} +\newlabel{SECTGFINTERNAL}{{3.5}{81}} +\@writefile{toc}{\contentsline {section}{\numberline {3.5}Internal Definitions}{81}} +\newlabel{./further:s80}{{3.5}{81}} +\newlabel{./further:s81}{{3.5}{81}} +\newlabel{./further:s82}{{3.5}{81}} +\newlabel{./further:s83}{{3.5}{81}} +\newlabel{./further:s84}{{3.5}{81}} +\newlabel{./further:s85}{{3.5}{81}} +\newlabel{./further:s86}{{3.5.1}{85}} +\newlabel{./further:s87}{{3.5.2}{85}} +\newlabel{./further:s88}{{3.5.3}{85}} +\newlabel{./further:s89}{{3.5.4}{85}} +\newlabel{SECTGFLIBRARIES}{{3.6}{85}} +\@writefile{toc}{\contentsline {section}{\numberline {3.6}Libraries}{85}} +\newlabel{./further:s90}{{3.6.1}{87}} +\newlabel{./further:s91}{{3.6.2}{87}} +\newlabel{./further:s92}{{3.6.3}{87}} +\@setckpt{further}{ +\setcounter{page}{89} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{3} +\setcounter{section}{6} +\setcounter{exercise}{3} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/grammar.aux b/csug/tspl4/grammar.aux new file mode 100644 index 0000000..8fc6ad3 --- /dev/null +++ b/csug/tspl4/grammar.aux @@ -0,0 +1,53 @@ +\relax +\citation{Unicode} +\@writefile{toc}{\contentsline {chapter}{Formal Syntax}{455}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{APPENDIXFORMALSYNTAX}{{12.11.7}{455}} +\newlabel{./grammar:s0}{{12.11.7}{455}} +\newlabel{./grammar:s1}{{12.11.7}{455}} +\newlabel{./grammar:s2}{{12.11.7}{455}} +\newlabel{./grammar:s3}{{12.11.7}{455}} +\newlabel{./grammar:s4}{{12.11.7}{455}} +\newlabel{./grammar:s5}{{12.11.7}{455}} +\newlabel{./grammar:s6}{{12.11.7}{455}} +\newlabel{./grammar:s7}{{12.11.7}{455}} +\newlabel{./grammar:s8}{{12.11.7}{455}} +\newlabel{./grammar:s9}{{12.11.7}{455}} +\newlabel{./grammar:s10}{{12.11.7}{455}} +\newlabel{./grammar:s11}{{12.11.7}{455}} +\newlabel{./grammar:s12}{{12.11.7}{456}} +\newlabel{grammar:datums}{{12.11.7}{456}} +\newlabel{./grammar:s13}{{12.11.7}{456}} +\newlabel{grammar:booleans}{{12.11.7}{457}} +\newlabel{./grammar:s14}{{12.11.7}{457}} +\newlabel{grammar:characters}{{12.11.7}{457}} +\newlabel{./grammar:s15}{{12.11.7}{457}} +\newlabel{grammar:strings}{{12.11.7}{458}} +\newlabel{./grammar:s16}{{12.11.7}{458}} +\newlabel{grammar:symbols}{{12.11.7}{458}} +\newlabel{./grammar:s17}{{12.11.7}{458}} +\newlabel{grammar:numbers}{{12.11.7}{459}} +\newlabel{./grammar:s18}{{12.11.7}{459}} +\newlabel{grammar:lists}{{12.11.7}{460}} +\newlabel{./grammar:s19}{{12.11.7}{460}} +\newlabel{./grammar:s20}{{12.11.7}{460}} +\newlabel{./grammar:s21}{{12.11.7}{460}} +\newlabel{grammar:vectors}{{12.11.7}{461}} +\newlabel{./grammar:s22}{{12.11.7}{461}} +\newlabel{grammar:bytevectors}{{12.11.7}{461}} +\newlabel{./grammar:s23}{{12.11.7}{461}} +\@setckpt{grammar}{ +\setcounter{page}{462} +\setcounter{equation}{0} +\setcounter{enumi}{8} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{32} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{12} +\setcounter{section}{11} +\setcounter{exercise}{7} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/intro.aux b/csug/tspl4/intro.aux new file mode 100644 index 0000000..a377227 --- /dev/null +++ b/csug/tspl4/intro.aux @@ -0,0 +1,85 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {1}Introduction}{1}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTINTRO}{{1}{1}} +\citation{r6rs} +\newlabel{./intro:s0}{{1}{3}} +\newlabel{./intro:s1}{{1}{3}} +\newlabel{./intro:s2}{{1}{3}} +\newlabel{./intro:s3}{{1}{3}} +\newlabel{./intro:s4}{{1}{3}} +\newlabel{./intro:s5}{{1}{4}} +\newlabel{./intro:s6}{{1}{4}} +\newlabel{./intro:s7}{{1}{4}} +\newlabel{./intro:s8}{{1}{4}} +\newlabel{./intro:s9}{{1}{4}} +\newlabel{./intro:s10}{{1}{4}} +\newlabel{./intro:s11}{{1}{4}} +\newlabel{./intro:s12}{{1}{4}} +\newlabel{./intro:s13}{{1}{4}} +\newlabel{./intro:s14}{{1}{4}} +\newlabel{./intro:s15}{{1}{4}} +\newlabel{./intro:s16}{{1}{5}} +\newlabel{./intro:s17}{{1}{5}} +\newlabel{./intro:s18}{{1}{5}} +\newlabel{./intro:s19}{{1}{5}} +\newlabel{./intro:s20}{{1}{5}} +\newlabel{./intro:s21}{{1}{5}} +\newlabel{./intro:s22}{{1}{5}} +\newlabel{./intro:s23}{{1}{5}} +\newlabel{./intro:s24}{{1}{5}} +\newlabel{./intro:s25}{{1}{5}} +\citation{Naur:algol} +\citation{Steele:common} +\newlabel{./intro:s26}{{1}{6}} +\newlabel{./intro:s27}{{1}{6}} +\newlabel{./intro:s28}{{1}{6}} +\newlabel{SECTINTROSYNTAX}{{1.1}{6}} +\@writefile{toc}{\contentsline {section}{\numberline {1.1}Scheme Syntax}{6}} +\newlabel{./intro:s29}{{1.1}{6}} +\newlabel{./intro:s30}{{1.1}{6}} +\newlabel{./intro:s31}{{1.1}{7}} +\newlabel{./intro:s32}{{1.1}{7}} +\newlabel{./intro:s33}{{1.1}{7}} +\newlabel{./intro:s34}{{1.1}{7}} +\newlabel{./intro:s35}{{1.1}{7}} +\newlabel{./intro:s36}{{1.1}{7}} +\newlabel{./intro:s37}{{1.1}{7}} +\newlabel{./intro:s38}{{1.1}{7}} +\newlabel{./intro:s39}{{1.1}{7}} +\newlabel{./intro:s40}{{1.1}{7}} +\newlabel{./intro:s41}{{1.1}{7}} +\newlabel{./intro:s42}{{1.1}{7}} +\newlabel{./intro:s43}{{1.1}{7}} +\newlabel{./intro:s44}{{1.1}{7}} +\newlabel{SECTINTRONAMING}{{1.2}{8}} +\@writefile{toc}{\contentsline {section}{\numberline {1.2}Scheme Naming Conventions}{8}} +\newlabel{./intro:s45}{{1.2}{8}} +\newlabel{./intro:s46}{{1.2}{8}} +\newlabel{./intro:s47}{{1.2}{8}} +\newlabel{./intro:s48}{{1.2}{8}} +\newlabel{./intro:s49}{{1.2}{8}} +\newlabel{./intro:s50}{{1.2}{8}} +\newlabel{./intro:s51}{{1.2}{8}} +\newlabel{./intro:s52}{{1.2}{8}} +\newlabel{SECTINTRONOTATION}{{1.3}{9}} +\@writefile{toc}{\contentsline {section}{\numberline {1.3}Typographical and Notational Conventions}{9}} +\newlabel{./intro:s53}{{1.3}{9}} +\newlabel{./intro:s54}{{1.3}{9}} +\newlabel{./intro:s55}{{1.3}{9}} +\newlabel{./intro:s56}{{1.3}{9}} +\@setckpt{intro}{ +\setcounter{page}{11} +\setcounter{equation}{0} +\setcounter{enumi}{0} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{1} +\setcounter{section}{3} +\setcounter{exercise}{0} +\setcounter{alphacount}{0} +} diff --git a/csug/tspl4/io.aux b/csug/tspl4/io.aux new file mode 100644 index 0000000..e80893c --- /dev/null +++ b/csug/tspl4/io.aux @@ -0,0 +1,141 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {7}Input and Output}{255}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTIO}{{7}{255}} +\newlabel{./io:s0}{{7}{257}} +\newlabel{./io:s1}{{7}{257}} +\newlabel{./io:s2}{{7}{257}} +\newlabel{./io:s3}{{7}{257}} +\newlabel{./io:s4}{{7}{257}} +\newlabel{./io:s5}{{7}{257}} +\newlabel{./io:s6}{{7}{257}} +\newlabel{./io:s7}{{7}{257}} +\newlabel{./io:s8}{{7}{257}} +\newlabel{./io:s9}{{7}{257}} +\newlabel{./io:s10}{{7}{257}} +\newlabel{./io:s11}{{7}{257}} +\newlabel{./io:s12}{{7}{257}} +\newlabel{./io:s13}{{7}{257}} +\newlabel{./io:s14}{{7}{257}} +\newlabel{./io:s15}{{7}{258}} +\newlabel{./io:s16}{{7}{258}} +\newlabel{./io:s17}{{7}{258}} +\newlabel{./io:s18}{{7}{258}} +\newlabel{SECTTRANSCODERS}{{7.1}{258}} +\@writefile{toc}{\contentsline {section}{\numberline {7.1}Transcoders}{258}} +\newlabel{./io:s19}{{7.1}{259}} +\newlabel{./io:s20}{{7.1}{259}} +\newlabel{./io:s21}{{7.1}{259}} +\newlabel{./io:s22}{{7.1}{259}} +\newlabel{./io:s23}{{7.1}{259}} +\newlabel{./io:s24}{{7.1}{260}} +\newlabel{./io:s25}{{7.1}{260}} +\newlabel{SECTOPENINGFILES}{{7.2}{260}} +\@writefile{toc}{\contentsline {section}{\numberline {7.2}Opening Files}{260}} +\citation{Dybvig:csug8} +\newlabel{./io:s26}{{7.2}{261}} +\newlabel{./io:s27}{{7.2}{261}} +\newlabel{./io:s28}{{7.2}{262}} +\newlabel{./io:s29}{{7.2}{262}} +\newlabel{./io:s30}{{7.2}{262}} +\newlabel{./io:s31}{{7.2}{263}} +\newlabel{SECTSTANDARDPORTS}{{7.3}{263}} +\@writefile{toc}{\contentsline {section}{\numberline {7.3}Standard Ports}{263}} +\newlabel{./io:s32}{{7.3}{263}} +\newlabel{./io:s33}{{7.3}{264}} +\newlabel{SECTSTRINGPORTS}{{7.4}{264}} +\@writefile{toc}{\contentsline {section}{\numberline {7.4}String and Bytevector Ports}{264}} +\newlabel{./io:s34}{{7.4}{264}} +\newlabel{./io:s35}{{7.4}{265}} +\newlabel{./io:s36}{{7.4}{265}} +\newlabel{./io:s37}{{7.4}{266}} +\newlabel{./io:s38}{{7.4}{266}} +\newlabel{./io:s39}{{7.4}{267}} +\newlabel{./io:s40}{{7.4}{267}} +\newlabel{SECTCUSTOMPORTS}{{7.5}{267}} +\@writefile{toc}{\contentsline {section}{\numberline {7.5}Opening Custom Ports}{267}} +\newlabel{./io:s41}{{7.5}{267}} +\newlabel{./io:s42}{{7.5}{268}} +\newlabel{SECTPORTOPERATIONS}{{7.6}{270}} +\@writefile{toc}{\contentsline {section}{\numberline {7.6}Port Operations}{270}} +\newlabel{./io:s43}{{7.6}{270}} +\newlabel{./io:s44}{{7.6}{270}} +\newlabel{./io:s45}{{7.6}{270}} +\newlabel{./io:s46}{{7.6}{270}} +\newlabel{./io:s47}{{7.6}{271}} +\newlabel{./io:s48}{{7.6}{271}} +\newlabel{./io:s49}{{7.6}{271}} +\newlabel{./io:s50}{{7.6}{272}} +\newlabel{./io:s51}{{7.6}{272}} +\newlabel{desc:call-with-port}{{7.6}{272}} +\newlabel{./io:s52}{{7.6}{273}} +\newlabel{SECTINPUT}{{7.7}{273}} +\@writefile{toc}{\contentsline {section}{\numberline {7.7}Input Operations}{273}} +\newlabel{./io:s53}{{7.7}{273}} +\newlabel{./io:s54}{{7.7}{273}} +\newlabel{./io:s55}{{7.7}{274}} +\newlabel{./io:s56}{{7.7}{274}} +\newlabel{./io:s57}{{7.7}{274}} +\newlabel{./io:s58}{{7.7}{274}} +\newlabel{./io:s59}{{7.7}{275}} +\newlabel{./io:s60}{{7.7}{275}} +\newlabel{./io:s61}{{7.7}{275}} +\newlabel{./io:s62}{{7.7}{275}} +\newlabel{./io:s63}{{7.7}{276}} +\newlabel{./io:s64}{{7.7}{276}} +\newlabel{backdoor-string-fill}{{7.7}{276}} +\newlabel{./io:s65}{{7.7}{277}} +\newlabel{./io:s66}{{7.7}{277}} +\newlabel{./io:s67}{{7.7}{278}} +\newlabel{./io:s68}{{7.7}{278}} +\newlabel{SECTOUTPUT}{{7.8}{278}} +\@writefile{toc}{\contentsline {section}{\numberline {7.8}Output Operations}{278}} +\newlabel{./io:s69}{{7.8}{278}} +\newlabel{./io:s70}{{7.8}{279}} +\newlabel{./io:s71}{{7.8}{279}} +\newlabel{./io:s72}{{7.8}{279}} +\newlabel{./io:s73}{{7.8}{279}} +\newlabel{./io:s74}{{7.8}{280}} +\newlabel{SECTCONVENIENCE}{{7.9}{280}} +\@writefile{toc}{\contentsline {section}{\numberline {7.9}Convenience I/O}{280}} +\newlabel{./io:s75}{{7.9}{280}} +\newlabel{./io:s76}{{7.9}{281}} +\newlabel{./io:s77}{{7.9}{281}} +\newlabel{./io:s78}{{7.9}{282}} +\newlabel{./io:s79}{{7.9}{283}} +\newlabel{./io:s80}{{7.9}{283}} +\newlabel{./io:s81}{{7.9}{284}} +\newlabel{./io:s82}{{7.9}{284}} +\newlabel{./io:s83}{{7.9}{284}} +\newlabel{./io:s84}{{7.9}{284}} +\newlabel{./io:s85}{{7.9}{285}} +\newlabel{./io:s86}{{7.9}{285}} +\newlabel{./io:s87}{{7.9}{285}} +\newlabel{./io:s88}{{7.9}{285}} +\newlabel{SECTFILESYSTEM}{{7.10}{286}} +\@writefile{toc}{\contentsline {section}{\numberline {7.10}Filesystem Operations}{286}} +\newlabel{./io:s89}{{7.10}{286}} +\newlabel{./io:s90}{{7.10}{286}} +\newlabel{SECTBSCONVS}{{7.11}{286}} +\@writefile{toc}{\contentsline {section}{\numberline {7.11}Bytevector/String Conversions}{286}} +\newlabel{./io:s91}{{7.11}{286}} +\newlabel{./io:s92}{{7.11}{287}} +\newlabel{./io:s93}{{7.11}{287}} +\newlabel{./io:s94}{{7.11}{287}} +\newlabel{./io:s95}{{7.11}{287}} +\newlabel{./io:s96}{{7.11}{288}} +\@setckpt{io}{ +\setcounter{page}{289} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{7} +\setcounter{section}{11} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/libraries.aux b/csug/tspl4/libraries.aux new file mode 100644 index 0000000..a415184 --- /dev/null +++ b/csug/tspl4/libraries.aux @@ -0,0 +1,49 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {10}Libraries and Top-Level Programs}{341}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTLIBRARIES}{{10}{341}} +\citation{r6rs} +\citation{r6rs} +\citation{r6rslibs} +\newlabel{./libraries:s0}{{10}{343}} +\newlabel{./libraries:s1}{{10}{343}} +\@writefile{toc}{\contentsline {section}{\numberline {10.1}Standard Libraries}{343}} +\@writefile{toc}{\contentsline {section}{\numberline {10.2}Defining New Libraries}{344}} +\newlabel{./libraries:s2}{{10.2}{344}} +\newlabel{./libraries:s3}{{10.2}{345}} +\newlabel{./libraries:s4}{{10.2}{345}} +\newlabel{./libraries:s5}{{10.2}{345}} +\newlabel{desc:import}{{10.2}{345}} +\newlabel{./libraries:s6}{{10.2}{345}} +\newlabel{./libraries:s7}{{10.2}{345}} +\newlabel{export-level}{{10.2}{345}} +\newlabel{./libraries:s8}{{10.2}{346}} +\newlabel{./libraries:s9}{{10.2}{346}} +\newlabel{./libraries:s10}{{10.2}{346}} +\newlabel{./libraries:s11}{{10.2}{346}} +\newlabel{./libraries:s12}{{10.2}{346}} +\newlabel{./libraries:s13}{{10.2}{347}} +\newlabel{./libraries:s14}{{10.2}{348}} +\newlabel{./libraries:s15}{{10.2}{349}} +\newlabel{./libraries:s16}{{10.2}{349}} +\newlabel{SECTLIBPROGRAMS}{{10.3}{350}} +\@writefile{toc}{\contentsline {section}{\numberline {10.3}Top-Level Programs}{350}} +\newlabel{./libraries:s17}{{10.3}{350}} +\newlabel{./libraries:s18}{{10.3}{350}} +\newlabel{SECTLIBEXAMPLES}{{10.4}{350}} +\@writefile{toc}{\contentsline {section}{\numberline {10.4}Examples}{350}} +\@setckpt{libraries}{ +\setcounter{page}{355} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{10} +\setcounter{section}{4} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/objects.aux b/csug/tspl4/objects.aux new file mode 100644 index 0000000..0f505b9 --- /dev/null +++ b/csug/tspl4/objects.aux @@ -0,0 +1,360 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {6}Operations on Objects}{139}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTOBJECTS}{{6}{139}} +\newlabel{./objects:s0}{{6}{141}} +\newlabel{SECTQUOTING}{{6.1}{141}} +\@writefile{toc}{\contentsline {section}{\numberline {6.1}Constants and Quotation}{141}} +\newlabel{./objects:s1}{{6.1}{141}} +\newlabel{./objects:s2}{{6.1}{141}} +\newlabel{./objects:s3}{{6.1}{141}} +\newlabel{./objects:s4}{{6.1}{141}} +\newlabel{./objects:s5}{{6.1}{142}} +\citation{bawden:pepm99} +\newlabel{SECTGENERIC}{{6.2}{143}} +\@writefile{toc}{\contentsline {section}{\numberline {6.2}Generic Equivalence and Type Predicates}{143}} +\newlabel{./objects:s6}{{6.2}{143}} +\newlabel{./objects:s7}{{6.2}{143}} +\newlabel{./objects:s8}{{6.2}{143}} +\newlabel{./objects:s9}{{6.2}{143}} +\newlabel{./objects:s10}{{6.2}{143}} +\newlabel{./objects:s11}{{6.2}{144}} +\newlabel{./objects:s12}{{6.2}{146}} +\citation{r6rs} +\citation{adams:equal} +\newlabel{./objects:s13}{{6.2}{148}} +\newlabel{./objects:s14}{{6.2}{150}} +\newlabel{./objects:s15}{{6.2}{151}} +\newlabel{./objects:s16}{{6.2}{151}} +\newlabel{./objects:s17}{{6.2}{151}} +\newlabel{./objects:s18}{{6.2}{153}} +\newlabel{./objects:s19}{{6.2}{154}} +\newlabel{./objects:s20}{{6.2}{154}} +\newlabel{./objects:s21}{{6.2}{154}} +\newlabel{./objects:s22}{{6.2}{154}} +\newlabel{./objects:s23}{{6.2}{155}} +\newlabel{./objects:s24}{{6.2}{155}} +\newlabel{./objects:s25}{{6.2}{155}} +\newlabel{SECTPAIRS}{{6.3}{155}} +\@writefile{toc}{\contentsline {section}{\numberline {6.3}Lists and Pairs}{155}} +\newlabel{./objects:s26}{{6.3}{155}} +\newlabel{./objects:s27}{{6.3}{155}} +\newlabel{./objects:s28}{{6.3}{155}} +\newlabel{./objects:s29}{{6.3}{155}} +\newlabel{./objects:s30}{{6.3}{155}} +\newlabel{./objects:s31}{{6.3}{155}} +\newlabel{./objects:s32}{{6.3}{155}} +\newlabel{./objects:s33}{{6.3}{155}} +\newlabel{./objects:s34}{{6.3}{155}} +\newlabel{./objects:s35}{{6.3}{155}} +\newlabel{./objects:s36}{{6.3}{156}} +\newlabel{./objects:s37}{{6.3}{156}} +\newlabel{./objects:s38}{{6.3}{156}} +\newlabel{./objects:s39}{{6.3}{156}} +\newlabel{./objects:s40}{{6.3}{157}} +\newlabel{./objects:s41}{{6.3}{157}} +\newlabel{./objects:s42}{{6.3}{157}} +\newlabel{./objects:s43}{{6.3}{158}} +\newlabel{./objects:s44}{{6.3}{158}} +\newlabel{./objects:s45}{{6.3}{158}} +\newlabel{./objects:s46}{{6.3}{159}} +\newlabel{./objects:s47}{{6.3}{159}} +\newlabel{defn:list-ref}{{6.3}{160}} +\newlabel{./objects:s48}{{6.3}{160}} +\newlabel{defn:list-tail}{{6.3}{160}} +\newlabel{./objects:s49}{{6.3}{160}} +\newlabel{./objects:s50}{{6.3}{161}} +\newlabel{./objects:s51}{{6.3}{161}} +\newlabel{./objects:s52}{{6.3}{163}} +\newlabel{./objects:s53}{{6.3}{163}} +\newlabel{./objects:s54}{{6.3}{163}} +\newlabel{./objects:s55}{{6.3}{164}} +\newlabel{./objects:s56}{{6.3}{164}} +\newlabel{./objects:s57}{{6.3}{165}} +\newlabel{./objects:s58}{{6.3}{165}} +\newlabel{page:assq}{{6.3}{165}} +\newlabel{./objects:s59}{{6.3}{165}} +\newlabel{./objects:s60}{{6.3}{166}} +\newlabel{./objects:s61}{{6.3}{166}} +\newlabel{./objects:s62}{{6.3}{167}} +\newlabel{SECTNUMBERS}{{6.4}{167}} +\@writefile{toc}{\contentsline {section}{\numberline {6.4}Numbers}{167}} +\newlabel{./objects:s63}{{6.4}{167}} +\newlabel{./objects:s64}{{6.4}{167}} +\newlabel{./objects:s65}{{6.4}{167}} +\newlabel{./objects:s66}{{6.4}{167}} +\newlabel{./objects:s67}{{6.4}{167}} +\newlabel{./objects:s68}{{6.4}{167}} +\newlabel{./objects:s69}{{6.4}{167}} +\newlabel{./objects:s70}{{6.4}{167}} +\newlabel{./objects:s71}{{6.4}{167}} +\newlabel{./objects:s72}{{6.4}{167}} +\newlabel{./objects:s73}{{6.4}{167}} +\newlabel{./objects:s74}{{6.4}{167}} +\newlabel{./objects:s75}{{6.4}{167}} +\newlabel{./objects:s76}{{6.4}{167}} +\newlabel{./objects:s77}{{6.4}{167}} +\newlabel{./objects:s78}{{6.4}{169}} +\newlabel{./objects:s79}{{6.4}{169}} +\newlabel{./objects:s80}{{6.4}{169}} +\newlabel{./objects:s81}{{6.4}{169}} +\newlabel{./objects:s82}{{6.4}{169}} +\newlabel{./objects:s83}{{6.4}{169}} +\newlabel{./objects:s84}{{6.4}{169}} +\newlabel{./objects:s85}{{6.4}{169}} +\newlabel{./objects:s86}{{6.4}{170}} +\newlabel{./objects:s87}{{6.4}{170}} +\newlabel{./objects:s88}{{6.4}{170}} +\newlabel{./objects:s89}{{6.4}{171}} +\newlabel{./objects:s90}{{6.4}{172}} +\newlabel{./objects:s91}{{6.4}{172}} +\newlabel{./objects:s92}{{6.4}{172}} +\newlabel{./objects:s93}{{6.4}{173}} +\newlabel{./objects:s94}{{6.4}{173}} +\newlabel{./objects:s95}{{6.4}{173}} +\newlabel{./objects:s96}{{6.4}{174}} +\newlabel{./objects:s97}{{6.4}{174}} +\newlabel{./objects:s98}{{6.4}{175}} +\newlabel{./objects:s99}{{6.4}{175}} +\newlabel{./objects:s100}{{6.4}{176}} +\newlabel{./objects:s101}{{6.4}{177}} +\newlabel{./objects:s102}{{6.4}{177}} +\newlabel{./objects:s103}{{6.4}{177}} +\newlabel{./objects:s104}{{6.4}{178}} +\newlabel{./objects:s105}{{6.4}{178}} +\newlabel{page:abs}{{6.4}{178}} +\newlabel{./objects:s106}{{6.4}{178}} +\newlabel{./objects:s107}{{6.4}{178}} +\newlabel{./objects:s108}{{6.4}{178}} +\newlabel{./objects:s109}{{6.4}{179}} +\newlabel{page:gcd}{{6.4}{179}} +\newlabel{./objects:s110}{{6.4}{179}} +\newlabel{./objects:s111}{{6.4}{179}} +\newlabel{./objects:s112}{{6.4}{180}} +\newlabel{./objects:s113}{{6.4}{180}} +\newlabel{./objects:s114}{{6.4}{180}} +\newlabel{./objects:s115}{{6.4}{180}} +\newlabel{./objects:s116}{{6.4}{181}} +\newlabel{./objects:s117}{{6.4}{181}} +\newlabel{./objects:s118}{{6.4}{181}} +\newlabel{./objects:s119}{{6.4}{181}} +\newlabel{./objects:s120}{{6.4}{182}} +\newlabel{./objects:s121}{{6.4}{182}} +\newlabel{./objects:s122}{{6.4}{182}} +\newlabel{./objects:s123}{{6.4}{183}} +\newlabel{./objects:s124}{{6.4}{183}} +\newlabel{./objects:s125}{{6.4}{183}} +\newlabel{page:magnitude}{{6.4}{183}} +\newlabel{./objects:s126}{{6.4}{183}} +\newlabel{./objects:s127}{{6.4}{183}} +\newlabel{./objects:s128}{{6.4}{184}} +\newlabel{./objects:s129}{{6.4}{184}} +\newlabel{./objects:s130}{{6.4}{184}} +\newlabel{./objects:s131}{{6.4}{185}} +\newlabel{./objects:s132}{{6.4}{185}} +\newlabel{./objects:s133}{{6.4}{185}} +\newlabel{./objects:s134}{{6.4}{186}} +\newlabel{./objects:s135}{{6.4}{186}} +\newlabel{./objects:s136}{{6.4}{187}} +\newlabel{./objects:s137}{{6.4}{187}} +\newlabel{./objects:s138}{{6.4}{187}} +\newlabel{./objects:s139}{{6.4}{188}} +\newlabel{./objects:s140}{{6.4}{188}} +\newlabel{./objects:s141}{{6.4}{189}} +\newlabel{./objects:s142}{{6.4}{189}} +\newlabel{./objects:s143}{{6.4}{189}} +\newlabel{./objects:s144}{{6.4}{190}} +\newlabel{./objects:s145}{{6.4}{190}} +\newlabel{./objects:s146}{{6.4}{191}} +\newlabel{./objects:s147}{{6.4}{191}} +\newlabel{./objects:s148}{{6.4}{191}} +\citation{Burger:floatprinting} +\newlabel{SECTFIXNUMS}{{6.5}{192}} +\@writefile{toc}{\contentsline {section}{\numberline {6.5}Fixnums}{192}} +\newlabel{./objects:s149}{{6.5}{192}} +\newlabel{./objects:s150}{{6.5}{193}} +\newlabel{./objects:s151}{{6.5}{193}} +\newlabel{./objects:s152}{{6.5}{193}} +\newlabel{./objects:s153}{{6.5}{193}} +\newlabel{./objects:s154}{{6.5}{194}} +\newlabel{./objects:s155}{{6.5}{194}} +\newlabel{./objects:s156}{{6.5}{195}} +\newlabel{./objects:s157}{{6.5}{195}} +\newlabel{./objects:s158}{{6.5}{195}} +\newlabel{./objects:s159}{{6.5}{195}} +\newlabel{./objects:s160}{{6.5}{196}} +\newlabel{./objects:s161}{{6.5}{196}} +\newlabel{./objects:s162}{{6.5}{197}} +\newlabel{./objects:s163}{{6.5}{197}} +\newlabel{./objects:s164}{{6.5}{198}} +\newlabel{./objects:s165}{{6.5}{198}} +\newlabel{./objects:s166}{{6.5}{198}} +\newlabel{./objects:s167}{{6.5}{199}} +\newlabel{./objects:s168}{{6.5}{199}} +\newlabel{./objects:s169}{{6.5}{200}} +\newlabel{./objects:s170}{{6.5}{200}} +\newlabel{./objects:s171}{{6.5}{200}} +\newlabel{./objects:s172}{{6.5}{201}} +\newlabel{./objects:s173}{{6.5}{201}} +\newlabel{./objects:s174}{{6.5}{201}} +\newlabel{./objects:s175}{{6.5}{202}} +\newlabel{SECTFLONUMS}{{6.6}{202}} +\@writefile{toc}{\contentsline {section}{\numberline {6.6}Flonums}{202}} +\newlabel{./objects:s176}{{6.6}{202}} +\newlabel{./objects:s177}{{6.6}{203}} +\newlabel{./objects:s178}{{6.6}{203}} +\newlabel{./objects:s179}{{6.6}{204}} +\newlabel{./objects:s180}{{6.6}{204}} +\newlabel{./objects:s181}{{6.6}{205}} +\newlabel{./objects:s182}{{6.6}{205}} +\newlabel{./objects:s183}{{6.6}{205}} +\newlabel{./objects:s184}{{6.6}{206}} +\newlabel{./objects:s185}{{6.6}{206}} +\newlabel{./objects:s186}{{6.6}{207}} +\newlabel{./objects:s187}{{6.6}{207}} +\newlabel{./objects:s188}{{6.6}{207}} +\newlabel{./objects:s189}{{6.6}{208}} +\newlabel{./objects:s190}{{6.6}{208}} +\newlabel{./objects:s191}{{6.6}{209}} +\newlabel{./objects:s192}{{6.6}{209}} +\newlabel{./objects:s193}{{6.6}{209}} +\newlabel{./objects:s194}{{6.6}{210}} +\newlabel{./objects:s195}{{6.6}{210}} +\newlabel{./objects:s196}{{6.6}{210}} +\newlabel{./objects:s197}{{6.6}{210}} +\newlabel{./objects:s198}{{6.6}{211}} +\newlabel{SECTCHARACTERS}{{6.7}{211}} +\@writefile{toc}{\contentsline {section}{\numberline {6.7}Characters}{211}} +\newlabel{./objects:s199}{{6.7}{211}} +\newlabel{./objects:s200}{{6.7}{211}} +\newlabel{./objects:s201}{{6.7}{212}} +\newlabel{./objects:s202}{{6.7}{212}} +\newlabel{./objects:s203}{{6.7}{213}} +\newlabel{./objects:s204}{{6.7}{213}} +\newlabel{./objects:s205}{{6.7}{214}} +\newlabel{./objects:s206}{{6.7}{214}} +\newlabel{./objects:s207}{{6.7}{214}} +\newlabel{./objects:s208}{{6.7}{214}} +\newlabel{./objects:s209}{{6.7}{215}} +\newlabel{./objects:s210}{{6.7}{215}} +\newlabel{./objects:s211}{{6.7}{215}} +\newlabel{SECTSTRINGS}{{6.8}{216}} +\@writefile{toc}{\contentsline {section}{\numberline {6.8}Strings}{216}} +\newlabel{./objects:s212}{{6.8}{216}} +\newlabel{./objects:s213}{{6.8}{216}} +\newlabel{./objects:s214}{{6.8}{216}} +\newlabel{./objects:s215}{{6.8}{216}} +\newlabel{./objects:s216}{{6.8}{217}} +\newlabel{./objects:s217}{{6.8}{218}} +\newlabel{./objects:s218}{{6.8}{218}} +\newlabel{./objects:s219}{{6.8}{218}} +\newlabel{./objects:s220}{{6.8}{218}} +\newlabel{./objects:s221}{{6.8}{219}} +\newlabel{./objects:s222}{{6.8}{219}} +\newlabel{./objects:s223}{{6.8}{219}} +\newlabel{./objects:s224}{{6.8}{220}} +\newlabel{./objects:s225}{{6.8}{220}} +\citation{UnicodeUAX29} +\newlabel{./objects:s226}{{6.8}{221}} +\newlabel{./objects:s227}{{6.8}{222}} +\newlabel{./objects:s228}{{6.8}{222}} +\newlabel{./objects:s229}{{6.8}{223}} +\newlabel{SECTVECTORS}{{6.9}{223}} +\@writefile{toc}{\contentsline {section}{\numberline {6.9}Vectors}{223}} +\newlabel{./objects:s230}{{6.9}{223}} +\newlabel{./objects:s231}{{6.9}{224}} +\newlabel{./objects:s232}{{6.9}{224}} +\newlabel{./objects:s233}{{6.9}{224}} +\newlabel{./objects:s234}{{6.9}{224}} +\newlabel{./objects:s235}{{6.9}{225}} +\newlabel{./objects:s236}{{6.9}{225}} +\newlabel{./objects:s237}{{6.9}{225}} +\newlabel{./objects:s238}{{6.9}{226}} +\newlabel{./objects:s239}{{6.9}{226}} +\newlabel{SECTBYTEVECTORS}{{6.10}{227}} +\@writefile{toc}{\contentsline {section}{\numberline {6.10}Bytevectors}{227}} +\newlabel{./objects:s240}{{6.10}{228}} +\newlabel{./objects:s241}{{6.10}{228}} +\newlabel{./objects:s242}{{6.10}{228}} +\newlabel{./objects:s243}{{6.10}{229}} +\newlabel{./objects:s244}{{6.10}{229}} +\newlabel{./objects:s245}{{6.10}{229}} +\newlabel{./objects:s246}{{6.10}{229}} +\newlabel{./objects:s247}{{6.10}{230}} +\newlabel{./objects:s248}{{6.10}{230}} +\newlabel{./objects:s249}{{6.10}{231}} +\newlabel{./objects:s250}{{6.10}{231}} +\newlabel{./objects:s251}{{6.10}{231}} +\newlabel{./objects:s252}{{6.10}{232}} +\newlabel{./objects:s253}{{6.10}{232}} +\newlabel{./objects:s254}{{6.10}{232}} +\newlabel{./objects:s255}{{6.10}{233}} +\newlabel{./objects:s256}{{6.10}{235}} +\newlabel{./objects:s257}{{6.10}{236}} +\newlabel{./objects:s258}{{6.10}{237}} +\newlabel{./objects:s259}{{6.10}{238}} +\newlabel{./objects:s260}{{6.10}{238}} +\newlabel{./objects:s261}{{6.10}{239}} +\newlabel{./objects:s262}{{6.10}{239}} +\newlabel{./objects:s263}{{6.10}{239}} +\newlabel{./objects:s264}{{6.10}{240}} +\newlabel{./objects:s265}{{6.10}{240}} +\newlabel{SECTSYMBOLS}{{6.11}{241}} +\@writefile{toc}{\contentsline {section}{\numberline {6.11}Symbols}{241}} +\newlabel{./objects:s266}{{6.11}{241}} +\newlabel{./objects:s267}{{6.11}{241}} +\newlabel{./objects:s268}{{6.11}{242}} +\newlabel{./objects:s269}{{6.11}{242}} +\newlabel{./objects:s270}{{6.11}{242}} +\newlabel{SECTMISCBOOLEANS}{{6.12}{243}} +\@writefile{toc}{\contentsline {section}{\numberline {6.12}Booleans}{243}} +\newlabel{./objects:s271}{{6.12}{243}} +\newlabel{SECTHASHTABLES}{{6.13}{243}} +\@writefile{toc}{\contentsline {section}{\numberline {6.13}Hashtables}{243}} +\newlabel{./objects:s272}{{6.13}{243}} +\newlabel{./objects:s273}{{6.13}{243}} +\newlabel{./objects:s274}{{6.13}{243}} +\newlabel{./objects:s275}{{6.13}{244}} +\newlabel{./objects:s276}{{6.13}{244}} +\newlabel{./objects:s277}{{6.13}{245}} +\newlabel{./objects:s278}{{6.13}{245}} +\newlabel{./objects:s279}{{6.13}{245}} +\newlabel{./objects:s280}{{6.13}{246}} +\newlabel{./objects:s281}{{6.13}{246}} +\newlabel{./objects:s282}{{6.13}{246}} +\newlabel{./objects:s283}{{6.13}{247}} +\newlabel{./objects:s284}{{6.13}{248}} +\newlabel{./objects:s285}{{6.13}{248}} +\newlabel{./objects:s286}{{6.13}{248}} +\newlabel{./objects:s287}{{6.13}{249}} +\newlabel{./objects:s288}{{6.13}{249}} +\newlabel{./objects:s289}{{6.13}{250}} +\newlabel{SECTENUMERATIONS}{{6.14}{250}} +\@writefile{toc}{\contentsline {section}{\numberline {6.14}Enumerations}{250}} +\newlabel{./objects:s290}{{6.14}{250}} +\newlabel{./objects:s291}{{6.14}{251}} +\newlabel{./objects:s292}{{6.14}{251}} +\newlabel{./objects:s293}{{6.14}{252}} +\newlabel{./objects:s294}{{6.14}{252}} +\newlabel{./objects:s295}{{6.14}{252}} +\newlabel{./objects:s296}{{6.14}{252}} +\newlabel{./objects:s297}{{6.14}{253}} +\newlabel{./objects:s298}{{6.14}{253}} +\newlabel{./objects:s299}{{6.14}{254}} +\newlabel{./objects:s300}{{6.14}{254}} +\newlabel{./objects:s301}{{6.14}{254}} +\@setckpt{objects}{ +\setcounter{page}{255} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{6} +\setcounter{section}{14} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/out.hidx b/csug/tspl4/out.hidx new file mode 100644 index 0000000..efa703f --- /dev/null +++ b/csug/tspl4/out.hidx @@ -0,0 +1,1418 @@ +( +#(index-entry "./grammar.html#./grammar:s23" ("bytevector syntax") ("bytevector syntax") "461" "" "") +#(index-entry "./grammar.html#./grammar:s22" ("vector syntax") ("vector syntax") "461" "" "") +#(index-entry "./grammar.html#./grammar:s21" ("dot (~.~)") ("dot (~\\scheme{{\\schdot}}~)") "460" "" "") +#(index-entry "./grammar.html#./grammar:s20" (". (dot)") ("\\scheme{{\\schdot}} (dot)") "460" "" "") +#(index-entry "./grammar.html#./grammar:s19" ("list syntax") ("list syntax") "460" "" "") +#(index-entry "./grammar.html#./grammar:s18" ("number syntax") ("number syntax") "459" "" "") +#(index-entry "./grammar.html#./grammar:s17" ("symbol syntax") ("symbol syntax") "458" "" "") +#(index-entry "./grammar.html#./grammar:s16" ("string syntax") ("string syntax") "458" "" "") +#(index-entry "./grammar.html#./grammar:s15" ("character syntax") ("character syntax") "457" "" "") +#(index-entry "./grammar.html#./grammar:s14" ("boolean syntax") ("boolean syntax") "457" "" "") +#(index-entry "./grammar.html#./grammar:s13" ("datum syntax") ("datum syntax") "456" "" "") +#(index-entry "./grammar.html#./grammar:s12" ("#!r6rs") ("\\scheme{\\#!r6rs}") "456" "" "") +#(index-entry "./grammar.html#./grammar:s11" ("block comment (~#|\\dots|#~)") ("block comment (~\\scheme{\\#|{\\dots}|\\#}~)") "455" "" "") +#(index-entry "./grammar.html#./grammar:s10" ("#|\\dots|# (block comment)") ("\\scheme{\\#|{\\dots}|\\#} (block comment)") "455" "" "") +#(index-entry "./grammar.html#./grammar:s9" ("datum comment (~#;~)") ("datum comment (~\\scheme{\\#;}~)") "455" "" "") +#(index-entry "./grammar.html#./grammar:s8" ("#; (datum comment)") ("\\scheme{\\#;} (datum comment)") "455" "" "") +#(index-entry "./grammar.html#./grammar:s7" ("semicolon (~;~)") ("semicolon (~\\scheme{;}~)") "455" "" "") +#(index-entry "./grammar.html#./grammar:s6" ("; (comment)") ("\\scheme{;} (comment)") "455" "" "") +#(index-entry "./grammar.html#./grammar:s5" ("comments") ("comments") "455" "" "") +#(index-entry "./grammar.html#./grammar:s4" ("intraline whitespace") ("intraline whitespace") "455" "" "") +#(index-entry "./grammar.html#./grammar:s3" ("line ending") ("line ending") "455" "" "") +#(index-entry "./grammar.html#./grammar:s2" ("whitespace") ("whitespace") "455" "" "") +#(index-entry "./grammar.html#./grammar:s1" ("tokens") ("tokens") "455" "" "") +#(index-entry "./grammar.html#./grammar:s0" ("datum syntax") ("datum syntax") "455" "" "") +#(index-entry "./examples.html#./examples:s109" ("nested engines") ("nested engines") "429" "" "") +#(index-entry "./examples.html#./examples:s106" ("operating system") ("operating system") "429" "" "") +#(index-entry "./examples.html#./examples:s100" ("call/cc") ("\\scheme{call/cc}") "426" "" "") +#(index-entry "./examples.html#./examples:s99" ("call-with-current-continuation") ("\\scheme{call-with-current-continuation}") "426" "" "") +#(index-entry "./examples.html#./examples:s98" ("call/cc") ("\\scheme{call/cc}") "425" "" "") +#(index-entry "./examples.html#./examples:s97" ("timer interrupts") ("timer interrupts") "425" "" "") +#(index-entry "./examples.html#./examples:s96" ("por (parallel-or)") ("\\scheme{por} (parallel-or)") "424" "" "") +#(index-entry "./examples.html#./examples:s95" ("nondeterministic computations") ("nondeterministic computations") "424" "" "") +#(index-entry "./examples.html#./examples:s94" ("operating system") ("operating system") "423" "" "") +#(index-entry "./examples.html#./examples:s93" ("round-robin") ("\\scheme{round-robin}") "423" "" "") +#(index-entry "./examples.html#./examples:s92" ("fibonacci") ("\\scheme{fibonacci}") "422" "" "") +#(index-entry "./examples.html#./examples:s91" ("expire") ("\\var{expire}") "421" "see{engines}" "") +#(index-entry "./examples.html#./examples:s90" ("complete") ("\\var{complete}") "421" "see{engines}" "") +#(index-entry "./examples.html#./examples:s89" ("ticks") ("\\var{ticks}") "421" "see{engines}" "") +#(index-entry "./examples.html#./examples:s88" ("continuations") ("continuations") "421" "" "") +#(index-entry "./examples.html#./examples:s87" ("nondeterministic computations") ("nondeterministic computations") "421" "" "") +#(index-entry "./examples.html#./examples:s86" ("threads") ("threads") "421" "" "") +#(index-entry "./examples.html#./examples:s85" ("light-weight threads") ("light-weight threads") "421" "" "") +#(index-entry "./examples.html#./examples:s84" ("multiprocessing") ("multiprocessing") "421" "" "") +#(index-entry "./examples.html#./examples:s83" ("timed preemption") ("timed preemption") "421" "" "") +#(index-entry "./examples.html#./examples:s82" ("engines") ("engines") "421" "" "") +#(index-entry "./examples.html#./examples:s78" ("unify") ("\\scheme{unify}") "418" "" "") +#(index-entry "./examples.html#./examples:s77" ("continuation-passing style") ("continuation-passing style") "418" "" "") +#(index-entry "./examples.html#./examples:s76" ("unification") ("unification") "417" "" "") +#(index-entry "./examples.html#./examples:s70" ("fast Fourier transform (FFT)") ("fast Fourier transform (FFT)") "412" "" "") +#(index-entry "./examples.html#./examples:s69" ("complex numbers") ("complex numbers") "412" "" "") +#(index-entry "./examples.html#./examples:s67" ("inheritance") ("inheritance") "412" "" "") +#(index-entry "./examples.html#./examples:s63" ("define-object") ("\\scheme{define-object}") "408" "" "") +#(index-entry "./examples.html#./examples:s62" ("messages") ("messages") "408" "" "") +#(index-entry "./examples.html#./examples:s61" ("object-oriented programming") ("object-oriented programming") "408" "" "") +#(index-entry "./examples.html#./examples:s60" ("abstract objects") ("abstract objects") "408" "" "") +#(index-entry "./examples.html#./examples:s59" ("delayed evaluation") ("delayed evaluation") "408" "" "") +#(index-entry "./examples.html#./examples:s58" ("call-by-name") ("call-by-name") "408" "" "") +#(index-entry "./examples.html#./examples:s57" ("call-by-value") ("call-by-value") "407" "" "") +#(index-entry "./examples.html#./examples:s51" ("core syntactic forms") ("core syntactic forms") "404" "" "") +#(index-entry "./examples.html#./examples:s50" ("association list") ("association list") "404" "" "") +#(index-entry "./examples.html#./examples:s49" ("environment") ("environment") "404" "" "") +#(index-entry "./examples.html#./examples:s48" ("interpreter") ("interpreter") "404" "" "") +#(index-entry "./examples.html#./examples:s47" ("meta-circular interpreter") ("meta-circular interpreter") "404" "" "") +#(index-entry "./examples.html#./examples:s46" ("interpret") ("\\scheme{interpret}") "404" "" "") +#(index-entry "./examples.html#./examples:s39" ("printf") ("\\scheme{printf}") "401" "" "") +#(index-entry "./examples.html#./examples:s38" ("fprintf") ("\\scheme{fprintf}") "401" "" "") +#(index-entry "./examples.html#./examples:s37" ("formatted output") ("formatted output") "401" "" "") +#(index-entry "./examples.html#./examples:s33" ("display") ("\\scheme{display}") "397" "" "") +#(index-entry "./examples.html#./examples:s32" ("write") ("\\scheme{write}") "397" "" "") +#(index-entry "./examples.html#./examples:s31" ("put-datum") ("\\scheme{put-datum}") "397" "" "") +#(index-entry "./examples.html#./examples:s24" ("frequency") ("\\scheme{frequency}") "393" "" "") +#(index-entry "./examples.html#./examples:s23" ("C") ("C") "393" "" "") +#(index-entry "./examples.html#./examples:s21" ("map") ("\\scheme{map}") "392" "" "") +#(index-entry "./examples.html#./examples:s18" ("syntax-rules") ("\\scheme{syntax-rules}") "389" "" "") +#(index-entry "./examples.html#./examples:s17" ("define-syntax") ("\\scheme{define-syntax}") "389" "" "") +#(index-entry "./examples.html#./examples:s16" ("sets") ("sets") "389" "" "") +#(index-entry "./examples.html#./examples:s15" ("set-of") ("\\scheme{set-of}") "389" "" "") +#(index-entry "./examples.html#./examples:s11" ("merge") ("\\scheme{merge}") "387" "" "") +#(index-entry "./examples.html#./examples:s10" ("sort") ("\\scheme{sort}") "387" "" "") +#(index-entry "./examples.html#./examples:s9" ("list-sort") ("\\scheme{list-sort}") "387" "" "") +#(index-entry "./examples.html#./examples:s3" ("vectors") ("vectors") "383" "" "") +#(index-entry "./examples.html#./examples:s2" ("mul") ("\\scheme{mul}") "382" "" "") +#(index-entry "./examples.html#./examples:s1" ("matrix multiplication") ("matrix multiplication") "381" "" "") +#(index-entry "./examples.html#./examples:s0" ("extended examples") ("extended examples") "381" "" "") +#(index-entry "./exceptions.html#./exceptions:s45" ("no-nans-violation?") ("\\scheme{no-nans-violation?}") "377" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s45" ("make-no-nans-violation") ("\\scheme{make-no-nans-violation}") "377" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s45" ("&no-nans") ("\\scheme{\\&no-nans}") "377" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s44" ("no-infinities-violation?") ("\\scheme{no-infinities-violation?}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s44" ("make-no-infinities-violation") ("\\scheme{make-no-infinities-violation}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s44" ("&no-infinities") ("\\scheme{\\&no-infinities}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s43" ("i/o-encoding-error-char") ("\\scheme{i/o-encoding-error-char}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s43" ("i/o-encoding-error?") ("\\scheme{i/o-encoding-error?}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s43" ("make-i/o-encoding-error") ("\\scheme{make-i/o-encoding-error}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s43" ("&i/o-encoding") ("\\scheme{\\&i/o-encoding}") "376" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s42" ("i/o-decoding-error?") ("\\scheme{i/o-decoding-error?}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s42" ("make-i/o-decoding-error") ("\\scheme{make-i/o-decoding-error}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s42" ("&i/o-decoding") ("\\scheme{\\&i/o-decoding}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s41" ("i/o-error-port") ("\\scheme{i/o-error-port}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s41" ("i/o-port-error?") ("\\scheme{i/o-port-error?}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s41" ("make-i/o-port-error") ("\\scheme{make-i/o-port-error}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s41" ("&i/o-port") ("\\scheme{\\&i/o-port}") "375" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s40" ("i/o-file-does-not-exist-error?") ("\\scheme{i/o-file-does-not-exist-error?}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s40" ("make-i/o-file-does-not-exist-error") ("\\scheme{make-i/o-file-does-not-exist-error}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s40" ("&i/o-file-does-not-exist") ("\\scheme{\\&i/o-file-does-not-exist}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s39" ("i/o-file-already-exists-error?") ("\\scheme{i/o-file-already-exists-error?}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s39" ("make-i/o-file-already-exists-error") ("\\scheme{make-i/o-file-already-exists-error}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s39" ("&i/o-file-already-exists") ("\\scheme{\\&i/o-file-already-exists}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s38" ("i/o-file-is-read-only-error?") ("\\scheme{i/o-file-is-read-only-error?}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s38" ("make-i/o-file-is-read-only-error") ("\\scheme{make-i/o-file-is-read-only-error}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s38" ("&i/o-file-is-read-only") ("\\scheme{\\&i/o-file-is-read-only}") "374" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s37" ("i/o-file-protection-error?") ("\\scheme{i/o-file-protection-error?}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s37" ("make-i/o-file-protection-error") ("\\scheme{make-i/o-file-protection-error}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s37" ("&i/o-file-protection") ("\\scheme{\\&i/o-file-protection}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s36" ("i/o-error-filename") ("\\scheme{i/o-error-filename}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s36" ("i/o-filename-error?") ("\\scheme{i/o-filename-error?}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s36" ("make-i/o-filename-error") ("\\scheme{make-i/o-filename-error}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s36" ("&i/o-filename") ("\\scheme{\\&i/o-filename}") "373" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s35" ("i/o-error-position") ("\\scheme{i/o-error-position}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s35" ("i/o-invalid-position-error?") ("\\scheme{i/o-invalid-position-error?}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s35" ("make-i/o-invalid-position-error") ("\\scheme{make-i/o-invalid-position-error}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s35" ("&i/o-invalid-position") ("\\scheme{\\&i/o-invalid-position}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s34" ("i/o-write-error?") ("\\scheme{i/o-write-error?}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s34" ("make-i/o-write-error") ("\\scheme{make-i/o-write-error}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s34" ("&i/o-write") ("\\scheme{\\&i/o-write}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s33" ("i/o-read-error?") ("\\scheme{i/o-read-error?}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s33" ("make-i/o-read-error") ("\\scheme{make-i/o-read-error}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s33" ("&i/o-read") ("\\scheme{\\&i/o-read}") "372" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s32" ("i/o-error?") ("\\scheme{i/o-error?}") "371" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s32" ("make-i/o-error") ("\\scheme{make-i/o-error}") "371" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s32" ("&i/o") ("\\scheme{\\&i/o}") "371" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s31" ("undefined-violation?") ("\\scheme{undefined-violation?}") "371" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s31" ("make-undefined-violation") ("\\scheme{make-undefined-violation}") "371" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s31" ("&undefined") ("\\scheme{\\&undefined}") "371" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s30" ("syntax-violation-subform") ("\\scheme{syntax-violation-subform}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s30" ("syntax-violation-form") ("\\scheme{syntax-violation-form}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s30" ("syntax-violation?") ("\\scheme{syntax-violation?}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s30" ("make-syntax-violation") ("\\scheme{make-syntax-violation}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s30" ("&syntax") ("\\scheme{\\&syntax}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s29" ("lexical-violation?") ("\\scheme{lexical-violation?}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s29" ("make-lexical-violation") ("\\scheme{make-lexical-violation}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s29" ("&lexical") ("\\scheme{\\&lexical}") "370" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s28" ("implementation-restriction-violation?") ("\\scheme{implementation-restriction-violation?}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s28" ("make-implementation-restriction-violation") ("\\scheme{make-implementation-restriction-violation}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s28" ("&implementation-restriction") ("\\scheme{\\&implementation-restriction}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s27" ("non-continuable-violation?") ("\\scheme{non-continuable-violation?}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s27" ("make-non-continuable-violation") ("\\scheme{make-non-continuable-violation}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s27" ("&non-continuable") ("\\scheme{\\&non-continuable}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s26" ("condition-who") ("\\scheme{condition-who}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s26" ("who-condition?") ("\\scheme{who-condition?}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s26" ("make-who-condition") ("\\scheme{make-who-condition}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s26" ("&who") ("\\scheme{\\&who}") "369" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s25" ("condition-irritants") ("\\scheme{condition-irritants}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s25" ("irritants-condition?") ("\\scheme{irritants-condition?}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s25" ("make-irritants-condition") ("\\scheme{make-irritants-condition}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s25" ("&irritants") ("\\scheme{\\&irritants}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s24" ("condition-message") ("\\scheme{condition-message}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s24" ("message-condition?") ("\\scheme{message-condition?}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s24" ("make-message-condition") ("\\scheme{make-message-condition}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s24" ("&message") ("\\scheme{\\&message}") "368" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s23" ("warning?") ("\\scheme{warning?}") "367" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s23" ("make-warning") ("\\scheme{make-warning}") "367" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s23" ("&warning") ("\\scheme{\\&warning}") "367" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s22" ("error?") ("\\scheme{error?}") "367" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s22" ("make-error") ("\\scheme{make-error}") "367" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s22" ("&error") ("\\scheme{\\&error}") "367" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s21" ("assertion-violation?") ("\\scheme{assertion-violation?}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s21" ("make-assertion-violation") ("\\scheme{make-assertion-violation}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s21" ("&assertion") ("\\scheme{\\&assertion}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s20" ("violation?") ("\\scheme{violation?}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s20" ("make-violation") ("\\scheme{make-violation}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s20" ("&violation") ("\\scheme{\\&violation}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s19" ("serious-condition?") ("\\scheme{serious-condition?}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s19" ("make-serious-condition") ("\\scheme{make-serious-condition}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s19" ("&serious") ("\\scheme{\\&serious}") "366" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s18" ("condition-accessor") ("\\scheme{condition-accessor}") "365" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s18" ("condition-predicate") ("\\scheme{condition-predicate}") "365" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s17" ("define-condition-type") ("\\scheme{define-condition-type}") "364" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s16" ("simple-conditions") ("\\scheme{simple-conditions}") "363" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s15" ("condition") ("\\scheme{condition}") "362" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s14" ("condition?") ("\\scheme{condition?}") "362" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s13" ("&condition") ("\\scheme{\\&condition}") "362" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s12" ("simple condition") ("simple condition") "362" "" "") +#(index-entry "./exceptions.html#./exceptions:s11" ("compound condition") ("compound condition") "362" "" "") +#(index-entry "./exceptions.html#./exceptions:s10" ("condition type") ("condition type") "361" "" "") +#(index-entry "./exceptions.html#./exceptions:s9" ("condition object") ("condition object") "361" "" "") +#(index-entry "./exceptions.html#./exceptions:s8" ("guard") ("\\scheme{guard}") "361" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s7" ("with-exception-handler") ("\\scheme{with-exception-handler}") "360" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s6" ("syntax-violation") ("\\scheme{syntax-violation}") "359" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s6" ("syntax-violation") ("\\scheme{syntax-violation}") "359" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s5" ("assert") ("\\scheme{assert}") "359" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s4" ("assertion-violation") ("\\scheme{assertion-violation}") "358" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s4" ("error") ("\\scheme{error}") "358" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s3" ("raise-continuable") ("\\scheme{raise-continuable}") "357" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s3" ("raise") ("\\scheme{raise}") "357" "emph" "") +#(index-entry "./exceptions.html#./exceptions:s2" ("current exception handler") ("current exception handler") "357" "" "") +#(index-entry "./exceptions.html#./exceptions:s1" ("conditions") ("conditions") "357" "" "") +#(index-entry "./exceptions.html#./exceptions:s0" ("exceptions") ("exceptions") "357" "" "") +#(index-entry "./libraries.html#./libraries:s18" ("exit") ("\\scheme{exit}") "350" "emph" "") +#(index-entry "./libraries.html#./libraries:s18" ("exit") ("\\scheme{exit}") "350" "emph" "") +#(index-entry "./libraries.html#./libraries:s17" ("command-line") ("\\scheme{command-line}") "350" "emph" "") +#(index-entry "./libraries.html#./libraries:s16" ("immutability of exports") ("immutability of exports") "349" "" "") +#(index-entry "./libraries.html#./libraries:s15" ("indirect exports") ("indirect exports") "349" "" "") +#(index-entry "./libraries.html#./libraries:s14" ("library body") ("library body") "348" "" "") +#(index-entry "./libraries.html#./libraries:s13" ("library version reference") ("library version reference") "347" "" "") +#(index-entry "./libraries.html#./libraries:s12" ("rename import set") ("\\scheme{rename} import set") "346" "" "") +#(index-entry "./libraries.html#./libraries:s11" ("prefix import set") ("\\scheme{prefix} import set") "346" "" "") +#(index-entry "./libraries.html#./libraries:s10" ("except import set") ("\\scheme{except} import set") "346" "" "") +#(index-entry "./libraries.html#./libraries:s9" ("only import set") ("\\scheme{only} import set") "346" "" "") +#(index-entry "./libraries.html#./libraries:s8" ("import spec") ("import spec") "346" "" "") +#(index-entry "./libraries.html#./libraries:s7" ("export level") ("export level") "345" "" "") +#(index-entry "./libraries.html#./libraries:s6" ("import level") ("import level") "345" "" "") +#(index-entry "./libraries.html#./libraries:s5" ("import spec") ("import spec") "345" "" "") +#(index-entry "./libraries.html#./libraries:s4" ("import") ("\\scheme{import}") "345" "" "") +#(index-entry "./libraries.html#./libraries:s3" ("export") ("\\scheme{export}") "345" "" "") +#(index-entry "./libraries.html#./libraries:s2" ("library version") ("library version") "344" "" "") +#(index-entry "./libraries.html#./libraries:s1" ("top-level programs") ("top-level programs") "343" "" "") +#(index-entry "./libraries.html#./libraries:s0" ("libraries") ("libraries") "343" "" "") +#(index-entry "./records.html#./records:s41" ("record-rtd") ("\\scheme{record-rtd}") "338" "emph" "") +#(index-entry "./records.html#./records:s40" ("record?") ("\\scheme{record?}") "338" "emph" "") +#(index-entry "./records.html#./records:s39" ("record-field-mutable?") ("\\scheme{record-field-mutable?}") "338" "emph" "") +#(index-entry "./records.html#./records:s38" ("record-type-field-names") ("\\scheme{record-type-field-names}") "337" "emph" "") +#(index-entry "./records.html#./records:s37" ("record-type-opaque?") ("\\scheme{record-type-opaque?}") "337" "emph" "") +#(index-entry "./records.html#./records:s37" ("record-type-sealed?") ("\\scheme{record-type-sealed?}") "337" "emph" "") +#(index-entry "./records.html#./records:s37" ("record-type-generative?") ("\\scheme{record-type-generative?}") "337" "emph" "") +#(index-entry "./records.html#./records:s36" ("record-type-uid") ("\\scheme{record-type-uid}") "336" "emph" "") +#(index-entry "./records.html#./records:s35" ("record-type-parent") ("\\scheme{record-type-parent}") "336" "emph" "") +#(index-entry "./records.html#./records:s34" ("record-type-name") ("\\scheme{record-type-name}") "336" "emph" "") +#(index-entry "./records.html#./records:s33" ("opaque record type") ("opaque record type") "336" "" "") +#(index-entry "./records.html#./records:s32" ("record-mutator") ("\\scheme{record-mutator}") "334" "emph" "") +#(index-entry "./records.html#./records:s31" ("record-accessor") ("\\scheme{record-accessor}") "334" "emph" "") +#(index-entry "./records.html#./records:s30" ("record-predicate") ("\\scheme{record-predicate}") "333" "emph" "") +#(index-entry "./records.html#./records:s29" ("record-constructor") ("\\scheme{record-constructor}") "333" "emph" "") +#(index-entry "./records.html#./records:s28" ("record-constructor-descriptor") ("\\scheme{record-constructor-descriptor}") "333" "emph" "") +#(index-entry "./records.html#./records:s28" ("record-type-descriptor") ("\\scheme{record-type-descriptor}") "333" "emph" "") +#(index-entry "./records.html#./records:s27" ("protocol for records") ("protocol for records") "332" "" "") +#(index-entry "./records.html#./records:s26" ("rcd") ("rcd") "332" "" "") +#(index-entry "./records.html#./records:s25" ("record-constructor descriptor") ("record-constructor descriptor") "332" "" "") +#(index-entry "./records.html#./records:s24" ("make-record-constructor-descriptor") ("\\scheme{make-record-constructor-descriptor}") "332" "emph" "") +#(index-entry "./records.html#./records:s23" ("record-type-descriptor?") ("\\scheme{record-type-descriptor?}") "332" "emph" "") +#(index-entry "./records.html#./records:s22" ("rtd") ("rtd") "331" "" "") +#(index-entry "./records.html#./records:s21" ("record-type descriptor") ("record-type descriptor") "331" "" "") +#(index-entry "./records.html#./records:s20" ("make-record-type-descriptor") ("\\scheme{make-record-type-descriptor}") "331" "emph" "") +#(index-entry "./records.html#./records:s19" ("make-record-type-descriptor") ("\\scheme{make-record-type-descriptor}") "331" "" "") +#(index-entry "./records.html#./records:s18" ("rtd") ("rtd") "331" "" "") +#(index-entry "./records.html#./records:s17" ("record-type descriptor") ("record-type descriptor") "331" "" "") +#(index-entry "./records.html#./records:s16" ("parent-rtd") ("\\scheme{parent-rtd}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("nongenerative") ("\\scheme{nongenerative}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("opaque") ("\\scheme{opaque}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("sealed") ("\\scheme{sealed}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("protocol") ("\\scheme{protocol}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("parent") ("\\scheme{parent}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("immutable") ("\\scheme{immutable}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("mutable") ("\\scheme{mutable}") "331" "emph" "") +#(index-entry "./records.html#./records:s16" ("fields") ("\\scheme{fields}") "331" "emph" "") +#(index-entry "./records.html#./records:s15" ("opaque record type") ("opaque record type") "330" "" "") +#(index-entry "./records.html#./records:s14" ("sealed record type") ("sealed record type") "330" "" "") +#(index-entry "./records.html#./records:s13" ("define-record-type") ("\\scheme{define-record-type}") "328" "emph" "") +#(index-entry "./records.html#./records:s13" ("define-record-type") ("\\scheme{define-record-type}") "328" "emph" "") +#(index-entry "./records.html#./records:s12" ("default protocol") ("default protocol") "327" "" "") +#(index-entry "./records.html#./records:s11" ("protocol for records") ("protocol for records") "326" "" "") +#(index-entry "./records.html#./records:s10" ("child type") ("child type") "325" "" "") +#(index-entry "./records.html#./records:s9" ("parent type") ("parent type") "325" "" "") +#(index-entry "./records.html#./records:s8" ("inheritance in records") ("inheritance in records") "325" "" "") +#(index-entry "./records.html#./records:s7" ("record inheritance") ("record inheritance") "325" "" "") +#(index-entry "./records.html#./records:s6" ("record uid") ("record uid") "325" "" "") +#(index-entry "./records.html#./records:s5" ("nongenerative") ("nongenerative") "324" "" "") +#(index-entry "./records.html#./records:s4" ("generative") ("generative") "324" "" "") +#(index-entry "./records.html#./records:s3" ("record generativity") ("record generativity") "324" "" "") +#(index-entry "./records.html#./records:s2" ("make-record-type-descriptor") ("\\scheme{make-record-type-descriptor}") "323" "" "") +#(index-entry "./records.html#./records:s1" ("define-record-type") ("\\scheme{define-record-type}") "323" "" "") +#(index-entry "./records.html#./records:s0" ("records") ("records") "323" "" "") +#(index-entry "./syntax.html#./syntax:s71" ("datum->syntax") ("\\scheme{datum->syntax}") "320" "" "") +#(index-entry "./syntax.html#./syntax:s70" ("define-structure") ("\\scheme{define-structure}") "318" "" "") +#(index-entry "./syntax.html#./syntax:s69" ("structures") ("structures") "318" "" "") +#(index-entry "./syntax.html#./syntax:s68" ("identifier-syntax") ("\\scheme{identifier-syntax}") "317" "" "") +#(index-entry "./syntax.html#./syntax:s67" ("method") ("\\scheme{method}") "317" "" "") +#(index-entry "./syntax.html#./syntax:s66" ("object-oriented programming") ("object-oriented programming") "317" "" "") +#(index-entry "./syntax.html#./syntax:s65" ("datum->syntax") ("\\scheme{datum->syntax}") "317" "" "") +#(index-entry "./syntax.html#./syntax:s64" ("identifier-syntax") ("\\scheme{identifier-syntax}") "317" "" "") +#(index-entry "./syntax.html#./syntax:s63" ("x++") ("\\scheme{x++}") "316" "" "") +#(index-entry "./syntax.html#./syntax:s62" ("identifier-syntax") ("\\scheme{identifier-syntax}") "316" "" "") +#(index-entry "./syntax.html#./syntax:s61" ("define-integrable") ("\\scheme{define-integrable}") "315" "" "") +#(index-entry "./syntax.html#./syntax:s60" ("integrable procedures") ("integrable procedures") "315" "" "") +#(index-entry "./syntax.html#./syntax:s59" ("_ (underscore)") ("\\scheme{{\\schunderscore}} (underscore)") "315" "" "") +#(index-entry "./syntax.html#./syntax:s58" ("underscore (~_~)") ("underscore (~\\scheme{{\\schunderscore}}~)") "315" "" "") +#(index-entry "./syntax.html#./syntax:s57" ("let-syntax") ("\\scheme{let-syntax}") "314" "" "") +#(index-entry "./syntax.html#./syntax:s56" ("letrec-syntax") ("\\scheme{letrec-syntax}") "314" "" "") +#(index-entry "./syntax.html#./syntax:s55" ("sequence") ("\\scheme{sequence}") "313" "" "") +#(index-entry "./syntax.html#./syntax:s54" ("be-like-begin") ("\\scheme{be-like-begin}") "313" "" "") +#(index-entry "./syntax.html#./syntax:s53" ("do") ("\\scheme{do}") "312" "" "") +#(index-entry "./syntax.html#./syntax:s52" ("rec") ("\\scheme{rec}") "311" "" "") +#(index-entry "./syntax.html#./syntax:s51" ("let-values") ("\\scheme{let-values}") "310" "" "") +#(index-entry "./syntax.html#./syntax:s50" ("letrec") ("\\scheme{letrec}") "310" "" "") +#(index-entry "./syntax.html#./syntax:s49" ("generate-temporaries") ("\\scheme{generate-temporaries}") "310" "emph" "") +#(index-entry "./syntax.html#./syntax:s48" ("include") ("\\scheme{include}") "309" "" "") +#(index-entry "./syntax.html#./syntax:s47" ("break") ("\\scheme{break}") "308" "" "") +#(index-entry "./syntax.html#./syntax:s46" ("loop") ("\\scheme{loop}") "308" "" "") +#(index-entry "./syntax.html#./syntax:s45" ("datum->syntax") ("\\scheme{datum->syntax}") "308" "emph" "") +#(index-entry "./syntax.html#./syntax:s44" ("syntax->datum") ("\\scheme{syntax->datum}") "308" "emph" "") +#(index-entry "./syntax.html#./syntax:s43" ("identifier-syntax") ("\\scheme{identifier-syntax}") "307" "" "") +#(index-entry "./syntax.html#./syntax:s42" ("make-variable-transformer") ("\\scheme{make-variable-transformer}") "306" "emph" "") +#(index-entry "./syntax.html#./syntax:s41" ("case") ("\\scheme{case}") "306" "" "") +#(index-entry "./syntax.html#./syntax:s40" ("#,@ (unsyntax-splicing)") ("\\scheme{\\#,{\\schatsign}} (\\scheme{unsyntax-splicing})") "305" "emph" "") +#(index-entry "./syntax.html#./syntax:s40" ("unsyntax-splicing (~#,@~)") ("\\scheme{unsyntax-splicing} (~\\scheme{\\#,{\\schatsign}}~)") "305" "emph" "") +#(index-entry "./syntax.html#./syntax:s40" ("#, (unsyntax)") ("\\scheme{\\#,} (\\scheme{unsyntax})") "305" "emph" "") +#(index-entry "./syntax.html#./syntax:s40" ("unsyntax (~#,~)") ("\\scheme{unsyntax} (~\\scheme{\\#,}~)") "305" "emph" "") +#(index-entry "./syntax.html#./syntax:s40" ("#` (quasisyntax)") ("\\scheme{\\#`} (\\scheme{quasisyntax})") "305" "emph" "") +#(index-entry "./syntax.html#./syntax:s40" ("quasisyntax (~#`~)") ("\\scheme{quasisyntax} (~\\scheme{\\#`}~)") "305" "emph" "") +#(index-entry "./syntax.html#./syntax:s39" ("cond") ("\\scheme{cond}") "304" "" "") +#(index-entry "./syntax.html#./syntax:s38" ("with-syntax") ("\\scheme{with-syntax}") "304" "emph" "") +#(index-entry "./syntax.html#./syntax:s37" ("bound-identifier=?") ("\\scheme{bound-identifier=?}") "302" "emph" "") +#(index-entry "./syntax.html#./syntax:s37" ("free-identifier=?") ("\\scheme{free-identifier=?}") "302" "emph" "") +#(index-entry "./syntax.html#./syntax:s36" ("fenders") ("fenders") "301" "" "") +#(index-entry "./syntax.html#./syntax:s35" ("identifier?") ("\\scheme{identifier?}") "301" "emph" "") +#(index-entry "./syntax.html#./syntax:s34" ("syntax-rules") ("\\scheme{syntax-rules}") "300" "" "") +#(index-entry "./syntax.html#./syntax:s33" ("#' (syntax)") ("\\scheme{\\#'} (\\scheme{syntax})") "300" "emph" "") +#(index-entry "./syntax.html#./syntax:s33" ("syntax (~#'~)") ("\\scheme{syntax} (~\\scheme{\\#'}~)") "300" "emph" "") +#(index-entry "./syntax.html#./syntax:s32" ("pattern variables") ("pattern variables") "299" "" "") +#(index-entry "./syntax.html#./syntax:s31" ("fenders") ("fenders") "299" "" "") +#(index-entry "./syntax.html#./syntax:s30" ("syntax-case") ("\\scheme{syntax-case}") "299" "emph" "") +#(index-entry "./syntax.html#./syntax:s29" ("syntax object") ("syntax object") "298" "" "") +#(index-entry "./syntax.html#./syntax:s28" ("make-variable-transformer") ("\\scheme{make-variable-transformer}") "298" "" "") +#(index-entry "./syntax.html#./syntax:s27" ("identifier-syntax") ("\\scheme{identifier-syntax}") "297" "emph" "") +#(index-entry "./syntax.html#./syntax:s27" ("identifier-syntax") ("\\scheme{identifier-syntax}") "297" "emph" "") +#(index-entry "./syntax.html#./syntax:s26" ("...~(ellipsis)") ("\\scheme{{\\schdot}{\\schdot}{\\schdot}}~(ellipsis)") "297" "emph" "") +#(index-entry "./syntax.html#./syntax:s26" ("_~(underscore)") ("\\scheme{{\\schunderscore}}~(underscore)") "297" "emph" "") +#(index-entry "./syntax.html#./syntax:s25" ("_ (underscore)") ("\\scheme{{\\schunderscore}} (underscore)") "296" "" "") +#(index-entry "./syntax.html#./syntax:s24" ("underscore (~_~)") ("underscore (~\\scheme{{\\schunderscore}}~)") "296" "" "") +#(index-entry "./syntax.html#./syntax:s23" ("templates") ("templates") "295" "" "") +#(index-entry "./syntax.html#./syntax:s22" ("auxiliary keywords") ("auxiliary keywords") "294" "" "") +#(index-entry "./syntax.html#./syntax:s21" ("ellipsis (~...~)") ("ellipsis (~\\scheme{{\\schdot}{\\schdot}{\\schdot}}~)") "294" "" "") +#(index-entry "./syntax.html#./syntax:s20" ("...~(ellipsis)") ("\\scheme{{\\schdot}{\\schdot}{\\schdot}}~(ellipsis)") "294" "" "") +#(index-entry "./syntax.html#./syntax:s19" ("underscore~(_)") ("underscore~(\\scheme{{\\schunderscore}})") "294" "" "") +#(index-entry "./syntax.html#./syntax:s18" ("_~(underscore)") ("\\scheme{{\\schunderscore}}~(underscore)") "294" "" "") +#(index-entry "./syntax.html#./syntax:s17" ("pattern variable") ("pattern variable") "294" "" "") +#(index-entry "./syntax.html#./syntax:s16" ("patterns") ("patterns") "294" "" "") +#(index-entry "./syntax.html#./syntax:s15" ("literals") ("literals") "294" "" "") +#(index-entry "./syntax.html#./syntax:s14" ("syntax-rules") ("\\scheme{syntax-rules}") "294" "emph" "") +#(index-entry "./syntax.html#./syntax:s13" ("letrec-syntax") ("\\scheme{letrec-syntax}") "293" "emph" "") +#(index-entry "./syntax.html#./syntax:s13" ("let-syntax") ("\\scheme{let-syntax}") "293" "emph" "") +#(index-entry "./syntax.html#./syntax:s12" ("define-syntax") ("\\scheme{define-syntax}") "292" "emph" "") +#(index-entry "./syntax.html#./syntax:s11" ("keywords") ("keywords") "291" "" "") +#(index-entry "./syntax.html#./syntax:s10" ("make-variable-transformer") ("\\scheme{make-variable-transformer}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s9" ("identifier-syntax") ("\\scheme{identifier-syntax}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s8" ("syntax") ("\\scheme{syntax}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s7" ("syntax-case") ("\\scheme{syntax-case}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s6" ("syntax-rules") ("\\scheme{syntax-rules}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s5" ("letrec-syntax") ("\\scheme{letrec-syntax}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s4" ("let-syntax") ("\\scheme{let-syntax}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s3" ("define-syntax") ("\\scheme{define-syntax}") "291" "" "") +#(index-entry "./syntax.html#./syntax:s2" ("macros") ("macros") "291" "" "") +#(index-entry "./syntax.html#./syntax:s1" ("syntactic forms") ("syntactic forms") "291" "" "") +#(index-entry "./syntax.html#./syntax:s0" ("syntactic extensions") ("syntactic extensions") "291" "" "") +#(index-entry "./io.html#./io:s96" ("utf32->string") ("\\scheme{utf32->string}") "288" "emph" "") +#(index-entry "./io.html#./io:s96" ("utf32->string") ("\\scheme{utf32->string}") "288" "emph" "") +#(index-entry "./io.html#./io:s96" ("utf16->string") ("\\scheme{utf16->string}") "288" "emph" "") +#(index-entry "./io.html#./io:s96" ("utf16->string") ("\\scheme{utf16->string}") "288" "emph" "") +#(index-entry "./io.html#./io:s95" ("utf8->string") ("\\scheme{utf8->string}") "287" "emph" "") +#(index-entry "./io.html#./io:s94" ("string->utf32") ("\\scheme{string->utf32}") "287" "emph" "") +#(index-entry "./io.html#./io:s94" ("string->utf32") ("\\scheme{string->utf32}") "287" "emph" "") +#(index-entry "./io.html#./io:s94" ("string->utf16") ("\\scheme{string->utf16}") "287" "emph" "") +#(index-entry "./io.html#./io:s94" ("string->utf16") ("\\scheme{string->utf16}") "287" "emph" "") +#(index-entry "./io.html#./io:s93" ("string->utf8") ("\\scheme{string->utf8}") "287" "emph" "") +#(index-entry "./io.html#./io:s92" ("string->bytevector") ("\\scheme{string->bytevector}") "287" "emph" "") +#(index-entry "./io.html#./io:s91" ("bytevector->string") ("\\scheme{bytevector->string}") "286" "emph" "") +#(index-entry "./io.html#./io:s90" ("delete-file") ("\\scheme{delete-file}") "286" "emph" "") +#(index-entry "./io.html#./io:s89" ("file-exists?") ("\\scheme{file-exists?}") "286" "emph" "") +#(index-entry "./io.html#./io:s88" ("close-output-port") ("\\scheme{close-output-port}") "285" "emph" "") +#(index-entry "./io.html#./io:s88" ("close-input-port") ("\\scheme{close-input-port}") "285" "emph" "") +#(index-entry "./io.html#./io:s87" ("newline") ("\\scheme{newline}") "285" "emph" "") +#(index-entry "./io.html#./io:s87" ("newline") ("\\scheme{newline}") "285" "emph" "") +#(index-entry "./io.html#./io:s86" ("write-char") ("\\scheme{write-char}") "285" "emph" "") +#(index-entry "./io.html#./io:s86" ("write-char") ("\\scheme{write-char}") "285" "emph" "") +#(index-entry "./io.html#./io:s85" ("display") ("\\scheme{display}") "285" "emph" "") +#(index-entry "./io.html#./io:s85" ("display") ("\\scheme{display}") "285" "emph" "") +#(index-entry "./io.html#./io:s84" ("write") ("\\scheme{write}") "284" "emph" "") +#(index-entry "./io.html#./io:s84" ("write") ("\\scheme{write}") "284" "emph" "") +#(index-entry "./io.html#./io:s83" ("peek-char") ("\\scheme{peek-char}") "284" "emph" "") +#(index-entry "./io.html#./io:s83" ("peek-char") ("\\scheme{peek-char}") "284" "emph" "") +#(index-entry "./io.html#./io:s82" ("read-char") ("\\scheme{read-char}") "284" "emph" "") +#(index-entry "./io.html#./io:s82" ("read-char") ("\\scheme{read-char}") "284" "emph" "") +#(index-entry "./io.html#./io:s81" ("read") ("\\scheme{read}") "284" "emph" "") +#(index-entry "./io.html#./io:s81" ("read") ("\\scheme{read}") "284" "emph" "") +#(index-entry "./io.html#./io:s80" ("with-output-to-file") ("\\scheme{with-output-to-file}") "283" "emph" "") +#(index-entry "./io.html#./io:s79" ("with-input-from-file") ("\\scheme{with-input-from-file}") "283" "emph" "") +#(index-entry "./io.html#./io:s78" ("call-with-output-file") ("\\scheme{call-with-output-file}") "282" "emph" "") +#(index-entry "./io.html#./io:s77" ("call-with-input-file") ("\\scheme{call-with-input-file}") "281" "emph" "") +#(index-entry "./io.html#./io:s76" ("open-output-file") ("\\scheme{open-output-file}") "281" "emph" "") +#(index-entry "./io.html#./io:s75" ("open-input-file") ("\\scheme{open-input-file}") "280" "emph" "") +#(index-entry "./io.html#./io:s74" ("flush-output-port") ("\\scheme{flush-output-port}") "280" "emph" "") +#(index-entry "./io.html#./io:s73" ("put-datum") ("\\scheme{put-datum}") "279" "emph" "") +#(index-entry "./io.html#./io:s72" ("put-string") ("\\scheme{put-string}") "279" "emph" "") +#(index-entry "./io.html#./io:s72" ("put-string") ("\\scheme{put-string}") "279" "emph" "") +#(index-entry "./io.html#./io:s72" ("put-string") ("\\scheme{put-string}") "279" "emph" "") +#(index-entry "./io.html#./io:s71" ("put-char") ("\\scheme{put-char}") "279" "emph" "") +#(index-entry "./io.html#./io:s70" ("put-bytevector") ("\\scheme{put-bytevector}") "279" "emph" "") +#(index-entry "./io.html#./io:s70" ("put-bytevector") ("\\scheme{put-bytevector}") "279" "emph" "") +#(index-entry "./io.html#./io:s70" ("put-bytevector") ("\\scheme{put-bytevector}") "279" "emph" "") +#(index-entry "./io.html#./io:s69" ("put-u8") ("\\scheme{put-u8}") "278" "emph" "") +#(index-entry "./io.html#./io:s68" ("port-eof?") ("\\scheme{port-eof?}") "278" "emph" "") +#(index-entry "./io.html#./io:s67" ("get-datum") ("\\scheme{get-datum}") "278" "emph" "") +#(index-entry "./io.html#./io:s66" ("get-line") ("\\scheme{get-line}") "277" "emph" "") +#(index-entry "./io.html#./io:s65" ("get-string-all") ("\\scheme{get-string-all}") "277" "emph" "") +#(index-entry "./io.html#./io:s64" ("get-string-n!") ("\\scheme{get-string-n!}") "276" "emph" "") +#(index-entry "./io.html#./io:s63" ("get-string-n") ("\\scheme{get-string-n}") "276" "emph" "") +#(index-entry "./io.html#./io:s62" ("lookahead-char") ("\\scheme{lookahead-char}") "275" "emph" "") +#(index-entry "./io.html#./io:s61" ("get-char") ("\\scheme{get-char}") "275" "emph" "") +#(index-entry "./io.html#./io:s60" ("get-bytevector-all") ("\\scheme{get-bytevector-all}") "275" "emph" "") +#(index-entry "./io.html#./io:s59" ("get-bytevector-some") ("\\scheme{get-bytevector-some}") "275" "emph" "") +#(index-entry "./io.html#./io:s58" ("get-bytevector-n!") ("\\scheme{get-bytevector-n!}") "274" "emph" "") +#(index-entry "./io.html#./io:s57" ("get-bytevector-n") ("\\scheme{get-bytevector-n}") "274" "emph" "") +#(index-entry "./io.html#./io:s56" ("lookahead-u8") ("\\scheme{lookahead-u8}") "274" "emph" "") +#(index-entry "./io.html#./io:s55" ("get-u8") ("\\scheme{get-u8}") "274" "emph" "") +#(index-entry "./io.html#./io:s54" ("eof-object") ("\\scheme{eof-object}") "273" "emph" "") +#(index-entry "./io.html#./io:s53" ("eof-object?") ("\\scheme{eof-object?}") "273" "emph" "") +#(index-entry "./io.html#./io:s52" ("output-port-buffer-mode") ("\\scheme{output-port-buffer-mode}") "273" "emph" "") +#(index-entry "./io.html#./io:s51" ("call-with-port") ("\\scheme{call-with-port}") "272" "emph" "") +#(index-entry "./io.html#./io:s50" ("port-has-set-port-position!?") ("\\scheme{port-has-set-port-position!?}") "272" "emph" "") +#(index-entry "./io.html#./io:s50" ("set-port-position!") ("\\scheme{set-port-position!}") "272" "emph" "") +#(index-entry "./io.html#./io:s49" ("port-has-port-position?") ("\\scheme{port-has-port-position?}") "271" "emph" "") +#(index-entry "./io.html#./io:s49" ("port-position") ("\\scheme{port-position}") "271" "emph" "") +#(index-entry "./io.html#./io:s48" ("port-transcoder") ("\\scheme{port-transcoder}") "271" "emph" "") +#(index-entry "./io.html#./io:s47" ("transcoded-port") ("\\scheme{transcoded-port}") "271" "emph" "") +#(index-entry "./io.html#./io:s46" ("close-port") ("\\scheme{close-port}") "270" "emph" "") +#(index-entry "./io.html#./io:s45" ("textual-port?") ("\\scheme{textual-port?}") "270" "emph" "") +#(index-entry "./io.html#./io:s45" ("binary-port?") ("\\scheme{binary-port?}") "270" "emph" "") +#(index-entry "./io.html#./io:s44" ("output-port?") ("\\scheme{output-port?}") "270" "emph" "") +#(index-entry "./io.html#./io:s44" ("input-port?") ("\\scheme{input-port?}") "270" "emph" "") +#(index-entry "./io.html#./io:s43" ("port?") ("\\scheme{port?}") "270" "emph" "") +#(index-entry "./io.html#./io:s42" ("make-custom-textual-input/output-port") ("\\scheme{make-custom-textual-input/output-port}") "268" "emph" "") +#(index-entry "./io.html#./io:s42" ("make-custom-textual-output-port") ("\\scheme{make-custom-textual-output-port}") "268" "emph" "") +#(index-entry "./io.html#./io:s42" ("make-custom-textual-input-port") ("\\scheme{make-custom-textual-input-port}") "268" "emph" "") +#(index-entry "./io.html#./io:s41" ("make-custom-binary-input/output-port") ("\\scheme{make-custom-binary-input/output-port}") "267" "emph" "") +#(index-entry "./io.html#./io:s41" ("make-custom-binary-output-port") ("\\scheme{make-custom-binary-output-port}") "267" "emph" "") +#(index-entry "./io.html#./io:s41" ("make-custom-binary-input-port") ("\\scheme{make-custom-binary-input-port}") "267" "emph" "") +#(index-entry "./io.html#./io:s40" ("object->string") ("\\scheme{object->string}") "267" "" "") +#(index-entry "./io.html#./io:s39" ("call-with-string-output-port") ("\\scheme{call-with-string-output-port}") "267" "emph" "") +#(index-entry "./io.html#./io:s38" ("call-with-bytevector-output-port") ("\\scheme{call-with-bytevector-output-port}") "266" "emph" "") +#(index-entry "./io.html#./io:s38" ("call-with-bytevector-output-port") ("\\scheme{call-with-bytevector-output-port}") "266" "emph" "") +#(index-entry "./io.html#./io:s37" ("open-string-output-port") ("\\scheme{open-string-output-port}") "266" "emph" "") +#(index-entry "./io.html#./io:s36" ("open-bytevector-output-port") ("\\scheme{open-bytevector-output-port}") "265" "emph" "") +#(index-entry "./io.html#./io:s36" ("open-bytevector-output-port") ("\\scheme{open-bytevector-output-port}") "265" "emph" "") +#(index-entry "./io.html#./io:s35" ("open-string-input-port") ("\\scheme{open-string-input-port}") "265" "emph" "") +#(index-entry "./io.html#./io:s34" ("open-bytevector-input-port") ("\\scheme{open-bytevector-input-port}") "264" "emph" "") +#(index-entry "./io.html#./io:s34" ("open-bytevector-input-port") ("\\scheme{open-bytevector-input-port}") "264" "emph" "") +#(index-entry "./io.html#./io:s33" ("standard-error-port") ("\\scheme{standard-error-port}") "264" "emph" "") +#(index-entry "./io.html#./io:s33" ("standard-output-port") ("\\scheme{standard-output-port}") "264" "emph" "") +#(index-entry "./io.html#./io:s33" ("standard-input-port") ("\\scheme{standard-input-port}") "264" "emph" "") +#(index-entry "./io.html#./io:s32" ("current-error-port") ("\\scheme{current-error-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s32" ("current-output-port") ("\\scheme{current-output-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s32" ("current-input-port") ("\\scheme{current-input-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s31" ("open-file-input/output-port") ("\\scheme{open-file-input/output-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s31" ("open-file-input/output-port") ("\\scheme{open-file-input/output-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s31" ("open-file-input/output-port") ("\\scheme{open-file-input/output-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s31" ("open-file-input/output-port") ("\\scheme{open-file-input/output-port}") "263" "emph" "") +#(index-entry "./io.html#./io:s30" ("open-file-output-port") ("\\scheme{open-file-output-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s30" ("open-file-output-port") ("\\scheme{open-file-output-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s30" ("open-file-output-port") ("\\scheme{open-file-output-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s30" ("open-file-output-port") ("\\scheme{open-file-output-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s29" ("open-file-input-port") ("\\scheme{open-file-input-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s29" ("open-file-input-port") ("\\scheme{open-file-input-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s29" ("open-file-input-port") ("\\scheme{open-file-input-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s29" ("open-file-input-port") ("\\scheme{open-file-input-port}") "262" "emph" "") +#(index-entry "./io.html#./io:s28" ("buffer-mode?") ("\\scheme{buffer-mode?}") "262" "emph" "") +#(index-entry "./io.html#./io:s27" ("buffer-mode") ("\\scheme{buffer-mode}") "261" "emph" "") +#(index-entry "./io.html#./io:s26" ("file-options") ("\\scheme{file-options}") "261" "emph" "") +#(index-entry "./io.html#./io:s25" ("error-handling-mode") ("\\scheme{error-handling-mode}") "260" "emph" "") +#(index-entry "./io.html#./io:s24" ("native-eol-style") ("\\scheme{native-eol-style}") "260" "emph" "") +#(index-entry "./io.html#./io:s23" ("eol-style") ("\\scheme{eol-style}") "259" "emph" "") +#(index-entry "./io.html#./io:s22" ("utf-16-codec") ("\\scheme{utf-16-codec}") "259" "emph" "") +#(index-entry "./io.html#./io:s22" ("utf-8-codec") ("\\scheme{utf-8-codec}") "259" "emph" "") +#(index-entry "./io.html#./io:s22" ("latin-1-codec") ("\\scheme{latin-1-codec}") "259" "emph" "") +#(index-entry "./io.html#./io:s21" ("native-transcoder") ("\\scheme{native-transcoder}") "259" "emph" "") +#(index-entry "./io.html#./io:s20" ("transcoder-error-handling-mode") ("\\scheme{transcoder-error-handling-mode}") "259" "emph" "") +#(index-entry "./io.html#./io:s20" ("transcoder-eol-style") ("\\scheme{transcoder-eol-style}") "259" "emph" "") +#(index-entry "./io.html#./io:s20" ("transcoder-codec") ("\\scheme{transcoder-codec}") "259" "emph" "") +#(index-entry "./io.html#./io:s19" ("make-transcoder") ("\\scheme{make-transcoder}") "259" "emph" "") +#(index-entry "./io.html#./io:s19" ("make-transcoder") ("\\scheme{make-transcoder}") "259" "emph" "") +#(index-entry "./io.html#./io:s19" ("make-transcoder") ("\\scheme{make-transcoder}") "259" "emph" "") +#(index-entry "./io.html#./io:s18" ("line buffering") ("line buffering") "258" "" "") +#(index-entry "./io.html#./io:s17" ("block buffering") ("block buffering") "258" "" "") +#(index-entry "./io.html#./io:s16" ("buffer modes") ("buffer modes") "258" "" "") +#(index-entry "./io.html#./io:s15" ("error handling mode") ("error handling mode") "258" "" "") +#(index-entry "./io.html#./io:s14" ("eol style") ("eol style") "257" "" "") +#(index-entry "./io.html#./io:s13" ("utf-16") ("utf-16") "257" "" "") +#(index-entry "./io.html#./io:s12" ("utf-8") ("utf-8") "257" "" "") +#(index-entry "./io.html#./io:s11" ("latin-1") ("latin-1") "257" "" "") +#(index-entry "./io.html#./io:s10" ("codec") ("codec") "257" "" "") +#(index-entry "./io.html#./io:s9" ("transcoder") ("transcoder") "257" "" "") +#(index-entry "./io.html#./io:s8" ("octet") ("octet") "257" "" "") +#(index-entry "./io.html#./io:s7" ("textual port") ("textual port") "257" "" "") +#(index-entry "./io.html#./io:s6" ("binary port") ("binary port") "257" "" "") +#(index-entry "./io.html#./io:s5" ("eof-object?") ("\\scheme{eof-object?}") "257" "" "") +#(index-entry "./io.html#./io:s4" ("eof object") ("eof object") "257" "" "") +#(index-entry "./io.html#./io:s3" ("file") ("file") "257" "" "") +#(index-entry "./io.html#./io:s2" ("output port") ("output port") "257" "" "") +#(index-entry "./io.html#./io:s1" ("input port") ("input port") "257" "" "") +#(index-entry "./io.html#./io:s0" ("port") ("port") "257" "" "") +#(index-entry "./objects.html#./objects:s301" ("enum-set-indexer") ("\\scheme{enum-set-indexer}") "254" "emph" "") +#(index-entry "./objects.html#./objects:s300" ("enum-set-projection") ("\\scheme{enum-set-projection}") "254" "emph" "") +#(index-entry "./objects.html#./objects:s299" ("enum-set-complement") ("\\scheme{enum-set-complement}") "254" "emph" "") +#(index-entry "./objects.html#./objects:s298" ("enum-set-difference") ("\\scheme{enum-set-difference}") "253" "emph" "") +#(index-entry "./objects.html#./objects:s298" ("enum-set-intersection") ("\\scheme{enum-set-intersection}") "253" "emph" "") +#(index-entry "./objects.html#./objects:s298" ("enum-set-union") ("\\scheme{enum-set-union}") "253" "emph" "") +#(index-entry "./objects.html#./objects:s297" ("enum-set-member?") ("\\scheme{enum-set-member?}") "253" "emph" "") +#(index-entry "./objects.html#./objects:s296" ("enum-set=?") ("\\scheme{enum-set=?}") "252" "emph" "") +#(index-entry "./objects.html#./objects:s295" ("enum-set-subset?") ("\\scheme{enum-set-subset?}") "252" "emph" "") +#(index-entry "./objects.html#./objects:s294" ("enum-set->list") ("\\scheme{enum-set->list}") "252" "emph" "") +#(index-entry "./objects.html#./objects:s293" ("enum-set-universe") ("\\scheme{enum-set-universe}") "252" "emph" "") +#(index-entry "./objects.html#./objects:s292" ("enum-set-constructor") ("\\scheme{enum-set-constructor}") "251" "emph" "") +#(index-entry "./objects.html#./objects:s291" ("make-enumeration") ("\\scheme{make-enumeration}") "251" "emph" "") +#(index-entry "./objects.html#./objects:s290" ("define-enumeration") ("\\scheme{define-enumeration}") "250" "emph" "") +#(index-entry "./objects.html#./objects:s289" ("hashtable-entries") ("\\scheme{hashtable-entries}") "250" "emph" "") +#(index-entry "./objects.html#./objects:s288" ("hashtable-keys") ("\\scheme{hashtable-keys}") "249" "emph" "") +#(index-entry "./objects.html#./objects:s287" ("hashtable-clear!") ("\\scheme{hashtable-clear!}") "249" "emph" "") +#(index-entry "./objects.html#./objects:s287" ("hashtable-clear!") ("\\scheme{hashtable-clear!}") "249" "emph" "") +#(index-entry "./objects.html#./objects:s286" ("hashtable-copy") ("\\scheme{hashtable-copy}") "248" "emph" "") +#(index-entry "./objects.html#./objects:s286" ("hashtable-copy") ("\\scheme{hashtable-copy}") "248" "emph" "") +#(index-entry "./objects.html#./objects:s285" ("hashtable-size") ("\\scheme{hashtable-size}") "248" "emph" "") +#(index-entry "./objects.html#./objects:s284" ("hashtable-delete!") ("\\scheme{hashtable-delete!}") "248" "emph" "") +#(index-entry "./objects.html#./objects:s283" ("hashtable-update!") ("\\scheme{hashtable-update!}") "247" "emph" "") +#(index-entry "./objects.html#./objects:s282" ("hashtable-contains?") ("\\scheme{hashtable-contains?}") "246" "emph" "") +#(index-entry "./objects.html#./objects:s281" ("hashtable-ref") ("\\scheme{hashtable-ref}") "246" "emph" "") +#(index-entry "./objects.html#./objects:s280" ("hashtable-set!") ("\\scheme{hashtable-set!}") "246" "emph" "") +#(index-entry "./objects.html#./objects:s279" ("symbol-hash") ("\\scheme{symbol-hash}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s279" ("string-ci-hash") ("\\scheme{string-ci-hash}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s279" ("string-hash") ("\\scheme{string-hash}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s279" ("equal-hash") ("\\scheme{equal-hash}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s278" ("hashtable-equivalence-function") ("\\scheme{hashtable-equivalence-function}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s278" ("hashtable-hash-function") ("\\scheme{hashtable-hash-function}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s277" ("hashtable-mutable?") ("\\scheme{hashtable-mutable?}") "245" "emph" "") +#(index-entry "./objects.html#./objects:s276" ("make-hashtable") ("\\scheme{make-hashtable}") "244" "emph" "") +#(index-entry "./objects.html#./objects:s276" ("make-hashtable") ("\\scheme{make-hashtable}") "244" "emph" "") +#(index-entry "./objects.html#./objects:s275" ("make-eqv-hashtable") ("\\scheme{make-eqv-hashtable}") "244" "emph" "") +#(index-entry "./objects.html#./objects:s275" ("make-eqv-hashtable") ("\\scheme{make-eqv-hashtable}") "244" "emph" "") +#(index-entry "./objects.html#./objects:s274" ("make-eq-hashtable") ("\\scheme{make-eq-hashtable}") "243" "emph" "") +#(index-entry "./objects.html#./objects:s274" ("make-eq-hashtable") ("\\scheme{make-eq-hashtable}") "243" "emph" "") +#(index-entry "./objects.html#./objects:s273" ("association list") ("association list") "243" "" "") +#(index-entry "./objects.html#./objects:s272" ("hashtables") ("hashtables") "243" "" "") +#(index-entry "./objects.html#./objects:s271" ("boolean=?") ("\\scheme{boolean=?}") "243" "emph" "") +#(index-entry "./objects.html#./objects:s270" ("symbol->string") ("\\scheme{symbol->string}") "242" "emph" "") +#(index-entry "./objects.html#./objects:s269" ("string->symbol") ("\\scheme{string->symbol}") "242" "emph" "") +#(index-entry "./objects.html#./objects:s268" ("symbol=?") ("\\scheme{symbol=?}") "242" "emph" "") +#(index-entry "./objects.html#./objects:s267" ("symbol table") ("symbol table") "241" "" "") +#(index-entry "./objects.html#./objects:s266" ("symbols") ("symbols") "241" "" "") +#(index-entry "./objects.html#./objects:s265" ("bytevector-ieee-double-set!") ("\\scheme{bytevector-ieee-double-set!}") "240" "emph" "") +#(index-entry "./objects.html#./objects:s265" ("bytevector-ieee-single-set!") ("\\scheme{bytevector-ieee-single-set!}") "240" "emph" "") +#(index-entry "./objects.html#./objects:s264" ("bytevector-ieee-double-ref") ("\\scheme{bytevector-ieee-double-ref}") "240" "emph" "") +#(index-entry "./objects.html#./objects:s264" ("bytevector-ieee-single-ref") ("\\scheme{bytevector-ieee-single-ref}") "240" "emph" "") +#(index-entry "./objects.html#./objects:s263" ("bytevector-ieee-double-native-set!") ("\\scheme{bytevector-ieee-double-native-set!}") "239" "emph" "") +#(index-entry "./objects.html#./objects:s263" ("bytevector-ieee-single-native-set!") ("\\scheme{bytevector-ieee-single-native-set!}") "239" "emph" "") +#(index-entry "./objects.html#./objects:s262" ("bytevector-ieee-double-native-ref") ("\\scheme{bytevector-ieee-double-native-ref}") "239" "emph" "") +#(index-entry "./objects.html#./objects:s262" ("bytevector-ieee-single-native-ref") ("\\scheme{bytevector-ieee-single-native-ref}") "239" "emph" "") +#(index-entry "./objects.html#./objects:s261" ("sint-list->bytevector") ("\\scheme{sint-list->bytevector}") "239" "emph" "") +#(index-entry "./objects.html#./objects:s261" ("uint-list->bytevector") ("\\scheme{uint-list->bytevector}") "239" "emph" "") +#(index-entry "./objects.html#./objects:s260" ("bytevector->sint-list") ("\\scheme{bytevector->sint-list}") "238" "emph" "") +#(index-entry "./objects.html#./objects:s260" ("bytevector->uint-list") ("\\scheme{bytevector->uint-list}") "238" "emph" "") +#(index-entry "./objects.html#./objects:s259" ("bytevector-sint-set!") ("\\scheme{bytevector-sint-set!}") "238" "emph" "") +#(index-entry "./objects.html#./objects:s259" ("bytevector-uint-set!") ("\\scheme{bytevector-uint-set!}") "238" "emph" "") +#(index-entry "./objects.html#./objects:s258" ("bytevector-sint-ref") ("\\scheme{bytevector-sint-ref}") "237" "emph" "") +#(index-entry "./objects.html#./objects:s258" ("bytevector-uint-ref") ("\\scheme{bytevector-uint-ref}") "237" "emph" "") +#(index-entry "./objects.html#./objects:s257" ("bytevector-s64-set!") ("\\scheme{bytevector-s64-set!}") "236" "emph" "") +#(index-entry "./objects.html#./objects:s257" ("bytevector-u64-set!") ("\\scheme{bytevector-u64-set!}") "236" "emph" "") +#(index-entry "./objects.html#./objects:s257" ("bytevector-s32-set!") ("\\scheme{bytevector-s32-set!}") "236" "emph" "") +#(index-entry "./objects.html#./objects:s257" ("bytevector-u32-set!") ("\\scheme{bytevector-u32-set!}") "236" "emph" "") +#(index-entry "./objects.html#./objects:s257" ("bytevector-s16-set!") ("\\scheme{bytevector-s16-set!}") "236" "emph" "") +#(index-entry "./objects.html#./objects:s257" ("bytevector-u16-set!") ("\\scheme{bytevector-u16-set!}") "236" "emph" "") +#(index-entry "./objects.html#./objects:s256" ("bytevector-s64-ref") ("\\scheme{bytevector-s64-ref}") "235" "emph" "") +#(index-entry "./objects.html#./objects:s256" ("bytevector-u64-ref") ("\\scheme{bytevector-u64-ref}") "235" "emph" "") +#(index-entry "./objects.html#./objects:s256" ("bytevector-s32-ref") ("\\scheme{bytevector-s32-ref}") "235" "emph" "") +#(index-entry "./objects.html#./objects:s256" ("bytevector-u32-ref") ("\\scheme{bytevector-u32-ref}") "235" "emph" "") +#(index-entry "./objects.html#./objects:s256" ("bytevector-s16-ref") ("\\scheme{bytevector-s16-ref}") "235" "emph" "") +#(index-entry "./objects.html#./objects:s256" ("bytevector-u16-ref") ("\\scheme{bytevector-u16-ref}") "235" "emph" "") +#(index-entry "./objects.html#./objects:s255" ("bytevector-s64-native-set!") ("\\scheme{bytevector-s64-native-set!}") "233" "emph" "") +#(index-entry "./objects.html#./objects:s255" ("bytevector-u64-native-set!") ("\\scheme{bytevector-u64-native-set!}") "233" "emph" "") +#(index-entry "./objects.html#./objects:s255" ("bytevector-s32-native-set!") ("\\scheme{bytevector-s32-native-set!}") "233" "emph" "") +#(index-entry "./objects.html#./objects:s255" ("bytevector-u32-native-set!") ("\\scheme{bytevector-u32-native-set!}") "233" "emph" "") +#(index-entry "./objects.html#./objects:s255" ("bytevector-s16-native-set!") ("\\scheme{bytevector-s16-native-set!}") "233" "emph" "") +#(index-entry "./objects.html#./objects:s255" ("bytevector-u16-native-set!") ("\\scheme{bytevector-u16-native-set!}") "233" "emph" "") +#(index-entry "./objects.html#./objects:s254" ("bytevector-s64-native-ref") ("\\scheme{bytevector-s64-native-ref}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s254" ("bytevector-u64-native-ref") ("\\scheme{bytevector-u64-native-ref}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s254" ("bytevector-s32-native-ref") ("\\scheme{bytevector-s32-native-ref}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s254" ("bytevector-u32-native-ref") ("\\scheme{bytevector-u32-native-ref}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s254" ("bytevector-s16-native-ref") ("\\scheme{bytevector-s16-native-ref}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s254" ("bytevector-u16-native-ref") ("\\scheme{bytevector-u16-native-ref}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s253" ("u8-list->bytevector") ("\\scheme{u8-list->bytevector}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s252" ("bytevector->u8-list") ("\\scheme{bytevector->u8-list}") "232" "emph" "") +#(index-entry "./objects.html#./objects:s251" ("bytevector-s8-set!") ("\\scheme{bytevector-s8-set!}") "231" "emph" "") +#(index-entry "./objects.html#./objects:s250" ("bytevector-u8-set!") ("\\scheme{bytevector-u8-set!}") "231" "emph" "") +#(index-entry "./objects.html#./objects:s249" ("bytevector-s8-ref") ("\\scheme{bytevector-s8-ref}") "231" "emph" "") +#(index-entry "./objects.html#./objects:s248" ("bytevector-u8-ref") ("\\scheme{bytevector-u8-ref}") "230" "emph" "") +#(index-entry "./objects.html#./objects:s247" ("bytevector-copy!") ("\\scheme{bytevector-copy!}") "230" "emph" "") +#(index-entry "./objects.html#./objects:s246" ("bytevector-copy") ("\\scheme{bytevector-copy}") "229" "emph" "") +#(index-entry "./objects.html#./objects:s245" ("bytevector-fill!") ("\\scheme{bytevector-fill!}") "229" "emph" "") +#(index-entry "./objects.html#./objects:s244" ("bytevector=?") ("\\scheme{bytevector=?}") "229" "emph" "") +#(index-entry "./objects.html#./objects:s243" ("bytevector-length") ("\\scheme{bytevector-length}") "229" "emph" "") +#(index-entry "./objects.html#./objects:s242" ("make-bytevector") ("\\scheme{make-bytevector}") "228" "emph" "") +#(index-entry "./objects.html#./objects:s242" ("make-bytevector") ("\\scheme{make-bytevector}") "228" "emph" "") +#(index-entry "./objects.html#./objects:s241" ("native-endianness") ("\\scheme{native-endianness}") "228" "emph" "") +#(index-entry "./objects.html#./objects:s240" ("endianness") ("\\scheme{endianness}") "228" "emph" "") +#(index-entry "./objects.html#./objects:s239" ("vector-sort!") ("\\scheme{vector-sort!}") "226" "emph" "") +#(index-entry "./objects.html#./objects:s239" ("vector-sort") ("\\scheme{vector-sort}") "226" "emph" "") +#(index-entry "./objects.html#./objects:s238" ("list->vector") ("\\scheme{list->vector}") "226" "emph" "") +#(index-entry "./objects.html#./objects:s237" ("vector->list") ("\\scheme{vector->list}") "225" "emph" "") +#(index-entry "./objects.html#./objects:s236" ("vector-fill!") ("\\scheme{vector-fill!}") "225" "emph" "") +#(index-entry "./objects.html#./objects:s235" ("vector-set!") ("\\scheme{vector-set!}") "225" "emph" "") +#(index-entry "./objects.html#./objects:s234" ("vector-ref") ("\\scheme{vector-ref}") "224" "emph" "") +#(index-entry "./objects.html#./objects:s233" ("vector-length") ("\\scheme{vector-length}") "224" "emph" "") +#(index-entry "./objects.html#./objects:s232" ("make-vector") ("\\scheme{make-vector}") "224" "emph" "") +#(index-entry "./objects.html#./objects:s232" ("make-vector") ("\\scheme{make-vector}") "224" "emph" "") +#(index-entry "./objects.html#./objects:s231" ("vector") ("\\scheme{vector}") "224" "emph" "") +#(index-entry "./objects.html#./objects:s230" ("vectors") ("vectors") "223" "" "") +#(index-entry "./objects.html#./objects:s229" ("list->string") ("\\scheme{list->string}") "223" "emph" "") +#(index-entry "./objects.html#./objects:s228" ("string->list") ("\\scheme{string->list}") "222" "emph" "") +#(index-entry "./objects.html#./objects:s227" ("string-normalize-nfkc") ("\\scheme{string-normalize-nfkc}") "222" "emph" "") +#(index-entry "./objects.html#./objects:s227" ("string-normalize-nfc") ("\\scheme{string-normalize-nfc}") "222" "emph" "") +#(index-entry "./objects.html#./objects:s227" ("string-normalize-nfkd") ("\\scheme{string-normalize-nfkd}") "222" "emph" "") +#(index-entry "./objects.html#./objects:s227" ("string-normalize-nfd") ("\\scheme{string-normalize-nfd}") "222" "emph" "") +#(index-entry "./objects.html#./objects:s226" ("string-titlecase") ("\\scheme{string-titlecase}") "221" "emph" "") +#(index-entry "./objects.html#./objects:s226" ("string-foldcase") ("\\scheme{string-foldcase}") "221" "emph" "") +#(index-entry "./objects.html#./objects:s226" ("string-downcase") ("\\scheme{string-downcase}") "221" "emph" "") +#(index-entry "./objects.html#./objects:s226" ("string-upcase") ("\\scheme{string-upcase}") "221" "emph" "") +#(index-entry "./objects.html#./objects:s225" ("string-fill!") ("\\scheme{string-fill!}") "220" "emph" "") +#(index-entry "./objects.html#./objects:s224" ("substring") ("\\scheme{substring}") "220" "emph" "") +#(index-entry "./objects.html#./objects:s223" ("string-append") ("\\scheme{string-append}") "219" "emph" "") +#(index-entry "./objects.html#./objects:s222" ("string-copy") ("\\scheme{string-copy}") "219" "emph" "") +#(index-entry "./objects.html#./objects:s221" ("string-set!") ("\\scheme{string-set!}") "219" "emph" "") +#(index-entry "./objects.html#./objects:s220" ("string-ref") ("\\scheme{string-ref}") "218" "emph" "") +#(index-entry "./objects.html#./objects:s219" ("string-length") ("\\scheme{string-length}") "218" "emph" "") +#(index-entry "./objects.html#./objects:s218" ("make-string") ("\\scheme{make-string}") "218" "emph" "") +#(index-entry "./objects.html#./objects:s218" ("make-string") ("\\scheme{make-string}") "218" "emph" "") +#(index-entry "./objects.html#./objects:s217" ("string") ("\\scheme{string}") "218" "emph" "") +#(index-entry "./objects.html#./objects:s216" ("string-ci>=?") ("\\scheme{string-ci>=?}") "217" "emph" "") +#(index-entry "./objects.html#./objects:s216" ("string-ci<=?") ("\\scheme{string-ci<=?}") "217" "emph" "") +#(index-entry "./objects.html#./objects:s216" ("string-ci>?") ("\\scheme{string-ci>?}") "217" "emph" "") +#(index-entry "./objects.html#./objects:s216" ("string-ci=?") ("\\scheme{string>=?}") "216" "emph" "") +#(index-entry "./objects.html#./objects:s215" ("string<=?") ("\\scheme{string<=?}") "216" "emph" "") +#(index-entry "./objects.html#./objects:s215" ("string>?") ("\\scheme{string>?}") "216" "emph" "") +#(index-entry "./objects.html#./objects:s215" ("stringchar") ("\\scheme{integer->char}") "215" "emph" "") +#(index-entry "./objects.html#./objects:s210" ("char->integer") ("\\scheme{char->integer}") "215" "emph" "") +#(index-entry "./objects.html#./objects:s209" ("char-foldcase") ("\\scheme{char-foldcase}") "215" "emph" "") +#(index-entry "./objects.html#./objects:s208" ("char-titlecase") ("\\scheme{char-titlecase}") "214" "emph" "") +#(index-entry "./objects.html#./objects:s207" ("char-downcase") ("\\scheme{char-downcase}") "214" "emph" "") +#(index-entry "./objects.html#./objects:s206" ("char-upcase") ("\\scheme{char-upcase}") "214" "emph" "") +#(index-entry "./objects.html#./objects:s205" ("char-general-category") ("\\scheme{char-general-category}") "214" "emph" "") +#(index-entry "./objects.html#./objects:s204" ("char-title-case?") ("\\scheme{char-title-case?}") "213" "emph" "") +#(index-entry "./objects.html#./objects:s204" ("char-upper-case?") ("\\scheme{char-upper-case?}") "213" "emph" "") +#(index-entry "./objects.html#./objects:s204" ("char-lower-case?") ("\\scheme{char-lower-case?}") "213" "emph" "") +#(index-entry "./objects.html#./objects:s203" ("char-whitespace?") ("\\scheme{char-whitespace?}") "213" "emph" "") +#(index-entry "./objects.html#./objects:s203" ("char-numeric?") ("\\scheme{char-numeric?}") "213" "emph" "") +#(index-entry "./objects.html#./objects:s203" ("char-alphabetic?") ("\\scheme{char-alphabetic?}") "213" "emph" "") +#(index-entry "./objects.html#./objects:s202" ("char-ci>=?") ("\\scheme{char-ci>=?}") "212" "emph" "") +#(index-entry "./objects.html#./objects:s202" ("char-ci<=?") ("\\scheme{char-ci<=?}") "212" "emph" "") +#(index-entry "./objects.html#./objects:s202" ("char-ci>?") ("\\scheme{char-ci>?}") "212" "emph" "") +#(index-entry "./objects.html#./objects:s202" ("char-ci=?") ("\\scheme{char>=?}") "212" "emph" "") +#(index-entry "./objects.html#./objects:s201" ("char<=?") ("\\scheme{char<=?}") "212" "emph" "") +#(index-entry "./objects.html#./objects:s201" ("char>?") ("\\scheme{char>?}") "212" "emph" "") +#(index-entry "./objects.html#./objects:s201" ("charflonum") ("\\scheme{real->flonum}") "211" "emph" "") +#(index-entry "./objects.html#./objects:s198" ("fixnum->flonum") ("\\scheme{fixnum->flonum}") "211" "emph" "") +#(index-entry "./objects.html#./objects:s197" ("flexpt") ("\\scheme{flexpt}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s196" ("flsqrt") ("\\scheme{flsqrt}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s195" ("flatan") ("\\scheme{flatan}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s195" ("flatan") ("\\scheme{flatan}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s195" ("flacos") ("\\scheme{flacos}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s195" ("flasin") ("\\scheme{flasin}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s194" ("fltan") ("\\scheme{fltan}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s194" ("flcos") ("\\scheme{flcos}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s194" ("flsin") ("\\scheme{flsin}") "210" "emph" "") +#(index-entry "./objects.html#./objects:s193" ("fllog") ("\\scheme{fllog}") "209" "emph" "") +#(index-entry "./objects.html#./objects:s193" ("fllog") ("\\scheme{fllog}") "209" "emph" "") +#(index-entry "./objects.html#./objects:s193" ("flexp") ("\\scheme{flexp}") "209" "emph" "") +#(index-entry "./objects.html#./objects:s192" ("flabs") ("\\scheme{flabs}") "209" "emph" "") +#(index-entry "./objects.html#./objects:s191" ("fldenominator") ("\\scheme{fldenominator}") "209" "emph" "") +#(index-entry "./objects.html#./objects:s191" ("flnumerator") ("\\scheme{flnumerator}") "209" "emph" "") +#(index-entry "./objects.html#./objects:s190" ("flceiling") ("\\scheme{flceiling}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s190" ("flfloor") ("\\scheme{flfloor}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s190" ("fltruncate") ("\\scheme{fltruncate}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s190" ("flround") ("\\scheme{flround}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s189" ("fldiv0-and-mod0") ("\\scheme{fldiv0-and-mod0}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s189" ("flmod0") ("\\scheme{flmod0}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s189" ("fldiv0") ("\\scheme{fldiv0}") "208" "emph" "") +#(index-entry "./objects.html#./objects:s188" ("fldiv-and-mod") ("\\scheme{fldiv-and-mod}") "207" "emph" "") +#(index-entry "./objects.html#./objects:s188" ("flmod") ("\\scheme{flmod}") "207" "emph" "") +#(index-entry "./objects.html#./objects:s188" ("fldiv") ("\\scheme{fldiv}") "207" "emph" "") +#(index-entry "./objects.html#./objects:s187" ("fl/") ("\\scheme{fl/}") "207" "emph" "") +#(index-entry "./objects.html#./objects:s187" ("fl/") ("\\scheme{fl/}") "207" "emph" "") +#(index-entry "./objects.html#./objects:s186" ("fl*") ("\\scheme{fl*}") "207" "emph" "") +#(index-entry "./objects.html#./objects:s185" ("fl-") ("\\scheme{fl-}") "206" "emph" "") +#(index-entry "./objects.html#./objects:s185" ("fl-") ("\\scheme{fl-}") "206" "emph" "") +#(index-entry "./objects.html#./objects:s184" ("fl+") ("\\scheme{fl+}") "206" "emph" "") +#(index-entry "./objects.html#./objects:s183" ("flmax") ("\\scheme{flmax}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s183" ("flmin") ("\\scheme{flmin}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s182" ("flodd?") ("\\scheme{flodd?}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s182" ("fleven?") ("\\scheme{fleven?}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s181" ("flnan?") ("\\scheme{flnan?}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s181" ("flinfinite?") ("\\scheme{flinfinite?}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s181" ("flfinite?") ("\\scheme{flfinite?}") "205" "emph" "") +#(index-entry "./objects.html#./objects:s180" ("flinteger?") ("\\scheme{flinteger?}") "204" "emph" "") +#(index-entry "./objects.html#./objects:s179" ("flnegative?") ("\\scheme{flnegative?}") "204" "emph" "") +#(index-entry "./objects.html#./objects:s179" ("flpositive?") ("\\scheme{flpositive?}") "204" "emph" "") +#(index-entry "./objects.html#./objects:s179" ("flzero?") ("\\scheme{flzero?}") "204" "emph" "") +#(index-entry "./objects.html#./objects:s178" ("fl>=?") ("\\scheme{fl>=?}") "203" "emph" "") +#(index-entry "./objects.html#./objects:s178" ("fl<=?") ("\\scheme{fl<=?}") "203" "emph" "") +#(index-entry "./objects.html#./objects:s178" ("fl>?") ("\\scheme{fl>?}") "203" "emph" "") +#(index-entry "./objects.html#./objects:s178" ("fl=?") ("\\scheme{fx>=?}") "193" "emph" "") +#(index-entry "./objects.html#./objects:s153" ("fx<=?") ("\\scheme{fx<=?}") "193" "emph" "") +#(index-entry "./objects.html#./objects:s153" ("fx>?") ("\\scheme{fx>?}") "193" "emph" "") +#(index-entry "./objects.html#./objects:s153" ("fxstring") ("\\scheme{number->string}") "191" "emph" "") +#(index-entry "./objects.html#./objects:s148" ("number->string") ("\\scheme{number->string}") "191" "emph" "") +#(index-entry "./objects.html#./objects:s148" ("number->string") ("\\scheme{number->string}") "191" "emph" "") +#(index-entry "./objects.html#./objects:s147" ("string->number") ("\\scheme{string->number}") "191" "emph" "") +#(index-entry "./objects.html#./objects:s147" ("string->number") ("\\scheme{string->number}") "191" "emph" "") +#(index-entry "./objects.html#./objects:s146" ("bitwise-reverse-bit-field") ("\\scheme{bitwise-reverse-bit-field}") "191" "emph" "") +#(index-entry "./objects.html#./objects:s145" ("bitwise-rotate-bit-field") ("\\scheme{bitwise-rotate-bit-field}") "190" "emph" "") +#(index-entry "./objects.html#./objects:s144" ("bitwise-arithmetic-shift") ("\\scheme{bitwise-arithmetic-shift}") "190" "emph" "") +#(index-entry "./objects.html#./objects:s143" ("bitwise-arithmetic-shift-left") ("\\scheme{bitwise-arithmetic-shift-left}") "189" "emph" "") +#(index-entry "./objects.html#./objects:s143" ("bitwise-arithmetic-shift-right") ("\\scheme{bitwise-arithmetic-shift-right}") "189" "emph" "") +#(index-entry "./objects.html#./objects:s142" ("bitwise-copy-bit-field") ("\\scheme{bitwise-copy-bit-field}") "189" "emph" "") +#(index-entry "./objects.html#./objects:s141" ("bitwise-bit-field") ("\\scheme{bitwise-bit-field}") "189" "emph" "") +#(index-entry "./objects.html#./objects:s140" ("bitwise-copy-bit") ("\\scheme{bitwise-copy-bit}") "188" "emph" "") +#(index-entry "./objects.html#./objects:s139" ("bitwise-bit-set?") ("\\scheme{bitwise-bit-set?}") "188" "emph" "") +#(index-entry "./objects.html#./objects:s138" ("bitwise-first-bit-set") ("\\scheme{bitwise-first-bit-set}") "187" "emph" "") +#(index-entry "./objects.html#./objects:s137" ("bitwise-length") ("\\scheme{bitwise-length}") "187" "emph" "") +#(index-entry "./objects.html#./objects:s136" ("bitwise-bit-count") ("\\scheme{bitwise-bit-count}") "187" "emph" "") +#(index-entry "./objects.html#./objects:s135" ("bitwise-if") ("\\scheme{bitwise-if}") "186" "emph" "") +#(index-entry "./objects.html#./objects:s134" ("bitwise-xor") ("\\scheme{bitwise-xor}") "186" "emph" "") +#(index-entry "./objects.html#./objects:s134" ("bitwise-ior") ("\\scheme{bitwise-ior}") "186" "emph" "") +#(index-entry "./objects.html#./objects:s134" ("bitwise-and") ("\\scheme{bitwise-and}") "186" "emph" "") +#(index-entry "./objects.html#./objects:s134" ("bitwise-not") ("\\scheme{bitwise-not}") "186" "emph" "") +#(index-entry "./objects.html#./objects:s133" ("atan") ("\\scheme{atan}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s133" ("atan") ("\\scheme{atan}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s132" ("acos") ("\\scheme{acos}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s132" ("asin") ("\\scheme{asin}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s131" ("tan") ("\\scheme{tan}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s131" ("cos") ("\\scheme{cos}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s131" ("sin") ("\\scheme{sin}") "185" "emph" "") +#(index-entry "./objects.html#./objects:s130" ("log") ("\\scheme{log}") "184" "emph" "") +#(index-entry "./objects.html#./objects:s130" ("log") ("\\scheme{log}") "184" "emph" "") +#(index-entry "./objects.html#./objects:s129" ("exp") ("\\scheme{exp}") "184" "emph" "") +#(index-entry "./objects.html#./objects:s128" ("exact-integer-sqrt") ("\\scheme{exact-integer-sqrt}") "184" "emph" "") +#(index-entry "./objects.html#./objects:s127" ("sqrt") ("\\scheme{sqrt}") "183" "emph" "") +#(index-entry "./objects.html#./objects:s126" ("abs") ("\\scheme{abs}") "183" "" "") +#(index-entry "./objects.html#./objects:s125" ("magnitude") ("\\scheme{magnitude}") "183" "emph" "") +#(index-entry "./objects.html#./objects:s124" ("angle") ("\\scheme{angle}") "183" "emph" "") +#(index-entry "./objects.html#./objects:s123" ("make-polar") ("\\scheme{make-polar}") "183" "emph" "") +#(index-entry "./objects.html#./objects:s122" ("make-rectangular") ("\\scheme{make-rectangular}") "182" "emph" "") +#(index-entry "./objects.html#./objects:s121" ("imag-part") ("\\scheme{imag-part}") "182" "emph" "") +#(index-entry "./objects.html#./objects:s120" ("real-part") ("\\scheme{real-part}") "182" "emph" "") +#(index-entry "./objects.html#./objects:s119" ("denominator") ("\\scheme{denominator}") "181" "emph" "") +#(index-entry "./objects.html#./objects:s118" ("numerator") ("\\scheme{numerator}") "181" "emph" "") +#(index-entry "./objects.html#./objects:s117" ("rationalize") ("\\scheme{rationalize}") "181" "emph" "") +#(index-entry "./objects.html#./objects:s116" ("inexact->exact") ("\\scheme{inexact->exact}") "181" "emph" "") +#(index-entry "./objects.html#./objects:s116" ("exact->inexact") ("\\scheme{exact->inexact}") "181" "emph" "") +#(index-entry "./objects.html#./objects:s115" ("exactness") ("exactness") "180" "" "") +#(index-entry "./objects.html#./objects:s114" ("exact") ("\\scheme{exact}") "180" "emph" "") +#(index-entry "./objects.html#./objects:s113" ("exactness") ("exactness") "180" "" "") +#(index-entry "./objects.html#./objects:s112" ("inexact") ("\\scheme{inexact}") "180" "emph" "") +#(index-entry "./objects.html#./objects:s111" ("expt") ("\\scheme{expt}") "179" "emph" "") +#(index-entry "./objects.html#./objects:s110" ("lcm") ("\\scheme{lcm}") "179" "emph" "") +#(index-entry "./objects.html#./objects:s109" ("gcd") ("\\scheme{gcd}") "179" "emph" "") +#(index-entry "./objects.html#./objects:s108" ("min") ("\\scheme{min}") "178" "emph" "") +#(index-entry "./objects.html#./objects:s107" ("max") ("\\scheme{max}") "178" "emph" "") +#(index-entry "./objects.html#./objects:s106" ("magnitude") ("\\scheme{magnitude}") "178" "" "") +#(index-entry "./objects.html#./objects:s105" ("abs") ("\\scheme{abs}") "178" "emph" "") +#(index-entry "./objects.html#./objects:s104" ("round") ("\\scheme{round}") "178" "emph" "") +#(index-entry "./objects.html#./objects:s103" ("ceiling") ("\\scheme{ceiling}") "177" "emph" "") +#(index-entry "./objects.html#./objects:s102" ("floor") ("\\scheme{floor}") "177" "emph" "") +#(index-entry "./objects.html#./objects:s101" ("truncate") ("\\scheme{truncate}") "177" "emph" "") +#(index-entry "./objects.html#./objects:s100" ("div0-and-mod0") ("\\scheme{div0-and-mod0}") "176" "emph" "") +#(index-entry "./objects.html#./objects:s100" ("mod0") ("\\scheme{mod0}") "176" "emph" "") +#(index-entry "./objects.html#./objects:s100" ("div0") ("\\scheme{div0}") "176" "emph" "") +#(index-entry "./objects.html#./objects:s99" ("div-and-mod") ("\\scheme{div-and-mod}") "175" "emph" "") +#(index-entry "./objects.html#./objects:s99" ("mod") ("\\scheme{mod}") "175" "emph" "") +#(index-entry "./objects.html#./objects:s99" ("div") ("\\scheme{div}") "175" "emph" "") +#(index-entry "./objects.html#./objects:s98" ("modulo") ("\\scheme{modulo}") "175" "emph" "") +#(index-entry "./objects.html#./objects:s98" ("remainder") ("\\scheme{remainder}") "175" "emph" "") +#(index-entry "./objects.html#./objects:s98" ("quotient") ("\\scheme{quotient}") "175" "emph" "") +#(index-entry "./objects.html#./objects:s97" ("nan?") ("\\scheme{nan?}") "174" "emph" "") +#(index-entry "./objects.html#./objects:s97" ("infinite?") ("\\scheme{infinite?}") "174" "emph" "") +#(index-entry "./objects.html#./objects:s97" ("finite?") ("\\scheme{finite?}") "174" "emph" "") +#(index-entry "./objects.html#./objects:s96" ("odd?") ("\\scheme{odd?}") "174" "emph" "") +#(index-entry "./objects.html#./objects:s96" ("even?") ("\\scheme{even?}") "174" "emph" "") +#(index-entry "./objects.html#./objects:s95" ("negative?") ("\\scheme{negative?}") "173" "emph" "") +#(index-entry "./objects.html#./objects:s94" ("positive?") ("\\scheme{positive?}") "173" "emph" "") +#(index-entry "./objects.html#./objects:s93" ("zero?") ("\\scheme{zero?}") "173" "emph" "") +#(index-entry "./objects.html#./objects:s92" ("/") ("\\scheme{/}") "172" "emph" "") +#(index-entry "./objects.html#./objects:s92" ("/") ("\\scheme{/}") "172" "emph" "") +#(index-entry "./objects.html#./objects:s91" ("*") ("\\scheme{*}") "172" "emph" "") +#(index-entry "./objects.html#./objects:s90" ("-") ("\\scheme{-}") "172" "emph" "") +#(index-entry "./objects.html#./objects:s90" ("-") ("\\scheme{-}") "172" "emph" "") +#(index-entry "./objects.html#./objects:s89" ("+") ("\\scheme{+}") "171" "emph" "") +#(index-entry "./objects.html#./objects:s88" (">=") ("\\scheme{>=}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s88" ("<=") ("\\scheme{<=}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s88" (">") ("\\scheme{>}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s88" ("<") ("\\scheme{<}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s88" ("=") ("\\scheme{=}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s87" ("inexact?") ("\\scheme{inexact?}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s86" ("exact?") ("\\scheme{exact?}") "170" "emph" "") +#(index-entry "./objects.html#./objects:s85" ("l (long)") ("\\scheme{l} (long)") "169" "" "") +#(index-entry "./objects.html#./objects:s84" ("d (double)") ("\\scheme{d} (double)") "169" "" "") +#(index-entry "./objects.html#./objects:s83" ("f (single)") ("\\scheme{f} (single)") "169" "" "") +#(index-entry "./objects.html#./objects:s82" ("s (short)") ("\\scheme{s} (short)") "169" "" "") +#(index-entry "./objects.html#./objects:s81" ("#x (hexadecimal)") ("\\scheme{\\#x} (hexadecimal)") "169" "" "") +#(index-entry "./objects.html#./objects:s80" ("#d (decimal)") ("\\scheme{\\#d} (decimal)") "169" "" "") +#(index-entry "./objects.html#./objects:s79" ("#o (octal)") ("\\scheme{\\#o} (octal)") "169" "" "") +#(index-entry "./objects.html#./objects:s78" ("#b (binary)") ("\\scheme{\\#b} (binary)") "169" "" "") +#(index-entry "./objects.html#./objects:s77" ("floating\npoint") ("floating\npoint") "167" "" "") +#(index-entry "./objects.html#./objects:s76" ("arbitrary precision") ("arbitrary precision") "167" "" "") +#(index-entry "./objects.html#./objects:s75" ("exactness preserving") ("exactness preserving") "167" "" "") +#(index-entry "./objects.html#./objects:s74" ("inexact?") ("\\scheme{inexact?}") "167" "" "") +#(index-entry "./objects.html#./objects:s73" ("exact?") ("\\scheme{exact?}") "167" "" "") +#(index-entry "./objects.html#./objects:s72" ("exactness") ("exactness") "167" "" "") +#(index-entry "./objects.html#./objects:s71" ("complex?") ("\\scheme{complex?}") "167" "" "") +#(index-entry "./objects.html#./objects:s70" ("real?") ("\\scheme{real?}") "167" "" "") +#(index-entry "./objects.html#./objects:s69" ("rational?") ("\\scheme{rational?}") "167" "" "") +#(index-entry "./objects.html#./objects:s68" ("integer?") ("\\scheme{integer?}") "167" "" "") +#(index-entry "./objects.html#./objects:s67" ("complex numbers") ("complex numbers") "167" "" "") +#(index-entry "./objects.html#./objects:s66" ("real numbers") ("real numbers") "167" "" "") +#(index-entry "./objects.html#./objects:s65" ("rational numbers") ("rational numbers") "167" "" "") +#(index-entry "./objects.html#./objects:s64" ("integers") ("integers") "167" "" "") +#(index-entry "./objects.html#./objects:s63" ("numbers") ("numbers") "167" "" "") +#(index-entry "./objects.html#./objects:s62" ("list-sort") ("\\scheme{list-sort}") "167" "emph" "") +#(index-entry "./objects.html#./objects:s61" ("association list") ("association list") "166" "" "") +#(index-entry "./objects.html#./objects:s60" ("assp") ("\\scheme{assp}") "166" "emph" "") +#(index-entry "./objects.html#./objects:s59" ("association list") ("association list") "165" "" "") +#(index-entry "./objects.html#./objects:s58" ("assoc") ("\\scheme{assoc}") "165" "emph" "") +#(index-entry "./objects.html#./objects:s58" ("assv") ("\\scheme{assv}") "165" "emph" "") +#(index-entry "./objects.html#./objects:s58" ("assq") ("\\scheme{assq}") "165" "emph" "") +#(index-entry "./objects.html#./objects:s57" ("find") ("\\scheme{find}") "165" "emph" "") +#(index-entry "./objects.html#./objects:s56" ("partition") ("\\scheme{partition}") "164" "emph" "") +#(index-entry "./objects.html#./objects:s55" ("filter") ("\\scheme{filter}") "164" "emph" "") +#(index-entry "./objects.html#./objects:s54" ("remp") ("\\scheme{remp}") "163" "emph" "") +#(index-entry "./objects.html#./objects:s53" ("remove") ("\\scheme{remove}") "163" "emph" "") +#(index-entry "./objects.html#./objects:s53" ("remv") ("\\scheme{remv}") "163" "emph" "") +#(index-entry "./objects.html#./objects:s53" ("remq") ("\\scheme{remq}") "163" "emph" "") +#(index-entry "./objects.html#./objects:s52" ("memp") ("\\scheme{memp}") "163" "emph" "") +#(index-entry "./objects.html#./objects:s51" ("member") ("\\scheme{member}") "161" "emph" "") +#(index-entry "./objects.html#./objects:s51" ("memv") ("\\scheme{memv}") "161" "emph" "") +#(index-entry "./objects.html#./objects:s51" ("memq") ("\\scheme{memq}") "161" "emph" "") +#(index-entry "./objects.html#./objects:s50" ("reverse") ("\\scheme{reverse}") "161" "emph" "") +#(index-entry "./objects.html#./objects:s49" ("append") ("\\scheme{append}") "160" "emph" "") +#(index-entry "./objects.html#./objects:s49" ("append") ("\\scheme{append}") "160" "emph" "") +#(index-entry "./objects.html#./objects:s48" ("list-tail") ("\\scheme{list-tail}") "160" "emph" "") +#(index-entry "./objects.html#./objects:s47" ("list-ref") ("\\scheme{list-ref}") "159" "emph" "") +#(index-entry "./objects.html#./objects:s46" ("length") ("\\scheme{length}") "159" "emph" "") +#(index-entry "./objects.html#./objects:s45" ("list?") ("\\scheme{list?}") "158" "emph" "") +#(index-entry "./objects.html#./objects:s44" ("cons*") ("\\scheme{cons*}") "158" "emph" "") +#(index-entry "./objects.html#./objects:s43" ("list") ("\\scheme{list}") "158" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cddddr") ("\\scheme{cddddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdddar") ("\\scheme{cdddar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cddadr") ("\\scheme{cddadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cddaar") ("\\scheme{cddaar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdaddr") ("\\scheme{cdaddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdadar") ("\\scheme{cdadar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdaadr") ("\\scheme{cdaadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdaaar") ("\\scheme{cdaaar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cadddr") ("\\scheme{cadddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caddar") ("\\scheme{caddar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cadadr") ("\\scheme{cadadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cadaar") ("\\scheme{cadaar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caaddr") ("\\scheme{caaddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caadar") ("\\scheme{caadar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caaadr") ("\\scheme{caaadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caaaar") ("\\scheme{caaaar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdddr") ("\\scheme{cdddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cddar") ("\\scheme{cddar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdadr") ("\\scheme{cdadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdaar") ("\\scheme{cdaar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caddr") ("\\scheme{caddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cadar") ("\\scheme{cadar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caadr") ("\\scheme{caadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caaar") ("\\scheme{caaar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cddr") ("\\scheme{cddr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cdar") ("\\scheme{cdar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("cadr") ("\\scheme{cadr}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s42" ("caar") ("\\scheme{caar}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s41" ("set-cdr!") ("\\scheme{set-cdr!}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s40" ("set-car!") ("\\scheme{set-car!}") "157" "emph" "") +#(index-entry "./objects.html#./objects:s39" ("cdr") ("\\scheme{cdr}") "156" "emph" "") +#(index-entry "./objects.html#./objects:s38" ("car") ("\\scheme{car}") "156" "emph" "") +#(index-entry "./objects.html#./objects:s37" ("cons") ("\\scheme{cons}") "156" "emph" "") +#(index-entry "./objects.html#./objects:s36" ("circular lists") ("circular lists") "156" "" "") +#(index-entry "./objects.html#./objects:s35" ("dotted pair") ("dotted pair") "155" "" "") +#(index-entry "./objects.html#./objects:s34" ("brackets (~[~]~)") ("brackets (~\\scheme{[}~\\scheme{]}~)") "155" "" "") +#(index-entry "./objects.html#./objects:s33" ("binary trees") ("binary trees") "155" "" "") +#(index-entry "./objects.html#./objects:s32" ("improper list") ("improper list") "155" "" "") +#(index-entry "./objects.html#./objects:s31" ("proper list") ("proper list") "155" "" "") +#(index-entry "./objects.html#./objects:s30" ("car") ("\\scheme{car}") "155" "" "") +#(index-entry "./objects.html#./objects:s29" ("cdr") ("\\scheme{cdr}") "155" "" "") +#(index-entry "./objects.html#./objects:s28" ("lists") ("lists") "155" "" "") +#(index-entry "./objects.html#./objects:s27" ("cons cell") ("cons cell") "155" "" "") +#(index-entry "./objects.html#./objects:s26" ("pairs") ("pairs") "155" "" "") +#(index-entry "./objects.html#./objects:s25" ("hashtable?") ("\\scheme{hashtable?}") "155" "emph" "") +#(index-entry "./objects.html#./objects:s24" ("bytevector?") ("\\scheme{bytevector?}") "155" "emph" "") +#(index-entry "./objects.html#./objects:s23" ("procedure?") ("\\scheme{procedure?}") "155" "emph" "") +#(index-entry "./objects.html#./objects:s22" ("symbol?") ("\\scheme{symbol?}") "154" "emph" "") +#(index-entry "./objects.html#./objects:s21" ("vector?") ("\\scheme{vector?}") "154" "emph" "") +#(index-entry "./objects.html#./objects:s20" ("string?") ("\\scheme{string?}") "154" "emph" "") +#(index-entry "./objects.html#./objects:s19" ("char?") ("\\scheme{char?}") "154" "emph" "") +#(index-entry "./objects.html#./objects:s18" ("integer-valued?") ("\\scheme{integer-valued?}") "153" "emph" "") +#(index-entry "./objects.html#./objects:s18" ("rational-valued?") ("\\scheme{rational-valued?}") "153" "emph" "") +#(index-entry "./objects.html#./objects:s18" ("real-valued?") ("\\scheme{real-valued?}") "153" "emph" "") +#(index-entry "./objects.html#./objects:s17" ("integer?") ("\\scheme{integer?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s17" ("rational?") ("\\scheme{rational?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s17" ("real?") ("\\scheme{real?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s17" ("complex?") ("\\scheme{complex?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s17" ("number?") ("\\scheme{number?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s16" ("pair?") ("\\scheme{pair?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s15" ("null?") ("\\scheme{null?}") "151" "emph" "") +#(index-entry "./objects.html#./objects:s14" ("boolean?") ("\\scheme{boolean?}") "150" "emph" "") +#(index-entry "./objects.html#./objects:s13" ("equal?") ("\\scheme{equal?}") "148" "emph" "") +#(index-entry "./objects.html#./objects:s12" ("eqv?") ("\\scheme{eqv?}") "146" "emph" "") +#(index-entry "./objects.html#./objects:s11" ("object identity") ("object identity") "144" "" "") +#(index-entry "./objects.html#./objects:s10" ("eq?") ("\\scheme{eq?}") "143" "emph" "") +#(index-entry "./objects.html#./objects:s9" ("equivalence predicates") ("equivalence predicates") "143" "" "") +#(index-entry "./objects.html#./objects:s8" ("#f") ("\\scheme{\\#f}") "143" "" "") +#(index-entry "./objects.html#./objects:s7" ("#t") ("\\scheme{\\#t}") "143" "" "") +#(index-entry "./objects.html#./objects:s6" ("predicates") ("predicates") "143" "" "") +#(index-entry "./objects.html#./objects:s5" (",@ (unquote-splicing)") ("\\scheme{,{\\schatsign}} (\\scheme{unquote-splicing})") "142" "emph" "") +#(index-entry "./objects.html#./objects:s5" ("unquote-splicing (~,@~)") ("\\scheme{unquote-splicing} (~\\scheme{,{\\schatsign}}~)") "142" "emph" "") +#(index-entry "./objects.html#./objects:s5" (", (unquote)") ("\\scheme{,} (\\scheme{unquote})") "142" "emph" "") +#(index-entry "./objects.html#./objects:s5" ("unquote (~,~)") ("\\scheme{unquote} (~\\scheme{,}~)") "142" "emph" "") +#(index-entry "./objects.html#./objects:s5" ("` (quasiquote)") ("\\scheme{`} (\\scheme{quasiquote})") "142" "emph" "") +#(index-entry "./objects.html#./objects:s5" ("quasiquote (~`~)") ("\\scheme{quasiquote} (~\\scheme{`}~)") "142" "emph" "") +#(index-entry "./objects.html#./objects:s4" ("constants") ("constants") "141" "" "") +#(index-entry "./objects.html#./objects:s3" ("data") ("data") "141" "" "") +#(index-entry "./objects.html#./objects:s2" ("' (quote)") ("\\scheme{'} (\\scheme{quote})") "141" "emph" "") +#(index-entry "./objects.html#./objects:s2" ("quote (~'~)") ("\\scheme{quote} (~\\scheme{'}~)") "141" "emph" "") +#(index-entry "./objects.html#./objects:s1" ("constant") ("constant") "141" "emph" "") +#(index-entry "./objects.html#./objects:s0" ("operations on objects") ("operations on objects") "141" "" "") +#(index-entry "./control.html#./control:s82" ("scheme-report-environment") ("\\scheme{scheme-report-environment}") "137" "emph" "") +#(index-entry "./control.html#./control:s82" ("null-environment") ("\\scheme{null-environment}") "137" "emph" "") +#(index-entry "./control.html#./control:s81" ("environment") ("\\scheme{environment}") "137" "emph" "") +#(index-entry "./control.html#./control:s80" ("eval") ("\\scheme{eval}") "136" "emph" "") +#(index-entry "./control.html#./control:s79" ("let*-values") ("\\scheme{let*-values}") "134" "" "") +#(index-entry "./control.html#./control:s78" ("let-values") ("\\scheme{let-values}") "134" "" "") +#(index-entry "./control.html#./control:s77" ("call/cc") ("\\scheme{call/cc}") "133" "" "") +#(index-entry "./control.html#./control:s76" ("split") ("\\scheme{split}") "133" "" "") +#(index-entry "./control.html#./control:s75" ("describe-segment") ("\\scheme{describe-segment}") "132" "" "") +#(index-entry "./control.html#./control:s74" ("segment-slope") ("\\scheme{segment-slope}") "132" "" "") +#(index-entry "./control.html#./control:s73" ("segment-length") ("\\scheme{segment-length}") "132" "" "") +#(index-entry "./control.html#./control:s72" ("dxdy") ("\\scheme{dxdy}") "131" "" "") +#(index-entry "./control.html#./control:s71" ("call-with-values") ("\\scheme{call-with-values}") "131" "emph" "") +#(index-entry "./control.html#./control:s70" ("values") ("\\scheme{values}") "131" "emph" "") +#(index-entry "./control.html#./control:s69" ("call-with-values") ("\\scheme{call-with-values}") "130" "" "") +#(index-entry "./control.html#./control:s68" ("values") ("\\scheme{values}") "130" "" "") +#(index-entry "./control.html#./control:s67" ("make-promise") ("\\scheme{make-promise}") "129" "" "") +#(index-entry "./control.html#./control:s66" ("streams") ("streams") "128" "" "") +#(index-entry "./control.html#./control:s65" ("force") ("\\scheme{force}") "128" "emph" "") +#(index-entry "./control.html#./control:s65" ("delay") ("\\scheme{delay}") "128" "emph" "") +#(index-entry "./control.html#./control:s64" ("lazy evaluation") ("lazy evaluation") "127" "" "") +#(index-entry "./control.html#./control:s63" ("winders") ("winders") "127" "see{\\scheme{dynamic-wind}}" "") +#(index-entry "./control.html#./control:s62" ("call/cc") ("\\scheme{call/cc}") "126" "" "") +#(index-entry "./control.html#./control:s61" ("fluid binding") ("fluid binding") "125" "" "") +#(index-entry "./control.html#./control:s60" ("nonlocal exits") ("nonlocal exits") "124" "" "") +#(index-entry "./control.html#./control:s59" ("unwind-protect (in Lisp)") ("unwind-protect (in Lisp)") "124" "" "") +#(index-entry "./control.html#./control:s58" ("thunk") ("thunk") "124" "" "") +#(index-entry "./control.html#./control:s57" ("continuations") ("continuations") "124" "" "") +#(index-entry "./control.html#./control:s56" ("dynamic-wind") ("\\scheme{dynamic-wind}") "124" "emph" "") +#(index-entry "./control.html#./control:s55" ("nonlocal exits") ("nonlocal exits") "123" "" "") +#(index-entry "./control.html#./control:s54" ("call-with-current-continuation") ("\\scheme{call-with-current-continuation}") "123" "emph" "") +#(index-entry "./control.html#./control:s54" ("call/cc") ("\\scheme{call/cc}") "123" "emph" "") +#(index-entry "./control.html#./control:s53" ("call/cc") ("\\scheme{call/cc}") "122" "" "") +#(index-entry "./control.html#./control:s52" ("iteration") ("iteration") "122" "" "") +#(index-entry "./control.html#./control:s51" ("mapping") ("mapping") "122" "" "") +#(index-entry "./control.html#./control:s50" ("string-for-each") ("\\scheme{string-for-each}") "122" "emph" "") +#(index-entry "./control.html#./control:s49" ("iteration") ("iteration") "122" "" "") +#(index-entry "./control.html#./control:s48" ("mapping") ("mapping") "122" "" "") +#(index-entry "./control.html#./control:s47" ("vector-for-each") ("\\scheme{vector-for-each}") "122" "emph" "") +#(index-entry "./control.html#./control:s46" ("iteration") ("iteration") "121" "" "") +#(index-entry "./control.html#./control:s45" ("mapping") ("mapping") "121" "" "") +#(index-entry "./control.html#./control:s44" ("vector-map") ("\\scheme{vector-map}") "121" "emph" "") +#(index-entry "./control.html#./control:s43" ("iteration") ("iteration") "121" "" "") +#(index-entry "./control.html#./control:s42" ("folding") ("folding") "121" "" "") +#(index-entry "./control.html#./control:s41" ("fold-right") ("\\scheme{fold-right}") "121" "emph" "") +#(index-entry "./control.html#./control:s40" ("iteration") ("iteration") "120" "" "") +#(index-entry "./control.html#./control:s39" ("folding") ("folding") "120" "" "") +#(index-entry "./control.html#./control:s38" ("fold-left") ("\\scheme{fold-left}") "120" "emph" "") +#(index-entry "./control.html#./control:s37" ("for-all") ("\\scheme{for-all}") "119" "emph" "") +#(index-entry "./control.html#./control:s36" ("exists") ("\\scheme{exists}") "119" "emph" "") +#(index-entry "./control.html#./control:s35" ("iteration") ("iteration") "118" "" "") +#(index-entry "./control.html#./control:s34" ("mapping") ("mapping") "118" "" "") +#(index-entry "./control.html#./control:s33" ("for-each") ("\\scheme{for-each}") "118" "emph" "") +#(index-entry "./control.html#./control:s32" ("iteration") ("iteration") "117" "" "") +#(index-entry "./control.html#./control:s31" ("mapping") ("mapping") "117" "" "") +#(index-entry "./control.html#./control:s30" ("map") ("\\scheme{map}") "117" "emph" "") +#(index-entry "./control.html#./control:s29" ("divisors") ("\\scheme{divisors}") "116" "" "") +#(index-entry "./control.html#./control:s28" ("fibonacci") ("\\scheme{fibonacci}") "116" "" "") +#(index-entry "./control.html#./control:s27" ("factorial") ("\\scheme{factorial}") "116" "" "") +#(index-entry "./control.html#./control:s26" ("iteration") ("iteration") "115" "" "") +#(index-entry "./control.html#./control:s25" ("do") ("\\scheme{do}") "115" "emph" "") +#(index-entry "./control.html#./control:s24" ("divisors") ("\\scheme{divisors}") "115" "" "") +#(index-entry "./control.html#./control:s23" ("recursion") ("recursion") "114" "" "") +#(index-entry "./control.html#./control:s22" ("iteration") ("iteration") "114" "" "") +#(index-entry "./control.html#./control:s21" ("named let") ("named \\scheme{let}") "114" "" "") +#(index-entry "./control.html#./control:s20" ("let") ("\\scheme{let}") "114" "emph" "") +#(index-entry "./control.html#./control:s19" ("else") ("\\scheme{else}") "113" "" "") +#(index-entry "./control.html#./control:s18" ("case") ("\\scheme{case}") "113" "emph" "") +#(index-entry "./control.html#./control:s17" ("unless") ("\\scheme{unless}") "112" "emph" "") +#(index-entry "./control.html#./control:s17" ("when") ("\\scheme{when}") "112" "emph" "") +#(index-entry "./control.html#./control:s16" ("=>") ("\\scheme{=>}") "112" "emph" "") +#(index-entry "./control.html#./control:s16" ("else") ("\\scheme{else}") "112" "emph" "") +#(index-entry "./control.html#./control:s15" ("else") ("\\scheme{else}") "111" "" "") +#(index-entry "./control.html#./control:s14" ("=>") ("\\scheme{=>}") "111" "" "") +#(index-entry "./control.html#./control:s13" ("cond") ("\\scheme{cond}") "111" "emph" "") +#(index-entry "./control.html#./control:s12" ("or") ("\\scheme{or}") "110" "emph" "") +#(index-entry "./control.html#./control:s11" ("and") ("\\scheme{and}") "110" "emph" "") +#(index-entry "./control.html#./control:s10" ("not") ("\\scheme{not}") "110" "emph" "") +#(index-entry "./control.html#./control:s9" ("conditionals") ("conditionals") "109" "" "") +#(index-entry "./control.html#./control:s8" ("if") ("\\scheme{if}") "109" "emph" "") +#(index-entry "./control.html#./control:s8" ("if") ("\\scheme{if}") "109" "emph" "") +#(index-entry "./control.html#./control:s7" ("implicit begin") ("implicit \\scheme{begin}") "109" "" "") +#(index-entry "./control.html#./control:s6" ("side effects") ("side effects") "108" "" "") +#(index-entry "./control.html#./control:s5" ("sequencing") ("sequencing") "108" "" "") +#(index-entry "./control.html#./control:s4" ("begin") ("\\scheme{begin}") "108" "emph" "") +#(index-entry "./control.html#./control:s3" ("apply") ("\\scheme{apply}") "107" "emph" "") +#(index-entry "./control.html#./control:s2" ("order of evaluation") ("order of evaluation") "107" "" "") +#(index-entry "./control.html#./control:s1" ("procedure application") ("procedure application") "107" "emph" "") +#(index-entry "./control.html#./control:s0" ("control structures") ("control structures") "107" "" "") +#(index-entry "./binding.html#./binding:s33" ("fibonacci") ("\\scheme{fibonacci}") "102" "" "") +#(index-entry "./binding.html#./binding:s32" ("Fibonacci numbers") ("Fibonacci numbers") "102" "" "") +#(index-entry "./binding.html#./binding:s31" ("flip-flop") ("\\scheme{flip-flop}") "102" "" "") +#(index-entry "./binding.html#./binding:s30" ("assignments") ("assignments") "102" "" "") +#(index-entry "./binding.html#./binding:s29" ("assignment") ("assignment") "102" "" "") +#(index-entry "./binding.html#./binding:s28" ("set!") ("\\scheme{set!}") "102" "emph" "") +#(index-entry "./binding.html#./binding:s27" ("top-level definitions") ("top-level definitions") "101" "" "") +#(index-entry "./binding.html#./binding:s26" ("begin") ("\\scheme{begin}") "101" "" "") +#(index-entry "./binding.html#./binding:s25" ("procedure definition") ("procedure definition") "100" "" "") +#(index-entry "./binding.html#./binding:s24" ("define") ("\\scheme{define}") "100" "emph" "") +#(index-entry "./binding.html#./binding:s24" ("define") ("\\scheme{define}") "100" "emph" "") +#(index-entry "./binding.html#./binding:s24" ("define") ("\\scheme{define}") "100" "emph" "") +#(index-entry "./binding.html#./binding:s24" ("define") ("\\scheme{define}") "100" "emph" "") +#(index-entry "./binding.html#./binding:s24" ("define") ("\\scheme{define}") "100" "emph" "") +#(index-entry "./binding.html#./binding:s23" ("let*-values") ("\\scheme{let*-values}") "99" "emph" "") +#(index-entry "./binding.html#./binding:s23" ("let-values") ("\\scheme{let-values}") "99" "emph" "") +#(index-entry "./binding.html#./binding:s22" ("letrec*") ("\\scheme{letrec*}") "98" "emph" "") +#(index-entry "./binding.html#./binding:s21" ("mutually recursive procedures") ("mutually recursive procedures") "97" "" "") +#(index-entry "./binding.html#./binding:s20" ("letrec") ("\\scheme{letrec}") "97" "emph" "") +#(index-entry "./binding.html#./binding:s19" ("nested let expressions") ("nested \\scheme{let} expressions") "96" "" "") +#(index-entry "./binding.html#./binding:s18" ("let*") ("\\scheme{let*}") "96" "emph" "") +#(index-entry "./binding.html#./binding:s17" ("local variable bindings") ("local variable bindings") "95" "" "") +#(index-entry "./binding.html#./binding:s16" ("let") ("\\scheme{let}") "95" "emph" "") +#(index-entry "./binding.html#./binding:s15" ("substring") ("\\scheme{substring}") "95" "" "") +#(index-entry "./binding.html#./binding:s14" ("make-list") ("\\scheme{make-list}") "94" "" "") +#(index-entry "./binding.html#./binding:s13" ("case-lambda") ("\\scheme{case-lambda}") "94" "emph" "") +#(index-entry "./binding.html#./binding:s12" ("lambda*") ("\\scheme{lambda*}") "94" "" "") +#(index-entry "./binding.html#./binding:s11" ("case-lambda") ("\\scheme{case-lambda}") "94" "" "") +#(index-entry "./binding.html#./binding:s10" ("optional arguments") ("optional arguments") "93" "" "") +#(index-entry "./binding.html#./binding:s9" ("lambda") ("\\scheme{lambda}") "93" "" "") +#(index-entry "./binding.html#./binding:s8" ("formal parameters") ("formal parameters") "92" "" "") +#(index-entry "./binding.html#./binding:s7" ("actual parameters") ("actual parameters") "92" "" "") +#(index-entry "./binding.html#./binding:s6" ("internal definitions") ("internal definitions") "92" "" "") +#(index-entry "./binding.html#./binding:s5" ("formal parameters") ("formal parameters") "92" "" "") +#(index-entry "./binding.html#./binding:s4" ("procedures") ("procedures") "92" "" "") +#(index-entry "./binding.html#./binding:s3" ("lambda") ("\\scheme{lambda}") "92" "emph" "") +#(index-entry "./binding.html#./binding:s2" ("variable reference") ("variable reference") "91" "emph" "") +#(index-entry "./binding.html#./binding:s1" ("procedures") ("procedures") "91" "" "") +#(index-entry "./binding.html#./binding:s0" ("variable binding") ("variable binding") "91" "" "") +#(index-entry "./further.html#./further:s85" ("list?") ("\\scheme{list?}") "81" "" "") +#(index-entry "./further.html#./further:s84" ("letrec") ("\\scheme{letrec}") "81" "" "") +#(index-entry "./further.html#./further:s83" ("odd?") ("\\scheme{odd?}") "81" "" "") +#(index-entry "./further.html#./further:s82" ("even?") ("\\scheme{even?}") "81" "" "") +#(index-entry "./further.html#./further:s81" ("internal definitions") ("internal definitions") "81" "" "") +#(index-entry "./further.html#./further:s80" ("define") ("\\scheme{define}") "81" "" "") +#(index-entry "./further.html#./further:s78" ("retry") ("\\scheme{retry}") "80" "" "") +#(index-entry "./further.html#./further:s76" ("reciprocal") ("\\scheme{reciprocal}") "80" "" "") +#(index-entry "./further.html#./further:s74" ("product") ("\\scheme{product}") "80" "" "") +#(index-entry "./further.html#./further:s73" ("integer-divide") ("\\scheme{integer-divide}") "79" "" "") +#(index-entry "./further.html#./further:s72" ("CPS") ("CPS") "78" "" "") +#(index-entry "./further.html#./further:s71" ("continuation-passing style") ("continuation-passing style") "78" "" "") +#(index-entry "./further.html#./further:s65" ("retry") ("\\scheme{retry}") "75" "" "") +#(index-entry "./further.html#./further:s64" ("factorial") ("\\scheme{factorial}") "75" "" "") +#(index-entry "./further.html#./further:s63" ("product") ("\\scheme{product}") "74" "" "") +#(index-entry "./further.html#./further:s62" ("call/cc") ("\\scheme{call/cc}") "74" "" "") +#(index-entry "./further.html#./further:s61" ("continuations") ("continuations") "73" "" "") +#(index-entry "./further.html#./further:s60" ("factor") ("\\scheme{factor}") "73" "" "") +#(index-entry "./further.html#./further:s54" ("factor") ("\\scheme{factor}") "72" "" "") +#(index-entry "./further.html#./further:s51" ("factor") ("\\scheme{factor}") "71" "" "") +#(index-entry "./further.html#./further:s50" ("named let") ("named \\scheme{let}") "71" "" "") +#(index-entry "./further.html#./further:s49" ("doubly recursive") ("doubly recursive") "70" "" "") +#(index-entry "./further.html#./further:s48" ("Fibonacci numbers") ("Fibonacci numbers") "69" "" "") +#(index-entry "./further.html#./further:s47" ("fibonacci") ("\\scheme{fibonacci}") "69" "" "") +#(index-entry "./further.html#./further:s46" ("factorial") ("\\scheme{factorial}") "68" "" "") +#(index-entry "./further.html#./further:s45" ("tail recursion") ("tail recursion") "68" "" "") +#(index-entry "./further.html#./further:s44" ("tail call") ("tail call") "68" "" "") +#(index-entry "./further.html#./further:s43" ("iteration") ("iteration") "68" "" "") +#(index-entry "./further.html#./further:s42" ("list?") ("\\scheme{list?}") "67" "" "") +#(index-entry "./further.html#./further:s41" ("named let") ("named \\scheme{let}") "67" "" "") +#(index-entry "./further.html#./further:s40" ("hare and tortoise") ("hare and tortoise") "66" "" "") +#(index-entry "./further.html#./further:s39" ("list?") ("\\scheme{list?}") "66" "" "") +#(index-entry "./further.html#./further:s38" ("odd?") ("\\scheme{odd?}") "66" "" "") +#(index-entry "./further.html#./further:s37" ("even?") ("\\scheme{even?}") "66" "" "") +#(index-entry "./further.html#./further:s36" ("mutually recursive procedures") ("mutually recursive procedures") "66" "" "") +#(index-entry "./further.html#./further:s35" ("letrec") ("\\scheme{letrec}") "65" "" "") +#(index-entry "./further.html#./further:s34" ("sum") ("sum") "65" "" "") +#(index-entry "./further.html#./further:s33" ("let") ("\\scheme{let}") "65" "" "") +#(index-entry "./further.html#./further:s32" ("recursion") ("recursion") "65" "" "") +#(index-entry "./further.html#./further:s31" ("unless") ("\\scheme{unless}") "64" "" "") +#(index-entry "./further.html#./further:s30" ("when") ("\\scheme{when}") "64" "" "") +#(index-entry "./further.html#./further:s28" ("let*") ("\\scheme{let*}") "64" "" "") +#(index-entry "./further.html#./further:s24" ("lexical scoping") ("lexical scoping") "63" "" "") +#(index-entry "./further.html#./further:s23" ("or") ("\\scheme{or}") "63" "" "") +#(index-entry "./further.html#./further:s22" ("and") ("\\scheme{and}") "62" "" "") +#(index-entry "./further.html#./further:s21" ("ellipsis (~...~)") ("ellipsis (~\\scheme{{\\schdot}{\\schdot}{\\schdot}}~)") "61" "" "") +#(index-entry "./further.html#./further:s20" ("...~(ellipsis)") ("\\scheme{{\\schdot}{\\schdot}{\\schdot}}~(ellipsis)") "61" "" "") +#(index-entry "./further.html#./further:s19" ("pattern variables") ("pattern variables") "61" "" "") +#(index-entry "./further.html#./further:s18" ("_ (underscore)") ("\\scheme{{\\schunderscore}} (underscore)") "61" "" "") +#(index-entry "./further.html#./further:s17" ("underscore (~_~)") ("underscore (~\\scheme{{\\schunderscore}}~)") "61" "" "") +#(index-entry "./further.html#./further:s16" ("auxiliary keywords") ("auxiliary keywords") "61" "" "") +#(index-entry "./further.html#./further:s15" ("keywords") ("keywords") "61" "" "") +#(index-entry "./further.html#./further:s14" ("transformer") ("transformer") "61" "" "") +#(index-entry "./further.html#./further:s13" ("define-syntax") ("\\scheme{define-syntax}") "61" "" "") +#(index-entry "./further.html#./further:s12" ("syntactic extensions") ("syntactic extensions") "60" "" "") +#(index-entry "./further.html#./further:s11" ("defining syntactic extensions") ("defining syntactic extensions") "60" "" "") +#(index-entry "./further.html#./further:s10" ("begin") ("\\scheme{begin}") "60" "" "") +#(index-entry "./further.html#./further:s9" ("defun syntax") ("defun syntax") "60" "" "") +#(index-entry "./further.html#./further:s8" ("set!") ("\\scheme{set!}") "59" "" "") +#(index-entry "./further.html#./further:s7" ("if") ("\\scheme{if}") "59" "" "") +#(index-entry "./further.html#./further:s6" ("lambda") ("\\scheme{lambda}") "59" "" "") +#(index-entry "./further.html#./further:s5" ("quote (~'~)") ("\\scheme{quote} (~\\scheme{'}~)") "59" "" "") +#(index-entry "./further.html#./further:s4" ("' (quote)") ("\\scheme{'} (\\scheme{quote})") "59" "" "") +#(index-entry "./further.html#./further:s3" ("expansion") ("expansion") "59" "" "") +#(index-entry "./further.html#./further:s2" ("syntactic extensions") ("syntactic extensions") "59" "" "") +#(index-entry "./further.html#./further:s1" ("syntactic forms") ("syntactic forms") "59" "" "") +#(index-entry "./further.html#./further:s0" ("core syntactic forms") ("core syntactic forms") "59" "" "") +#(index-entry "./start.html#./start:s202" ("hare and tortoise") ("hare and tortoise") "56" "" "") +#(index-entry "./start.html#./start:s201" ("proper list") ("proper list") "56" "" "") +#(index-entry "./start.html#./start:s200" ("list?") ("\\scheme{list?}") "56" "" "") +#(index-entry "./start.html#./start:s198" ("cyclic lists") ("cyclic lists") "56" "" "") +#(index-entry "./start.html#./start:s197" ("set-cdr!") ("\\scheme{set-cdr!}") "56" "" "") +#(index-entry "./start.html#./start:s193" ("vectors") ("vectors") "55" "" "") +#(index-entry "./start.html#./start:s190" ("make-stack") ("\\scheme{make-stack}") "55" "" "") +#(index-entry "./start.html#./start:s189" ("case") ("\\scheme{case}") "55" "" "") +#(index-entry "./start.html#./start:s187" ("make-counter") ("\\scheme{make-counter}") "54" "" "") +#(index-entry "./start.html#./start:s185" ("delq!") ("\\scheme{delq!}") "54" "" "") +#(index-entry "./start.html#./start:s184" ("getq") ("\\scheme{getq}") "54" "" "") +#(index-entry "./start.html#./start:s183" ("putq!") ("\\scheme{putq!}") "54" "" "") +#(index-entry "./start.html#./start:s182" ("make-queue") ("\\scheme{make-queue}") "54" "" "") +#(index-entry "./start.html#./start:s181" ("tconc") ("tconc") "53" "" "") +#(index-entry "./start.html#./start:s180" ("queue") ("queue") "53" "" "") +#(index-entry "./start.html#./start:s179" ("abstract objects") ("abstract objects") "53" "" "") +#(index-entry "./start.html#./start:s178" ("make-stack") ("\\scheme{make-stack}") "52" "" "") +#(index-entry "./start.html#./start:s177" ("messages") ("messages") "52" "" "") +#(index-entry "./start.html#./start:s176" ("stack objects") ("stack objects") "52" "" "") +#(index-entry "./start.html#./start:s175" ("if") ("\\scheme{if}") "51" "" "") +#(index-entry "./start.html#./start:s174" ("begin") ("\\scheme{begin}") "51" "" "") +#(index-entry "./start.html#./start:s173" ("thunk") ("thunk") "51" "" "") +#(index-entry "./start.html#./start:s172" ("lazy") ("\\scheme{lazy}") "51" "" "") +#(index-entry "./start.html#./start:s171" ("lazy evaluation") ("lazy evaluation") "51" "" "") +#(index-entry "./start.html#./start:s170" ("tell") ("\\scheme{tell}") "50" "" "") +#(index-entry "./start.html#./start:s169" ("shhh") ("\\scheme{shhh}") "50" "" "") +#(index-entry "./start.html#./start:s168" ("make-counter") ("\\scheme{make-counter}") "50" "" "") +#(index-entry "./start.html#./start:s167" ("internal state") ("internal state") "49" "" "") +#(index-entry "./start.html#./start:s166" ("quadratic-formula") ("\\scheme{quadratic-formula}") "48" "" "") +#(index-entry "./start.html#./start:s165" ("set!") ("\\scheme{set!}") "47" "" "") +#(index-entry "./start.html#./start:s164" ("variables") ("variables") "47" "" "") +#(index-entry "./start.html#./start:s163" ("assignments") ("assignments") "47" "" "") +#(index-entry "./start.html#./start:s162" ("map") ("\\scheme{map}") "47" "" "") +#(index-entry "./start.html#./start:s160" ("even?") ("\\scheme{even?}") "47" "" "") +#(index-entry "./start.html#./start:s159" ("odd?") ("\\scheme{odd?}") "47" "" "") +#(index-entry "./start.html#./start:s157" ("shorter?") ("\\scheme{shorter?}") "47" "" "") +#(index-entry "./start.html#./start:s156" ("shorter") ("\\scheme{shorter}") "47" "" "") +#(index-entry "./start.html#./start:s153" ("make-list") ("\\scheme{make-list}") "46" "" "") +#(index-entry "./start.html#./start:s151" ("append") ("\\scheme{append}") "46" "" "") +#(index-entry "./start.html#./start:s148" ("map1") ("\\scheme{map1}") "46" "" "") +#(index-entry "./start.html#./start:s147" ("map") ("\\scheme{map}") "45" "" "") +#(index-entry "./start.html#./start:s146" ("mapping") ("mapping") "45" "" "") +#(index-entry "./start.html#./start:s145" ("iteration") ("iteration") "45" "" "") +#(index-entry "./start.html#./start:s144" ("tree-copy") ("\\scheme{tree-copy}") "44" "" "") +#(index-entry "./start.html#./start:s143" ("remv") ("\\scheme{remv}") "44" "" "") +#(index-entry "./start.html#./start:s142" ("cond") ("\\scheme{cond}") "44" "" "") +#(index-entry "./start.html#./start:s141" ("memv") ("\\scheme{memv}") "43" "" "") +#(index-entry "./start.html#./start:s140" ("list-copy") ("\\scheme{list-copy}") "43" "" "") +#(index-entry "./start.html#./start:s139" ("ChezScheme") ("\\ChezScheme") "42" "" "") +#(index-entry "./start.html#./start:s138" ("trace") ("\\scheme{trace}") "42" "" "") +#(index-entry "./start.html#./start:s137" ("tracing") ("tracing") "42" "" "") +#(index-entry "./start.html#./start:s136" ("length") ("\\scheme{length}") "42" "" "") +#(index-entry "./start.html#./start:s135" ("recursion step") ("recursion step") "41" "" "") +#(index-entry "./start.html#./start:s134" ("base case") ("base case") "41" "" "") +#(index-entry "./start.html#./start:s133" ("goodbye") ("\\scheme{goodbye}") "41" "" "") +#(index-entry "./start.html#./start:s132" ("recursive procedure") ("recursive procedure") "41" "" "") +#(index-entry "./start.html#./start:s131" ("recursion") ("recursion") "41" "" "") +#(index-entry "./start.html#./start:s130" ("recursion") ("recursion") "41" "" "") +#(index-entry "./start.html#./start:s129" ("shorter") ("\\scheme{shorter}") "41" "" "") +#(index-entry "./start.html#./start:s127" ("atom?") ("\\scheme{atom?}") "41" "" "") +#(index-entry "./start.html#./start:s125" ("if") ("\\scheme{if}") "39" "" "") +#(index-entry "./start.html#./start:s124" ("cond") ("\\scheme{cond}") "39" "" "") +#(index-entry "./start.html#./start:s123" ("reciprocal") ("\\scheme{reciprocal}") "39" "" "") +#(index-entry "./start.html#./start:s122" ("pair?") ("\\scheme{pair?}") "38" "" "") +#(index-entry "./start.html#./start:s121" ("string?") ("\\scheme{string?}") "38" "" "") +#(index-entry "./start.html#./start:s120" ("number?") ("\\scheme{number?}") "38" "" "") +#(index-entry "./start.html#./start:s119" ("symbol?") ("\\scheme{symbol?}") "38" "" "") +#(index-entry "./start.html#./start:s118" ("pair?") ("\\scheme{pair?}") "38" "" "") +#(index-entry "./start.html#./start:s117" ("type predicates") ("type predicates") "38" "" "") +#(index-entry "./start.html#./start:s116" ("eqv?") ("\\scheme{eqv?}") "38" "" "") +#(index-entry "./start.html#./start:s115" ("lisp-cdr") ("\\scheme{lisp-cdr}") "38" "" "") +#(index-entry "./start.html#./start:s114" ("cdr") ("\\scheme{cdr}") "38" "" "") +#(index-entry "./start.html#./start:s113" ("null?") ("\\scheme{null?}") "37" "" "") +#(index-entry "./start.html#./start:s112" ("question mark (~?~)") ("question mark (~\\scheme{?}~)") "37" "" "") +#(index-entry "./start.html#./start:s111" ("? (question mark)") ("\\scheme{?} (question mark)") "37" "" "") +#(index-entry "./start.html#./start:s110" ("predicates") ("predicates") "37" "" "") +#(index-entry "./start.html#./start:s109" ("reciprocal") ("\\scheme{reciprocal}") "37" "" "") +#(index-entry "./start.html#./start:s108" ("and") ("\\scheme{and}") "37" "" "") +#(index-entry "./start.html#./start:s107" ("false") ("false") "36" "" "") +#(index-entry "./start.html#./start:s106" ("true") ("true") "36" "" "") +#(index-entry "./start.html#./start:s105" ("#f") ("\\scheme{\\#f}") "36" "" "") +#(index-entry "./start.html#./start:s104" ("#t") ("\\scheme{\\#t}") "36" "" "") +#(index-entry "./start.html#./start:s103" ("or") ("\\scheme{or}") "36" "" "") +#(index-entry "./start.html#./start:s102" ("if") ("\\scheme{if}") "36" "" "") +#(index-entry "./start.html#./start:s101" ("or") ("\\scheme{or}") "36" "" "") +#(index-entry "./start.html#./start:s100" ("not") ("\\scheme{not}") "36" "" "") +#(index-entry "./start.html#./start:s99" ("if") ("\\scheme{if}") "35" "" "") +#(index-entry "./start.html#./start:s98" ("abs") ("\\scheme{abs}") "34" "" "") +#(index-entry "./start.html#./start:s97" ("caar, cadr, \\dots, cddddr") ("\\scheme{caar,~cadr,~{\\dots},~cddddr}") "34" "" "") +#(index-entry "./start.html#./start:s95" ("compose") ("\\scheme{compose}") "34" "" "") +#(index-entry "./start.html#./start:s94" ("cddr") ("\\scheme{cddr}") "34" "" "") +#(index-entry "./start.html#./start:s93" ("cadr") ("\\scheme{cadr}") "34" "" "") +#(index-entry "./start.html#./start:s90" ("double-cons") ("\\scheme{double-cons}") "33" "" "") +#(index-entry "./start.html#./start:s89" ("double") ("\\scheme{double}") "33" "" "") +#(index-entry "./start.html#./start:s88" ("doubler") ("\\scheme{doubler}") "33" "" "") +#(index-entry "./start.html#./start:s87" ("defun syntax") ("defun syntax") "33" "" "") +#(index-entry "./start.html#./start:s86" ("list") ("\\scheme{list}") "32" "" "") +#(index-entry "./start.html#./start:s85" ("cadr") ("\\scheme{cadr}") "32" "" "") +#(index-entry "./start.html#./start:s84" ("cddr") ("\\scheme{cddr}") "31" "" "") +#(index-entry "./start.html#./start:s83" ("cadr") ("\\scheme{cadr}") "31" "" "") +#(index-entry "./start.html#./start:s82" ("list") ("\\scheme{list}") "31" "" "") +#(index-entry "./start.html#./start:s81" ("shadowing") ("shadowing") "31" "" "") +#(index-entry "./start.html#./start:s80" ("procedure definition") ("procedure definition") "31" "" "") +#(index-entry "./start.html#./start:s79" ("double-any") ("\\scheme{double-any}") "30" "" "") +#(index-entry "./start.html#./start:s78" ("define") ("\\scheme{define}") "30" "" "") +#(index-entry "./start.html#./start:s77" ("variables") ("variables") "30" "" "") +#(index-entry "./start.html#./start:s76" ("top-level definitions") ("top-level definitions") "30" "" "") +#(index-entry "./start.html#./start:s75" ("occur free") ("occur free") "30" "" "") +#(index-entry "./start.html#./start:s71" ("lambda") ("\\scheme{lambda}") "29" "" "") +#(index-entry "./start.html#./start:s70" ("formal parameters") ("formal parameters") "29" "" "") +#(index-entry "./start.html#./start:s69" ("let") ("\\scheme{let}") "28" "" "") +#(index-entry "./start.html#./start:s68" ("free variable") ("free variable") "28" "" "") +#(index-entry "./start.html#./start:s67" ("occur free") ("occur free") "28" "" "") +#(index-entry "./start.html#./start:s66" ("double-cons") ("\\scheme{double-cons}") "27" "" "") +#(index-entry "./start.html#./start:s65" ("double") ("\\scheme{double}") "27" "" "") +#(index-entry "./start.html#./start:s64" ("actual parameters") ("actual parameters") "27" "" "") +#(index-entry "./start.html#./start:s63" ("procedure application") ("procedure application") "27" "" "") +#(index-entry "./start.html#./start:s62" ("formal parameters") ("formal parameters") "26" "" "") +#(index-entry "./start.html#./start:s61" ("procedures") ("procedures") "26" "" "") +#(index-entry "./start.html#./start:s60" ("lambda") ("\\scheme{lambda}") "26" "" "") +#(index-entry "./start.html#./start:s56" ("lexical scoping") ("lexical scoping") "25" "" "") +#(index-entry "./start.html#./start:s55" ("scope") ("scope") "25" "" "") +#(index-entry "./start.html#./start:s54" ("shadowing") ("shadowing") "25" "" "") +#(index-entry "./start.html#./start:s53" ("let-bound variables") ("\\scheme{let}-bound variables") "23" "" "") +#(index-entry "./start.html#./start:s52" ("variable binding") ("variable binding") "23" "" "") +#(index-entry "./start.html#./start:s51" ("let") ("\\scheme{let}") "23" "" "") +#(index-entry "./start.html#./start:s50" ("variables") ("variables") "23" "" "") +#(index-entry "./start.html#./start:s48" ("order of evaluation") ("order of evaluation") "22" "" "") +#(index-entry "./start.html#./start:s47" ("core syntactic forms") ("core syntactic forms") "22" "" "") +#(index-entry "./start.html#./start:s46" ("syntactic extensions") ("syntactic extensions") "22" "" "") +#(index-entry "./start.html#./start:s45" ("quote (~'~)") ("\\scheme{quote} (~\\scheme{'}~)") "22" "" "") +#(index-entry "./start.html#./start:s44" ("' (quote)") ("\\scheme{'} (\\scheme{quote})") "22" "" "") +#(index-entry "./start.html#./start:s43" ("procedure application") ("procedure application") "21" "" "") +#(index-entry "./start.html#./start:s42" ("constants") ("constants") "21" "" "") +#(index-entry "./start.html#./start:s33" ("list") ("\\scheme{list}") "20" "" "") +#(index-entry "./start.html#./start:s32" ("dotted pair") ("dotted pair") "20" "" "") +#(index-entry "./start.html#./start:s31" ("dot (~.~)") ("dot (~\\scheme{{\\schdot}}~)") "19" "" "") +#(index-entry "./start.html#./start:s30" (". (dot)") ("\\scheme{{\\schdot}} (dot)") "19" "" "") +#(index-entry "./start.html#./start:s29" ("improper list") ("improper list") "19" "" "") +#(index-entry "./start.html#./start:s28" ("proper list") ("proper list") "19" "" "") +#(index-entry "./start.html#./start:s27" ("pairs") ("pairs") "19" "" "") +#(index-entry "./start.html#./start:s26" ("consing") ("consing") "19" "" "") +#(index-entry "./start.html#./start:s25" ("cons") ("\\scheme{cons}") "19" "" "") +#(index-entry "./start.html#./start:s24" ("empty list") ("empty list") "19" "" "") +#(index-entry "./start.html#./start:s23" ("()") ("\\scheme{()}") "19" "" "") +#(index-entry "./start.html#./start:s22" ("cdr") ("\\scheme{cdr}") "18" "" "") +#(index-entry "./start.html#./start:s21" ("car") ("\\scheme{car}") "18" "" "") +#(index-entry "./start.html#./start:s20" ("lists") ("lists") "18" "" "") +#(index-entry "./start.html#./start:s19" ("symbols") ("symbols") "18" "" "") +#(index-entry "./start.html#./start:s18" ("variables") ("variables") "18" "" "") +#(index-entry "./start.html#./start:s17" ("syntactic forms") ("syntactic forms") "18" "" "") +#(index-entry "./start.html#./start:s16" ("quote (~'~)") ("\\scheme{quote} (~\\scheme{'}~)") "17" "" "") +#(index-entry "./start.html#./start:s15" ("' (quote)") ("\\scheme{'} (\\scheme{quote})") "17" "" "") +#(index-entry "./start.html#./start:s14" ("procedure application") ("procedure application") "17" "" "") +#(index-entry "./start.html#./start:s13" ("lists") ("lists") "17" "" "") +#(index-entry "./start.html#./start:s12" ("operator precedence") ("operator precedence") "16" "" "") +#(index-entry "./start.html#./start:s11" ("prefix notation") ("prefix notation") "16" "" "") +#(index-entry "./start.html#./start:s10" ("procedure application") ("procedure application") "16" "" "") +#(index-entry "./start.html#./start:s9" ("/") ("\\scheme{/}") "16" "" "") +#(index-entry "./start.html#./start:s8" ("*") ("\\scheme{*}") "16" "" "") +#(index-entry "./start.html#./start:s7" ("-") ("\\scheme{-}") "16" "" "") +#(index-entry "./start.html#./start:s6" ("+") ("\\scheme{+}") "16" "" "") +#(index-entry "./start.html#./start:s5" ("numbers") ("numbers") "16" "" "") +#(index-entry "./start.html#./start:s4" ("reciprocal") ("\\scheme{reciprocal}") "15" "" "") +#(index-entry "./start.html#./start:s3" ("prefix notation") ("prefix notation") "15" "" "") +#(index-entry "./start.html#./start:s2" ("square") ("\\scheme{square}") "14" "" "") +#(index-entry "./start.html#./start:s1" ("strings") ("strings") "14" "" "") +#(index-entry "./start.html#./start:s0" ("load") ("\\scheme{load}") "13" "" "") +#(index-entry "./intro.html#./intro:s56" ("syntax violation") ("syntax violation") "9" "" "") +#(index-entry "./intro.html#./intro:s55" ("exceptions") ("exceptions") "9" "" "") +#(index-entry "./intro.html#./intro:s54" ("multiple values") ("multiple values") "9" "" "") +#(index-entry "./intro.html#./intro:s53" ("unspecified") ("unspecified") "9" "" "") +#(index-entry "./intro.html#./intro:s52" ("side effects") ("side effects") "8" "" "") +#(index-entry "./intro.html#./intro:s51" ("exclamation point (~!~)") ("exclamation point (~\\scheme{!}~)") "8" "" "") +#(index-entry "./intro.html#./intro:s50" ("! (exclamation point)") ("\\scheme{!} (exclamation point)") "8" "" "") +#(index-entry "./intro.html#./intro:s49" ("->") ("\\scheme{->}") "8" "" "") +#(index-entry "./intro.html#./intro:s48" ("predicates") ("predicates") "8" "" "") +#(index-entry "./intro.html#./intro:s47" ("question mark (~?~)") ("question mark (~\\scheme{?}~)") "8" "" "") +#(index-entry "./intro.html#./intro:s46" ("? (question mark)") ("\\scheme{?} (question mark)") "8" "" "") +#(index-entry "./intro.html#./intro:s45" ("naming conventions") ("naming conventions") "8" "" "") +#(index-entry "./intro.html#./intro:s44" ("semicolon (~;~)") ("semicolon (~\\scheme{;}~)") "7" "" "") +#(index-entry "./intro.html#./intro:s43" ("; (comment)") ("\\scheme{;} (comment)") "7" "" "") +#(index-entry "./intro.html#./intro:s42" ("comments") ("comments") "7" "" "") +#(index-entry "./intro.html#./intro:s41" ("whitespace characters") ("whitespace characters") "7" "" "") +#(index-entry "./intro.html#./intro:s40" ("expressions") ("expressions") "7" "" "") +#(index-entry "./intro.html#./intro:s39" ("#f") ("\\scheme{\\#f}") "7" "" "") +#(index-entry "./intro.html#./intro:s38" ("#t") ("\\scheme{\\#t}") "7" "" "") +#(index-entry "./intro.html#./intro:s37" ("false") ("false") "7" "" "") +#(index-entry "./intro.html#./intro:s36" ("true") ("true") "7" "" "") +#(index-entry "./intro.html#./intro:s35" ("boolean values") ("boolean values") "7" "" "") +#(index-entry "./intro.html#./intro:s34" ("brackets (~[~]~)") ("brackets (~\\scheme{[}~\\scheme{]}~)") "7" "" "") +#(index-entry "./intro.html#./intro:s33" ("()") ("\\scheme{()}") "7" "" "") +#(index-entry "./intro.html#./intro:s32" ("empty list") ("empty list") "7" "" "") +#(index-entry "./intro.html#./intro:s31" ("list constants") ("list constants") "7" "" "") +#(index-entry "./intro.html#./intro:s30" ("identifiers") ("identifiers") "6" "" "") +#(index-entry "./intro.html#./intro:s29" ("structured forms") ("structured forms") "6" "" "") +#(index-entry "./intro.html#./intro:s28" ("Common Lisp") ("Common Lisp") "6" "" "") +#(index-entry "./intro.html#./intro:s27" ("Algol 60") ("Algol 60") "6" "" "") +#(index-entry "./intro.html#./intro:s26" ("Lisp") ("Lisp") "6" "" "") +#(index-entry "./intro.html#./intro:s25" ("syntactic extensions") ("syntactic extensions") "5" "" "") +#(index-entry "./intro.html#./intro:s24" ("continuations") ("continuations") "5" "" "") +#(index-entry "./intro.html#./intro:s23" ("tail call") ("tail call") "5" "" "") +#(index-entry "./intro.html#./intro:s22" ("looping") ("looping") "5" "" "") +#(index-entry "./intro.html#./intro:s21" ("iteration") ("iteration") "5" "" "") +#(index-entry "./intro.html#./intro:s20" ("tail recursion") ("tail recursion") "5" "" "") +#(index-entry "./intro.html#./intro:s19" ("recursion") ("recursion") "5" "" "") +#(index-entry "./intro.html#./intro:s18" ("first-class procedures") ("first-class procedures") "5" "" "") +#(index-entry "./intro.html#./intro:s17" ("lexical scoping") ("lexical scoping") "5" "" "") +#(index-entry "./intro.html#./intro:s16" ("procedure definition") ("procedure definition") "5" "" "") +#(index-entry "./intro.html#./intro:s15" ("shadowing") ("shadowing") "4" "" "") +#(index-entry "./intro.html#./intro:s14" ("binding") ("binding") "4" "" "") +#(index-entry "./intro.html#./intro:s13" ("block structure") ("block structure") "4" "" "") +#(index-entry "./intro.html#./intro:s12" ("lexical scoping") ("lexical scoping") "4" "" "") +#(index-entry "./intro.html#./intro:s11" ("keywords") ("keywords") "4" "" "") +#(index-entry "./intro.html#./intro:s10" ("variables") ("variables") "4" "" "") +#(index-entry "./intro.html#./intro:s9" ("compiler") ("compiler") "4" "" "") +#(index-entry "./intro.html#./intro:s8" ("interpreter") ("interpreter") "4" "" "") +#(index-entry "./intro.html#./intro:s7" ("primitive procedures") ("primitive procedures") "4" "" "") +#(index-entry "./intro.html#./intro:s6" ("core syntactic forms") ("core syntactic forms") "4" "" "") +#(index-entry "./intro.html#./intro:s5" ("pointers") ("pointers") "4" "" "") +#(index-entry "./intro.html#./intro:s4" ("first-class data values") ("first-class data values") "3" "" "") +#(index-entry "./intro.html#./intro:s3" ("garbage collector") ("garbage collector") "3" "" "") +#(index-entry "./intro.html#./intro:s2" ("dynamic allocation") ("dynamic allocation") "3" "" "") +#(index-entry "./intro.html#./intro:s1" ("objects") ("objects") "3" "" "") +#(index-entry "./intro.html#./intro:s0" ("Revised Reports") ("Revised Reports") "3" "" "") +#(index-entry "./preface.html#./preface:s4" ("PetiteChezScheme") ("\\PetiteChezScheme") "ix" "" "") +#(index-entry "./preface.html#./preface:s3" ("ChezScheme") ("\\ChezScheme") "ix" "" "") +#(index-entry "./preface.html#./preface:s2" ("Revised Reports") ("Revised Reports") "ix" "" "") +#(index-entry "./preface.html#./preface:s1" ("Scheme standard") ("Scheme standard") "ix" "" "") +#(index-entry "./preface.html#./preface:s0" ("Lisp") ("Lisp") "ix" "" "") +) diff --git a/csug/tspl4/preface.aux b/csug/tspl4/preface.aux new file mode 100644 index 0000000..214741b --- /dev/null +++ b/csug/tspl4/preface.aux @@ -0,0 +1,29 @@ +\relax +\citation{Steele:scheme} +\citation{Sussman-Steele:HOSC98} +\citation{Friedman:lisper} +\citation{IEEE:1178} +\citation{r6rs} +\citation{Dybvig:csug8} +\@writefile{toc}{\contentsline {chapter}{Preface}{ix}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{./preface:s0}{{}{ix}} +\newlabel{./preface:s1}{{}{ix}} +\newlabel{./preface:s2}{{}{ix}} +\newlabel{./preface:s3}{{}{ix}} +\newlabel{./preface:s4}{{}{ix}} +\@setckpt{preface}{ +\setcounter{page}{13} +\setcounter{equation}{0} +\setcounter{enumi}{0} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{0} +\setcounter{section}{0} +\setcounter{exercise}{0} +\setcounter{alphacount}{0} +} diff --git a/csug/tspl4/records.aux b/csug/tspl4/records.aux new file mode 100644 index 0000000..2720418 --- /dev/null +++ b/csug/tspl4/records.aux @@ -0,0 +1,73 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {9}Records}{321}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTRECORDS}{{9}{321}} +\newlabel{./records:s0}{{9}{323}} +\newlabel{./records:s1}{{9}{323}} +\newlabel{./records:s2}{{9}{323}} +\newlabel{SECTRECORDDEFINITION}{{9.1}{323}} +\@writefile{toc}{\contentsline {section}{\numberline {9.1}Defining Records}{323}} +\newlabel{./records:s3}{{9.1}{324}} +\newlabel{./records:s4}{{9.1}{324}} +\newlabel{./records:s5}{{9.1}{324}} +\citation{RFC4122} +\newlabel{./records:s6}{{9.1}{325}} +\newlabel{page:record-uid}{{9.1}{325}} +\newlabel{./records:s7}{{9.1}{325}} +\newlabel{./records:s8}{{9.1}{325}} +\newlabel{./records:s9}{{9.1}{325}} +\newlabel{./records:s10}{{9.1}{325}} +\newlabel{page:parent-type}{{9.1}{325}} +\newlabel{./records:s11}{{9.1}{326}} +\newlabel{page:protocols}{{9.1}{326}} +\newlabel{./records:s12}{{9.1}{327}} +\newlabel{./records:s13}{{9.1}{328}} +\newlabel{./records:s14}{{9.1}{330}} +\newlabel{page:sealed}{{9.1}{330}} +\newlabel{./records:s15}{{9.1}{330}} +\newlabel{page:opaque}{{9.1}{330}} +\newlabel{./records:s16}{{9.1}{331}} +\newlabel{SECTRECORDPROCEDURAL}{{9.2}{331}} +\@writefile{toc}{\contentsline {section}{\numberline {9.2}Procedural Interface}{331}} +\newlabel{./records:s17}{{9.2}{331}} +\newlabel{./records:s18}{{9.2}{331}} +\newlabel{./records:s19}{{9.2}{331}} +\newlabel{./records:s20}{{9.2}{331}} +\newlabel{./records:s21}{{9.2}{331}} +\newlabel{./records:s22}{{9.2}{331}} +\newlabel{./records:s23}{{9.2}{332}} +\newlabel{./records:s24}{{9.2}{332}} +\newlabel{./records:s25}{{9.2}{332}} +\newlabel{./records:s26}{{9.2}{332}} +\newlabel{./records:s27}{{9.2}{332}} +\newlabel{./records:s28}{{9.2}{333}} +\newlabel{./records:s29}{{9.2}{333}} +\newlabel{./records:s30}{{9.2}{333}} +\newlabel{./records:s31}{{9.2}{334}} +\newlabel{./records:s32}{{9.2}{334}} +\newlabel{SECTRECORDINSPECTION}{{9.3}{335}} +\@writefile{toc}{\contentsline {section}{\numberline {9.3}Inspection}{335}} +\newlabel{./records:s33}{{9.3}{336}} +\newlabel{./records:s34}{{9.3}{336}} +\newlabel{./records:s35}{{9.3}{336}} +\newlabel{./records:s36}{{9.3}{336}} +\newlabel{./records:s37}{{9.3}{337}} +\newlabel{./records:s38}{{9.3}{337}} +\newlabel{./records:s39}{{9.3}{338}} +\newlabel{./records:s40}{{9.3}{338}} +\newlabel{./records:s41}{{9.3}{338}} +\@setckpt{records}{ +\setcounter{page}{340} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{9} +\setcounter{section}{3} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/start.aux b/csug/tspl4/start.aux new file mode 100644 index 0000000..83d254b --- /dev/null +++ b/csug/tspl4/start.aux @@ -0,0 +1,249 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {2}Getting Started}{11}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTGETTINGSTARTED}{{2}{11}} +\newlabel{SECTGSINTERACTING}{{2.1}{13}} +\@writefile{toc}{\contentsline {section}{\numberline {2.1}Interacting with Scheme}{13}} +\newlabel{./start:s0}{{2.1}{13}} +\newlabel{./start:s1}{{2.1}{14}} +\newlabel{./start:s2}{{2.1}{14}} +\newlabel{./start:s3}{{2.1}{15}} +\newlabel{./start:s4}{{2.1}{15}} +\newlabel{SECTGSSIMPLE}{{2.2}{16}} +\@writefile{toc}{\contentsline {section}{\numberline {2.2}Simple Expressions}{16}} +\newlabel{./start:s5}{{2.2}{16}} +\newlabel{./start:s6}{{2.2}{16}} +\newlabel{./start:s7}{{2.2}{16}} +\newlabel{./start:s8}{{2.2}{16}} +\newlabel{./start:s9}{{2.2}{16}} +\newlabel{./start:s10}{{2.2}{16}} +\newlabel{./start:s11}{{2.2}{16}} +\newlabel{./start:s12}{{2.2}{16}} +\newlabel{./start:s13}{{2.2}{17}} +\newlabel{./start:s14}{{2.2}{17}} +\newlabel{./start:s15}{{2.2}{17}} +\newlabel{./start:s16}{{2.2}{17}} +\newlabel{./start:s17}{{2.2}{18}} +\newlabel{./start:s18}{{2.2}{18}} +\newlabel{./start:s19}{{2.2}{18}} +\newlabel{./start:s20}{{2.2}{18}} +\newlabel{./start:s21}{{2.2}{18}} +\newlabel{./start:s22}{{2.2}{18}} +\newlabel{./start:s23}{{2.2}{19}} +\newlabel{./start:s24}{{2.2}{19}} +\newlabel{./start:s25}{{2.2}{19}} +\newlabel{./start:s26}{{2.2}{19}} +\newlabel{./start:s27}{{2.2}{19}} +\newlabel{./start:s28}{{2.2}{19}} +\newlabel{./start:s29}{{2.2}{19}} +\newlabel{./start:s30}{{2.2}{19}} +\newlabel{./start:s31}{{2.2}{19}} +\newlabel{./start:s32}{{2.2}{20}} +\newlabel{./start:s33}{{2.2}{20}} +\newlabel{./start:s34}{{2.2.1}{20}} +\newlabel{./start:s35}{{2.2.2}{20}} +\newlabel{./start:s36}{{2.2.3}{20}} +\newlabel{EXEXPRVALUE}{{2.2.3}{20}} +\newlabel{./start:s37}{{2.2.4}{21}} +\newlabel{./start:s38}{{2.2.5}{21}} +\newlabel{./start:s39}{{2.2.6}{21}} +\newlabel{./start:s40}{{2.2.7}{21}} +\newlabel{./start:s41}{{2.2.8}{21}} +\newlabel{SECTGSEVALUATING}{{2.3}{21}} +\@writefile{toc}{\contentsline {section}{\numberline {2.3}Evaluating Scheme Expressions}{21}} +\newlabel{./start:s42}{{2.3}{21}} +\newlabel{./start:s43}{{2.3}{21}} +\newlabel{./start:s44}{{2.3}{22}} +\newlabel{./start:s45}{{2.3}{22}} +\newlabel{./start:s46}{{2.3}{22}} +\newlabel{./start:s47}{{2.3}{22}} +\newlabel{./start:s48}{{2.3}{22}} +\newlabel{./start:s49}{{2.3.1}{23}} +\newlabel{SECTGSIDENTIFIERS}{{2.4}{23}} +\@writefile{toc}{\contentsline {section}{\numberline {2.4}Variables and Let Expressions}{23}} +\newlabel{./start:s50}{{2.4}{23}} +\newlabel{./start:s51}{{2.4}{23}} +\newlabel{./start:s52}{{2.4}{23}} +\newlabel{./start:s53}{{2.4}{23}} +\newlabel{./start:s54}{{2.4}{25}} +\newlabel{./start:s55}{{2.4}{25}} +\newlabel{./start:s56}{{2.4}{25}} +\newlabel{./start:s57}{{2.4.1}{25}} +\newlabel{./start:s58}{{2.4.2}{25}} +\newlabel{./start:s59}{{2.4.3}{26}} +\newlabel{SECTGSLAMBDA}{{2.5}{26}} +\@writefile{toc}{\contentsline {section}{\numberline {2.5}Lambda Expressions}{26}} +\newlabel{./start:s60}{{2.5}{26}} +\newlabel{./start:s61}{{2.5}{26}} +\newlabel{./start:s62}{{2.5}{26}} +\newlabel{./start:s63}{{2.5}{27}} +\newlabel{./start:s64}{{2.5}{27}} +\newlabel{./start:s65}{{2.5}{27}} +\newlabel{./start:s66}{{2.5}{27}} +\newlabel{./start:s67}{{2.5}{28}} +\newlabel{./start:s68}{{2.5}{28}} +\newlabel{./start:s69}{{2.5}{28}} +\newlabel{./start:s70}{{2.5}{29}} +\newlabel{./start:s71}{{2.5}{29}} +\newlabel{./start:s72}{{2.5.1}{30}} +\newlabel{./start:s73}{{2.5.2}{30}} +\newlabel{./start:s74}{{2.5.3}{30}} +\newlabel{./start:s75}{{2.5.3}{30}} +\newlabel{SECTGSTOPLEVEL}{{2.6}{30}} +\@writefile{toc}{\contentsline {section}{\numberline {2.6}Top-Level Definitions}{30}} +\newlabel{./start:s76}{{2.6}{30}} +\newlabel{./start:s77}{{2.6}{30}} +\newlabel{./start:s78}{{2.6}{30}} +\newlabel{./start:s79}{{2.6}{30}} +\newlabel{./start:s80}{{2.6}{31}} +\newlabel{./start:s81}{{2.6}{31}} +\newlabel{defn:list}{{2.6}{31}} +\newlabel{./start:s82}{{2.6}{31}} +\newlabel{./start:s83}{{2.6}{31}} +\newlabel{./start:s84}{{2.6}{31}} +\newlabel{./start:s85}{{2.6}{32}} +\newlabel{./start:s86}{{2.6}{32}} +\newlabel{./start:s87}{{2.6}{33}} +\newlabel{./start:s88}{{2.6}{33}} +\newlabel{./start:s89}{{2.6}{33}} +\newlabel{./start:s90}{{2.6}{33}} +\newlabel{./start:s91}{{2.6.1}{34}} +\newlabel{./start:s92}{{2.6.2}{34}} +\newlabel{./start:s93}{{2.6.2}{34}} +\newlabel{./start:s94}{{2.6.2}{34}} +\newlabel{./start:s95}{{2.6.2}{34}} +\newlabel{./start:s96}{{2.6.3}{34}} +\newlabel{./start:s97}{{2.6.3}{34}} +\newlabel{SECTGSCONDITIONALS}{{2.7}{34}} +\@writefile{toc}{\contentsline {section}{\numberline {2.7}Conditional Expressions}{34}} +\newlabel{./start:s98}{{2.7}{34}} +\newlabel{./start:s99}{{2.7}{35}} +\newlabel{./start:s100}{{2.7}{36}} +\newlabel{./start:s101}{{2.7}{36}} +\newlabel{./start:s102}{{2.7}{36}} +\newlabel{./start:s103}{{2.7}{36}} +\newlabel{./start:s104}{{2.7}{36}} +\newlabel{./start:s105}{{2.7}{36}} +\newlabel{./start:s106}{{2.7}{36}} +\newlabel{./start:s107}{{2.7}{36}} +\newlabel{./start:s108}{{2.7}{37}} +\newlabel{./start:s109}{{2.7}{37}} +\newlabel{./start:s110}{{2.7}{37}} +\newlabel{./start:s111}{{2.7}{37}} +\newlabel{./start:s112}{{2.7}{37}} +\newlabel{./start:s113}{{2.7}{37}} +\newlabel{./start:s114}{{2.7}{38}} +\newlabel{./start:s115}{{2.7}{38}} +\newlabel{./start:s116}{{2.7}{38}} +\newlabel{./start:s117}{{2.7}{38}} +\newlabel{./start:s118}{{2.7}{38}} +\newlabel{./start:s119}{{2.7}{38}} +\newlabel{./start:s120}{{2.7}{38}} +\newlabel{./start:s121}{{2.7}{38}} +\newlabel{./start:s122}{{2.7}{38}} +\newlabel{./start:s123}{{2.7}{39}} +\newlabel{./start:s124}{{2.7}{39}} +\newlabel{./start:s125}{{2.7}{39}} +\newlabel{./start:s126}{{2.7.1}{41}} +\newlabel{./start:s127}{{2.7.1}{41}} +\newlabel{./start:s128}{{2.7.2}{41}} +\newlabel{EXSHORTER1}{{2.7.2}{41}} +\newlabel{./start:s129}{{2.7.2}{41}} +\newlabel{SECTGSRECURSION}{{2.8}{41}} +\@writefile{toc}{\contentsline {section}{\numberline {2.8}Simple Recursion}{41}} +\newlabel{./start:s130}{{2.8}{41}} +\newlabel{./start:s131}{{2.8}{41}} +\newlabel{./start:s132}{{2.8}{41}} +\newlabel{./start:s133}{{2.8}{41}} +\newlabel{./start:s134}{{2.8}{41}} +\newlabel{./start:s135}{{2.8}{41}} +\newlabel{./start:s136}{{2.8}{42}} +\newlabel{defn:simplelength}{{2.8}{42}} +\newlabel{./start:s137}{{2.8}{42}} +\newlabel{./start:s138}{{2.8}{42}} +\newlabel{./start:s139}{{2.8}{42}} +\newlabel{./start:s140}{{2.8}{43}} +\newlabel{./start:s141}{{2.8}{43}} +\newlabel{./start:s142}{{2.8}{44}} +\newlabel{./start:s143}{{2.8}{44}} +\newlabel{./start:s144}{{2.8}{44}} +\newlabel{./start:s145}{{2.8}{45}} +\newlabel{./start:s146}{{2.8}{45}} +\newlabel{./start:s147}{{2.8}{45}} +\newlabel{./start:s148}{{2.8}{46}} +\newlabel{defn:map1}{{2.8}{46}} +\newlabel{./start:s149}{{2.8.1}{46}} +\newlabel{./start:s150}{{2.8.2}{46}} +\newlabel{./start:s151}{{2.8.2}{46}} +\newlabel{./start:s152}{{2.8.3}{46}} +\newlabel{./start:s153}{{2.8.3}{46}} +\newlabel{./start:s154}{{2.8.4}{47}} +\newlabel{./start:s155}{{2.8.5}{47}} +\newlabel{./start:s156}{{2.8.5}{47}} +\newlabel{./start:s157}{{2.8.5}{47}} +\newlabel{./start:s158}{{2.8.6}{47}} +\newlabel{EXEVENODD}{{2.8.6}{47}} +\newlabel{./start:s159}{{2.8.6}{47}} +\newlabel{./start:s160}{{2.8.6}{47}} +\newlabel{./start:s161}{{2.8.7}{47}} +\newlabel{./start:s162}{{2.8.7}{47}} +\newlabel{SECTGSASSIGNMENT}{{2.9}{47}} +\@writefile{toc}{\contentsline {section}{\numberline {2.9}Assignment}{47}} +\newlabel{./start:s163}{{2.9}{47}} +\newlabel{./start:s164}{{2.9}{47}} +\newlabel{./start:s165}{{2.9}{47}} +\newlabel{./start:s166}{{2.9}{48}} +\newlabel{./start:s167}{{2.9}{49}} +\newlabel{./start:s168}{{2.9}{50}} +\newlabel{./start:s169}{{2.9}{50}} +\newlabel{./start:s170}{{2.9}{50}} +\newlabel{./start:s171}{{2.9}{51}} +\newlabel{./start:s172}{{2.9}{51}} +\newlabel{./start:s173}{{2.9}{51}} +\newlabel{./start:s174}{{2.9}{51}} +\newlabel{./start:s175}{{2.9}{51}} +\newlabel{./start:s176}{{2.9}{52}} +\newlabel{./start:s177}{{2.9}{52}} +\newlabel{./start:s178}{{2.9}{52}} +\newlabel{./start:s179}{{2.9}{53}} +\newlabel{queue-datatype}{{2.9}{53}} +\newlabel{./start:s180}{{2.9}{53}} +\newlabel{./start:s181}{{2.9}{53}} +\newlabel{./start:s182}{{2.9}{54}} +\newlabel{./start:s183}{{2.9}{54}} +\newlabel{./start:s184}{{2.9}{54}} +\newlabel{./start:s185}{{2.9}{54}} +\newlabel{./start:s186}{{2.9.1}{54}} +\newlabel{./start:s187}{{2.9.1}{54}} +\newlabel{./start:s188}{{2.9.2}{55}} +\newlabel{./start:s189}{{2.9.2}{55}} +\newlabel{./start:s190}{{2.9.2}{55}} +\newlabel{./start:s191}{{2.9.3}{55}} +\newlabel{EXSTACKREFANDSET}{{2.9.3}{55}} +\newlabel{./start:s192}{{2.9.4}{55}} +\newlabel{./start:s193}{{2.9.4}{55}} +\newlabel{./start:s194}{{2.9.5}{56}} +\newlabel{./start:s195}{{2.9.6}{56}} +\newlabel{./start:s196}{{2.9.7}{56}} +\newlabel{./start:s197}{{2.9.7}{56}} +\newlabel{./start:s198}{{2.9.7}{56}} +\newlabel{./start:s199}{{2.9.8}{56}} +\newlabel{EXLIST?}{{2.9.8}{56}} +\newlabel{./start:s200}{{2.9.8}{56}} +\newlabel{./start:s201}{{2.9.8}{56}} +\newlabel{./start:s202}{{2.9.8}{56}} +\@setckpt{start}{ +\setcounter{page}{57} +\setcounter{equation}{0} +\setcounter{enumi}{0} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{2} +\setcounter{section}{9} +\setcounter{exercise}{8} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/summary.aux b/csug/tspl4/summary.aux new file mode 100644 index 0000000..503752f --- /dev/null +++ b/csug/tspl4/summary.aux @@ -0,0 +1,18 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{Summary of Forms}{463}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\@setckpt{summary}{ +\setcounter{page}{481} +\setcounter{equation}{0} +\setcounter{enumi}{8} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{32} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{12} +\setcounter{section}{11} +\setcounter{exercise}{7} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/syntax.aux b/csug/tspl4/syntax.aux new file mode 100644 index 0000000..bcef1ac --- /dev/null +++ b/csug/tspl4/syntax.aux @@ -0,0 +1,115 @@ +\relax +\@writefile{toc}{\contentsline {chapter}{\numberline {8}Syntactic Extension}{289}} +\@writefile{lof}{\addvspace {10\p@ }} +\@writefile{lot}{\addvspace {10\p@ }} +\newlabel{CHPTSYNTAX}{{8}{289}} +\citation{Dybvig:syntactic} +\citation{Dybvig:csug8} +\newlabel{./syntax:s0}{{8}{291}} +\newlabel{./syntax:s1}{{8}{291}} +\newlabel{./syntax:s2}{{8}{291}} +\newlabel{./syntax:s3}{{8}{291}} +\newlabel{./syntax:s4}{{8}{291}} +\newlabel{./syntax:s5}{{8}{291}} +\newlabel{./syntax:s6}{{8}{291}} +\newlabel{./syntax:s7}{{8}{291}} +\newlabel{./syntax:s8}{{8}{291}} +\newlabel{./syntax:s9}{{8}{291}} +\newlabel{./syntax:s10}{{8}{291}} +\newlabel{SECTSYNTAXDEFINITIONS}{{8.1}{291}} +\@writefile{toc}{\contentsline {section}{\numberline {8.1}Keyword Bindings}{291}} +\newlabel{./syntax:s11}{{8.1}{291}} +\newlabel{./syntax:s12}{{8.1}{292}} +\newlabel{body-expansion}{{8.1}{292}} +\newlabel{./syntax:s13}{{8.1}{293}} +\newlabel{letsyntaximplicitbegin}{{8.1}{293}} +\newlabel{SECTSYNTAXRULES}{{8.2}{294}} +\@writefile{toc}{\contentsline {section}{\numberline {8.2}Syntax-Rules Transformers}{294}} +\newlabel{./syntax:s14}{{8.2}{294}} +\newlabel{./syntax:s15}{{8.2}{294}} +\newlabel{./syntax:s16}{{8.2}{294}} +\newlabel{./syntax:s17}{{8.2}{294}} +\newlabel{./syntax:s18}{{8.2}{294}} +\newlabel{./syntax:s19}{{8.2}{294}} +\newlabel{./syntax:s20}{{8.2}{294}} +\newlabel{./syntax:s21}{{8.2}{294}} +\newlabel{./syntax:s22}{{8.2}{294}} +\newlabel{patterns}{{8.2}{294}} +\newlabel{./syntax:s23}{{8.2}{295}} +\newlabel{./syntax:s24}{{8.2}{296}} +\newlabel{./syntax:s25}{{8.2}{296}} +\newlabel{./syntax:s26}{{8.2}{297}} +\newlabel{./syntax:s27}{{8.2}{297}} +\newlabel{./syntax:s28}{{8.2}{298}} +\newlabel{SECTSYNTAXCASE}{{8.3}{298}} +\@writefile{toc}{\contentsline {section}{\numberline {8.3}Syntax-Case Transformers}{298}} +\newlabel{./syntax:s29}{{8.3}{298}} +\newlabel{./syntax:s30}{{8.3}{299}} +\newlabel{./syntax:s31}{{8.3}{299}} +\newlabel{./syntax:s32}{{8.3}{299}} +\newlabel{./syntax:s33}{{8.3}{300}} +\newlabel{./syntax:s34}{{8.3}{300}} +\newlabel{./syntax:s35}{{8.3}{301}} +\newlabel{./syntax:s36}{{8.3}{301}} +\newlabel{./syntax:s37}{{8.3}{302}} +\newlabel{./syntax:s38}{{8.3}{304}} +\newlabel{./syntax:s39}{{8.3}{304}} +\newlabel{defn:cond}{{8.3}{305}} +\newlabel{./syntax:s40}{{8.3}{305}} +\citation{bawden:pepm99} +\newlabel{./syntax:s41}{{8.3}{306}} +\newlabel{defn:case}{{8.3}{306}} +\newlabel{./syntax:s42}{{8.3}{306}} +\newlabel{desc:make-variable-transformer}{{8.3}{306}} +\newlabel{./syntax:s43}{{8.3}{307}} +\newlabel{defn:identifier-syntax}{{8.3}{307}} +\newlabel{./syntax:s44}{{8.3}{308}} +\newlabel{./syntax:s45}{{8.3}{308}} +\newlabel{./syntax:s46}{{8.3}{308}} +\newlabel{./syntax:s47}{{8.3}{308}} +\newlabel{./syntax:s48}{{8.3}{309}} +\newlabel{./syntax:s49}{{8.3}{310}} +\newlabel{./syntax:s50}{{8.3}{310}} +\newlabel{defn:letrec}{{8.3}{310}} +\newlabel{fullletvalues}{{8.3}{310}} +\newlabel{./syntax:s51}{{8.3}{310}} +\newlabel{SECTSYNTAXEXAMPLES}{{8.4}{311}} +\@writefile{toc}{\contentsline {section}{\numberline {8.4}Examples}{311}} +\newlabel{./syntax:s52}{{8.4}{311}} +\newlabel{defn:let}{{8.4}{312}} +\newlabel{./syntax:s53}{{8.4}{312}} +\newlabel{defn:do}{{8.4}{313}} +\newlabel{./syntax:s54}{{8.4}{313}} +\newlabel{./syntax:s55}{{8.4}{313}} +\newlabel{./syntax:s56}{{8.4}{314}} +\newlabel{./syntax:s57}{{8.4}{314}} +\newlabel{./syntax:s58}{{8.4}{315}} +\newlabel{./syntax:s59}{{8.4}{315}} +\newlabel{./syntax:s60}{{8.4}{315}} +\newlabel{./syntax:s61}{{8.4}{315}} +\citation{Dybvig:csug8} +\newlabel{./syntax:s62}{{8.4}{316}} +\newlabel{./syntax:s63}{{8.4}{316}} +\newlabel{./syntax:s64}{{8.4}{317}} +\newlabel{./syntax:s65}{{8.4}{317}} +\newlabel{./syntax:s66}{{8.4}{317}} +\newlabel{./syntax:s67}{{8.4}{317}} +\newlabel{defn:method}{{8.4}{317}} +\newlabel{./syntax:s68}{{8.4}{317}} +\newlabel{./syntax:s69}{{8.4}{318}} +\newlabel{./syntax:s70}{{8.4}{318}} +\newlabel{./syntax:s71}{{8.4}{320}} +\@setckpt{syntax}{ +\setcounter{page}{321} +\setcounter{equation}{0} +\setcounter{enumi}{6} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{8} +\setcounter{section}{4} +\setcounter{exercise}{0} +\setcounter{alphacount}{6} +} diff --git a/csug/tspl4/title.aux b/csug/tspl4/title.aux new file mode 100644 index 0000000..d81109d --- /dev/null +++ b/csug/tspl4/title.aux @@ -0,0 +1,15 @@ +\relax +\@setckpt{title}{ +\setcounter{page}{4} +\setcounter{equation}{0} +\setcounter{enumi}{0} +\setcounter{enumii}{0} +\setcounter{enumiii}{0} +\setcounter{enumiv}{0} +\setcounter{footnote}{0} +\setcounter{mpfootnote}{0} +\setcounter{chapter}{0} +\setcounter{section}{0} +\setcounter{exercise}{0} +\setcounter{alphacount}{0} +} diff --git a/csug/tspl4/tspl.aux b/csug/tspl4/tspl.aux new file mode 100644 index 0000000..f78500a --- /dev/null +++ b/csug/tspl4/tspl.aux @@ -0,0 +1,22 @@ +\relax +\@input{title.aux} +\@input{copyright.aux} +\@input{contents.aux} +\@input{preface.aux} +\@input{intro.aux} +\@input{start.aux} +\@input{further.aux} +\@input{binding.aux} +\@input{control.aux} +\@input{objects.aux} +\@input{io.aux} +\@input{syntax.aux} +\@input{records.aux} +\@input{libraries.aux} +\@input{exceptions.aux} +\@input{examples.aux} +\@input{bibliography.aux} +\@input{answers.aux} +\@input{grammar.aux} +\@input{summary.aux} +\@writefile{toc}{\contentsline {chapter}{Index}{481}} diff --git a/csug/tspl4/tspl.haux b/csug/tspl4/tspl.haux new file mode 100644 index 0000000..53e87d0 --- /dev/null +++ b/csug/tspl4/tspl.haux @@ -0,0 +1,4422 @@ +(putprop (quote \x2E;/preface:h0) (quote pageref-url) "./preface.html#./preface:h0") +(putprop (quote \x2E;/preface:s0) (quote pageref-url) "./preface.html#./preface:s0") +(putprop (quote \x2E;/preface:s1) (quote pageref-url) "./preface.html#./preface:s1") +(putprop (quote \x2E;/preface:s2) (quote pageref-url) "./preface.html#./preface:s2") +(putprop (quote \x2E;/preface:s3) (quote pageref-url) "./preface.html#./preface:s3") +(putprop (quote \x2E;/preface:s4) (quote pageref-url) "./preface.html#./preface:s4") +(putprop (quote \x2E;/intro:h0) (quote pageref-url) "./intro.html#./intro:h0") +(putprop (quote \x2E;/intro:h0) (quote ref) "1") +(putprop (quote \x2E;/intro:h0) (quote ref-url) "./intro.html#g0") +(putprop (quote CHPTINTRO) (quote pageref-url) "./intro.html#CHPTINTRO") +(putprop (quote CHPTINTRO) (quote ref) "1") +(putprop (quote CHPTINTRO) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s0) (quote pageref-url) "./intro.html#./intro:s0") +(putprop (quote \x2E;/intro:s0) (quote ref) "1") +(putprop (quote \x2E;/intro:s0) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s1) (quote pageref-url) "./intro.html#./intro:s1") +(putprop (quote \x2E;/intro:s1) (quote ref) "1") +(putprop (quote \x2E;/intro:s1) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s2) (quote pageref-url) "./intro.html#./intro:s2") +(putprop (quote \x2E;/intro:s2) (quote ref) "1") +(putprop (quote \x2E;/intro:s2) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s3) (quote pageref-url) "./intro.html#./intro:s3") +(putprop (quote \x2E;/intro:s3) (quote ref) "1") +(putprop (quote \x2E;/intro:s3) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s4) (quote pageref-url) "./intro.html#./intro:s4") +(putprop (quote \x2E;/intro:s4) (quote ref) "1") +(putprop (quote \x2E;/intro:s4) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s5) (quote pageref-url) "./intro.html#./intro:s5") +(putprop (quote \x2E;/intro:s5) (quote ref) "1") +(putprop (quote \x2E;/intro:s5) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s6) (quote pageref-url) "./intro.html#./intro:s6") +(putprop (quote \x2E;/intro:s6) (quote ref) "1") +(putprop (quote \x2E;/intro:s6) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s7) (quote pageref-url) "./intro.html#./intro:s7") +(putprop (quote \x2E;/intro:s7) (quote ref) "1") +(putprop (quote \x2E;/intro:s7) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s8) (quote pageref-url) "./intro.html#./intro:s8") +(putprop (quote \x2E;/intro:s8) (quote ref) "1") +(putprop (quote \x2E;/intro:s8) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s9) (quote pageref-url) "./intro.html#./intro:s9") +(putprop (quote \x2E;/intro:s9) (quote ref) "1") +(putprop (quote \x2E;/intro:s9) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s10) (quote pageref-url) "./intro.html#./intro:s10") +(putprop (quote \x2E;/intro:s10) (quote ref) "1") +(putprop (quote \x2E;/intro:s10) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s11) (quote pageref-url) "./intro.html#./intro:s11") +(putprop (quote \x2E;/intro:s11) (quote ref) "1") +(putprop (quote \x2E;/intro:s11) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s12) (quote pageref-url) "./intro.html#./intro:s12") +(putprop (quote \x2E;/intro:s12) (quote ref) "1") +(putprop (quote \x2E;/intro:s12) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s13) (quote pageref-url) "./intro.html#./intro:s13") +(putprop (quote \x2E;/intro:s13) (quote ref) "1") +(putprop (quote \x2E;/intro:s13) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s14) (quote pageref-url) "./intro.html#./intro:s14") +(putprop (quote \x2E;/intro:s14) (quote ref) "1") +(putprop (quote \x2E;/intro:s14) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s15) (quote pageref-url) "./intro.html#./intro:s15") +(putprop (quote \x2E;/intro:s15) (quote ref) "1") +(putprop (quote \x2E;/intro:s15) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s16) (quote pageref-url) "./intro.html#./intro:s16") +(putprop (quote \x2E;/intro:s16) (quote ref) "1") +(putprop (quote \x2E;/intro:s16) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s17) (quote pageref-url) "./intro.html#./intro:s17") +(putprop (quote \x2E;/intro:s17) (quote ref) "1") +(putprop (quote \x2E;/intro:s17) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s18) (quote pageref-url) "./intro.html#./intro:s18") +(putprop (quote \x2E;/intro:s18) (quote ref) "1") +(putprop (quote \x2E;/intro:s18) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s19) (quote pageref-url) "./intro.html#./intro:s19") +(putprop (quote \x2E;/intro:s19) (quote ref) "1") +(putprop (quote \x2E;/intro:s19) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s20) (quote pageref-url) "./intro.html#./intro:s20") +(putprop (quote \x2E;/intro:s20) (quote ref) "1") +(putprop (quote \x2E;/intro:s20) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s21) (quote pageref-url) "./intro.html#./intro:s21") +(putprop (quote \x2E;/intro:s21) (quote ref) "1") +(putprop (quote \x2E;/intro:s21) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s22) (quote pageref-url) "./intro.html#./intro:s22") +(putprop (quote \x2E;/intro:s22) (quote ref) "1") +(putprop (quote \x2E;/intro:s22) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s23) (quote pageref-url) "./intro.html#./intro:s23") +(putprop (quote \x2E;/intro:s23) (quote ref) "1") +(putprop (quote \x2E;/intro:s23) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s24) (quote pageref-url) "./intro.html#./intro:s24") +(putprop (quote \x2E;/intro:s24) (quote ref) "1") +(putprop (quote \x2E;/intro:s24) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s25) (quote pageref-url) "./intro.html#./intro:s25") +(putprop (quote \x2E;/intro:s25) (quote ref) "1") +(putprop (quote \x2E;/intro:s25) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s26) (quote pageref-url) "./intro.html#./intro:s26") +(putprop (quote \x2E;/intro:s26) (quote ref) "1") +(putprop (quote \x2E;/intro:s26) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s27) (quote pageref-url) "./intro.html#./intro:s27") +(putprop (quote \x2E;/intro:s27) (quote ref) "1") +(putprop (quote \x2E;/intro:s27) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:s28) (quote pageref-url) "./intro.html#./intro:s28") +(putprop (quote \x2E;/intro:s28) (quote ref) "1") +(putprop (quote \x2E;/intro:s28) (quote ref-url) "./intro.html#g0") +(putprop (quote \x2E;/intro:h1) (quote pageref-url) "./intro.html#./intro:h1") +(putprop (quote \x2E;/intro:h1) (quote ref) "1.1") +(putprop (quote \x2E;/intro:h1) (quote ref-url) "./intro.html#g1") +(putprop (quote SECTINTROSYNTAX) (quote pageref-url) "./intro.html#SECTINTROSYNTAX") +(putprop (quote SECTINTROSYNTAX) (quote ref) "1.1") +(putprop (quote SECTINTROSYNTAX) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s29) (quote pageref-url) "./intro.html#./intro:s29") +(putprop (quote \x2E;/intro:s29) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s29) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s30) (quote pageref-url) "./intro.html#./intro:s30") +(putprop (quote \x2E;/intro:s30) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s30) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s31) (quote pageref-url) "./intro.html#./intro:s31") +(putprop (quote \x2E;/intro:s31) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s31) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s32) (quote pageref-url) "./intro.html#./intro:s32") +(putprop (quote \x2E;/intro:s32) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s32) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s33) (quote pageref-url) "./intro.html#./intro:s33") +(putprop (quote \x2E;/intro:s33) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s33) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s34) (quote pageref-url) "./intro.html#./intro:s34") +(putprop (quote \x2E;/intro:s34) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s34) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s35) (quote pageref-url) "./intro.html#./intro:s35") +(putprop (quote \x2E;/intro:s35) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s35) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s36) (quote pageref-url) "./intro.html#./intro:s36") +(putprop (quote \x2E;/intro:s36) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s36) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s37) (quote pageref-url) "./intro.html#./intro:s37") +(putprop (quote \x2E;/intro:s37) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s37) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s38) (quote pageref-url) "./intro.html#./intro:s38") +(putprop (quote \x2E;/intro:s38) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s38) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s39) (quote pageref-url) "./intro.html#./intro:s39") +(putprop (quote \x2E;/intro:s39) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s39) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s40) (quote pageref-url) "./intro.html#./intro:s40") +(putprop (quote \x2E;/intro:s40) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s40) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s41) (quote pageref-url) "./intro.html#./intro:s41") +(putprop (quote \x2E;/intro:s41) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s41) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s42) (quote pageref-url) "./intro.html#./intro:s42") +(putprop (quote \x2E;/intro:s42) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s42) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s43) (quote pageref-url) "./intro.html#./intro:s43") +(putprop (quote \x2E;/intro:s43) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s43) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:s44) (quote pageref-url) "./intro.html#./intro:s44") +(putprop (quote \x2E;/intro:s44) (quote ref) "1.1") +(putprop (quote \x2E;/intro:s44) (quote ref-url) "./intro.html#g1") +(putprop (quote \x2E;/intro:h2) (quote pageref-url) "./intro.html#./intro:h2") +(putprop (quote \x2E;/intro:h2) (quote ref) "1.2") +(putprop (quote \x2E;/intro:h2) (quote ref-url) "./intro.html#g2") +(putprop (quote SECTINTRONAMING) (quote pageref-url) "./intro.html#SECTINTRONAMING") +(putprop (quote SECTINTRONAMING) (quote ref) "1.2") +(putprop (quote SECTINTRONAMING) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s45) (quote pageref-url) "./intro.html#./intro:s45") +(putprop (quote \x2E;/intro:s45) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s45) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s46) (quote pageref-url) "./intro.html#./intro:s46") +(putprop (quote \x2E;/intro:s46) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s46) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s47) (quote pageref-url) "./intro.html#./intro:s47") +(putprop (quote \x2E;/intro:s47) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s47) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s48) (quote pageref-url) "./intro.html#./intro:s48") +(putprop (quote \x2E;/intro:s48) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s48) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s49) (quote pageref-url) "./intro.html#./intro:s49") +(putprop (quote \x2E;/intro:s49) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s49) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s50) (quote pageref-url) "./intro.html#./intro:s50") +(putprop (quote \x2E;/intro:s50) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s50) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s51) (quote pageref-url) "./intro.html#./intro:s51") +(putprop (quote \x2E;/intro:s51) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s51) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:s52) (quote pageref-url) "./intro.html#./intro:s52") +(putprop (quote \x2E;/intro:s52) (quote ref) "1.2") +(putprop (quote \x2E;/intro:s52) (quote ref-url) "./intro.html#g2") +(putprop (quote \x2E;/intro:h3) (quote pageref-url) "./intro.html#./intro:h3") +(putprop (quote \x2E;/intro:h3) (quote ref) "1.3") +(putprop (quote \x2E;/intro:h3) (quote ref-url) "./intro.html#g3") +(putprop (quote SECTINTRONOTATION) (quote pageref-url) "./intro.html#SECTINTRONOTATION") +(putprop (quote SECTINTRONOTATION) (quote ref) "1.3") +(putprop (quote SECTINTRONOTATION) (quote ref-url) "./intro.html#g3") +(putprop (quote \x2E;/intro:s53) (quote pageref-url) "./intro.html#./intro:s53") +(putprop (quote \x2E;/intro:s53) (quote ref) "1.3") +(putprop (quote \x2E;/intro:s53) (quote ref-url) "./intro.html#g3") +(putprop (quote \x2E;/intro:s54) (quote pageref-url) "./intro.html#./intro:s54") +(putprop (quote \x2E;/intro:s54) (quote ref) "1.3") +(putprop (quote \x2E;/intro:s54) (quote ref-url) "./intro.html#g3") +(putprop (quote \x2E;/intro:s55) (quote pageref-url) "./intro.html#./intro:s55") +(putprop (quote \x2E;/intro:s55) (quote ref) "1.3") +(putprop (quote \x2E;/intro:s55) (quote ref-url) "./intro.html#g3") +(putprop (quote \x2E;/intro:s56) (quote pageref-url) "./intro.html#./intro:s56") +(putprop (quote \x2E;/intro:s56) (quote ref) "1.3") +(putprop (quote \x2E;/intro:s56) (quote ref-url) "./intro.html#g3") +(putprop (quote \x2E;/start:h0) (quote pageref-url) "./start.html#./start:h0") +(putprop (quote \x2E;/start:h0) (quote ref) "2") +(putprop (quote \x2E;/start:h0) (quote ref-url) "./start.html#g4") +(putprop (quote CHPTGETTINGSTARTED) (quote pageref-url) "./start.html#CHPTGETTINGSTARTED") +(putprop (quote CHPTGETTINGSTARTED) (quote ref) "2") +(putprop (quote CHPTGETTINGSTARTED) (quote ref-url) "./start.html#g4") +(putprop (quote \x2E;/start:h1) (quote pageref-url) "./start.html#./start:h1") +(putprop (quote \x2E;/start:h1) (quote ref) "2.1") +(putprop (quote \x2E;/start:h1) (quote ref-url) "./start.html#g5") +(putprop (quote SECTGSINTERACTING) (quote pageref-url) "./start.html#SECTGSINTERACTING") +(putprop (quote SECTGSINTERACTING) (quote ref) "2.1") +(putprop (quote SECTGSINTERACTING) (quote ref-url) "./start.html#g5") +(putprop (quote \x2E;/start:s0) (quote pageref-url) "./start.html#./start:s0") +(putprop (quote \x2E;/start:s0) (quote ref) "2.1") +(putprop (quote \x2E;/start:s0) (quote ref-url) "./start.html#g5") +(putprop (quote \x2E;/start:s1) (quote pageref-url) "./start.html#./start:s1") +(putprop (quote \x2E;/start:s1) (quote ref) "2.1") +(putprop (quote \x2E;/start:s1) (quote ref-url) "./start.html#g5") +(putprop (quote \x2E;/start:s2) (quote pageref-url) "./start.html#./start:s2") +(putprop (quote \x2E;/start:s2) (quote ref) "2.1") +(putprop (quote \x2E;/start:s2) (quote ref-url) "./start.html#g5") +(putprop (quote \x2E;/start:s3) (quote pageref-url) "./start.html#./start:s3") +(putprop (quote \x2E;/start:s3) (quote ref) "2.1") +(putprop (quote \x2E;/start:s3) (quote ref-url) "./start.html#g5") +(putprop (quote \x2E;/start:s4) (quote pageref-url) "./start.html#./start:s4") +(putprop (quote \x2E;/start:s4) (quote ref) "2.1") +(putprop (quote \x2E;/start:s4) (quote ref-url) "./start.html#g5") +(putprop (quote \x2E;/start:h2) (quote pageref-url) "./start.html#./start:h2") +(putprop (quote \x2E;/start:h2) (quote ref) "2.2") +(putprop (quote \x2E;/start:h2) (quote ref-url) "./start.html#g6") +(putprop (quote SECTGSSIMPLE) (quote pageref-url) "./start.html#SECTGSSIMPLE") +(putprop (quote SECTGSSIMPLE) (quote ref) "2.2") +(putprop (quote SECTGSSIMPLE) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s5) (quote pageref-url) "./start.html#./start:s5") +(putprop (quote \x2E;/start:s5) (quote ref) "2.2") +(putprop (quote \x2E;/start:s5) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s6) (quote pageref-url) "./start.html#./start:s6") +(putprop (quote \x2E;/start:s6) (quote ref) "2.2") +(putprop (quote \x2E;/start:s6) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s7) (quote pageref-url) "./start.html#./start:s7") +(putprop (quote \x2E;/start:s7) (quote ref) "2.2") +(putprop (quote \x2E;/start:s7) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s8) (quote pageref-url) "./start.html#./start:s8") +(putprop (quote \x2E;/start:s8) (quote ref) "2.2") +(putprop (quote \x2E;/start:s8) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s9) (quote pageref-url) "./start.html#./start:s9") +(putprop (quote \x2E;/start:s9) (quote ref) "2.2") +(putprop (quote \x2E;/start:s9) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s10) (quote pageref-url) "./start.html#./start:s10") +(putprop (quote \x2E;/start:s10) (quote ref) "2.2") +(putprop (quote \x2E;/start:s10) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s11) (quote pageref-url) "./start.html#./start:s11") +(putprop (quote \x2E;/start:s11) (quote ref) "2.2") +(putprop (quote \x2E;/start:s11) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s12) (quote pageref-url) "./start.html#./start:s12") +(putprop (quote \x2E;/start:s12) (quote ref) "2.2") +(putprop (quote \x2E;/start:s12) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s13) (quote pageref-url) "./start.html#./start:s13") +(putprop (quote \x2E;/start:s13) (quote ref) "2.2") +(putprop (quote \x2E;/start:s13) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s14) (quote pageref-url) "./start.html#./start:s14") +(putprop (quote \x2E;/start:s14) (quote ref) "2.2") +(putprop (quote \x2E;/start:s14) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s15) (quote pageref-url) "./start.html#./start:s15") +(putprop (quote \x2E;/start:s15) (quote ref) "2.2") +(putprop (quote \x2E;/start:s15) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s16) (quote pageref-url) "./start.html#./start:s16") +(putprop (quote \x2E;/start:s16) (quote ref) "2.2") +(putprop (quote \x2E;/start:s16) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s17) (quote pageref-url) "./start.html#./start:s17") +(putprop (quote \x2E;/start:s17) (quote ref) "2.2") +(putprop (quote \x2E;/start:s17) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s18) (quote pageref-url) "./start.html#./start:s18") +(putprop (quote \x2E;/start:s18) (quote ref) "2.2") +(putprop (quote \x2E;/start:s18) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s19) (quote pageref-url) "./start.html#./start:s19") +(putprop (quote \x2E;/start:s19) (quote ref) "2.2") +(putprop (quote \x2E;/start:s19) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s20) (quote pageref-url) "./start.html#./start:s20") +(putprop (quote \x2E;/start:s20) (quote ref) "2.2") +(putprop (quote \x2E;/start:s20) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s21) (quote pageref-url) "./start.html#./start:s21") +(putprop (quote \x2E;/start:s21) (quote ref) "2.2") +(putprop (quote \x2E;/start:s21) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s22) (quote pageref-url) "./start.html#./start:s22") +(putprop (quote \x2E;/start:s22) (quote ref) "2.2") +(putprop (quote \x2E;/start:s22) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s23) (quote pageref-url) "./start.html#./start:s23") +(putprop (quote \x2E;/start:s23) (quote ref) "2.2") +(putprop (quote \x2E;/start:s23) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s24) (quote pageref-url) "./start.html#./start:s24") +(putprop (quote \x2E;/start:s24) (quote ref) "2.2") +(putprop (quote \x2E;/start:s24) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s25) (quote pageref-url) "./start.html#./start:s25") +(putprop (quote \x2E;/start:s25) (quote ref) "2.2") +(putprop (quote \x2E;/start:s25) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s26) (quote pageref-url) "./start.html#./start:s26") +(putprop (quote \x2E;/start:s26) (quote ref) "2.2") +(putprop (quote \x2E;/start:s26) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s27) (quote pageref-url) "./start.html#./start:s27") +(putprop (quote \x2E;/start:s27) (quote ref) "2.2") +(putprop (quote \x2E;/start:s27) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s28) (quote pageref-url) "./start.html#./start:s28") +(putprop (quote \x2E;/start:s28) (quote ref) "2.2") +(putprop (quote \x2E;/start:s28) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s29) (quote pageref-url) "./start.html#./start:s29") +(putprop (quote \x2E;/start:s29) (quote ref) "2.2") +(putprop (quote \x2E;/start:s29) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s30) (quote pageref-url) "./start.html#./start:s30") +(putprop (quote \x2E;/start:s30) (quote ref) "2.2") +(putprop (quote \x2E;/start:s30) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s31) (quote pageref-url) "./start.html#./start:s31") +(putprop (quote \x2E;/start:s31) (quote ref) "2.2") +(putprop (quote \x2E;/start:s31) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s32) (quote pageref-url) "./start.html#./start:s32") +(putprop (quote \x2E;/start:s32) (quote ref) "2.2") +(putprop (quote \x2E;/start:s32) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s33) (quote pageref-url) "./start.html#./start:s33") +(putprop (quote \x2E;/start:s33) (quote ref) "2.2") +(putprop (quote \x2E;/start:s33) (quote ref-url) "./start.html#g6") +(putprop (quote \x2E;/start:s34) (quote pageref-url) "./start.html#./start:s34") +(putprop (quote \x2E;/start:s34) (quote ref) "2.2.1") +(putprop (quote \x2E;/start:s34) (quote ref-url) "./start.html#g7") +(putprop (quote \x2E;/start:s35) (quote pageref-url) "./start.html#./start:s35") +(putprop (quote \x2E;/start:s35) (quote ref) "2.2.2") +(putprop (quote \x2E;/start:s35) (quote ref-url) "./start.html#g8") +(putprop (quote \x2E;/start:s36) (quote pageref-url) "./start.html#./start:s36") +(putprop (quote \x2E;/start:s36) (quote ref) "2.2.3") +(putprop (quote \x2E;/start:s36) (quote ref-url) "./start.html#g9") +(putprop (quote EXEXPRVALUE) (quote pageref-url) "./start.html#EXEXPRVALUE") +(putprop (quote EXEXPRVALUE) (quote ref) "2.2.3") +(putprop (quote EXEXPRVALUE) (quote ref-url) "./start.html#g9") +(putprop (quote \x2E;/start:s37) (quote pageref-url) "./start.html#./start:s37") +(putprop (quote \x2E;/start:s37) (quote ref) "2.2.4") +(putprop (quote \x2E;/start:s37) (quote ref-url) "./start.html#g10") +(putprop (quote \x2E;/start:s38) (quote pageref-url) "./start.html#./start:s38") +(putprop (quote \x2E;/start:s38) (quote ref) "2.2.5") +(putprop (quote \x2E;/start:s38) (quote ref-url) "./start.html#g11") +(putprop (quote \x2E;/start:s39) (quote pageref-url) "./start.html#./start:s39") +(putprop (quote \x2E;/start:s39) (quote ref) "2.2.6") +(putprop (quote \x2E;/start:s39) (quote ref-url) "./start.html#g12") +(putprop (quote \x2E;/start:s40) (quote pageref-url) "./start.html#./start:s40") +(putprop (quote \x2E;/start:s40) (quote ref) "2.2.7") +(putprop (quote \x2E;/start:s40) (quote ref-url) "./start.html#g13") +(putprop (quote \x2E;/start:s41) (quote pageref-url) "./start.html#./start:s41") +(putprop (quote \x2E;/start:s41) (quote ref) "2.2.8") +(putprop (quote \x2E;/start:s41) (quote ref-url) "./start.html#g14") +(putprop (quote \x2E;/start:h3) (quote pageref-url) "./start.html#./start:h3") +(putprop (quote \x2E;/start:h3) (quote ref) "2.3") +(putprop (quote \x2E;/start:h3) (quote ref-url) "./start.html#g15") +(putprop (quote SECTGSEVALUATING) (quote pageref-url) "./start.html#SECTGSEVALUATING") +(putprop (quote SECTGSEVALUATING) (quote ref) "2.3") +(putprop (quote SECTGSEVALUATING) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s42) (quote pageref-url) "./start.html#./start:s42") +(putprop (quote \x2E;/start:s42) (quote ref) "2.3") +(putprop (quote \x2E;/start:s42) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s43) (quote pageref-url) "./start.html#./start:s43") +(putprop (quote \x2E;/start:s43) (quote ref) "2.3") +(putprop (quote \x2E;/start:s43) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s44) (quote pageref-url) "./start.html#./start:s44") +(putprop (quote \x2E;/start:s44) (quote ref) "2.3") +(putprop (quote \x2E;/start:s44) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s45) (quote pageref-url) "./start.html#./start:s45") +(putprop (quote \x2E;/start:s45) (quote ref) "2.3") +(putprop (quote \x2E;/start:s45) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s46) (quote pageref-url) "./start.html#./start:s46") +(putprop (quote \x2E;/start:s46) (quote ref) "2.3") +(putprop (quote \x2E;/start:s46) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s47) (quote pageref-url) "./start.html#./start:s47") +(putprop (quote \x2E;/start:s47) (quote ref) "2.3") +(putprop (quote \x2E;/start:s47) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s48) (quote pageref-url) "./start.html#./start:s48") +(putprop (quote \x2E;/start:s48) (quote ref) "2.3") +(putprop (quote \x2E;/start:s48) (quote ref-url) "./start.html#g15") +(putprop (quote \x2E;/start:s49) (quote pageref-url) "./start.html#./start:s49") +(putprop (quote \x2E;/start:s49) (quote ref) "2.3.1") +(putprop (quote \x2E;/start:s49) (quote ref-url) "./start.html#g16") +(putprop (quote \x2E;/start:h4) (quote pageref-url) "./start.html#./start:h4") +(putprop (quote \x2E;/start:h4) (quote ref) "2.4") +(putprop (quote \x2E;/start:h4) (quote ref-url) "./start.html#g17") +(putprop (quote SECTGSIDENTIFIERS) (quote pageref-url) "./start.html#SECTGSIDENTIFIERS") +(putprop (quote SECTGSIDENTIFIERS) (quote ref) "2.4") +(putprop (quote SECTGSIDENTIFIERS) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s50) (quote pageref-url) "./start.html#./start:s50") +(putprop (quote \x2E;/start:s50) (quote ref) "2.4") +(putprop (quote \x2E;/start:s50) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s51) (quote pageref-url) "./start.html#./start:s51") +(putprop (quote \x2E;/start:s51) (quote ref) "2.4") +(putprop (quote \x2E;/start:s51) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s52) (quote pageref-url) "./start.html#./start:s52") +(putprop (quote \x2E;/start:s52) (quote ref) "2.4") +(putprop (quote \x2E;/start:s52) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s53) (quote pageref-url) "./start.html#./start:s53") +(putprop (quote \x2E;/start:s53) (quote ref) "2.4") +(putprop (quote \x2E;/start:s53) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s54) (quote pageref-url) "./start.html#./start:s54") +(putprop (quote \x2E;/start:s54) (quote ref) "2.4") +(putprop (quote \x2E;/start:s54) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s55) (quote pageref-url) "./start.html#./start:s55") +(putprop (quote \x2E;/start:s55) (quote ref) "2.4") +(putprop (quote \x2E;/start:s55) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s56) (quote pageref-url) "./start.html#./start:s56") +(putprop (quote \x2E;/start:s56) (quote ref) "2.4") +(putprop (quote \x2E;/start:s56) (quote ref-url) "./start.html#g17") +(putprop (quote \x2E;/start:s57) (quote pageref-url) "./start.html#./start:s57") +(putprop (quote \x2E;/start:s57) (quote ref) "2.4.1") +(putprop (quote \x2E;/start:s57) (quote ref-url) "./start.html#g18") +(putprop (quote \x2E;/start:s58) (quote pageref-url) "./start.html#./start:s58") +(putprop (quote \x2E;/start:s58) (quote ref) "2.4.2") +(putprop (quote \x2E;/start:s58) (quote ref-url) "./start.html#g19") +(putprop (quote \x2E;/start:s59) (quote pageref-url) "./start.html#./start:s59") +(putprop (quote \x2E;/start:s59) (quote ref) "2.4.3") +(putprop (quote \x2E;/start:s59) (quote ref-url) "./start.html#g20") +(putprop (quote \x2E;/start:h5) (quote pageref-url) "./start.html#./start:h5") +(putprop (quote \x2E;/start:h5) (quote ref) "2.5") +(putprop (quote \x2E;/start:h5) (quote ref-url) "./start.html#g21") +(putprop (quote SECTGSLAMBDA) (quote pageref-url) "./start.html#SECTGSLAMBDA") +(putprop (quote SECTGSLAMBDA) (quote ref) "2.5") +(putprop (quote SECTGSLAMBDA) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s60) (quote pageref-url) "./start.html#./start:s60") +(putprop (quote \x2E;/start:s60) (quote ref) "2.5") +(putprop (quote \x2E;/start:s60) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s61) (quote pageref-url) "./start.html#./start:s61") +(putprop (quote \x2E;/start:s61) (quote ref) "2.5") +(putprop (quote \x2E;/start:s61) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s62) (quote pageref-url) "./start.html#./start:s62") +(putprop (quote \x2E;/start:s62) (quote ref) "2.5") +(putprop (quote \x2E;/start:s62) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s63) (quote pageref-url) "./start.html#./start:s63") +(putprop (quote \x2E;/start:s63) (quote ref) "2.5") +(putprop (quote \x2E;/start:s63) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s64) (quote pageref-url) "./start.html#./start:s64") +(putprop (quote \x2E;/start:s64) (quote ref) "2.5") +(putprop (quote \x2E;/start:s64) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s65) (quote pageref-url) "./start.html#./start:s65") +(putprop (quote \x2E;/start:s65) (quote ref) "2.5") +(putprop (quote \x2E;/start:s65) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s66) (quote pageref-url) "./start.html#./start:s66") +(putprop (quote \x2E;/start:s66) (quote ref) "2.5") +(putprop (quote \x2E;/start:s66) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s67) (quote pageref-url) "./start.html#./start:s67") +(putprop (quote \x2E;/start:s67) (quote ref) "2.5") +(putprop (quote \x2E;/start:s67) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s68) (quote pageref-url) "./start.html#./start:s68") +(putprop (quote \x2E;/start:s68) (quote ref) "2.5") +(putprop (quote \x2E;/start:s68) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s69) (quote pageref-url) "./start.html#./start:s69") +(putprop (quote \x2E;/start:s69) (quote ref) "2.5") +(putprop (quote \x2E;/start:s69) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s70) (quote pageref-url) "./start.html#./start:s70") +(putprop (quote \x2E;/start:s70) (quote ref) "2.5") +(putprop (quote \x2E;/start:s70) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s71) (quote pageref-url) "./start.html#./start:s71") +(putprop (quote \x2E;/start:s71) (quote ref) "2.5") +(putprop (quote \x2E;/start:s71) (quote ref-url) "./start.html#g21") +(putprop (quote \x2E;/start:s72) (quote pageref-url) "./start.html#./start:s72") +(putprop (quote \x2E;/start:s72) (quote ref) "2.5.1") +(putprop (quote \x2E;/start:s72) (quote ref-url) "./start.html#g22") +(putprop (quote \x2E;/start:s73) (quote pageref-url) "./start.html#./start:s73") +(putprop (quote \x2E;/start:s73) (quote ref) "2.5.2") +(putprop (quote \x2E;/start:s73) (quote ref-url) "./start.html#g23") +(putprop (quote \x2E;/start:s74) (quote pageref-url) "./start.html#./start:s74") +(putprop (quote \x2E;/start:s74) (quote ref) "2.5.3") +(putprop (quote \x2E;/start:s74) (quote ref-url) "./start.html#g24") +(putprop (quote \x2E;/start:s75) (quote pageref-url) "./start.html#./start:s75") +(putprop (quote \x2E;/start:s75) (quote ref) "2.5.3") +(putprop (quote \x2E;/start:s75) (quote ref-url) "./start.html#g24") +(putprop (quote \x2E;/start:h6) (quote pageref-url) "./start.html#./start:h6") +(putprop (quote \x2E;/start:h6) (quote ref) "2.6") +(putprop (quote \x2E;/start:h6) (quote ref-url) "./start.html#g25") +(putprop (quote SECTGSTOPLEVEL) (quote pageref-url) "./start.html#SECTGSTOPLEVEL") +(putprop (quote SECTGSTOPLEVEL) (quote ref) "2.6") +(putprop (quote SECTGSTOPLEVEL) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s76) (quote pageref-url) "./start.html#./start:s76") +(putprop (quote \x2E;/start:s76) (quote ref) "2.6") +(putprop (quote \x2E;/start:s76) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s77) (quote pageref-url) "./start.html#./start:s77") +(putprop (quote \x2E;/start:s77) (quote ref) "2.6") +(putprop (quote \x2E;/start:s77) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s78) (quote pageref-url) "./start.html#./start:s78") +(putprop (quote \x2E;/start:s78) (quote ref) "2.6") +(putprop (quote \x2E;/start:s78) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s79) (quote pageref-url) "./start.html#./start:s79") +(putprop (quote \x2E;/start:s79) (quote ref) "2.6") +(putprop (quote \x2E;/start:s79) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s80) (quote pageref-url) "./start.html#./start:s80") +(putprop (quote \x2E;/start:s80) (quote ref) "2.6") +(putprop (quote \x2E;/start:s80) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s81) (quote pageref-url) "./start.html#./start:s81") +(putprop (quote \x2E;/start:s81) (quote ref) "2.6") +(putprop (quote \x2E;/start:s81) (quote ref-url) "./start.html#g25") +(putprop (quote defn:list) (quote pageref-url) "./start.html#defn:list") +(putprop (quote defn:list) (quote ref) "2.6") +(putprop (quote defn:list) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s82) (quote pageref-url) "./start.html#./start:s82") +(putprop (quote \x2E;/start:s82) (quote ref) "2.6") +(putprop (quote \x2E;/start:s82) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s83) (quote pageref-url) "./start.html#./start:s83") +(putprop (quote \x2E;/start:s83) (quote ref) "2.6") +(putprop (quote \x2E;/start:s83) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s84) (quote pageref-url) "./start.html#./start:s84") +(putprop (quote \x2E;/start:s84) (quote ref) "2.6") +(putprop (quote \x2E;/start:s84) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s85) (quote pageref-url) "./start.html#./start:s85") +(putprop (quote \x2E;/start:s85) (quote ref) "2.6") +(putprop (quote \x2E;/start:s85) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s86) (quote pageref-url) "./start.html#./start:s86") +(putprop (quote \x2E;/start:s86) (quote ref) "2.6") +(putprop (quote \x2E;/start:s86) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s87) (quote pageref-url) "./start.html#./start:s87") +(putprop (quote \x2E;/start:s87) (quote ref) "2.6") +(putprop (quote \x2E;/start:s87) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s88) (quote pageref-url) "./start.html#./start:s88") +(putprop (quote \x2E;/start:s88) (quote ref) "2.6") +(putprop (quote \x2E;/start:s88) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s89) (quote pageref-url) "./start.html#./start:s89") +(putprop (quote \x2E;/start:s89) (quote ref) "2.6") +(putprop (quote \x2E;/start:s89) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s90) (quote pageref-url) "./start.html#./start:s90") +(putprop (quote \x2E;/start:s90) (quote ref) "2.6") +(putprop (quote \x2E;/start:s90) (quote ref-url) "./start.html#g25") +(putprop (quote \x2E;/start:s91) (quote pageref-url) "./start.html#./start:s91") +(putprop (quote \x2E;/start:s91) (quote ref) "2.6.1") +(putprop (quote \x2E;/start:s91) (quote ref-url) "./start.html#g26") +(putprop (quote \x2E;/start:s92) (quote pageref-url) "./start.html#./start:s92") +(putprop (quote \x2E;/start:s92) (quote ref) "2.6.2") +(putprop (quote \x2E;/start:s92) (quote ref-url) "./start.html#g27") +(putprop (quote \x2E;/start:s93) (quote pageref-url) "./start.html#./start:s93") +(putprop (quote \x2E;/start:s93) (quote ref) "2.6.2") +(putprop (quote \x2E;/start:s93) (quote ref-url) "./start.html#g27") +(putprop (quote \x2E;/start:s94) (quote pageref-url) "./start.html#./start:s94") +(putprop (quote \x2E;/start:s94) (quote ref) "2.6.2") +(putprop (quote \x2E;/start:s94) (quote ref-url) "./start.html#g27") +(putprop (quote \x2E;/start:s95) (quote pageref-url) "./start.html#./start:s95") +(putprop (quote \x2E;/start:s95) (quote ref) "2.6.2") +(putprop (quote \x2E;/start:s95) (quote ref-url) "./start.html#g27") +(putprop (quote \x2E;/start:s96) (quote pageref-url) "./start.html#./start:s96") +(putprop (quote \x2E;/start:s96) (quote ref) "2.6.3") +(putprop (quote \x2E;/start:s96) (quote ref-url) "./start.html#g28") +(putprop (quote \x2E;/start:s97) (quote pageref-url) "./start.html#./start:s97") +(putprop (quote \x2E;/start:s97) (quote ref) "2.6.3") +(putprop (quote \x2E;/start:s97) (quote ref-url) "./start.html#g28") +(putprop (quote \x2E;/start:h7) (quote pageref-url) "./start.html#./start:h7") +(putprop (quote \x2E;/start:h7) (quote ref) "2.7") +(putprop (quote \x2E;/start:h7) (quote ref-url) "./start.html#g29") +(putprop (quote SECTGSCONDITIONALS) (quote pageref-url) "./start.html#SECTGSCONDITIONALS") +(putprop (quote SECTGSCONDITIONALS) (quote ref) "2.7") +(putprop (quote SECTGSCONDITIONALS) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s98) (quote pageref-url) "./start.html#./start:s98") +(putprop (quote \x2E;/start:s98) (quote ref) "2.7") +(putprop (quote \x2E;/start:s98) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s99) (quote pageref-url) "./start.html#./start:s99") +(putprop (quote \x2E;/start:s99) (quote ref) "2.7") +(putprop (quote \x2E;/start:s99) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s100) (quote pageref-url) "./start.html#./start:s100") +(putprop (quote \x2E;/start:s100) (quote ref) "2.7") +(putprop (quote \x2E;/start:s100) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s101) (quote pageref-url) "./start.html#./start:s101") +(putprop (quote \x2E;/start:s101) (quote ref) "2.7") +(putprop (quote \x2E;/start:s101) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s102) (quote pageref-url) "./start.html#./start:s102") +(putprop (quote \x2E;/start:s102) (quote ref) "2.7") +(putprop (quote \x2E;/start:s102) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s103) (quote pageref-url) "./start.html#./start:s103") +(putprop (quote \x2E;/start:s103) (quote ref) "2.7") +(putprop (quote \x2E;/start:s103) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s104) (quote pageref-url) "./start.html#./start:s104") +(putprop (quote \x2E;/start:s104) (quote ref) "2.7") +(putprop (quote \x2E;/start:s104) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s105) (quote pageref-url) "./start.html#./start:s105") +(putprop (quote \x2E;/start:s105) (quote ref) "2.7") +(putprop (quote \x2E;/start:s105) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s106) (quote pageref-url) "./start.html#./start:s106") +(putprop (quote \x2E;/start:s106) (quote ref) "2.7") +(putprop (quote \x2E;/start:s106) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s107) (quote pageref-url) "./start.html#./start:s107") +(putprop (quote \x2E;/start:s107) (quote ref) "2.7") +(putprop (quote \x2E;/start:s107) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s108) (quote pageref-url) "./start.html#./start:s108") +(putprop (quote \x2E;/start:s108) (quote ref) "2.7") +(putprop (quote \x2E;/start:s108) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s109) (quote pageref-url) "./start.html#./start:s109") +(putprop (quote \x2E;/start:s109) (quote ref) "2.7") +(putprop (quote \x2E;/start:s109) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s110) (quote pageref-url) "./start.html#./start:s110") +(putprop (quote \x2E;/start:s110) (quote ref) "2.7") +(putprop (quote \x2E;/start:s110) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s111) (quote pageref-url) "./start.html#./start:s111") +(putprop (quote \x2E;/start:s111) (quote ref) "2.7") +(putprop (quote \x2E;/start:s111) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s112) (quote pageref-url) "./start.html#./start:s112") +(putprop (quote \x2E;/start:s112) (quote ref) "2.7") +(putprop (quote \x2E;/start:s112) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s113) (quote pageref-url) "./start.html#./start:s113") +(putprop (quote \x2E;/start:s113) (quote ref) "2.7") +(putprop (quote \x2E;/start:s113) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s114) (quote pageref-url) "./start.html#./start:s114") +(putprop (quote \x2E;/start:s114) (quote ref) "2.7") +(putprop (quote \x2E;/start:s114) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s115) (quote pageref-url) "./start.html#./start:s115") +(putprop (quote \x2E;/start:s115) (quote ref) "2.7") +(putprop (quote \x2E;/start:s115) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s116) (quote pageref-url) "./start.html#./start:s116") +(putprop (quote \x2E;/start:s116) (quote ref) "2.7") +(putprop (quote \x2E;/start:s116) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s117) (quote pageref-url) "./start.html#./start:s117") +(putprop (quote \x2E;/start:s117) (quote ref) "2.7") +(putprop (quote \x2E;/start:s117) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s118) (quote pageref-url) "./start.html#./start:s118") +(putprop (quote \x2E;/start:s118) (quote ref) "2.7") +(putprop (quote \x2E;/start:s118) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s119) (quote pageref-url) "./start.html#./start:s119") +(putprop (quote \x2E;/start:s119) (quote ref) "2.7") +(putprop (quote \x2E;/start:s119) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s120) (quote pageref-url) "./start.html#./start:s120") +(putprop (quote \x2E;/start:s120) (quote ref) "2.7") +(putprop (quote \x2E;/start:s120) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s121) (quote pageref-url) "./start.html#./start:s121") +(putprop (quote \x2E;/start:s121) (quote ref) "2.7") +(putprop (quote \x2E;/start:s121) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s122) (quote pageref-url) "./start.html#./start:s122") +(putprop (quote \x2E;/start:s122) (quote ref) "2.7") +(putprop (quote \x2E;/start:s122) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s123) (quote pageref-url) "./start.html#./start:s123") +(putprop (quote \x2E;/start:s123) (quote ref) "2.7") +(putprop (quote \x2E;/start:s123) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s124) (quote pageref-url) "./start.html#./start:s124") +(putprop (quote \x2E;/start:s124) (quote ref) "2.7") +(putprop (quote \x2E;/start:s124) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s125) (quote pageref-url) "./start.html#./start:s125") +(putprop (quote \x2E;/start:s125) (quote ref) "2.7") +(putprop (quote \x2E;/start:s125) (quote ref-url) "./start.html#g29") +(putprop (quote \x2E;/start:s126) (quote pageref-url) "./start.html#./start:s126") +(putprop (quote \x2E;/start:s126) (quote ref) "2.7.1") +(putprop (quote \x2E;/start:s126) (quote ref-url) "./start.html#g30") +(putprop (quote \x2E;/start:s127) (quote pageref-url) "./start.html#./start:s127") +(putprop (quote \x2E;/start:s127) (quote ref) "2.7.1") +(putprop (quote \x2E;/start:s127) (quote ref-url) "./start.html#g30") +(putprop (quote \x2E;/start:s128) (quote pageref-url) "./start.html#./start:s128") +(putprop (quote \x2E;/start:s128) (quote ref) "2.7.2") +(putprop (quote \x2E;/start:s128) (quote ref-url) "./start.html#g31") +(putprop (quote EXSHORTER1) (quote pageref-url) "./start.html#EXSHORTER1") +(putprop (quote EXSHORTER1) (quote ref) "2.7.2") +(putprop (quote EXSHORTER1) (quote ref-url) "./start.html#g31") +(putprop (quote \x2E;/start:s129) (quote pageref-url) "./start.html#./start:s129") +(putprop (quote \x2E;/start:s129) (quote ref) "2.7.2") +(putprop (quote \x2E;/start:s129) (quote ref-url) "./start.html#g31") +(putprop (quote \x2E;/start:h8) (quote pageref-url) "./start.html#./start:h8") +(putprop (quote \x2E;/start:h8) (quote ref) "2.8") +(putprop (quote \x2E;/start:h8) (quote ref-url) "./start.html#g32") +(putprop (quote SECTGSRECURSION) (quote pageref-url) "./start.html#SECTGSRECURSION") +(putprop (quote SECTGSRECURSION) (quote ref) "2.8") +(putprop (quote SECTGSRECURSION) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s130) (quote pageref-url) "./start.html#./start:s130") +(putprop (quote \x2E;/start:s130) (quote ref) "2.8") +(putprop (quote \x2E;/start:s130) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s131) (quote pageref-url) "./start.html#./start:s131") +(putprop (quote \x2E;/start:s131) (quote ref) "2.8") +(putprop (quote \x2E;/start:s131) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s132) (quote pageref-url) "./start.html#./start:s132") +(putprop (quote \x2E;/start:s132) (quote ref) "2.8") +(putprop (quote \x2E;/start:s132) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s133) (quote pageref-url) "./start.html#./start:s133") +(putprop (quote \x2E;/start:s133) (quote ref) "2.8") +(putprop (quote \x2E;/start:s133) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s134) (quote pageref-url) "./start.html#./start:s134") +(putprop (quote \x2E;/start:s134) (quote ref) "2.8") +(putprop (quote \x2E;/start:s134) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s135) (quote pageref-url) "./start.html#./start:s135") +(putprop (quote \x2E;/start:s135) (quote ref) "2.8") +(putprop (quote \x2E;/start:s135) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s136) (quote pageref-url) "./start.html#./start:s136") +(putprop (quote \x2E;/start:s136) (quote ref) "2.8") +(putprop (quote \x2E;/start:s136) (quote ref-url) "./start.html#g32") +(putprop (quote defn:simplelength) (quote pageref-url) "./start.html#defn:simplelength") +(putprop (quote defn:simplelength) (quote ref) "2.8") +(putprop (quote defn:simplelength) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s137) (quote pageref-url) "./start.html#./start:s137") +(putprop (quote \x2E;/start:s137) (quote ref) "2.8") +(putprop (quote \x2E;/start:s137) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s138) (quote pageref-url) "./start.html#./start:s138") +(putprop (quote \x2E;/start:s138) (quote ref) "2.8") +(putprop (quote \x2E;/start:s138) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s139) (quote pageref-url) "./start.html#./start:s139") +(putprop (quote \x2E;/start:s139) (quote ref) "2.8") +(putprop (quote \x2E;/start:s139) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s140) (quote pageref-url) "./start.html#./start:s140") +(putprop (quote \x2E;/start:s140) (quote ref) "2.8") +(putprop (quote \x2E;/start:s140) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s141) (quote pageref-url) "./start.html#./start:s141") +(putprop (quote \x2E;/start:s141) (quote ref) "2.8") +(putprop (quote \x2E;/start:s141) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s142) (quote pageref-url) "./start.html#./start:s142") +(putprop (quote \x2E;/start:s142) (quote ref) "2.8") +(putprop (quote \x2E;/start:s142) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s143) (quote pageref-url) "./start.html#./start:s143") +(putprop (quote \x2E;/start:s143) (quote ref) "2.8") +(putprop (quote \x2E;/start:s143) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s144) (quote pageref-url) "./start.html#./start:s144") +(putprop (quote \x2E;/start:s144) (quote ref) "2.8") +(putprop (quote \x2E;/start:s144) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s145) (quote pageref-url) "./start.html#./start:s145") +(putprop (quote \x2E;/start:s145) (quote ref) "2.8") +(putprop (quote \x2E;/start:s145) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s146) (quote pageref-url) "./start.html#./start:s146") +(putprop (quote \x2E;/start:s146) (quote ref) "2.8") +(putprop (quote \x2E;/start:s146) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s147) (quote pageref-url) "./start.html#./start:s147") +(putprop (quote \x2E;/start:s147) (quote ref) "2.8") +(putprop (quote \x2E;/start:s147) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s148) (quote pageref-url) "./start.html#./start:s148") +(putprop (quote \x2E;/start:s148) (quote ref) "2.8") +(putprop (quote \x2E;/start:s148) (quote ref-url) "./start.html#g32") +(putprop (quote defn:map1) (quote pageref-url) "./start.html#defn:map1") +(putprop (quote defn:map1) (quote ref) "2.8") +(putprop (quote defn:map1) (quote ref-url) "./start.html#g32") +(putprop (quote \x2E;/start:s149) (quote pageref-url) "./start.html#./start:s149") +(putprop (quote \x2E;/start:s149) (quote ref) "2.8.1") +(putprop (quote \x2E;/start:s149) (quote ref-url) "./start.html#g33") +(putprop (quote \x2E;/start:s150) (quote pageref-url) "./start.html#./start:s150") +(putprop (quote \x2E;/start:s150) (quote ref) "2.8.2") +(putprop (quote \x2E;/start:s150) (quote ref-url) "./start.html#g34") +(putprop (quote \x2E;/start:s151) (quote pageref-url) "./start.html#./start:s151") +(putprop (quote \x2E;/start:s151) (quote ref) "2.8.2") +(putprop (quote \x2E;/start:s151) (quote ref-url) "./start.html#g34") +(putprop (quote \x2E;/start:s152) (quote pageref-url) "./start.html#./start:s152") +(putprop (quote \x2E;/start:s152) (quote ref) "2.8.3") +(putprop (quote \x2E;/start:s152) (quote ref-url) "./start.html#g35") +(putprop (quote \x2E;/start:s153) (quote pageref-url) "./start.html#./start:s153") +(putprop (quote \x2E;/start:s153) (quote ref) "2.8.3") +(putprop (quote \x2E;/start:s153) (quote ref-url) "./start.html#g35") +(putprop (quote \x2E;/start:s154) (quote pageref-url) "./start.html#./start:s154") +(putprop (quote \x2E;/start:s154) (quote ref) "2.8.4") +(putprop (quote \x2E;/start:s154) (quote ref-url) "./start.html#g36") +(putprop (quote \x2E;/start:s155) (quote pageref-url) "./start.html#./start:s155") +(putprop (quote \x2E;/start:s155) (quote ref) "2.8.5") +(putprop (quote \x2E;/start:s155) (quote ref-url) "./start.html#g37") +(putprop (quote \x2E;/start:s156) (quote pageref-url) "./start.html#./start:s156") +(putprop (quote \x2E;/start:s156) (quote ref) "2.8.5") +(putprop (quote \x2E;/start:s156) (quote ref-url) "./start.html#g37") +(putprop (quote \x2E;/start:s157) (quote pageref-url) "./start.html#./start:s157") +(putprop (quote \x2E;/start:s157) (quote ref) "2.8.5") +(putprop (quote \x2E;/start:s157) (quote ref-url) "./start.html#g37") +(putprop (quote \x2E;/start:s158) (quote pageref-url) "./start.html#./start:s158") +(putprop (quote \x2E;/start:s158) (quote ref) "2.8.6") +(putprop (quote \x2E;/start:s158) (quote ref-url) "./start.html#g38") +(putprop (quote EXEVENODD) (quote pageref-url) "./start.html#EXEVENODD") +(putprop (quote EXEVENODD) (quote ref) "2.8.6") +(putprop (quote EXEVENODD) (quote ref-url) "./start.html#g38") +(putprop (quote \x2E;/start:s159) (quote pageref-url) "./start.html#./start:s159") +(putprop (quote \x2E;/start:s159) (quote ref) "2.8.6") +(putprop (quote \x2E;/start:s159) (quote ref-url) "./start.html#g38") +(putprop (quote \x2E;/start:s160) (quote pageref-url) "./start.html#./start:s160") +(putprop (quote \x2E;/start:s160) (quote ref) "2.8.6") +(putprop (quote \x2E;/start:s160) (quote ref-url) "./start.html#g38") +(putprop (quote \x2E;/start:s161) (quote pageref-url) "./start.html#./start:s161") +(putprop (quote \x2E;/start:s161) (quote ref) "2.8.7") +(putprop (quote \x2E;/start:s161) (quote ref-url) "./start.html#g39") +(putprop (quote \x2E;/start:s162) (quote pageref-url) "./start.html#./start:s162") +(putprop (quote \x2E;/start:s162) (quote ref) "2.8.7") +(putprop (quote \x2E;/start:s162) (quote ref-url) "./start.html#g39") +(putprop (quote \x2E;/start:h9) (quote pageref-url) "./start.html#./start:h9") +(putprop (quote \x2E;/start:h9) (quote ref) "2.9") +(putprop (quote \x2E;/start:h9) (quote ref-url) "./start.html#g40") +(putprop (quote SECTGSASSIGNMENT) (quote pageref-url) "./start.html#SECTGSASSIGNMENT") +(putprop (quote SECTGSASSIGNMENT) (quote ref) "2.9") +(putprop (quote SECTGSASSIGNMENT) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s163) (quote pageref-url) "./start.html#./start:s163") +(putprop (quote \x2E;/start:s163) (quote ref) "2.9") +(putprop (quote \x2E;/start:s163) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s164) (quote pageref-url) "./start.html#./start:s164") +(putprop (quote \x2E;/start:s164) (quote ref) "2.9") +(putprop (quote \x2E;/start:s164) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s165) (quote pageref-url) "./start.html#./start:s165") +(putprop (quote \x2E;/start:s165) (quote ref) "2.9") +(putprop (quote \x2E;/start:s165) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s166) (quote pageref-url) "./start.html#./start:s166") +(putprop (quote \x2E;/start:s166) (quote ref) "2.9") +(putprop (quote \x2E;/start:s166) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s167) (quote pageref-url) "./start.html#./start:s167") +(putprop (quote \x2E;/start:s167) (quote ref) "2.9") +(putprop (quote \x2E;/start:s167) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s168) (quote pageref-url) "./start.html#./start:s168") +(putprop (quote \x2E;/start:s168) (quote ref) "2.9") +(putprop (quote \x2E;/start:s168) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s169) (quote pageref-url) "./start.html#./start:s169") +(putprop (quote \x2E;/start:s169) (quote ref) "2.9") +(putprop (quote \x2E;/start:s169) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s170) (quote pageref-url) "./start.html#./start:s170") +(putprop (quote \x2E;/start:s170) (quote ref) "2.9") +(putprop (quote \x2E;/start:s170) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s171) (quote pageref-url) "./start.html#./start:s171") +(putprop (quote \x2E;/start:s171) (quote ref) "2.9") +(putprop (quote \x2E;/start:s171) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s172) (quote pageref-url) "./start.html#./start:s172") +(putprop (quote \x2E;/start:s172) (quote ref) "2.9") +(putprop (quote \x2E;/start:s172) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s173) (quote pageref-url) "./start.html#./start:s173") +(putprop (quote \x2E;/start:s173) (quote ref) "2.9") +(putprop (quote \x2E;/start:s173) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s174) (quote pageref-url) "./start.html#./start:s174") +(putprop (quote \x2E;/start:s174) (quote ref) "2.9") +(putprop (quote \x2E;/start:s174) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s175) (quote pageref-url) "./start.html#./start:s175") +(putprop (quote \x2E;/start:s175) (quote ref) "2.9") +(putprop (quote \x2E;/start:s175) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s176) (quote pageref-url) "./start.html#./start:s176") +(putprop (quote \x2E;/start:s176) (quote ref) "2.9") +(putprop (quote \x2E;/start:s176) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s177) (quote pageref-url) "./start.html#./start:s177") +(putprop (quote \x2E;/start:s177) (quote ref) "2.9") +(putprop (quote \x2E;/start:s177) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s178) (quote pageref-url) "./start.html#./start:s178") +(putprop (quote \x2E;/start:s178) (quote ref) "2.9") +(putprop (quote \x2E;/start:s178) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s179) (quote pageref-url) "./start.html#./start:s179") +(putprop (quote \x2E;/start:s179) (quote ref) "2.9") +(putprop (quote \x2E;/start:s179) (quote ref-url) "./start.html#g40") +(putprop (quote queue-datatype) (quote pageref-url) "./start.html#queue-datatype") +(putprop (quote queue-datatype) (quote ref) "2.9") +(putprop (quote queue-datatype) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s180) (quote pageref-url) "./start.html#./start:s180") +(putprop (quote \x2E;/start:s180) (quote ref) "2.9") +(putprop (quote \x2E;/start:s180) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s181) (quote pageref-url) "./start.html#./start:s181") +(putprop (quote \x2E;/start:s181) (quote ref) "2.9") +(putprop (quote \x2E;/start:s181) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s182) (quote pageref-url) "./start.html#./start:s182") +(putprop (quote \x2E;/start:s182) (quote ref) "2.9") +(putprop (quote \x2E;/start:s182) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s183) (quote pageref-url) "./start.html#./start:s183") +(putprop (quote \x2E;/start:s183) (quote ref) "2.9") +(putprop (quote \x2E;/start:s183) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s184) (quote pageref-url) "./start.html#./start:s184") +(putprop (quote \x2E;/start:s184) (quote ref) "2.9") +(putprop (quote \x2E;/start:s184) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s185) (quote pageref-url) "./start.html#./start:s185") +(putprop (quote \x2E;/start:s185) (quote ref) "2.9") +(putprop (quote \x2E;/start:s185) (quote ref-url) "./start.html#g40") +(putprop (quote \x2E;/start:s186) (quote pageref-url) "./start.html#./start:s186") +(putprop (quote \x2E;/start:s186) (quote ref) "2.9.1") +(putprop (quote \x2E;/start:s186) (quote ref-url) "./start.html#g41") +(putprop (quote \x2E;/start:s187) (quote pageref-url) "./start.html#./start:s187") +(putprop (quote \x2E;/start:s187) (quote ref) "2.9.1") +(putprop (quote \x2E;/start:s187) (quote ref-url) "./start.html#g41") +(putprop (quote \x2E;/start:s188) (quote pageref-url) "./start.html#./start:s188") +(putprop (quote \x2E;/start:s188) (quote ref) "2.9.2") +(putprop (quote \x2E;/start:s188) (quote ref-url) "./start.html#g42") +(putprop (quote \x2E;/start:s189) (quote pageref-url) "./start.html#./start:s189") +(putprop (quote \x2E;/start:s189) (quote ref) "2.9.2") +(putprop (quote \x2E;/start:s189) (quote ref-url) "./start.html#g42") +(putprop (quote \x2E;/start:s190) (quote pageref-url) "./start.html#./start:s190") +(putprop (quote \x2E;/start:s190) (quote ref) "2.9.2") +(putprop (quote \x2E;/start:s190) (quote ref-url) "./start.html#g42") +(putprop (quote \x2E;/start:s191) (quote pageref-url) "./start.html#./start:s191") +(putprop (quote \x2E;/start:s191) (quote ref) "2.9.3") +(putprop (quote \x2E;/start:s191) (quote ref-url) "./start.html#g43") +(putprop (quote EXSTACKREFANDSET) (quote pageref-url) "./start.html#EXSTACKREFANDSET") +(putprop (quote EXSTACKREFANDSET) (quote ref) "2.9.3") +(putprop (quote EXSTACKREFANDSET) (quote ref-url) "./start.html#g43") +(putprop (quote \x2E;/start:s192) (quote pageref-url) "./start.html#./start:s192") +(putprop (quote \x2E;/start:s192) (quote ref) "2.9.4") +(putprop (quote \x2E;/start:s192) (quote ref-url) "./start.html#g44") +(putprop (quote \x2E;/start:s193) (quote pageref-url) "./start.html#./start:s193") +(putprop (quote \x2E;/start:s193) (quote ref) "2.9.4") +(putprop (quote \x2E;/start:s193) (quote ref-url) "./start.html#g44") +(putprop (quote \x2E;/start:s194) (quote pageref-url) "./start.html#./start:s194") +(putprop (quote \x2E;/start:s194) (quote ref) "2.9.5") +(putprop (quote \x2E;/start:s194) (quote ref-url) "./start.html#g45") +(putprop (quote \x2E;/start:s195) (quote pageref-url) "./start.html#./start:s195") +(putprop (quote \x2E;/start:s195) (quote ref) "2.9.6") +(putprop (quote \x2E;/start:s195) (quote ref-url) "./start.html#g46") +(putprop (quote \x2E;/start:s196) (quote pageref-url) "./start.html#./start:s196") +(putprop (quote \x2E;/start:s196) (quote ref) "2.9.7") +(putprop (quote \x2E;/start:s196) (quote ref-url) "./start.html#g47") +(putprop (quote \x2E;/start:s197) (quote pageref-url) "./start.html#./start:s197") +(putprop (quote \x2E;/start:s197) (quote ref) "2.9.7") +(putprop (quote \x2E;/start:s197) (quote ref-url) "./start.html#g47") +(putprop (quote \x2E;/start:s198) (quote pageref-url) "./start.html#./start:s198") +(putprop (quote \x2E;/start:s198) (quote ref) "2.9.7") +(putprop (quote \x2E;/start:s198) (quote ref-url) "./start.html#g47") +(putprop (quote \x2E;/start:s199) (quote pageref-url) "./start.html#./start:s199") +(putprop (quote \x2E;/start:s199) (quote ref) "2.9.8") +(putprop (quote \x2E;/start:s199) (quote ref-url) "./start.html#g48") +(putprop (quote EXLIST?) (quote pageref-url) "./start.html#EXLIST?") +(putprop (quote EXLIST?) (quote ref) "2.9.8") +(putprop (quote EXLIST?) (quote ref-url) "./start.html#g48") +(putprop (quote \x2E;/start:s200) (quote pageref-url) "./start.html#./start:s200") +(putprop (quote \x2E;/start:s200) (quote ref) "2.9.8") +(putprop (quote \x2E;/start:s200) (quote ref-url) "./start.html#g48") +(putprop (quote \x2E;/start:s201) (quote pageref-url) "./start.html#./start:s201") +(putprop (quote \x2E;/start:s201) (quote ref) "2.9.8") +(putprop (quote \x2E;/start:s201) (quote ref-url) "./start.html#g48") +(putprop (quote \x2E;/start:s202) (quote pageref-url) "./start.html#./start:s202") +(putprop (quote \x2E;/start:s202) (quote ref) "2.9.8") +(putprop (quote \x2E;/start:s202) (quote ref-url) "./start.html#g48") +(putprop (quote \x2E;/further:h0) (quote pageref-url) "./further.html#./further:h0") +(putprop (quote \x2E;/further:h0) (quote ref) "3") +(putprop (quote \x2E;/further:h0) (quote ref-url) "./further.html#g49") +(putprop (quote CHPTGOINGFURTHER) (quote pageref-url) "./further.html#CHPTGOINGFURTHER") +(putprop (quote CHPTGOINGFURTHER) (quote ref) "3") +(putprop (quote CHPTGOINGFURTHER) (quote ref-url) "./further.html#g49") +(putprop (quote \x2E;/further:h1) (quote pageref-url) "./further.html#./further:h1") +(putprop (quote \x2E;/further:h1) (quote ref) "3.1") +(putprop (quote \x2E;/further:h1) (quote ref-url) "./further.html#g50") +(putprop (quote SECTGFSYNTAX) (quote pageref-url) "./further.html#SECTGFSYNTAX") +(putprop (quote SECTGFSYNTAX) (quote ref) "3.1") +(putprop (quote SECTGFSYNTAX) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s0) (quote pageref-url) "./further.html#./further:s0") +(putprop (quote \x2E;/further:s0) (quote ref) "3.1") +(putprop (quote \x2E;/further:s0) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s1) (quote pageref-url) "./further.html#./further:s1") +(putprop (quote \x2E;/further:s1) (quote ref) "3.1") +(putprop (quote \x2E;/further:s1) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s2) (quote pageref-url) "./further.html#./further:s2") +(putprop (quote \x2E;/further:s2) (quote ref) "3.1") +(putprop (quote \x2E;/further:s2) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s3) (quote pageref-url) "./further.html#./further:s3") +(putprop (quote \x2E;/further:s3) (quote ref) "3.1") +(putprop (quote \x2E;/further:s3) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s4) (quote pageref-url) "./further.html#./further:s4") +(putprop (quote \x2E;/further:s4) (quote ref) "3.1") +(putprop (quote \x2E;/further:s4) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s5) (quote pageref-url) "./further.html#./further:s5") +(putprop (quote \x2E;/further:s5) (quote ref) "3.1") +(putprop (quote \x2E;/further:s5) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s6) (quote pageref-url) "./further.html#./further:s6") +(putprop (quote \x2E;/further:s6) (quote ref) "3.1") +(putprop (quote \x2E;/further:s6) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s7) (quote pageref-url) "./further.html#./further:s7") +(putprop (quote \x2E;/further:s7) (quote ref) "3.1") +(putprop (quote \x2E;/further:s7) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s8) (quote pageref-url) "./further.html#./further:s8") +(putprop (quote \x2E;/further:s8) (quote ref) "3.1") +(putprop (quote \x2E;/further:s8) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s9) (quote pageref-url) "./further.html#./further:s9") +(putprop (quote \x2E;/further:s9) (quote ref) "3.1") +(putprop (quote \x2E;/further:s9) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s10) (quote pageref-url) "./further.html#./further:s10") +(putprop (quote \x2E;/further:s10) (quote ref) "3.1") +(putprop (quote \x2E;/further:s10) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s11) (quote pageref-url) "./further.html#./further:s11") +(putprop (quote \x2E;/further:s11) (quote ref) "3.1") +(putprop (quote \x2E;/further:s11) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s12) (quote pageref-url) "./further.html#./further:s12") +(putprop (quote \x2E;/further:s12) (quote ref) "3.1") +(putprop (quote \x2E;/further:s12) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s13) (quote pageref-url) "./further.html#./further:s13") +(putprop (quote \x2E;/further:s13) (quote ref) "3.1") +(putprop (quote \x2E;/further:s13) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s14) (quote pageref-url) "./further.html#./further:s14") +(putprop (quote \x2E;/further:s14) (quote ref) "3.1") +(putprop (quote \x2E;/further:s14) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s15) (quote pageref-url) "./further.html#./further:s15") +(putprop (quote \x2E;/further:s15) (quote ref) "3.1") +(putprop (quote \x2E;/further:s15) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s16) (quote pageref-url) "./further.html#./further:s16") +(putprop (quote \x2E;/further:s16) (quote ref) "3.1") +(putprop (quote \x2E;/further:s16) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s17) (quote pageref-url) "./further.html#./further:s17") +(putprop (quote \x2E;/further:s17) (quote ref) "3.1") +(putprop (quote \x2E;/further:s17) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s18) (quote pageref-url) "./further.html#./further:s18") +(putprop (quote \x2E;/further:s18) (quote ref) "3.1") +(putprop (quote \x2E;/further:s18) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s19) (quote pageref-url) "./further.html#./further:s19") +(putprop (quote \x2E;/further:s19) (quote ref) "3.1") +(putprop (quote \x2E;/further:s19) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s20) (quote pageref-url) "./further.html#./further:s20") +(putprop (quote \x2E;/further:s20) (quote ref) "3.1") +(putprop (quote \x2E;/further:s20) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s21) (quote pageref-url) "./further.html#./further:s21") +(putprop (quote \x2E;/further:s21) (quote ref) "3.1") +(putprop (quote \x2E;/further:s21) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s22) (quote pageref-url) "./further.html#./further:s22") +(putprop (quote \x2E;/further:s22) (quote ref) "3.1") +(putprop (quote \x2E;/further:s22) (quote ref-url) "./further.html#g50") +(putprop (quote defn:and) (quote pageref-url) "./further.html#defn:and") +(putprop (quote defn:and) (quote ref) "3.1") +(putprop (quote defn:and) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s23) (quote pageref-url) "./further.html#./further:s23") +(putprop (quote \x2E;/further:s23) (quote ref) "3.1") +(putprop (quote \x2E;/further:s23) (quote ref-url) "./further.html#g50") +(putprop (quote defn:or) (quote pageref-url) "./further.html#defn:or") +(putprop (quote defn:or) (quote ref) "3.1") +(putprop (quote defn:or) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s24) (quote pageref-url) "./further.html#./further:s24") +(putprop (quote \x2E;/further:s24) (quote ref) "3.1") +(putprop (quote \x2E;/further:s24) (quote ref-url) "./further.html#g50") +(putprop (quote \x2E;/further:s25) (quote pageref-url) "./further.html#./further:s25") +(putprop (quote \x2E;/further:s25) (quote ref) "3.1.1") +(putprop (quote \x2E;/further:s25) (quote ref-url) "./further.html#g51") +(putprop (quote \x2E;/further:s26) (quote pageref-url) "./further.html#./further:s26") +(putprop (quote \x2E;/further:s26) (quote ref) "3.1.2") +(putprop (quote \x2E;/further:s26) (quote ref-url) "./further.html#g52") +(putprop (quote \x2E;/further:s27) (quote pageref-url) "./further.html#./further:s27") +(putprop (quote \x2E;/further:s27) (quote ref) "3.1.3") +(putprop (quote \x2E;/further:s27) (quote ref-url) "./further.html#g53") +(putprop (quote \x2E;/further:s28) (quote pageref-url) "./further.html#./further:s28") +(putprop (quote \x2E;/further:s28) (quote ref) "3.1.3") +(putprop (quote \x2E;/further:s28) (quote ref-url) "./further.html#g53") +(putprop (quote \x2E;/further:s29) (quote pageref-url) "./further.html#./further:s29") +(putprop (quote \x2E;/further:s29) (quote ref) "3.1.4") +(putprop (quote \x2E;/further:s29) (quote ref-url) "./further.html#g54") +(putprop (quote \x2E;/further:s30) (quote pageref-url) "./further.html#./further:s30") +(putprop (quote \x2E;/further:s30) (quote ref) "3.1.4") +(putprop (quote \x2E;/further:s30) (quote ref-url) "./further.html#g54") +(putprop (quote \x2E;/further:s31) (quote pageref-url) "./further.html#./further:s31") +(putprop (quote \x2E;/further:s31) (quote ref) "3.1.4") +(putprop (quote \x2E;/further:s31) (quote ref-url) "./further.html#g54") +(putprop (quote \x2E;/further:h2) (quote pageref-url) "./further.html#./further:h2") +(putprop (quote \x2E;/further:h2) (quote ref) "3.2") +(putprop (quote \x2E;/further:h2) (quote ref-url) "./further.html#g55") +(putprop (quote SECTGFMORERECURSION) (quote pageref-url) "./further.html#SECTGFMORERECURSION") +(putprop (quote SECTGFMORERECURSION) (quote ref) "3.2") +(putprop (quote SECTGFMORERECURSION) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s32) (quote pageref-url) "./further.html#./further:s32") +(putprop (quote \x2E;/further:s32) (quote ref) "3.2") +(putprop (quote \x2E;/further:s32) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s33) (quote pageref-url) "./further.html#./further:s33") +(putprop (quote \x2E;/further:s33) (quote ref) "3.2") +(putprop (quote \x2E;/further:s33) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s34) (quote pageref-url) "./further.html#./further:s34") +(putprop (quote \x2E;/further:s34) (quote ref) "3.2") +(putprop (quote \x2E;/further:s34) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s35) (quote pageref-url) "./further.html#./further:s35") +(putprop (quote \x2E;/further:s35) (quote ref) "3.2") +(putprop (quote \x2E;/further:s35) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s36) (quote pageref-url) "./further.html#./further:s36") +(putprop (quote \x2E;/further:s36) (quote ref) "3.2") +(putprop (quote \x2E;/further:s36) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s37) (quote pageref-url) "./further.html#./further:s37") +(putprop (quote \x2E;/further:s37) (quote ref) "3.2") +(putprop (quote \x2E;/further:s37) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s38) (quote pageref-url) "./further.html#./further:s38") +(putprop (quote \x2E;/further:s38) (quote ref) "3.2") +(putprop (quote \x2E;/further:s38) (quote ref-url) "./further.html#g55") +(putprop (quote defn:even?/odd?) (quote pageref-url) "./further.html#defn:even?/odd?") +(putprop (quote defn:even?/odd?) (quote ref) "3.2") +(putprop (quote defn:even?/odd?) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s39) (quote pageref-url) "./further.html#./further:s39") +(putprop (quote \x2E;/further:s39) (quote ref) "3.2") +(putprop (quote \x2E;/further:s39) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s40) (quote pageref-url) "./further.html#./further:s40") +(putprop (quote \x2E;/further:s40) (quote ref) "3.2") +(putprop (quote \x2E;/further:s40) (quote ref-url) "./further.html#g55") +(putprop (quote defn:list?) (quote pageref-url) "./further.html#defn:list?") +(putprop (quote defn:list?) (quote ref) "3.2") +(putprop (quote defn:list?) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s41) (quote pageref-url) "./further.html#./further:s41") +(putprop (quote \x2E;/further:s41) (quote ref) "3.2") +(putprop (quote \x2E;/further:s41) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s42) (quote pageref-url) "./further.html#./further:s42") +(putprop (quote \x2E;/further:s42) (quote ref) "3.2") +(putprop (quote \x2E;/further:s42) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s43) (quote pageref-url) "./further.html#./further:s43") +(putprop (quote \x2E;/further:s43) (quote ref) "3.2") +(putprop (quote \x2E;/further:s43) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s44) (quote pageref-url) "./further.html#./further:s44") +(putprop (quote \x2E;/further:s44) (quote ref) "3.2") +(putprop (quote \x2E;/further:s44) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s45) (quote pageref-url) "./further.html#./further:s45") +(putprop (quote \x2E;/further:s45) (quote ref) "3.2") +(putprop (quote \x2E;/further:s45) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s46) (quote pageref-url) "./further.html#./further:s46") +(putprop (quote \x2E;/further:s46) (quote ref) "3.2") +(putprop (quote \x2E;/further:s46) (quote ref-url) "./further.html#g55") +(putprop (quote fibonacci) (quote pageref-url) "./further.html#fibonacci") +(putprop (quote fibonacci) (quote ref) "3.2") +(putprop (quote fibonacci) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s47) (quote pageref-url) "./further.html#./further:s47") +(putprop (quote \x2E;/further:s47) (quote ref) "3.2") +(putprop (quote \x2E;/further:s47) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s48) (quote pageref-url) "./further.html#./further:s48") +(putprop (quote \x2E;/further:s48) (quote ref) "3.2") +(putprop (quote \x2E;/further:s48) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s49) (quote pageref-url) "./further.html#./further:s49") +(putprop (quote \x2E;/further:s49) (quote ref) "3.2") +(putprop (quote \x2E;/further:s49) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s50) (quote pageref-url) "./further.html#./further:s50") +(putprop (quote \x2E;/further:s50) (quote ref) "3.2") +(putprop (quote \x2E;/further:s50) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s51) (quote pageref-url) "./further.html#./further:s51") +(putprop (quote \x2E;/further:s51) (quote ref) "3.2") +(putprop (quote \x2E;/further:s51) (quote ref-url) "./further.html#g55") +(putprop (quote \x2E;/further:s52) (quote pageref-url) "./further.html#./further:s52") +(putprop (quote \x2E;/further:s52) (quote ref) "3.2.1") +(putprop (quote \x2E;/further:s52) (quote ref-url) "./further.html#g56") +(putprop (quote \x2E;/further:s53) (quote pageref-url) "./further.html#./further:s53") +(putprop (quote \x2E;/further:s53) (quote ref) "3.2.2") +(putprop (quote \x2E;/further:s53) (quote ref-url) "./further.html#g57") +(putprop (quote \x2E;/further:s54) (quote pageref-url) "./further.html#./further:s54") +(putprop (quote \x2E;/further:s54) (quote ref) "3.2.2") +(putprop (quote \x2E;/further:s54) (quote ref-url) "./further.html#g57") +(putprop (quote \x2E;/further:s55) (quote pageref-url) "./further.html#./further:s55") +(putprop (quote \x2E;/further:s55) (quote ref) "3.2.3") +(putprop (quote \x2E;/further:s55) (quote ref-url) "./further.html#g58") +(putprop (quote \x2E;/further:s56) (quote pageref-url) "./further.html#./further:s56") +(putprop (quote \x2E;/further:s56) (quote ref) "3.2.4") +(putprop (quote \x2E;/further:s56) (quote ref-url) "./further.html#g59") +(putprop (quote \x2E;/further:s57) (quote pageref-url) "./further.html#./further:s57") +(putprop (quote \x2E;/further:s57) (quote ref) "3.2.5") +(putprop (quote \x2E;/further:s57) (quote ref-url) "./further.html#g60") +(putprop (quote \x2E;/further:s58) (quote pageref-url) "./further.html#./further:s58") +(putprop (quote \x2E;/further:s58) (quote ref) "3.2.6") +(putprop (quote \x2E;/further:s58) (quote ref-url) "./further.html#g61") +(putprop (quote ex:incorrect-or) (quote pageref-url) "./further.html#ex:incorrect-or") +(putprop (quote ex:incorrect-or) (quote ref) "3.2.6") +(putprop (quote ex:incorrect-or) (quote ref-url) "./further.html#g61") +(putprop (quote \x2E;/further:s59) (quote pageref-url) "./further.html#./further:s59") +(putprop (quote \x2E;/further:s59) (quote ref) "3.2.7") +(putprop (quote \x2E;/further:s59) (quote ref-url) "./further.html#g62") +(putprop (quote \x2E;/further:s60) (quote pageref-url) "./further.html#./further:s60") +(putprop (quote \x2E;/further:s60) (quote ref) "3.2.7") +(putprop (quote \x2E;/further:s60) (quote ref-url) "./further.html#g62") +(putprop (quote \x2E;/further:h3) (quote pageref-url) "./further.html#./further:h3") +(putprop (quote \x2E;/further:h3) (quote ref) "3.3") +(putprop (quote \x2E;/further:h3) (quote ref-url) "./further.html#g63") +(putprop (quote SECTGFCONTINUATIONS) (quote pageref-url) "./further.html#SECTGFCONTINUATIONS") +(putprop (quote SECTGFCONTINUATIONS) (quote ref) "3.3") +(putprop (quote SECTGFCONTINUATIONS) (quote ref-url) "./further.html#g63") +(putprop (quote \x2E;/further:s61) (quote pageref-url) "./further.html#./further:s61") +(putprop (quote \x2E;/further:s61) (quote ref) "3.3") +(putprop (quote \x2E;/further:s61) (quote ref-url) "./further.html#g63") +(putprop (quote \x2E;/further:s62) (quote pageref-url) "./further.html#./further:s62") +(putprop (quote \x2E;/further:s62) (quote ref) "6") +(putprop (quote \x2E;/further:s62) (quote ref-url) "./further.html#g69") +(putprop (quote \x2E;/further:s63) (quote pageref-url) "./further.html#./further:s63") +(putprop (quote \x2E;/further:s63) (quote ref) "6") +(putprop (quote \x2E;/further:s63) (quote ref-url) "./further.html#g69") +(putprop (quote defn:product-call/cc) (quote pageref-url) "./further.html#defn:product-call/cc") +(putprop (quote defn:product-call/cc) (quote ref) "6") +(putprop (quote defn:product-call/cc) (quote ref-url) "./further.html#g69") +(putprop (quote \x2E;/further:s64) (quote pageref-url) "./further.html#./further:s64") +(putprop (quote \x2E;/further:s64) (quote ref) "6") +(putprop (quote \x2E;/further:s64) (quote ref-url) "./further.html#g69") +(putprop (quote \x2E;/further:s65) (quote pageref-url) "./further.html#./further:s65") +(putprop (quote \x2E;/further:s65) (quote ref) "6") +(putprop (quote \x2E;/further:s65) (quote ref-url) "./further.html#g69") +(putprop (quote retry) (quote pageref-url) "./further.html#retry") +(putprop (quote retry) (quote ref) "6") +(putprop (quote retry) (quote ref-url) "./further.html#g69") +(putprop (quote \x2E;/further:s66) (quote pageref-url) "./further.html#./further:s66") +(putprop (quote \x2E;/further:s66) (quote ref) "3.3.1") +(putprop (quote \x2E;/further:s66) (quote ref-url) "./further.html#g70") +(putprop (quote \x2E;/further:s67) (quote pageref-url) "./further.html#./further:s67") +(putprop (quote \x2E;/further:s67) (quote ref) "3.3.2") +(putprop (quote \x2E;/further:s67) (quote ref-url) "./further.html#g71") +(putprop (quote \x2E;/further:s68) (quote pageref-url) "./further.html#./further:s68") +(putprop (quote \x2E;/further:s68) (quote ref) "3.3.3") +(putprop (quote \x2E;/further:s68) (quote ref-url) "./further.html#g72") +(putprop (quote \x2E;/further:s69) (quote pageref-url) "./further.html#./further:s69") +(putprop (quote \x2E;/further:s69) (quote ref) "3.3.4") +(putprop (quote \x2E;/further:s69) (quote ref-url) "./further.html#g73") +(putprop (quote \x2E;/further:s70) (quote pageref-url) "./further.html#./further:s70") +(putprop (quote \x2E;/further:s70) (quote ref) "3.3.5") +(putprop (quote \x2E;/further:s70) (quote ref-url) "./further.html#g74") +(putprop (quote \x2E;/further:h4) (quote pageref-url) "./further.html#./further:h4") +(putprop (quote \x2E;/further:h4) (quote ref) "3.4") +(putprop (quote \x2E;/further:h4) (quote ref-url) "./further.html#g75") +(putprop (quote SECTGFCPS) (quote pageref-url) "./further.html#SECTGFCPS") +(putprop (quote SECTGFCPS) (quote ref) "3.4") +(putprop (quote SECTGFCPS) (quote ref-url) "./further.html#g75") +(putprop (quote \x2E;/further:s71) (quote pageref-url) "./further.html#./further:s71") +(putprop (quote \x2E;/further:s71) (quote ref) "3.4") +(putprop (quote \x2E;/further:s71) (quote ref-url) "./further.html#g75") +(putprop (quote \x2E;/further:s72) (quote pageref-url) "./further.html#./further:s72") +(putprop (quote \x2E;/further:s72) (quote ref) "3.4") +(putprop (quote \x2E;/further:s72) (quote ref-url) "./further.html#g75") +(putprop (quote \x2E;/further:s73) (quote pageref-url) "./further.html#./further:s73") +(putprop (quote \x2E;/further:s73) (quote ref) "3.4") +(putprop (quote \x2E;/further:s73) (quote ref-url) "./further.html#g75") +(putprop (quote \x2E;/further:s74) (quote pageref-url) "./further.html#./further:s74") +(putprop (quote \x2E;/further:s74) (quote ref) "3.4") +(putprop (quote \x2E;/further:s74) (quote ref-url) "./further.html#g75") +(putprop (quote \x2E;/further:s75) (quote pageref-url) "./further.html#./further:s75") +(putprop (quote \x2E;/further:s75) (quote ref) "3.4.1") +(putprop (quote \x2E;/further:s75) (quote ref-url) "./further.html#g76") +(putprop (quote \x2E;/further:s76) (quote pageref-url) "./further.html#./further:s76") +(putprop (quote \x2E;/further:s76) (quote ref) "3.4.1") +(putprop (quote \x2E;/further:s76) (quote ref-url) "./further.html#g76") +(putprop (quote \x2E;/further:s77) (quote pageref-url) "./further.html#./further:s77") +(putprop (quote \x2E;/further:s77) (quote ref) "3.4.2") +(putprop (quote \x2E;/further:s77) (quote ref-url) "./further.html#g77") +(putprop (quote \x2E;/further:s78) (quote pageref-url) "./further.html#./further:s78") +(putprop (quote \x2E;/further:s78) (quote ref) "3.4.2") +(putprop (quote \x2E;/further:s78) (quote ref-url) "./further.html#g77") +(putprop (quote \x2E;/further:s79) (quote pageref-url) "./further.html#./further:s79") +(putprop (quote \x2E;/further:s79) (quote ref) "3.4.3") +(putprop (quote \x2E;/further:s79) (quote ref-url) "./further.html#g78") +(putprop (quote \x2E;/further:h5) (quote pageref-url) "./further.html#./further:h5") +(putprop (quote \x2E;/further:h5) (quote ref) "3.5") +(putprop (quote \x2E;/further:h5) (quote ref-url) "./further.html#g79") +(putprop (quote SECTGFINTERNAL) (quote pageref-url) "./further.html#SECTGFINTERNAL") +(putprop (quote SECTGFINTERNAL) (quote ref) "3.5") +(putprop (quote SECTGFINTERNAL) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s80) (quote pageref-url) "./further.html#./further:s80") +(putprop (quote \x2E;/further:s80) (quote ref) "3.5") +(putprop (quote \x2E;/further:s80) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s81) (quote pageref-url) "./further.html#./further:s81") +(putprop (quote \x2E;/further:s81) (quote ref) "3.5") +(putprop (quote \x2E;/further:s81) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s82) (quote pageref-url) "./further.html#./further:s82") +(putprop (quote \x2E;/further:s82) (quote ref) "3.5") +(putprop (quote \x2E;/further:s82) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s83) (quote pageref-url) "./further.html#./further:s83") +(putprop (quote \x2E;/further:s83) (quote ref) "3.5") +(putprop (quote \x2E;/further:s83) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s84) (quote pageref-url) "./further.html#./further:s84") +(putprop (quote \x2E;/further:s84) (quote ref) "3.5") +(putprop (quote \x2E;/further:s84) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s85) (quote pageref-url) "./further.html#./further:s85") +(putprop (quote \x2E;/further:s85) (quote ref) "3.5") +(putprop (quote \x2E;/further:s85) (quote ref-url) "./further.html#g79") +(putprop (quote \x2E;/further:s86) (quote pageref-url) "./further.html#./further:s86") +(putprop (quote \x2E;/further:s86) (quote ref) "3.5.1") +(putprop (quote \x2E;/further:s86) (quote ref-url) "./further.html#g80") +(putprop (quote \x2E;/further:s87) (quote pageref-url) "./further.html#./further:s87") +(putprop (quote \x2E;/further:s87) (quote ref) "3.5.2") +(putprop (quote \x2E;/further:s87) (quote ref-url) "./further.html#g81") +(putprop (quote \x2E;/further:s88) (quote pageref-url) "./further.html#./further:s88") +(putprop (quote \x2E;/further:s88) (quote ref) "3.5.3") +(putprop (quote \x2E;/further:s88) (quote ref-url) "./further.html#g82") +(putprop (quote \x2E;/further:s89) (quote pageref-url) "./further.html#./further:s89") +(putprop (quote \x2E;/further:s89) (quote ref) "3.5.4") +(putprop (quote \x2E;/further:s89) (quote ref-url) "./further.html#g83") +(putprop (quote \x2E;/further:h6) (quote pageref-url) "./further.html#./further:h6") +(putprop (quote \x2E;/further:h6) (quote ref) "3.6") +(putprop (quote \x2E;/further:h6) (quote ref-url) "./further.html#g84") +(putprop (quote SECTGFLIBRARIES) (quote pageref-url) "./further.html#SECTGFLIBRARIES") +(putprop (quote SECTGFLIBRARIES) (quote ref) "3.6") +(putprop (quote SECTGFLIBRARIES) (quote ref-url) "./further.html#g84") +(putprop (quote \x2E;/further:s90) (quote pageref-url) "./further.html#./further:s90") +(putprop (quote \x2E;/further:s90) (quote ref) "3.6.1") +(putprop (quote \x2E;/further:s90) (quote ref-url) "./further.html#g85") +(putprop (quote \x2E;/further:s91) (quote pageref-url) "./further.html#./further:s91") +(putprop (quote \x2E;/further:s91) (quote ref) "3.6.2") +(putprop (quote \x2E;/further:s91) (quote ref-url) "./further.html#g86") +(putprop (quote \x2E;/further:s92) (quote pageref-url) "./further.html#./further:s92") +(putprop (quote \x2E;/further:s92) (quote ref) "3.6.3") +(putprop (quote \x2E;/further:s92) (quote ref-url) "./further.html#g87") +(putprop (quote \x2E;/binding:h0) (quote pageref-url) "./binding.html#./binding:h0") +(putprop (quote \x2E;/binding:h0) (quote ref) "4") +(putprop (quote \x2E;/binding:h0) (quote ref-url) "./binding.html#g88") +(putprop (quote CHPTBINDING) (quote pageref-url) "./binding.html#CHPTBINDING") +(putprop (quote CHPTBINDING) (quote ref) "4") +(putprop (quote CHPTBINDING) (quote ref-url) "./binding.html#g88") +(putprop (quote \x2E;/binding:s0) (quote pageref-url) "./binding.html#./binding:s0") +(putprop (quote \x2E;/binding:s0) (quote ref) "4") +(putprop (quote \x2E;/binding:s0) (quote ref-url) "./binding.html#g88") +(putprop (quote \x2E;/binding:s1) (quote pageref-url) "./binding.html#./binding:s1") +(putprop (quote \x2E;/binding:s1) (quote ref) "4") +(putprop (quote \x2E;/binding:s1) (quote ref-url) "./binding.html#g88") +(putprop (quote \x2E;/binding:h1) (quote pageref-url) "./binding.html#./binding:h1") +(putprop (quote \x2E;/binding:h1) (quote ref) "4.1") +(putprop (quote \x2E;/binding:h1) (quote ref-url) "./binding.html#g89") +(putprop (quote SECTVARREF) (quote pageref-url) "./binding.html#SECTVARREF") +(putprop (quote SECTVARREF) (quote ref) "4.1") +(putprop (quote SECTVARREF) (quote ref-url) "./binding.html#g89") +(putprop (quote \x2E;/binding:s2) (quote pageref-url) "./binding.html#./binding:s2") +(putprop (quote \x2E;/binding:s2) (quote ref) "4.1") +(putprop (quote \x2E;/binding:s2) (quote ref-url) "./binding.html#g89") +(putprop (quote \x2E;/binding:h2) (quote pageref-url) "./binding.html#./binding:h2") +(putprop (quote \x2E;/binding:h2) (quote ref) "4.2") +(putprop (quote \x2E;/binding:h2) (quote ref-url) "./binding.html#g90") +(putprop (quote SECTLAMBDA) (quote pageref-url) "./binding.html#SECTLAMBDA") +(putprop (quote SECTLAMBDA) (quote ref) "4.2") +(putprop (quote SECTLAMBDA) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:s3) (quote pageref-url) "./binding.html#./binding:s3") +(putprop (quote \x2E;/binding:s3) (quote ref) "4.2") +(putprop (quote \x2E;/binding:s3) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:s4) (quote pageref-url) "./binding.html#./binding:s4") +(putprop (quote \x2E;/binding:s4) (quote ref) "4.2") +(putprop (quote \x2E;/binding:s4) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:s5) (quote pageref-url) "./binding.html#./binding:s5") +(putprop (quote \x2E;/binding:s5) (quote ref) "4.2") +(putprop (quote \x2E;/binding:s5) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:s6) (quote pageref-url) "./binding.html#./binding:s6") +(putprop (quote \x2E;/binding:s6) (quote ref) "4.2") +(putprop (quote \x2E;/binding:s6) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:s7) (quote pageref-url) "./binding.html#./binding:s7") +(putprop (quote \x2E;/binding:s7) (quote ref) "4.2") +(putprop (quote \x2E;/binding:s7) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:s8) (quote pageref-url) "./binding.html#./binding:s8") +(putprop (quote \x2E;/binding:s8) (quote ref) "4.2") +(putprop (quote \x2E;/binding:s8) (quote ref-url) "./binding.html#g90") +(putprop (quote \x2E;/binding:h3) (quote pageref-url) "./binding.html#./binding:h3") +(putprop (quote \x2E;/binding:h3) (quote ref) "4.3") +(putprop (quote \x2E;/binding:h3) (quote ref-url) "./binding.html#g91") +(putprop (quote SECTOPTARGS) (quote pageref-url) "./binding.html#SECTOPTARGS") +(putprop (quote SECTOPTARGS) (quote ref) "4.3") +(putprop (quote SECTOPTARGS) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s9) (quote pageref-url) "./binding.html#./binding:s9") +(putprop (quote \x2E;/binding:s9) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s9) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s10) (quote pageref-url) "./binding.html#./binding:s10") +(putprop (quote \x2E;/binding:s10) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s10) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s11) (quote pageref-url) "./binding.html#./binding:s11") +(putprop (quote \x2E;/binding:s11) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s11) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s12) (quote pageref-url) "./binding.html#./binding:s12") +(putprop (quote \x2E;/binding:s12) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s12) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s13) (quote pageref-url) "./binding.html#./binding:s13") +(putprop (quote \x2E;/binding:s13) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s13) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s14) (quote pageref-url) "./binding.html#./binding:s14") +(putprop (quote \x2E;/binding:s14) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s14) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:s15) (quote pageref-url) "./binding.html#./binding:s15") +(putprop (quote \x2E;/binding:s15) (quote ref) "4.3") +(putprop (quote \x2E;/binding:s15) (quote ref-url) "./binding.html#g91") +(putprop (quote \x2E;/binding:h4) (quote pageref-url) "./binding.html#./binding:h4") +(putprop (quote \x2E;/binding:h4) (quote ref) "4.4") +(putprop (quote \x2E;/binding:h4) (quote ref-url) "./binding.html#g92") +(putprop (quote SECTLOCALBINDING) (quote pageref-url) "./binding.html#SECTLOCALBINDING") +(putprop (quote SECTLOCALBINDING) (quote ref) "4.4") +(putprop (quote SECTLOCALBINDING) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s16) (quote pageref-url) "./binding.html#./binding:s16") +(putprop (quote \x2E;/binding:s16) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s16) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s17) (quote pageref-url) "./binding.html#./binding:s17") +(putprop (quote \x2E;/binding:s17) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s17) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s18) (quote pageref-url) "./binding.html#./binding:s18") +(putprop (quote \x2E;/binding:s18) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s18) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s19) (quote pageref-url) "./binding.html#./binding:s19") +(putprop (quote \x2E;/binding:s19) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s19) (quote ref-url) "./binding.html#g92") +(putprop (quote defn:let*) (quote pageref-url) "./binding.html#defn:let*") +(putprop (quote defn:let*) (quote ref) "4.4") +(putprop (quote defn:let*) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s20) (quote pageref-url) "./binding.html#./binding:s20") +(putprop (quote \x2E;/binding:s20) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s20) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s21) (quote pageref-url) "./binding.html#./binding:s21") +(putprop (quote \x2E;/binding:s21) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s21) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:s22) (quote pageref-url) "./binding.html#./binding:s22") +(putprop (quote \x2E;/binding:s22) (quote ref) "4.4") +(putprop (quote \x2E;/binding:s22) (quote ref-url) "./binding.html#g92") +(putprop (quote desc:letrec*) (quote pageref-url) "./binding.html#desc:letrec*") +(putprop (quote desc:letrec*) (quote ref) "4.4") +(putprop (quote desc:letrec*) (quote ref-url) "./binding.html#g92") +(putprop (quote \x2E;/binding:h5) (quote pageref-url) "./binding.html#./binding:h5") +(putprop (quote \x2E;/binding:h5) (quote ref) "4.5") +(putprop (quote \x2E;/binding:h5) (quote ref-url) "./binding.html#g93") +(putprop (quote SECTLETVALUES) (quote pageref-url) "./binding.html#SECTLETVALUES") +(putprop (quote SECTLETVALUES) (quote ref) "4.5") +(putprop (quote SECTLETVALUES) (quote ref-url) "./binding.html#g93") +(putprop (quote \x2E;/binding:s23) (quote pageref-url) "./binding.html#./binding:s23") +(putprop (quote \x2E;/binding:s23) (quote ref) "4.5") +(putprop (quote \x2E;/binding:s23) (quote ref-url) "./binding.html#g93") +(putprop (quote desc:let-values) (quote pageref-url) "./binding.html#desc:let-values") +(putprop (quote desc:let-values) (quote ref) "4.5") +(putprop (quote desc:let-values) (quote ref-url) "./binding.html#g93") +(putprop (quote \x2E;/binding:h6) (quote pageref-url) "./binding.html#./binding:h6") +(putprop (quote \x2E;/binding:h6) (quote ref) "4.6") +(putprop (quote \x2E;/binding:h6) (quote ref-url) "./binding.html#g94") +(putprop (quote SECTDEFINITIONS) (quote pageref-url) "./binding.html#SECTDEFINITIONS") +(putprop (quote SECTDEFINITIONS) (quote ref) "4.6") +(putprop (quote SECTDEFINITIONS) (quote ref-url) "./binding.html#g94") +(putprop (quote \x2E;/binding:s24) (quote pageref-url) "./binding.html#./binding:s24") +(putprop (quote \x2E;/binding:s24) (quote ref) "4.6") +(putprop (quote \x2E;/binding:s24) (quote ref-url) "./binding.html#g94") +(putprop (quote \x2E;/binding:s25) (quote pageref-url) "./binding.html#./binding:s25") +(putprop (quote \x2E;/binding:s25) (quote ref) "4.6") +(putprop (quote \x2E;/binding:s25) (quote ref-url) "./binding.html#g94") +(putprop (quote \x2E;/binding:s26) (quote pageref-url) "./binding.html#./binding:s26") +(putprop (quote \x2E;/binding:s26) (quote ref) "4.6") +(putprop (quote \x2E;/binding:s26) (quote ref-url) "./binding.html#g94") +(putprop (quote multi-define-syntax) (quote pageref-url) "./binding.html#multi-define-syntax") +(putprop (quote multi-define-syntax) (quote ref) "4.6") +(putprop (quote multi-define-syntax) (quote ref-url) "./binding.html#g94") +(putprop (quote \x2E;/binding:s27) (quote pageref-url) "./binding.html#./binding:s27") +(putprop (quote \x2E;/binding:s27) (quote ref) "4.6") +(putprop (quote \x2E;/binding:s27) (quote ref-url) "./binding.html#g94") +(putprop (quote \x2E;/binding:h7) (quote pageref-url) "./binding.html#./binding:h7") +(putprop (quote \x2E;/binding:h7) (quote ref) "4.7") +(putprop (quote \x2E;/binding:h7) (quote ref-url) "./binding.html#g95") +(putprop (quote SECTASSIGNMENTS) (quote pageref-url) "./binding.html#SECTASSIGNMENTS") +(putprop (quote SECTASSIGNMENTS) (quote ref) "4.7") +(putprop (quote SECTASSIGNMENTS) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/binding:s28) (quote pageref-url) "./binding.html#./binding:s28") +(putprop (quote \x2E;/binding:s28) (quote ref) "4.7") +(putprop (quote \x2E;/binding:s28) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/binding:s29) (quote pageref-url) "./binding.html#./binding:s29") +(putprop (quote \x2E;/binding:s29) (quote ref) "4.7") +(putprop (quote \x2E;/binding:s29) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/binding:s30) (quote pageref-url) "./binding.html#./binding:s30") +(putprop (quote \x2E;/binding:s30) (quote ref) "4.7") +(putprop (quote \x2E;/binding:s30) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/binding:s31) (quote pageref-url) "./binding.html#./binding:s31") +(putprop (quote \x2E;/binding:s31) (quote ref) "4.7") +(putprop (quote \x2E;/binding:s31) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/binding:s32) (quote pageref-url) "./binding.html#./binding:s32") +(putprop (quote \x2E;/binding:s32) (quote ref) "4.7") +(putprop (quote \x2E;/binding:s32) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/binding:s33) (quote pageref-url) "./binding.html#./binding:s33") +(putprop (quote \x2E;/binding:s33) (quote ref) "4.7") +(putprop (quote \x2E;/binding:s33) (quote ref-url) "./binding.html#g95") +(putprop (quote \x2E;/control:h0) (quote pageref-url) "./control.html#./control:h0") +(putprop (quote \x2E;/control:h0) (quote ref) "5") +(putprop (quote \x2E;/control:h0) (quote ref-url) "./control.html#g96") +(putprop (quote CHPTCONTROL) (quote pageref-url) "./control.html#CHPTCONTROL") +(putprop (quote CHPTCONTROL) (quote ref) "5") +(putprop (quote CHPTCONTROL) (quote ref-url) "./control.html#g96") +(putprop (quote \x2E;/control:s0) (quote pageref-url) "./control.html#./control:s0") +(putprop (quote \x2E;/control:s0) (quote ref) "5") +(putprop (quote \x2E;/control:s0) (quote ref-url) "./control.html#g96") +(putprop (quote \x2E;/control:h1) (quote pageref-url) "./control.html#./control:h1") +(putprop (quote \x2E;/control:h1) (quote ref) "5.1") +(putprop (quote \x2E;/control:h1) (quote ref-url) "./control.html#g97") +(putprop (quote SECTAPPLICATION) (quote pageref-url) "./control.html#SECTAPPLICATION") +(putprop (quote SECTAPPLICATION) (quote ref) "5.1") +(putprop (quote SECTAPPLICATION) (quote ref-url) "./control.html#g97") +(putprop (quote \x2E;/control:s1) (quote pageref-url) "./control.html#./control:s1") +(putprop (quote \x2E;/control:s1) (quote ref) "5.1") +(putprop (quote \x2E;/control:s1) (quote ref-url) "./control.html#g97") +(putprop (quote \x2E;/control:s2) (quote pageref-url) "./control.html#./control:s2") +(putprop (quote \x2E;/control:s2) (quote ref) "5.1") +(putprop (quote \x2E;/control:s2) (quote ref-url) "./control.html#g97") +(putprop (quote \x2E;/control:s3) (quote pageref-url) "./control.html#./control:s3") +(putprop (quote \x2E;/control:s3) (quote ref) "5.1") +(putprop (quote \x2E;/control:s3) (quote ref-url) "./control.html#g97") +(putprop (quote desc:apply) (quote pageref-url) "./control.html#desc:apply") +(putprop (quote desc:apply) (quote ref) "5.1") +(putprop (quote desc:apply) (quote ref-url) "./control.html#g97") +(putprop (quote \x2E;/control:h2) (quote pageref-url) "./control.html#./control:h2") +(putprop (quote \x2E;/control:h2) (quote ref) "5.2") +(putprop (quote \x2E;/control:h2) (quote ref-url) "./control.html#g98") +(putprop (quote SECTSEQUENCING) (quote pageref-url) "./control.html#SECTSEQUENCING") +(putprop (quote SECTSEQUENCING) (quote ref) "5.2") +(putprop (quote SECTSEQUENCING) (quote ref-url) "./control.html#g98") +(putprop (quote \x2E;/control:s4) (quote pageref-url) "./control.html#./control:s4") +(putprop (quote \x2E;/control:s4) (quote ref) "5.2") +(putprop (quote \x2E;/control:s4) (quote ref-url) "./control.html#g98") +(putprop (quote \x2E;/control:s5) (quote pageref-url) "./control.html#./control:s5") +(putprop (quote \x2E;/control:s5) (quote ref) "5.2") +(putprop (quote \x2E;/control:s5) (quote ref-url) "./control.html#g98") +(putprop (quote \x2E;/control:s6) (quote pageref-url) "./control.html#./control:s6") +(putprop (quote \x2E;/control:s6) (quote ref) "5.2") +(putprop (quote \x2E;/control:s6) (quote ref-url) "./control.html#g98") +(putprop (quote \x2E;/control:s7) (quote pageref-url) "./control.html#./control:s7") +(putprop (quote \x2E;/control:s7) (quote ref) "5.2") +(putprop (quote \x2E;/control:s7) (quote ref-url) "./control.html#g98") +(putprop (quote \x2E;/control:h3) (quote pageref-url) "./control.html#./control:h3") +(putprop (quote \x2E;/control:h3) (quote ref) "5.3") +(putprop (quote \x2E;/control:h3) (quote ref-url) "./control.html#g99") +(putprop (quote SECTCONDITIONALS) (quote pageref-url) "./control.html#SECTCONDITIONALS") +(putprop (quote SECTCONDITIONALS) (quote ref) "5.3") +(putprop (quote SECTCONDITIONALS) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s8) (quote pageref-url) "./control.html#./control:s8") +(putprop (quote \x2E;/control:s8) (quote ref) "5.3") +(putprop (quote \x2E;/control:s8) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s9) (quote pageref-url) "./control.html#./control:s9") +(putprop (quote \x2E;/control:s9) (quote ref) "5.3") +(putprop (quote \x2E;/control:s9) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s10) (quote pageref-url) "./control.html#./control:s10") +(putprop (quote \x2E;/control:s10) (quote ref) "5.3") +(putprop (quote \x2E;/control:s10) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s11) (quote pageref-url) "./control.html#./control:s11") +(putprop (quote \x2E;/control:s11) (quote ref) "5.3") +(putprop (quote \x2E;/control:s11) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s12) (quote pageref-url) "./control.html#./control:s12") +(putprop (quote \x2E;/control:s12) (quote ref) "5.3") +(putprop (quote \x2E;/control:s12) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s13) (quote pageref-url) "./control.html#./control:s13") +(putprop (quote \x2E;/control:s13) (quote ref) "5.3") +(putprop (quote \x2E;/control:s13) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s14) (quote pageref-url) "./control.html#./control:s14") +(putprop (quote \x2E;/control:s14) (quote ref) "5.3") +(putprop (quote \x2E;/control:s14) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s15) (quote pageref-url) "./control.html#./control:s15") +(putprop (quote \x2E;/control:s15) (quote ref) "5.3") +(putprop (quote \x2E;/control:s15) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s16) (quote pageref-url) "./control.html#./control:s16") +(putprop (quote \x2E;/control:s16) (quote ref) "5.3") +(putprop (quote \x2E;/control:s16) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s17) (quote pageref-url) "./control.html#./control:s17") +(putprop (quote \x2E;/control:s17) (quote ref) "5.3") +(putprop (quote \x2E;/control:s17) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s18) (quote pageref-url) "./control.html#./control:s18") +(putprop (quote \x2E;/control:s18) (quote ref) "5.3") +(putprop (quote \x2E;/control:s18) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:s19) (quote pageref-url) "./control.html#./control:s19") +(putprop (quote \x2E;/control:s19) (quote ref) "5.3") +(putprop (quote \x2E;/control:s19) (quote ref-url) "./control.html#g99") +(putprop (quote \x2E;/control:h4) (quote pageref-url) "./control.html#./control:h4") +(putprop (quote \x2E;/control:h4) (quote ref) "5.4") +(putprop (quote \x2E;/control:h4) (quote ref-url) "./control.html#g100") +(putprop (quote SECTRECURSION) (quote pageref-url) "./control.html#SECTRECURSION") +(putprop (quote SECTRECURSION) (quote ref) "5.4") +(putprop (quote SECTRECURSION) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s20) (quote pageref-url) "./control.html#./control:s20") +(putprop (quote \x2E;/control:s20) (quote ref) "5.4") +(putprop (quote \x2E;/control:s20) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s21) (quote pageref-url) "./control.html#./control:s21") +(putprop (quote \x2E;/control:s21) (quote ref) "5.4") +(putprop (quote \x2E;/control:s21) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s22) (quote pageref-url) "./control.html#./control:s22") +(putprop (quote \x2E;/control:s22) (quote ref) "5.4") +(putprop (quote \x2E;/control:s22) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s23) (quote pageref-url) "./control.html#./control:s23") +(putprop (quote \x2E;/control:s23) (quote ref) "5.4") +(putprop (quote \x2E;/control:s23) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s24) (quote pageref-url) "./control.html#./control:s24") +(putprop (quote \x2E;/control:s24) (quote ref) "5.4") +(putprop (quote \x2E;/control:s24) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s25) (quote pageref-url) "./control.html#./control:s25") +(putprop (quote \x2E;/control:s25) (quote ref) "5.4") +(putprop (quote \x2E;/control:s25) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s26) (quote pageref-url) "./control.html#./control:s26") +(putprop (quote \x2E;/control:s26) (quote ref) "5.4") +(putprop (quote \x2E;/control:s26) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s27) (quote pageref-url) "./control.html#./control:s27") +(putprop (quote \x2E;/control:s27) (quote ref) "5.4") +(putprop (quote \x2E;/control:s27) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s28) (quote pageref-url) "./control.html#./control:s28") +(putprop (quote \x2E;/control:s28) (quote ref) "5.4") +(putprop (quote \x2E;/control:s28) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:s29) (quote pageref-url) "./control.html#./control:s29") +(putprop (quote \x2E;/control:s29) (quote ref) "5.4") +(putprop (quote \x2E;/control:s29) (quote ref-url) "./control.html#g100") +(putprop (quote \x2E;/control:h5) (quote pageref-url) "./control.html#./control:h5") +(putprop (quote \x2E;/control:h5) (quote ref) "5.5") +(putprop (quote \x2E;/control:h5) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s30) (quote pageref-url) "./control.html#./control:s30") +(putprop (quote \x2E;/control:s30) (quote ref) "5.5") +(putprop (quote \x2E;/control:s30) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s31) (quote pageref-url) "./control.html#./control:s31") +(putprop (quote \x2E;/control:s31) (quote ref) "5.5") +(putprop (quote \x2E;/control:s31) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s32) (quote pageref-url) "./control.html#./control:s32") +(putprop (quote \x2E;/control:s32) (quote ref) "5.5") +(putprop (quote \x2E;/control:s32) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s33) (quote pageref-url) "./control.html#./control:s33") +(putprop (quote \x2E;/control:s33) (quote ref) "5.5") +(putprop (quote \x2E;/control:s33) (quote ref-url) "./control.html#g101") +(putprop (quote desc:for-each) (quote pageref-url) "./control.html#desc:for-each") +(putprop (quote desc:for-each) (quote ref) "5.5") +(putprop (quote desc:for-each) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s34) (quote pageref-url) "./control.html#./control:s34") +(putprop (quote \x2E;/control:s34) (quote ref) "5.5") +(putprop (quote \x2E;/control:s34) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s35) (quote pageref-url) "./control.html#./control:s35") +(putprop (quote \x2E;/control:s35) (quote ref) "5.5") +(putprop (quote \x2E;/control:s35) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s36) (quote pageref-url) "./control.html#./control:s36") +(putprop (quote \x2E;/control:s36) (quote ref) "5.5") +(putprop (quote \x2E;/control:s36) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s37) (quote pageref-url) "./control.html#./control:s37") +(putprop (quote \x2E;/control:s37) (quote ref) "5.5") +(putprop (quote \x2E;/control:s37) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s38) (quote pageref-url) "./control.html#./control:s38") +(putprop (quote \x2E;/control:s38) (quote ref) "5.5") +(putprop (quote \x2E;/control:s38) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s39) (quote pageref-url) "./control.html#./control:s39") +(putprop (quote \x2E;/control:s39) (quote ref) "5.5") +(putprop (quote \x2E;/control:s39) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s40) (quote pageref-url) "./control.html#./control:s40") +(putprop (quote \x2E;/control:s40) (quote ref) "5.5") +(putprop (quote \x2E;/control:s40) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s41) (quote pageref-url) "./control.html#./control:s41") +(putprop (quote \x2E;/control:s41) (quote ref) "5.5") +(putprop (quote \x2E;/control:s41) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s42) (quote pageref-url) "./control.html#./control:s42") +(putprop (quote \x2E;/control:s42) (quote ref) "5.5") +(putprop (quote \x2E;/control:s42) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s43) (quote pageref-url) "./control.html#./control:s43") +(putprop (quote \x2E;/control:s43) (quote ref) "5.5") +(putprop (quote \x2E;/control:s43) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s44) (quote pageref-url) "./control.html#./control:s44") +(putprop (quote \x2E;/control:s44) (quote ref) "5.5") +(putprop (quote \x2E;/control:s44) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s45) (quote pageref-url) "./control.html#./control:s45") +(putprop (quote \x2E;/control:s45) (quote ref) "5.5") +(putprop (quote \x2E;/control:s45) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s46) (quote pageref-url) "./control.html#./control:s46") +(putprop (quote \x2E;/control:s46) (quote ref) "5.5") +(putprop (quote \x2E;/control:s46) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s47) (quote pageref-url) "./control.html#./control:s47") +(putprop (quote \x2E;/control:s47) (quote ref) "5.5") +(putprop (quote \x2E;/control:s47) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s48) (quote pageref-url) "./control.html#./control:s48") +(putprop (quote \x2E;/control:s48) (quote ref) "5.5") +(putprop (quote \x2E;/control:s48) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s49) (quote pageref-url) "./control.html#./control:s49") +(putprop (quote \x2E;/control:s49) (quote ref) "5.5") +(putprop (quote \x2E;/control:s49) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s50) (quote pageref-url) "./control.html#./control:s50") +(putprop (quote \x2E;/control:s50) (quote ref) "5.5") +(putprop (quote \x2E;/control:s50) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s51) (quote pageref-url) "./control.html#./control:s51") +(putprop (quote \x2E;/control:s51) (quote ref) "5.5") +(putprop (quote \x2E;/control:s51) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:s52) (quote pageref-url) "./control.html#./control:s52") +(putprop (quote \x2E;/control:s52) (quote ref) "5.5") +(putprop (quote \x2E;/control:s52) (quote ref-url) "./control.html#g101") +(putprop (quote \x2E;/control:h6) (quote pageref-url) "./control.html#./control:h6") +(putprop (quote \x2E;/control:h6) (quote ref) "5.6") +(putprop (quote \x2E;/control:h6) (quote ref-url) "./control.html#g102") +(putprop (quote SECTCONTINUATIONS) (quote pageref-url) "./control.html#SECTCONTINUATIONS") +(putprop (quote SECTCONTINUATIONS) (quote ref) "5.6") +(putprop (quote SECTCONTINUATIONS) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s53) (quote pageref-url) "./control.html#./control:s53") +(putprop (quote \x2E;/control:s53) (quote ref) "5.6") +(putprop (quote \x2E;/control:s53) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s54) (quote pageref-url) "./control.html#./control:s54") +(putprop (quote \x2E;/control:s54) (quote ref) "5.6") +(putprop (quote \x2E;/control:s54) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s55) (quote pageref-url) "./control.html#./control:s55") +(putprop (quote \x2E;/control:s55) (quote ref) "5.6") +(putprop (quote \x2E;/control:s55) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s56) (quote pageref-url) "./control.html#./control:s56") +(putprop (quote \x2E;/control:s56) (quote ref) "5.6") +(putprop (quote \x2E;/control:s56) (quote ref-url) "./control.html#g102") +(putprop (quote desc:dynamic-wind) (quote pageref-url) "./control.html#desc:dynamic-wind") +(putprop (quote desc:dynamic-wind) (quote ref) "5.6") +(putprop (quote desc:dynamic-wind) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s57) (quote pageref-url) "./control.html#./control:s57") +(putprop (quote \x2E;/control:s57) (quote ref) "5.6") +(putprop (quote \x2E;/control:s57) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s58) (quote pageref-url) "./control.html#./control:s58") +(putprop (quote \x2E;/control:s58) (quote ref) "5.6") +(putprop (quote \x2E;/control:s58) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s59) (quote pageref-url) "./control.html#./control:s59") +(putprop (quote \x2E;/control:s59) (quote ref) "5.6") +(putprop (quote \x2E;/control:s59) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s60) (quote pageref-url) "./control.html#./control:s60") +(putprop (quote \x2E;/control:s60) (quote ref) "5.6") +(putprop (quote \x2E;/control:s60) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s61) (quote pageref-url) "./control.html#./control:s61") +(putprop (quote \x2E;/control:s61) (quote ref) "5.6") +(putprop (quote \x2E;/control:s61) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s62) (quote pageref-url) "./control.html#./control:s62") +(putprop (quote \x2E;/control:s62) (quote ref) "5.6") +(putprop (quote \x2E;/control:s62) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:s63) (quote pageref-url) "./control.html#./control:s63") +(putprop (quote \x2E;/control:s63) (quote ref) "5.6") +(putprop (quote \x2E;/control:s63) (quote ref-url) "./control.html#g102") +(putprop (quote \x2E;/control:h7) (quote pageref-url) "./control.html#./control:h7") +(putprop (quote \x2E;/control:h7) (quote ref) "5.7") +(putprop (quote \x2E;/control:h7) (quote ref-url) "./control.html#g103") +(putprop (quote SECTDELAYED) (quote pageref-url) "./control.html#SECTDELAYED") +(putprop (quote SECTDELAYED) (quote ref) "5.7") +(putprop (quote SECTDELAYED) (quote ref-url) "./control.html#g103") +(putprop (quote \x2E;/control:s64) (quote pageref-url) "./control.html#./control:s64") +(putprop (quote \x2E;/control:s64) (quote ref) "5.7") +(putprop (quote \x2E;/control:s64) (quote ref-url) "./control.html#g103") +(putprop (quote \x2E;/control:s65) (quote pageref-url) "./control.html#./control:s65") +(putprop (quote \x2E;/control:s65) (quote ref) "5.7") +(putprop (quote \x2E;/control:s65) (quote ref-url) "./control.html#g103") +(putprop (quote \x2E;/control:s66) (quote pageref-url) "./control.html#./control:s66") +(putprop (quote \x2E;/control:s66) (quote ref) "5.7") +(putprop (quote \x2E;/control:s66) (quote ref-url) "./control.html#g103") +(putprop (quote \x2E;/control:s67) (quote pageref-url) "./control.html#./control:s67") +(putprop (quote \x2E;/control:s67) (quote ref) "5.7") +(putprop (quote \x2E;/control:s67) (quote ref-url) "./control.html#g103") +(putprop (quote \x2E;/control:h8) (quote pageref-url) "./control.html#./control:h8") +(putprop (quote \x2E;/control:h8) (quote ref) "5.8") +(putprop (quote \x2E;/control:h8) (quote ref-url) "./control.html#g104") +(putprop (quote SECTMRVS) (quote pageref-url) "./control.html#SECTMRVS") +(putprop (quote SECTMRVS) (quote ref) "5.8") +(putprop (quote SECTMRVS) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s68) (quote pageref-url) "./control.html#./control:s68") +(putprop (quote \x2E;/control:s68) (quote ref) "5.8") +(putprop (quote \x2E;/control:s68) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s69) (quote pageref-url) "./control.html#./control:s69") +(putprop (quote \x2E;/control:s69) (quote ref) "5.8") +(putprop (quote \x2E;/control:s69) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s70) (quote pageref-url) "./control.html#./control:s70") +(putprop (quote \x2E;/control:s70) (quote ref) "5.8") +(putprop (quote \x2E;/control:s70) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s71) (quote pageref-url) "./control.html#./control:s71") +(putprop (quote \x2E;/control:s71) (quote ref) "5.8") +(putprop (quote \x2E;/control:s71) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s72) (quote pageref-url) "./control.html#./control:s72") +(putprop (quote \x2E;/control:s72) (quote ref) "5.8") +(putprop (quote \x2E;/control:s72) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s73) (quote pageref-url) "./control.html#./control:s73") +(putprop (quote \x2E;/control:s73) (quote ref) "5.8") +(putprop (quote \x2E;/control:s73) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s74) (quote pageref-url) "./control.html#./control:s74") +(putprop (quote \x2E;/control:s74) (quote ref) "5.8") +(putprop (quote \x2E;/control:s74) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s75) (quote pageref-url) "./control.html#./control:s75") +(putprop (quote \x2E;/control:s75) (quote ref) "5.8") +(putprop (quote \x2E;/control:s75) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s76) (quote pageref-url) "./control.html#./control:s76") +(putprop (quote \x2E;/control:s76) (quote ref) "5.8") +(putprop (quote \x2E;/control:s76) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s77) (quote pageref-url) "./control.html#./control:s77") +(putprop (quote \x2E;/control:s77) (quote ref) "5.8") +(putprop (quote \x2E;/control:s77) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s78) (quote pageref-url) "./control.html#./control:s78") +(putprop (quote \x2E;/control:s78) (quote ref) "5.8") +(putprop (quote \x2E;/control:s78) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:s79) (quote pageref-url) "./control.html#./control:s79") +(putprop (quote \x2E;/control:s79) (quote ref) "5.8") +(putprop (quote \x2E;/control:s79) (quote ref-url) "./control.html#g104") +(putprop (quote defn:call-with-port) (quote pageref-url) "./control.html#defn:call-with-port") +(putprop (quote defn:call-with-port) (quote ref) "5.8") +(putprop (quote defn:call-with-port) (quote ref-url) "./control.html#g104") +(putprop (quote \x2E;/control:h9) (quote pageref-url) "./control.html#./control:h9") +(putprop (quote \x2E;/control:h9) (quote ref) "5.9") +(putprop (quote \x2E;/control:h9) (quote ref-url) "./control.html#g105") +(putprop (quote SECTEVAL) (quote pageref-url) "./control.html#SECTEVAL") +(putprop (quote SECTEVAL) (quote ref) "5.9") +(putprop (quote SECTEVAL) (quote ref-url) "./control.html#g105") +(putprop (quote \x2E;/control:s80) (quote pageref-url) "./control.html#./control:s80") +(putprop (quote \x2E;/control:s80) (quote ref) "5.9") +(putprop (quote \x2E;/control:s80) (quote ref-url) "./control.html#g105") +(putprop (quote \x2E;/control:s81) (quote pageref-url) "./control.html#./control:s81") +(putprop (quote \x2E;/control:s81) (quote ref) "5.9") +(putprop (quote \x2E;/control:s81) (quote ref-url) "./control.html#g105") +(putprop (quote \x2E;/control:s82) (quote pageref-url) "./control.html#./control:s82") +(putprop (quote \x2E;/control:s82) (quote ref) "5.9") +(putprop (quote \x2E;/control:s82) (quote ref-url) "./control.html#g105") +(putprop (quote \x2E;/objects:h0) (quote pageref-url) "./objects.html#./objects:h0") +(putprop (quote \x2E;/objects:h0) (quote ref) "6") +(putprop (quote \x2E;/objects:h0) (quote ref-url) "./objects.html#g106") +(putprop (quote CHPTOBJECTS) (quote pageref-url) "./objects.html#CHPTOBJECTS") +(putprop (quote CHPTOBJECTS) (quote ref) "6") +(putprop (quote CHPTOBJECTS) (quote ref-url) "./objects.html#g106") +(putprop (quote \x2E;/objects:s0) (quote pageref-url) "./objects.html#./objects:s0") +(putprop (quote \x2E;/objects:s0) (quote ref) "6") +(putprop (quote \x2E;/objects:s0) (quote ref-url) "./objects.html#g106") +(putprop (quote \x2E;/objects:h1) (quote pageref-url) "./objects.html#./objects:h1") +(putprop (quote \x2E;/objects:h1) (quote ref) "6.1") +(putprop (quote \x2E;/objects:h1) (quote ref-url) "./objects.html#g107") +(putprop (quote SECTQUOTING) (quote pageref-url) "./objects.html#SECTQUOTING") +(putprop (quote SECTQUOTING) (quote ref) "6.1") +(putprop (quote SECTQUOTING) (quote ref-url) "./objects.html#g107") +(putprop (quote \x2E;/objects:s1) (quote pageref-url) "./objects.html#./objects:s1") +(putprop (quote \x2E;/objects:s1) (quote ref) "6.1") +(putprop (quote \x2E;/objects:s1) (quote ref-url) "./objects.html#g107") +(putprop (quote \x2E;/objects:s2) (quote pageref-url) "./objects.html#./objects:s2") +(putprop (quote \x2E;/objects:s2) (quote ref) "6.1") +(putprop (quote \x2E;/objects:s2) (quote ref-url) "./objects.html#g107") +(putprop (quote \x2E;/objects:s3) (quote pageref-url) "./objects.html#./objects:s3") +(putprop (quote \x2E;/objects:s3) (quote ref) "6.1") +(putprop (quote \x2E;/objects:s3) (quote ref-url) "./objects.html#g107") +(putprop (quote \x2E;/objects:s4) (quote pageref-url) "./objects.html#./objects:s4") +(putprop (quote \x2E;/objects:s4) (quote ref) "6.1") +(putprop (quote \x2E;/objects:s4) (quote ref-url) "./objects.html#g107") +(putprop (quote \x2E;/objects:s5) (quote pageref-url) "./objects.html#./objects:s5") +(putprop (quote \x2E;/objects:s5) (quote ref) "6.1") +(putprop (quote \x2E;/objects:s5) (quote ref-url) "./objects.html#g107") +(putprop (quote \x2E;/objects:h2) (quote pageref-url) "./objects.html#./objects:h2") +(putprop (quote \x2E;/objects:h2) (quote ref) "6.2") +(putprop (quote \x2E;/objects:h2) (quote ref-url) "./objects.html#g108") +(putprop (quote SECTGENERIC) (quote pageref-url) "./objects.html#SECTGENERIC") +(putprop (quote SECTGENERIC) (quote ref) "6.2") +(putprop (quote SECTGENERIC) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s6) (quote pageref-url) "./objects.html#./objects:s6") +(putprop (quote \x2E;/objects:s6) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s6) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s7) (quote pageref-url) "./objects.html#./objects:s7") +(putprop (quote \x2E;/objects:s7) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s7) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s8) (quote pageref-url) "./objects.html#./objects:s8") +(putprop (quote \x2E;/objects:s8) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s8) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s9) (quote pageref-url) "./objects.html#./objects:s9") +(putprop (quote \x2E;/objects:s9) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s9) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s10) (quote pageref-url) "./objects.html#./objects:s10") +(putprop (quote \x2E;/objects:s10) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s10) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s11) (quote pageref-url) "./objects.html#./objects:s11") +(putprop (quote \x2E;/objects:s11) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s11) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s12) (quote pageref-url) "./objects.html#./objects:s12") +(putprop (quote \x2E;/objects:s12) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s12) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s13) (quote pageref-url) "./objects.html#./objects:s13") +(putprop (quote \x2E;/objects:s13) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s13) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s14) (quote pageref-url) "./objects.html#./objects:s14") +(putprop (quote \x2E;/objects:s14) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s14) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s15) (quote pageref-url) "./objects.html#./objects:s15") +(putprop (quote \x2E;/objects:s15) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s15) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s16) (quote pageref-url) "./objects.html#./objects:s16") +(putprop (quote \x2E;/objects:s16) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s16) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s17) (quote pageref-url) "./objects.html#./objects:s17") +(putprop (quote \x2E;/objects:s17) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s17) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s18) (quote pageref-url) "./objects.html#./objects:s18") +(putprop (quote \x2E;/objects:s18) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s18) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s19) (quote pageref-url) "./objects.html#./objects:s19") +(putprop (quote \x2E;/objects:s19) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s19) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s20) (quote pageref-url) "./objects.html#./objects:s20") +(putprop (quote \x2E;/objects:s20) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s20) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s21) (quote pageref-url) "./objects.html#./objects:s21") +(putprop (quote \x2E;/objects:s21) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s21) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s22) (quote pageref-url) "./objects.html#./objects:s22") +(putprop (quote \x2E;/objects:s22) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s22) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s23) (quote pageref-url) "./objects.html#./objects:s23") +(putprop (quote \x2E;/objects:s23) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s23) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s24) (quote pageref-url) "./objects.html#./objects:s24") +(putprop (quote \x2E;/objects:s24) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s24) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:s25) (quote pageref-url) "./objects.html#./objects:s25") +(putprop (quote \x2E;/objects:s25) (quote ref) "6.2") +(putprop (quote \x2E;/objects:s25) (quote ref-url) "./objects.html#g108") +(putprop (quote \x2E;/objects:h3) (quote pageref-url) "./objects.html#./objects:h3") +(putprop (quote \x2E;/objects:h3) (quote ref) "6.3") +(putprop (quote \x2E;/objects:h3) (quote ref-url) "./objects.html#g109") +(putprop (quote SECTPAIRS) (quote pageref-url) "./objects.html#SECTPAIRS") +(putprop (quote SECTPAIRS) (quote ref) "6.3") +(putprop (quote SECTPAIRS) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s26) (quote pageref-url) "./objects.html#./objects:s26") +(putprop (quote \x2E;/objects:s26) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s26) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s27) (quote pageref-url) "./objects.html#./objects:s27") +(putprop (quote \x2E;/objects:s27) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s27) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s28) (quote pageref-url) "./objects.html#./objects:s28") +(putprop (quote \x2E;/objects:s28) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s28) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s29) (quote pageref-url) "./objects.html#./objects:s29") +(putprop (quote \x2E;/objects:s29) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s29) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s30) (quote pageref-url) "./objects.html#./objects:s30") +(putprop (quote \x2E;/objects:s30) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s30) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s31) (quote pageref-url) "./objects.html#./objects:s31") +(putprop (quote \x2E;/objects:s31) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s31) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s32) (quote pageref-url) "./objects.html#./objects:s32") +(putprop (quote \x2E;/objects:s32) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s32) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s33) (quote pageref-url) "./objects.html#./objects:s33") +(putprop (quote \x2E;/objects:s33) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s33) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s34) (quote pageref-url) "./objects.html#./objects:s34") +(putprop (quote \x2E;/objects:s34) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s34) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s35) (quote pageref-url) "./objects.html#./objects:s35") +(putprop (quote \x2E;/objects:s35) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s35) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s36) (quote pageref-url) "./objects.html#./objects:s36") +(putprop (quote \x2E;/objects:s36) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s36) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s37) (quote pageref-url) "./objects.html#./objects:s37") +(putprop (quote \x2E;/objects:s37) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s37) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s38) (quote pageref-url) "./objects.html#./objects:s38") +(putprop (quote \x2E;/objects:s38) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s38) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s39) (quote pageref-url) "./objects.html#./objects:s39") +(putprop (quote \x2E;/objects:s39) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s39) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s40) (quote pageref-url) "./objects.html#./objects:s40") +(putprop (quote \x2E;/objects:s40) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s40) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s41) (quote pageref-url) "./objects.html#./objects:s41") +(putprop (quote \x2E;/objects:s41) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s41) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s42) (quote pageref-url) "./objects.html#./objects:s42") +(putprop (quote \x2E;/objects:s42) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s42) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s43) (quote pageref-url) "./objects.html#./objects:s43") +(putprop (quote \x2E;/objects:s43) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s43) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s44) (quote pageref-url) "./objects.html#./objects:s44") +(putprop (quote \x2E;/objects:s44) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s44) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s45) (quote pageref-url) "./objects.html#./objects:s45") +(putprop (quote \x2E;/objects:s45) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s45) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s46) (quote pageref-url) "./objects.html#./objects:s46") +(putprop (quote \x2E;/objects:s46) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s46) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s47) (quote pageref-url) "./objects.html#./objects:s47") +(putprop (quote \x2E;/objects:s47) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s47) (quote ref-url) "./objects.html#g109") +(putprop (quote defn:list-ref) (quote pageref-url) "./objects.html#defn:list-ref") +(putprop (quote defn:list-ref) (quote ref) "6.3") +(putprop (quote defn:list-ref) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s48) (quote pageref-url) "./objects.html#./objects:s48") +(putprop (quote \x2E;/objects:s48) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s48) (quote ref-url) "./objects.html#g109") +(putprop (quote defn:list-tail) (quote pageref-url) "./objects.html#defn:list-tail") +(putprop (quote defn:list-tail) (quote ref) "6.3") +(putprop (quote defn:list-tail) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s49) (quote pageref-url) "./objects.html#./objects:s49") +(putprop (quote \x2E;/objects:s49) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s49) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s50) (quote pageref-url) "./objects.html#./objects:s50") +(putprop (quote \x2E;/objects:s50) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s50) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s51) (quote pageref-url) "./objects.html#./objects:s51") +(putprop (quote \x2E;/objects:s51) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s51) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s52) (quote pageref-url) "./objects.html#./objects:s52") +(putprop (quote \x2E;/objects:s52) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s52) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s53) (quote pageref-url) "./objects.html#./objects:s53") +(putprop (quote \x2E;/objects:s53) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s53) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s54) (quote pageref-url) "./objects.html#./objects:s54") +(putprop (quote \x2E;/objects:s54) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s54) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s55) (quote pageref-url) "./objects.html#./objects:s55") +(putprop (quote \x2E;/objects:s55) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s55) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s56) (quote pageref-url) "./objects.html#./objects:s56") +(putprop (quote \x2E;/objects:s56) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s56) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s57) (quote pageref-url) "./objects.html#./objects:s57") +(putprop (quote \x2E;/objects:s57) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s57) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s58) (quote pageref-url) "./objects.html#./objects:s58") +(putprop (quote \x2E;/objects:s58) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s58) (quote ref-url) "./objects.html#g109") +(putprop (quote page:assq) (quote pageref-url) "./objects.html#page:assq") +(putprop (quote page:assq) (quote ref) "6.3") +(putprop (quote page:assq) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s59) (quote pageref-url) "./objects.html#./objects:s59") +(putprop (quote \x2E;/objects:s59) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s59) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s60) (quote pageref-url) "./objects.html#./objects:s60") +(putprop (quote \x2E;/objects:s60) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s60) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s61) (quote pageref-url) "./objects.html#./objects:s61") +(putprop (quote \x2E;/objects:s61) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s61) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:s62) (quote pageref-url) "./objects.html#./objects:s62") +(putprop (quote \x2E;/objects:s62) (quote ref) "6.3") +(putprop (quote \x2E;/objects:s62) (quote ref-url) "./objects.html#g109") +(putprop (quote \x2E;/objects:h4) (quote pageref-url) "./objects.html#./objects:h4") +(putprop (quote \x2E;/objects:h4) (quote ref) "6.4") +(putprop (quote \x2E;/objects:h4) (quote ref-url) "./objects.html#g110") +(putprop (quote SECTNUMBERS) (quote pageref-url) "./objects.html#SECTNUMBERS") +(putprop (quote SECTNUMBERS) (quote ref) "6.4") +(putprop (quote SECTNUMBERS) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s63) (quote pageref-url) "./objects.html#./objects:s63") +(putprop (quote \x2E;/objects:s63) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s63) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s64) (quote pageref-url) "./objects.html#./objects:s64") +(putprop (quote \x2E;/objects:s64) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s64) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s65) (quote pageref-url) "./objects.html#./objects:s65") +(putprop (quote \x2E;/objects:s65) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s65) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s66) (quote pageref-url) "./objects.html#./objects:s66") +(putprop (quote \x2E;/objects:s66) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s66) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s67) (quote pageref-url) "./objects.html#./objects:s67") +(putprop (quote \x2E;/objects:s67) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s67) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s68) (quote pageref-url) "./objects.html#./objects:s68") +(putprop (quote \x2E;/objects:s68) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s68) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s69) (quote pageref-url) "./objects.html#./objects:s69") +(putprop (quote \x2E;/objects:s69) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s69) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s70) (quote pageref-url) "./objects.html#./objects:s70") +(putprop (quote \x2E;/objects:s70) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s70) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s71) (quote pageref-url) "./objects.html#./objects:s71") +(putprop (quote \x2E;/objects:s71) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s71) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s72) (quote pageref-url) "./objects.html#./objects:s72") +(putprop (quote \x2E;/objects:s72) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s72) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s73) (quote pageref-url) "./objects.html#./objects:s73") +(putprop (quote \x2E;/objects:s73) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s73) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s74) (quote pageref-url) "./objects.html#./objects:s74") +(putprop (quote \x2E;/objects:s74) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s74) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s75) (quote pageref-url) "./objects.html#./objects:s75") +(putprop (quote \x2E;/objects:s75) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s75) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s76) (quote pageref-url) "./objects.html#./objects:s76") +(putprop (quote \x2E;/objects:s76) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s76) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s77) (quote pageref-url) "./objects.html#./objects:s77") +(putprop (quote \x2E;/objects:s77) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s77) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s78) (quote pageref-url) "./objects.html#./objects:s78") +(putprop (quote \x2E;/objects:s78) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s78) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s79) (quote pageref-url) "./objects.html#./objects:s79") +(putprop (quote \x2E;/objects:s79) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s79) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s80) (quote pageref-url) "./objects.html#./objects:s80") +(putprop (quote \x2E;/objects:s80) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s80) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s81) (quote pageref-url) "./objects.html#./objects:s81") +(putprop (quote \x2E;/objects:s81) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s81) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s82) (quote pageref-url) "./objects.html#./objects:s82") +(putprop (quote \x2E;/objects:s82) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s82) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s83) (quote pageref-url) "./objects.html#./objects:s83") +(putprop (quote \x2E;/objects:s83) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s83) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s84) (quote pageref-url) "./objects.html#./objects:s84") +(putprop (quote \x2E;/objects:s84) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s84) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s85) (quote pageref-url) "./objects.html#./objects:s85") +(putprop (quote \x2E;/objects:s85) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s85) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s86) (quote pageref-url) "./objects.html#./objects:s86") +(putprop (quote \x2E;/objects:s86) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s86) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s87) (quote pageref-url) "./objects.html#./objects:s87") +(putprop (quote \x2E;/objects:s87) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s87) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s88) (quote pageref-url) "./objects.html#./objects:s88") +(putprop (quote \x2E;/objects:s88) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s88) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s89) (quote pageref-url) "./objects.html#./objects:s89") +(putprop (quote \x2E;/objects:s89) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s89) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s90) (quote pageref-url) "./objects.html#./objects:s90") +(putprop (quote \x2E;/objects:s90) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s90) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s91) (quote pageref-url) "./objects.html#./objects:s91") +(putprop (quote \x2E;/objects:s91) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s91) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s92) (quote pageref-url) "./objects.html#./objects:s92") +(putprop (quote \x2E;/objects:s92) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s92) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s93) (quote pageref-url) "./objects.html#./objects:s93") +(putprop (quote \x2E;/objects:s93) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s93) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s94) (quote pageref-url) "./objects.html#./objects:s94") +(putprop (quote \x2E;/objects:s94) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s94) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s95) (quote pageref-url) "./objects.html#./objects:s95") +(putprop (quote \x2E;/objects:s95) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s95) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s96) (quote pageref-url) "./objects.html#./objects:s96") +(putprop (quote \x2E;/objects:s96) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s96) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s97) (quote pageref-url) "./objects.html#./objects:s97") +(putprop (quote \x2E;/objects:s97) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s97) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s98) (quote pageref-url) "./objects.html#./objects:s98") +(putprop (quote \x2E;/objects:s98) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s98) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s99) (quote pageref-url) "./objects.html#./objects:s99") +(putprop (quote \x2E;/objects:s99) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s99) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s100) (quote pageref-url) "./objects.html#./objects:s100") +(putprop (quote \x2E;/objects:s100) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s100) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s101) (quote pageref-url) "./objects.html#./objects:s101") +(putprop (quote \x2E;/objects:s101) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s101) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s102) (quote pageref-url) "./objects.html#./objects:s102") +(putprop (quote \x2E;/objects:s102) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s102) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s103) (quote pageref-url) "./objects.html#./objects:s103") +(putprop (quote \x2E;/objects:s103) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s103) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s104) (quote pageref-url) "./objects.html#./objects:s104") +(putprop (quote \x2E;/objects:s104) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s104) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s105) (quote pageref-url) "./objects.html#./objects:s105") +(putprop (quote \x2E;/objects:s105) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s105) (quote ref-url) "./objects.html#g110") +(putprop (quote page:abs) (quote pageref-url) "./objects.html#page:abs") +(putprop (quote page:abs) (quote ref) "6.4") +(putprop (quote page:abs) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s106) (quote pageref-url) "./objects.html#./objects:s106") +(putprop (quote \x2E;/objects:s106) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s106) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s107) (quote pageref-url) "./objects.html#./objects:s107") +(putprop (quote \x2E;/objects:s107) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s107) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s108) (quote pageref-url) "./objects.html#./objects:s108") +(putprop (quote \x2E;/objects:s108) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s108) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s109) (quote pageref-url) "./objects.html#./objects:s109") +(putprop (quote \x2E;/objects:s109) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s109) (quote ref-url) "./objects.html#g110") +(putprop (quote page:gcd) (quote pageref-url) "./objects.html#page:gcd") +(putprop (quote page:gcd) (quote ref) "6.4") +(putprop (quote page:gcd) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s110) (quote pageref-url) "./objects.html#./objects:s110") +(putprop (quote \x2E;/objects:s110) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s110) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s111) (quote pageref-url) "./objects.html#./objects:s111") +(putprop (quote \x2E;/objects:s111) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s111) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s112) (quote pageref-url) "./objects.html#./objects:s112") +(putprop (quote \x2E;/objects:s112) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s112) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s113) (quote pageref-url) "./objects.html#./objects:s113") +(putprop (quote \x2E;/objects:s113) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s113) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s114) (quote pageref-url) "./objects.html#./objects:s114") +(putprop (quote \x2E;/objects:s114) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s114) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s115) (quote pageref-url) "./objects.html#./objects:s115") +(putprop (quote \x2E;/objects:s115) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s115) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s116) (quote pageref-url) "./objects.html#./objects:s116") +(putprop (quote \x2E;/objects:s116) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s116) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s117) (quote pageref-url) "./objects.html#./objects:s117") +(putprop (quote \x2E;/objects:s117) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s117) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s118) (quote pageref-url) "./objects.html#./objects:s118") +(putprop (quote \x2E;/objects:s118) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s118) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s119) (quote pageref-url) "./objects.html#./objects:s119") +(putprop (quote \x2E;/objects:s119) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s119) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s120) (quote pageref-url) "./objects.html#./objects:s120") +(putprop (quote \x2E;/objects:s120) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s120) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s121) (quote pageref-url) "./objects.html#./objects:s121") +(putprop (quote \x2E;/objects:s121) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s121) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s122) (quote pageref-url) "./objects.html#./objects:s122") +(putprop (quote \x2E;/objects:s122) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s122) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s123) (quote pageref-url) "./objects.html#./objects:s123") +(putprop (quote \x2E;/objects:s123) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s123) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s124) (quote pageref-url) "./objects.html#./objects:s124") +(putprop (quote \x2E;/objects:s124) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s124) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s125) (quote pageref-url) "./objects.html#./objects:s125") +(putprop (quote \x2E;/objects:s125) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s125) (quote ref-url) "./objects.html#g110") +(putprop (quote page:magnitude) (quote pageref-url) "./objects.html#page:magnitude") +(putprop (quote page:magnitude) (quote ref) "6.4") +(putprop (quote page:magnitude) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s126) (quote pageref-url) "./objects.html#./objects:s126") +(putprop (quote \x2E;/objects:s126) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s126) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s127) (quote pageref-url) "./objects.html#./objects:s127") +(putprop (quote \x2E;/objects:s127) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s127) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s128) (quote pageref-url) "./objects.html#./objects:s128") +(putprop (quote \x2E;/objects:s128) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s128) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s129) (quote pageref-url) "./objects.html#./objects:s129") +(putprop (quote \x2E;/objects:s129) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s129) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s130) (quote pageref-url) "./objects.html#./objects:s130") +(putprop (quote \x2E;/objects:s130) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s130) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s131) (quote pageref-url) "./objects.html#./objects:s131") +(putprop (quote \x2E;/objects:s131) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s131) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s132) (quote pageref-url) "./objects.html#./objects:s132") +(putprop (quote \x2E;/objects:s132) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s132) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s133) (quote pageref-url) "./objects.html#./objects:s133") +(putprop (quote \x2E;/objects:s133) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s133) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s134) (quote pageref-url) "./objects.html#./objects:s134") +(putprop (quote \x2E;/objects:s134) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s134) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s135) (quote pageref-url) "./objects.html#./objects:s135") +(putprop (quote \x2E;/objects:s135) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s135) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s136) (quote pageref-url) "./objects.html#./objects:s136") +(putprop (quote \x2E;/objects:s136) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s136) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s137) (quote pageref-url) "./objects.html#./objects:s137") +(putprop (quote \x2E;/objects:s137) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s137) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s138) (quote pageref-url) "./objects.html#./objects:s138") +(putprop (quote \x2E;/objects:s138) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s138) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s139) (quote pageref-url) "./objects.html#./objects:s139") +(putprop (quote \x2E;/objects:s139) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s139) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s140) (quote pageref-url) "./objects.html#./objects:s140") +(putprop (quote \x2E;/objects:s140) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s140) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s141) (quote pageref-url) "./objects.html#./objects:s141") +(putprop (quote \x2E;/objects:s141) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s141) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s142) (quote pageref-url) "./objects.html#./objects:s142") +(putprop (quote \x2E;/objects:s142) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s142) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s143) (quote pageref-url) "./objects.html#./objects:s143") +(putprop (quote \x2E;/objects:s143) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s143) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s144) (quote pageref-url) "./objects.html#./objects:s144") +(putprop (quote \x2E;/objects:s144) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s144) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s145) (quote pageref-url) "./objects.html#./objects:s145") +(putprop (quote \x2E;/objects:s145) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s145) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s146) (quote pageref-url) "./objects.html#./objects:s146") +(putprop (quote \x2E;/objects:s146) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s146) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s147) (quote pageref-url) "./objects.html#./objects:s147") +(putprop (quote \x2E;/objects:s147) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s147) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:s148) (quote pageref-url) "./objects.html#./objects:s148") +(putprop (quote \x2E;/objects:s148) (quote ref) "6.4") +(putprop (quote \x2E;/objects:s148) (quote ref-url) "./objects.html#g110") +(putprop (quote \x2E;/objects:h5) (quote pageref-url) "./objects.html#./objects:h5") +(putprop (quote \x2E;/objects:h5) (quote ref) "6.5") +(putprop (quote \x2E;/objects:h5) (quote ref-url) "./objects.html#g111") +(putprop (quote SECTFIXNUMS) (quote pageref-url) "./objects.html#SECTFIXNUMS") +(putprop (quote SECTFIXNUMS) (quote ref) "6.5") +(putprop (quote SECTFIXNUMS) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s149) (quote pageref-url) "./objects.html#./objects:s149") +(putprop (quote \x2E;/objects:s149) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s149) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s150) (quote pageref-url) "./objects.html#./objects:s150") +(putprop (quote \x2E;/objects:s150) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s150) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s151) (quote pageref-url) "./objects.html#./objects:s151") +(putprop (quote \x2E;/objects:s151) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s151) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s152) (quote pageref-url) "./objects.html#./objects:s152") +(putprop (quote \x2E;/objects:s152) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s152) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s153) (quote pageref-url) "./objects.html#./objects:s153") +(putprop (quote \x2E;/objects:s153) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s153) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s154) (quote pageref-url) "./objects.html#./objects:s154") +(putprop (quote \x2E;/objects:s154) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s154) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s155) (quote pageref-url) "./objects.html#./objects:s155") +(putprop (quote \x2E;/objects:s155) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s155) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s156) (quote pageref-url) "./objects.html#./objects:s156") +(putprop (quote \x2E;/objects:s156) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s156) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s157) (quote pageref-url) "./objects.html#./objects:s157") +(putprop (quote \x2E;/objects:s157) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s157) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s158) (quote pageref-url) "./objects.html#./objects:s158") +(putprop (quote \x2E;/objects:s158) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s158) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s159) (quote pageref-url) "./objects.html#./objects:s159") +(putprop (quote \x2E;/objects:s159) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s159) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s160) (quote pageref-url) "./objects.html#./objects:s160") +(putprop (quote \x2E;/objects:s160) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s160) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s161) (quote pageref-url) "./objects.html#./objects:s161") +(putprop (quote \x2E;/objects:s161) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s161) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s162) (quote pageref-url) "./objects.html#./objects:s162") +(putprop (quote \x2E;/objects:s162) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s162) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s163) (quote pageref-url) "./objects.html#./objects:s163") +(putprop (quote \x2E;/objects:s163) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s163) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s164) (quote pageref-url) "./objects.html#./objects:s164") +(putprop (quote \x2E;/objects:s164) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s164) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s165) (quote pageref-url) "./objects.html#./objects:s165") +(putprop (quote \x2E;/objects:s165) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s165) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s166) (quote pageref-url) "./objects.html#./objects:s166") +(putprop (quote \x2E;/objects:s166) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s166) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s167) (quote pageref-url) "./objects.html#./objects:s167") +(putprop (quote \x2E;/objects:s167) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s167) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s168) (quote pageref-url) "./objects.html#./objects:s168") +(putprop (quote \x2E;/objects:s168) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s168) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s169) (quote pageref-url) "./objects.html#./objects:s169") +(putprop (quote \x2E;/objects:s169) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s169) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s170) (quote pageref-url) "./objects.html#./objects:s170") +(putprop (quote \x2E;/objects:s170) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s170) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s171) (quote pageref-url) "./objects.html#./objects:s171") +(putprop (quote \x2E;/objects:s171) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s171) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s172) (quote pageref-url) "./objects.html#./objects:s172") +(putprop (quote \x2E;/objects:s172) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s172) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s173) (quote pageref-url) "./objects.html#./objects:s173") +(putprop (quote \x2E;/objects:s173) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s173) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s174) (quote pageref-url) "./objects.html#./objects:s174") +(putprop (quote \x2E;/objects:s174) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s174) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:s175) (quote pageref-url) "./objects.html#./objects:s175") +(putprop (quote \x2E;/objects:s175) (quote ref) "6.5") +(putprop (quote \x2E;/objects:s175) (quote ref-url) "./objects.html#g111") +(putprop (quote \x2E;/objects:h6) (quote pageref-url) "./objects.html#./objects:h6") +(putprop (quote \x2E;/objects:h6) (quote ref) "6.6") +(putprop (quote \x2E;/objects:h6) (quote ref-url) "./objects.html#g112") +(putprop (quote SECTFLONUMS) (quote pageref-url) "./objects.html#SECTFLONUMS") +(putprop (quote SECTFLONUMS) (quote ref) "6.6") +(putprop (quote SECTFLONUMS) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s176) (quote pageref-url) "./objects.html#./objects:s176") +(putprop (quote \x2E;/objects:s176) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s176) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s177) (quote pageref-url) "./objects.html#./objects:s177") +(putprop (quote \x2E;/objects:s177) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s177) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s178) (quote pageref-url) "./objects.html#./objects:s178") +(putprop (quote \x2E;/objects:s178) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s178) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s179) (quote pageref-url) "./objects.html#./objects:s179") +(putprop (quote \x2E;/objects:s179) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s179) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s180) (quote pageref-url) "./objects.html#./objects:s180") +(putprop (quote \x2E;/objects:s180) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s180) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s181) (quote pageref-url) "./objects.html#./objects:s181") +(putprop (quote \x2E;/objects:s181) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s181) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s182) (quote pageref-url) "./objects.html#./objects:s182") +(putprop (quote \x2E;/objects:s182) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s182) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s183) (quote pageref-url) "./objects.html#./objects:s183") +(putprop (quote \x2E;/objects:s183) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s183) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s184) (quote pageref-url) "./objects.html#./objects:s184") +(putprop (quote \x2E;/objects:s184) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s184) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s185) (quote pageref-url) "./objects.html#./objects:s185") +(putprop (quote \x2E;/objects:s185) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s185) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s186) (quote pageref-url) "./objects.html#./objects:s186") +(putprop (quote \x2E;/objects:s186) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s186) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s187) (quote pageref-url) "./objects.html#./objects:s187") +(putprop (quote \x2E;/objects:s187) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s187) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s188) (quote pageref-url) "./objects.html#./objects:s188") +(putprop (quote \x2E;/objects:s188) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s188) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s189) (quote pageref-url) "./objects.html#./objects:s189") +(putprop (quote \x2E;/objects:s189) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s189) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s190) (quote pageref-url) "./objects.html#./objects:s190") +(putprop (quote \x2E;/objects:s190) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s190) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s191) (quote pageref-url) "./objects.html#./objects:s191") +(putprop (quote \x2E;/objects:s191) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s191) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s192) (quote pageref-url) "./objects.html#./objects:s192") +(putprop (quote \x2E;/objects:s192) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s192) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s193) (quote pageref-url) "./objects.html#./objects:s193") +(putprop (quote \x2E;/objects:s193) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s193) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s194) (quote pageref-url) "./objects.html#./objects:s194") +(putprop (quote \x2E;/objects:s194) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s194) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s195) (quote pageref-url) "./objects.html#./objects:s195") +(putprop (quote \x2E;/objects:s195) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s195) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s196) (quote pageref-url) "./objects.html#./objects:s196") +(putprop (quote \x2E;/objects:s196) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s196) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s197) (quote pageref-url) "./objects.html#./objects:s197") +(putprop (quote \x2E;/objects:s197) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s197) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:s198) (quote pageref-url) "./objects.html#./objects:s198") +(putprop (quote \x2E;/objects:s198) (quote ref) "6.6") +(putprop (quote \x2E;/objects:s198) (quote ref-url) "./objects.html#g112") +(putprop (quote \x2E;/objects:h7) (quote pageref-url) "./objects.html#./objects:h7") +(putprop (quote \x2E;/objects:h7) (quote ref) "6.7") +(putprop (quote \x2E;/objects:h7) (quote ref-url) "./objects.html#g113") +(putprop (quote SECTCHARACTERS) (quote pageref-url) "./objects.html#SECTCHARACTERS") +(putprop (quote SECTCHARACTERS) (quote ref) "6.7") +(putprop (quote SECTCHARACTERS) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s199) (quote pageref-url) "./objects.html#./objects:s199") +(putprop (quote \x2E;/objects:s199) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s199) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s200) (quote pageref-url) "./objects.html#./objects:s200") +(putprop (quote \x2E;/objects:s200) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s200) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s201) (quote pageref-url) "./objects.html#./objects:s201") +(putprop (quote \x2E;/objects:s201) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s201) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s202) (quote pageref-url) "./objects.html#./objects:s202") +(putprop (quote \x2E;/objects:s202) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s202) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s203) (quote pageref-url) "./objects.html#./objects:s203") +(putprop (quote \x2E;/objects:s203) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s203) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s204) (quote pageref-url) "./objects.html#./objects:s204") +(putprop (quote \x2E;/objects:s204) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s204) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s205) (quote pageref-url) "./objects.html#./objects:s205") +(putprop (quote \x2E;/objects:s205) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s205) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s206) (quote pageref-url) "./objects.html#./objects:s206") +(putprop (quote \x2E;/objects:s206) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s206) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s207) (quote pageref-url) "./objects.html#./objects:s207") +(putprop (quote \x2E;/objects:s207) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s207) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s208) (quote pageref-url) "./objects.html#./objects:s208") +(putprop (quote \x2E;/objects:s208) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s208) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s209) (quote pageref-url) "./objects.html#./objects:s209") +(putprop (quote \x2E;/objects:s209) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s209) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s210) (quote pageref-url) "./objects.html#./objects:s210") +(putprop (quote \x2E;/objects:s210) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s210) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:s211) (quote pageref-url) "./objects.html#./objects:s211") +(putprop (quote \x2E;/objects:s211) (quote ref) "6.7") +(putprop (quote \x2E;/objects:s211) (quote ref-url) "./objects.html#g113") +(putprop (quote \x2E;/objects:h8) (quote pageref-url) "./objects.html#./objects:h8") +(putprop (quote \x2E;/objects:h8) (quote ref) "6.8") +(putprop (quote \x2E;/objects:h8) (quote ref-url) "./objects.html#g114") +(putprop (quote SECTSTRINGS) (quote pageref-url) "./objects.html#SECTSTRINGS") +(putprop (quote SECTSTRINGS) (quote ref) "6.8") +(putprop (quote SECTSTRINGS) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s212) (quote pageref-url) "./objects.html#./objects:s212") +(putprop (quote \x2E;/objects:s212) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s212) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s213) (quote pageref-url) "./objects.html#./objects:s213") +(putprop (quote \x2E;/objects:s213) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s213) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s214) (quote pageref-url) "./objects.html#./objects:s214") +(putprop (quote \x2E;/objects:s214) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s214) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s215) (quote pageref-url) "./objects.html#./objects:s215") +(putprop (quote \x2E;/objects:s215) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s215) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s216) (quote pageref-url) "./objects.html#./objects:s216") +(putprop (quote \x2E;/objects:s216) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s216) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s217) (quote pageref-url) "./objects.html#./objects:s217") +(putprop (quote \x2E;/objects:s217) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s217) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s218) (quote pageref-url) "./objects.html#./objects:s218") +(putprop (quote \x2E;/objects:s218) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s218) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s219) (quote pageref-url) "./objects.html#./objects:s219") +(putprop (quote \x2E;/objects:s219) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s219) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s220) (quote pageref-url) "./objects.html#./objects:s220") +(putprop (quote \x2E;/objects:s220) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s220) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s221) (quote pageref-url) "./objects.html#./objects:s221") +(putprop (quote \x2E;/objects:s221) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s221) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s222) (quote pageref-url) "./objects.html#./objects:s222") +(putprop (quote \x2E;/objects:s222) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s222) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s223) (quote pageref-url) "./objects.html#./objects:s223") +(putprop (quote \x2E;/objects:s223) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s223) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s224) (quote pageref-url) "./objects.html#./objects:s224") +(putprop (quote \x2E;/objects:s224) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s224) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s225) (quote pageref-url) "./objects.html#./objects:s225") +(putprop (quote \x2E;/objects:s225) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s225) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s226) (quote pageref-url) "./objects.html#./objects:s226") +(putprop (quote \x2E;/objects:s226) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s226) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s227) (quote pageref-url) "./objects.html#./objects:s227") +(putprop (quote \x2E;/objects:s227) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s227) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s228) (quote pageref-url) "./objects.html#./objects:s228") +(putprop (quote \x2E;/objects:s228) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s228) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:s229) (quote pageref-url) "./objects.html#./objects:s229") +(putprop (quote \x2E;/objects:s229) (quote ref) "6.8") +(putprop (quote \x2E;/objects:s229) (quote ref-url) "./objects.html#g114") +(putprop (quote \x2E;/objects:h9) (quote pageref-url) "./objects.html#./objects:h9") +(putprop (quote \x2E;/objects:h9) (quote ref) "6.9") +(putprop (quote \x2E;/objects:h9) (quote ref-url) "./objects.html#g115") +(putprop (quote SECTVECTORS) (quote pageref-url) "./objects.html#SECTVECTORS") +(putprop (quote SECTVECTORS) (quote ref) "6.9") +(putprop (quote SECTVECTORS) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s230) (quote pageref-url) "./objects.html#./objects:s230") +(putprop (quote \x2E;/objects:s230) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s230) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s231) (quote pageref-url) "./objects.html#./objects:s231") +(putprop (quote \x2E;/objects:s231) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s231) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s232) (quote pageref-url) "./objects.html#./objects:s232") +(putprop (quote \x2E;/objects:s232) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s232) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s233) (quote pageref-url) "./objects.html#./objects:s233") +(putprop (quote \x2E;/objects:s233) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s233) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s234) (quote pageref-url) "./objects.html#./objects:s234") +(putprop (quote \x2E;/objects:s234) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s234) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s235) (quote pageref-url) "./objects.html#./objects:s235") +(putprop (quote \x2E;/objects:s235) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s235) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s236) (quote pageref-url) "./objects.html#./objects:s236") +(putprop (quote \x2E;/objects:s236) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s236) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s237) (quote pageref-url) "./objects.html#./objects:s237") +(putprop (quote \x2E;/objects:s237) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s237) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s238) (quote pageref-url) "./objects.html#./objects:s238") +(putprop (quote \x2E;/objects:s238) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s238) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:s239) (quote pageref-url) "./objects.html#./objects:s239") +(putprop (quote \x2E;/objects:s239) (quote ref) "6.9") +(putprop (quote \x2E;/objects:s239) (quote ref-url) "./objects.html#g115") +(putprop (quote \x2E;/objects:h10) (quote pageref-url) "./objects.html#./objects:h10") +(putprop (quote \x2E;/objects:h10) (quote ref) "6.10") +(putprop (quote \x2E;/objects:h10) (quote ref-url) "./objects.html#g116") +(putprop (quote SECTBYTEVECTORS) (quote pageref-url) "./objects.html#SECTBYTEVECTORS") +(putprop (quote SECTBYTEVECTORS) (quote ref) "6.10") +(putprop (quote SECTBYTEVECTORS) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s240) (quote pageref-url) "./objects.html#./objects:s240") +(putprop (quote \x2E;/objects:s240) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s240) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s241) (quote pageref-url) "./objects.html#./objects:s241") +(putprop (quote \x2E;/objects:s241) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s241) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s242) (quote pageref-url) "./objects.html#./objects:s242") +(putprop (quote \x2E;/objects:s242) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s242) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s243) (quote pageref-url) "./objects.html#./objects:s243") +(putprop (quote \x2E;/objects:s243) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s243) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s244) (quote pageref-url) "./objects.html#./objects:s244") +(putprop (quote \x2E;/objects:s244) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s244) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s245) (quote pageref-url) "./objects.html#./objects:s245") +(putprop (quote \x2E;/objects:s245) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s245) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s246) (quote pageref-url) "./objects.html#./objects:s246") +(putprop (quote \x2E;/objects:s246) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s246) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s247) (quote pageref-url) "./objects.html#./objects:s247") +(putprop (quote \x2E;/objects:s247) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s247) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s248) (quote pageref-url) "./objects.html#./objects:s248") +(putprop (quote \x2E;/objects:s248) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s248) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s249) (quote pageref-url) "./objects.html#./objects:s249") +(putprop (quote \x2E;/objects:s249) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s249) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s250) (quote pageref-url) "./objects.html#./objects:s250") +(putprop (quote \x2E;/objects:s250) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s250) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s251) (quote pageref-url) "./objects.html#./objects:s251") +(putprop (quote \x2E;/objects:s251) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s251) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s252) (quote pageref-url) "./objects.html#./objects:s252") +(putprop (quote \x2E;/objects:s252) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s252) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s253) (quote pageref-url) "./objects.html#./objects:s253") +(putprop (quote \x2E;/objects:s253) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s253) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s254) (quote pageref-url) "./objects.html#./objects:s254") +(putprop (quote \x2E;/objects:s254) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s254) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s255) (quote pageref-url) "./objects.html#./objects:s255") +(putprop (quote \x2E;/objects:s255) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s255) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s256) (quote pageref-url) "./objects.html#./objects:s256") +(putprop (quote \x2E;/objects:s256) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s256) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s257) (quote pageref-url) "./objects.html#./objects:s257") +(putprop (quote \x2E;/objects:s257) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s257) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s258) (quote pageref-url) "./objects.html#./objects:s258") +(putprop (quote \x2E;/objects:s258) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s258) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s259) (quote pageref-url) "./objects.html#./objects:s259") +(putprop (quote \x2E;/objects:s259) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s259) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s260) (quote pageref-url) "./objects.html#./objects:s260") +(putprop (quote \x2E;/objects:s260) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s260) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s261) (quote pageref-url) "./objects.html#./objects:s261") +(putprop (quote \x2E;/objects:s261) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s261) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s262) (quote pageref-url) "./objects.html#./objects:s262") +(putprop (quote \x2E;/objects:s262) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s262) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s263) (quote pageref-url) "./objects.html#./objects:s263") +(putprop (quote \x2E;/objects:s263) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s263) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s264) (quote pageref-url) "./objects.html#./objects:s264") +(putprop (quote \x2E;/objects:s264) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s264) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:s265) (quote pageref-url) "./objects.html#./objects:s265") +(putprop (quote \x2E;/objects:s265) (quote ref) "6.10") +(putprop (quote \x2E;/objects:s265) (quote ref-url) "./objects.html#g116") +(putprop (quote \x2E;/objects:h11) (quote pageref-url) "./objects.html#./objects:h11") +(putprop (quote \x2E;/objects:h11) (quote ref) "6.11") +(putprop (quote \x2E;/objects:h11) (quote ref-url) "./objects.html#g117") +(putprop (quote SECTSYMBOLS) (quote pageref-url) "./objects.html#SECTSYMBOLS") +(putprop (quote SECTSYMBOLS) (quote ref) "6.11") +(putprop (quote SECTSYMBOLS) (quote ref-url) "./objects.html#g117") +(putprop (quote \x2E;/objects:s266) (quote pageref-url) "./objects.html#./objects:s266") +(putprop (quote \x2E;/objects:s266) (quote ref) "6.11") +(putprop (quote \x2E;/objects:s266) (quote ref-url) "./objects.html#g117") +(putprop (quote \x2E;/objects:s267) (quote pageref-url) "./objects.html#./objects:s267") +(putprop (quote \x2E;/objects:s267) (quote ref) "6.11") +(putprop (quote \x2E;/objects:s267) (quote ref-url) "./objects.html#g117") +(putprop (quote \x2E;/objects:s268) (quote pageref-url) "./objects.html#./objects:s268") +(putprop (quote \x2E;/objects:s268) (quote ref) "6.11") +(putprop (quote \x2E;/objects:s268) (quote ref-url) "./objects.html#g117") +(putprop (quote \x2E;/objects:s269) (quote pageref-url) "./objects.html#./objects:s269") +(putprop (quote \x2E;/objects:s269) (quote ref) "6.11") +(putprop (quote \x2E;/objects:s269) (quote ref-url) "./objects.html#g117") +(putprop (quote \x2E;/objects:s270) (quote pageref-url) "./objects.html#./objects:s270") +(putprop (quote \x2E;/objects:s270) (quote ref) "6.11") +(putprop (quote \x2E;/objects:s270) (quote ref-url) "./objects.html#g117") +(putprop (quote \x2E;/objects:h12) (quote pageref-url) "./objects.html#./objects:h12") +(putprop (quote \x2E;/objects:h12) (quote ref) "6.12") +(putprop (quote \x2E;/objects:h12) (quote ref-url) "./objects.html#g118") +(putprop (quote SECTMISCBOOLEANS) (quote pageref-url) "./objects.html#SECTMISCBOOLEANS") +(putprop (quote SECTMISCBOOLEANS) (quote ref) "6.12") +(putprop (quote SECTMISCBOOLEANS) (quote ref-url) "./objects.html#g118") +(putprop (quote \x2E;/objects:s271) (quote pageref-url) "./objects.html#./objects:s271") +(putprop (quote \x2E;/objects:s271) (quote ref) "6.12") +(putprop (quote \x2E;/objects:s271) (quote ref-url) "./objects.html#g118") +(putprop (quote \x2E;/objects:h13) (quote pageref-url) "./objects.html#./objects:h13") +(putprop (quote \x2E;/objects:h13) (quote ref) "6.13") +(putprop (quote \x2E;/objects:h13) (quote ref-url) "./objects.html#g119") +(putprop (quote SECTHASHTABLES) (quote pageref-url) "./objects.html#SECTHASHTABLES") +(putprop (quote SECTHASHTABLES) (quote ref) "6.13") +(putprop (quote SECTHASHTABLES) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s272) (quote pageref-url) "./objects.html#./objects:s272") +(putprop (quote \x2E;/objects:s272) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s272) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s273) (quote pageref-url) "./objects.html#./objects:s273") +(putprop (quote \x2E;/objects:s273) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s273) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s274) (quote pageref-url) "./objects.html#./objects:s274") +(putprop (quote \x2E;/objects:s274) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s274) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s275) (quote pageref-url) "./objects.html#./objects:s275") +(putprop (quote \x2E;/objects:s275) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s275) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s276) (quote pageref-url) "./objects.html#./objects:s276") +(putprop (quote \x2E;/objects:s276) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s276) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s277) (quote pageref-url) "./objects.html#./objects:s277") +(putprop (quote \x2E;/objects:s277) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s277) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s278) (quote pageref-url) "./objects.html#./objects:s278") +(putprop (quote \x2E;/objects:s278) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s278) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s279) (quote pageref-url) "./objects.html#./objects:s279") +(putprop (quote \x2E;/objects:s279) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s279) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s280) (quote pageref-url) "./objects.html#./objects:s280") +(putprop (quote \x2E;/objects:s280) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s280) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s281) (quote pageref-url) "./objects.html#./objects:s281") +(putprop (quote \x2E;/objects:s281) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s281) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s282) (quote pageref-url) "./objects.html#./objects:s282") +(putprop (quote \x2E;/objects:s282) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s282) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s283) (quote pageref-url) "./objects.html#./objects:s283") +(putprop (quote \x2E;/objects:s283) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s283) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s284) (quote pageref-url) "./objects.html#./objects:s284") +(putprop (quote \x2E;/objects:s284) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s284) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s285) (quote pageref-url) "./objects.html#./objects:s285") +(putprop (quote \x2E;/objects:s285) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s285) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s286) (quote pageref-url) "./objects.html#./objects:s286") +(putprop (quote \x2E;/objects:s286) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s286) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s287) (quote pageref-url) "./objects.html#./objects:s287") +(putprop (quote \x2E;/objects:s287) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s287) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s288) (quote pageref-url) "./objects.html#./objects:s288") +(putprop (quote \x2E;/objects:s288) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s288) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:s289) (quote pageref-url) "./objects.html#./objects:s289") +(putprop (quote \x2E;/objects:s289) (quote ref) "6.13") +(putprop (quote \x2E;/objects:s289) (quote ref-url) "./objects.html#g119") +(putprop (quote \x2E;/objects:h14) (quote pageref-url) "./objects.html#./objects:h14") +(putprop (quote \x2E;/objects:h14) (quote ref) "6.14") +(putprop (quote \x2E;/objects:h14) (quote ref-url) "./objects.html#g120") +(putprop (quote SECTENUMERATIONS) (quote pageref-url) "./objects.html#SECTENUMERATIONS") +(putprop (quote SECTENUMERATIONS) (quote ref) "6.14") +(putprop (quote SECTENUMERATIONS) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s290) (quote pageref-url) "./objects.html#./objects:s290") +(putprop (quote \x2E;/objects:s290) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s290) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s291) (quote pageref-url) "./objects.html#./objects:s291") +(putprop (quote \x2E;/objects:s291) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s291) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s292) (quote pageref-url) "./objects.html#./objects:s292") +(putprop (quote \x2E;/objects:s292) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s292) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s293) (quote pageref-url) "./objects.html#./objects:s293") +(putprop (quote \x2E;/objects:s293) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s293) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s294) (quote pageref-url) "./objects.html#./objects:s294") +(putprop (quote \x2E;/objects:s294) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s294) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s295) (quote pageref-url) "./objects.html#./objects:s295") +(putprop (quote \x2E;/objects:s295) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s295) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s296) (quote pageref-url) "./objects.html#./objects:s296") +(putprop (quote \x2E;/objects:s296) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s296) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s297) (quote pageref-url) "./objects.html#./objects:s297") +(putprop (quote \x2E;/objects:s297) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s297) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s298) (quote pageref-url) "./objects.html#./objects:s298") +(putprop (quote \x2E;/objects:s298) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s298) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s299) (quote pageref-url) "./objects.html#./objects:s299") +(putprop (quote \x2E;/objects:s299) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s299) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s300) (quote pageref-url) "./objects.html#./objects:s300") +(putprop (quote \x2E;/objects:s300) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s300) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/objects:s301) (quote pageref-url) "./objects.html#./objects:s301") +(putprop (quote \x2E;/objects:s301) (quote ref) "6.14") +(putprop (quote \x2E;/objects:s301) (quote ref-url) "./objects.html#g120") +(putprop (quote \x2E;/io:h0) (quote pageref-url) "./io.html#./io:h0") +(putprop (quote \x2E;/io:h0) (quote ref) "7") +(putprop (quote \x2E;/io:h0) (quote ref-url) "./io.html#g121") +(putprop (quote CHPTIO) (quote pageref-url) "./io.html#CHPTIO") +(putprop (quote CHPTIO) (quote ref) "7") +(putprop (quote CHPTIO) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s0) (quote pageref-url) "./io.html#./io:s0") +(putprop (quote \x2E;/io:s0) (quote ref) "7") +(putprop (quote \x2E;/io:s0) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s1) (quote pageref-url) "./io.html#./io:s1") +(putprop (quote \x2E;/io:s1) (quote ref) "7") +(putprop (quote \x2E;/io:s1) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s2) (quote pageref-url) "./io.html#./io:s2") +(putprop (quote \x2E;/io:s2) (quote ref) "7") +(putprop (quote \x2E;/io:s2) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s3) (quote pageref-url) "./io.html#./io:s3") +(putprop (quote \x2E;/io:s3) (quote ref) "7") +(putprop (quote \x2E;/io:s3) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s4) (quote pageref-url) "./io.html#./io:s4") +(putprop (quote \x2E;/io:s4) (quote ref) "7") +(putprop (quote \x2E;/io:s4) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s5) (quote pageref-url) "./io.html#./io:s5") +(putprop (quote \x2E;/io:s5) (quote ref) "7") +(putprop (quote \x2E;/io:s5) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s6) (quote pageref-url) "./io.html#./io:s6") +(putprop (quote \x2E;/io:s6) (quote ref) "7") +(putprop (quote \x2E;/io:s6) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s7) (quote pageref-url) "./io.html#./io:s7") +(putprop (quote \x2E;/io:s7) (quote ref) "7") +(putprop (quote \x2E;/io:s7) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s8) (quote pageref-url) "./io.html#./io:s8") +(putprop (quote \x2E;/io:s8) (quote ref) "7") +(putprop (quote \x2E;/io:s8) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s9) (quote pageref-url) "./io.html#./io:s9") +(putprop (quote \x2E;/io:s9) (quote ref) "7") +(putprop (quote \x2E;/io:s9) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s10) (quote pageref-url) "./io.html#./io:s10") +(putprop (quote \x2E;/io:s10) (quote ref) "7") +(putprop (quote \x2E;/io:s10) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s11) (quote pageref-url) "./io.html#./io:s11") +(putprop (quote \x2E;/io:s11) (quote ref) "7") +(putprop (quote \x2E;/io:s11) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s12) (quote pageref-url) "./io.html#./io:s12") +(putprop (quote \x2E;/io:s12) (quote ref) "7") +(putprop (quote \x2E;/io:s12) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s13) (quote pageref-url) "./io.html#./io:s13") +(putprop (quote \x2E;/io:s13) (quote ref) "7") +(putprop (quote \x2E;/io:s13) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s14) (quote pageref-url) "./io.html#./io:s14") +(putprop (quote \x2E;/io:s14) (quote ref) "7") +(putprop (quote \x2E;/io:s14) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s15) (quote pageref-url) "./io.html#./io:s15") +(putprop (quote \x2E;/io:s15) (quote ref) "7") +(putprop (quote \x2E;/io:s15) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s16) (quote pageref-url) "./io.html#./io:s16") +(putprop (quote \x2E;/io:s16) (quote ref) "7") +(putprop (quote \x2E;/io:s16) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s17) (quote pageref-url) "./io.html#./io:s17") +(putprop (quote \x2E;/io:s17) (quote ref) "7") +(putprop (quote \x2E;/io:s17) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:s18) (quote pageref-url) "./io.html#./io:s18") +(putprop (quote \x2E;/io:s18) (quote ref) "7") +(putprop (quote \x2E;/io:s18) (quote ref-url) "./io.html#g121") +(putprop (quote \x2E;/io:h1) (quote pageref-url) "./io.html#./io:h1") +(putprop (quote \x2E;/io:h1) (quote ref) "7.1") +(putprop (quote \x2E;/io:h1) (quote ref-url) "./io.html#g122") +(putprop (quote SECTTRANSCODERS) (quote pageref-url) "./io.html#SECTTRANSCODERS") +(putprop (quote SECTTRANSCODERS) (quote ref) "7.1") +(putprop (quote SECTTRANSCODERS) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s19) (quote pageref-url) "./io.html#./io:s19") +(putprop (quote \x2E;/io:s19) (quote ref) "7.1") +(putprop (quote \x2E;/io:s19) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s20) (quote pageref-url) "./io.html#./io:s20") +(putprop (quote \x2E;/io:s20) (quote ref) "7.1") +(putprop (quote \x2E;/io:s20) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s21) (quote pageref-url) "./io.html#./io:s21") +(putprop (quote \x2E;/io:s21) (quote ref) "7.1") +(putprop (quote \x2E;/io:s21) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s22) (quote pageref-url) "./io.html#./io:s22") +(putprop (quote \x2E;/io:s22) (quote ref) "7.1") +(putprop (quote \x2E;/io:s22) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s23) (quote pageref-url) "./io.html#./io:s23") +(putprop (quote \x2E;/io:s23) (quote ref) "7.1") +(putprop (quote \x2E;/io:s23) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s24) (quote pageref-url) "./io.html#./io:s24") +(putprop (quote \x2E;/io:s24) (quote ref) "7.1") +(putprop (quote \x2E;/io:s24) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:s25) (quote pageref-url) "./io.html#./io:s25") +(putprop (quote \x2E;/io:s25) (quote ref) "7.1") +(putprop (quote \x2E;/io:s25) (quote ref-url) "./io.html#g122") +(putprop (quote \x2E;/io:h2) (quote pageref-url) "./io.html#./io:h2") +(putprop (quote \x2E;/io:h2) (quote ref) "7.2") +(putprop (quote \x2E;/io:h2) (quote ref-url) "./io.html#g123") +(putprop (quote SECTOPENINGFILES) (quote pageref-url) "./io.html#SECTOPENINGFILES") +(putprop (quote SECTOPENINGFILES) (quote ref) "7.2") +(putprop (quote SECTOPENINGFILES) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:s26) (quote pageref-url) "./io.html#./io:s26") +(putprop (quote \x2E;/io:s26) (quote ref) "7.2") +(putprop (quote \x2E;/io:s26) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:s27) (quote pageref-url) "./io.html#./io:s27") +(putprop (quote \x2E;/io:s27) (quote ref) "7.2") +(putprop (quote \x2E;/io:s27) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:s28) (quote pageref-url) "./io.html#./io:s28") +(putprop (quote \x2E;/io:s28) (quote ref) "7.2") +(putprop (quote \x2E;/io:s28) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:s29) (quote pageref-url) "./io.html#./io:s29") +(putprop (quote \x2E;/io:s29) (quote ref) "7.2") +(putprop (quote \x2E;/io:s29) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:s30) (quote pageref-url) "./io.html#./io:s30") +(putprop (quote \x2E;/io:s30) (quote ref) "7.2") +(putprop (quote \x2E;/io:s30) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:s31) (quote pageref-url) "./io.html#./io:s31") +(putprop (quote \x2E;/io:s31) (quote ref) "7.2") +(putprop (quote \x2E;/io:s31) (quote ref-url) "./io.html#g123") +(putprop (quote \x2E;/io:h3) (quote pageref-url) "./io.html#./io:h3") +(putprop (quote \x2E;/io:h3) (quote ref) "7.3") +(putprop (quote \x2E;/io:h3) (quote ref-url) "./io.html#g124") +(putprop (quote SECTSTANDARDPORTS) (quote pageref-url) "./io.html#SECTSTANDARDPORTS") +(putprop (quote SECTSTANDARDPORTS) (quote ref) "7.3") +(putprop (quote SECTSTANDARDPORTS) (quote ref-url) "./io.html#g124") +(putprop (quote \x2E;/io:s32) (quote pageref-url) "./io.html#./io:s32") +(putprop (quote \x2E;/io:s32) (quote ref) "7.3") +(putprop (quote \x2E;/io:s32) (quote ref-url) "./io.html#g124") +(putprop (quote \x2E;/io:s33) (quote pageref-url) "./io.html#./io:s33") +(putprop (quote \x2E;/io:s33) (quote ref) "7.3") +(putprop (quote \x2E;/io:s33) (quote ref-url) "./io.html#g124") +(putprop (quote \x2E;/io:h4) (quote pageref-url) "./io.html#./io:h4") +(putprop (quote \x2E;/io:h4) (quote ref) "7.4") +(putprop (quote \x2E;/io:h4) (quote ref-url) "./io.html#g125") +(putprop (quote SECTSTRINGPORTS) (quote pageref-url) "./io.html#SECTSTRINGPORTS") +(putprop (quote SECTSTRINGPORTS) (quote ref) "7.4") +(putprop (quote SECTSTRINGPORTS) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s34) (quote pageref-url) "./io.html#./io:s34") +(putprop (quote \x2E;/io:s34) (quote ref) "7.4") +(putprop (quote \x2E;/io:s34) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s35) (quote pageref-url) "./io.html#./io:s35") +(putprop (quote \x2E;/io:s35) (quote ref) "7.4") +(putprop (quote \x2E;/io:s35) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s36) (quote pageref-url) "./io.html#./io:s36") +(putprop (quote \x2E;/io:s36) (quote ref) "7.4") +(putprop (quote \x2E;/io:s36) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s37) (quote pageref-url) "./io.html#./io:s37") +(putprop (quote \x2E;/io:s37) (quote ref) "7.4") +(putprop (quote \x2E;/io:s37) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s38) (quote pageref-url) "./io.html#./io:s38") +(putprop (quote \x2E;/io:s38) (quote ref) "7.4") +(putprop (quote \x2E;/io:s38) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s39) (quote pageref-url) "./io.html#./io:s39") +(putprop (quote \x2E;/io:s39) (quote ref) "7.4") +(putprop (quote \x2E;/io:s39) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:s40) (quote pageref-url) "./io.html#./io:s40") +(putprop (quote \x2E;/io:s40) (quote ref) "7.4") +(putprop (quote \x2E;/io:s40) (quote ref-url) "./io.html#g125") +(putprop (quote \x2E;/io:h5) (quote pageref-url) "./io.html#./io:h5") +(putprop (quote \x2E;/io:h5) (quote ref) "7.5") +(putprop (quote \x2E;/io:h5) (quote ref-url) "./io.html#g126") +(putprop (quote SECTCUSTOMPORTS) (quote pageref-url) "./io.html#SECTCUSTOMPORTS") +(putprop (quote SECTCUSTOMPORTS) (quote ref) "7.5") +(putprop (quote SECTCUSTOMPORTS) (quote ref-url) "./io.html#g126") +(putprop (quote \x2E;/io:s41) (quote pageref-url) "./io.html#./io:s41") +(putprop (quote \x2E;/io:s41) (quote ref) "7.5") +(putprop (quote \x2E;/io:s41) (quote ref-url) "./io.html#g126") +(putprop (quote \x2E;/io:s42) (quote pageref-url) "./io.html#./io:s42") +(putprop (quote \x2E;/io:s42) (quote ref) "7.5") +(putprop (quote \x2E;/io:s42) (quote ref-url) "./io.html#g126") +(putprop (quote \x2E;/io:h6) (quote pageref-url) "./io.html#./io:h6") +(putprop (quote \x2E;/io:h6) (quote ref) "7.6") +(putprop (quote \x2E;/io:h6) (quote ref-url) "./io.html#g127") +(putprop (quote SECTPORTOPERATIONS) (quote pageref-url) "./io.html#SECTPORTOPERATIONS") +(putprop (quote SECTPORTOPERATIONS) (quote ref) "7.6") +(putprop (quote SECTPORTOPERATIONS) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s43) (quote pageref-url) "./io.html#./io:s43") +(putprop (quote \x2E;/io:s43) (quote ref) "7.6") +(putprop (quote \x2E;/io:s43) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s44) (quote pageref-url) "./io.html#./io:s44") +(putprop (quote \x2E;/io:s44) (quote ref) "7.6") +(putprop (quote \x2E;/io:s44) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s45) (quote pageref-url) "./io.html#./io:s45") +(putprop (quote \x2E;/io:s45) (quote ref) "7.6") +(putprop (quote \x2E;/io:s45) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s46) (quote pageref-url) "./io.html#./io:s46") +(putprop (quote \x2E;/io:s46) (quote ref) "7.6") +(putprop (quote \x2E;/io:s46) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s47) (quote pageref-url) "./io.html#./io:s47") +(putprop (quote \x2E;/io:s47) (quote ref) "7.6") +(putprop (quote \x2E;/io:s47) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s48) (quote pageref-url) "./io.html#./io:s48") +(putprop (quote \x2E;/io:s48) (quote ref) "7.6") +(putprop (quote \x2E;/io:s48) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s49) (quote pageref-url) "./io.html#./io:s49") +(putprop (quote \x2E;/io:s49) (quote ref) "7.6") +(putprop (quote \x2E;/io:s49) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s50) (quote pageref-url) "./io.html#./io:s50") +(putprop (quote \x2E;/io:s50) (quote ref) "7.6") +(putprop (quote \x2E;/io:s50) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s51) (quote pageref-url) "./io.html#./io:s51") +(putprop (quote \x2E;/io:s51) (quote ref) "7.6") +(putprop (quote \x2E;/io:s51) (quote ref-url) "./io.html#g127") +(putprop (quote desc:call-with-port) (quote pageref-url) "./io.html#desc:call-with-port") +(putprop (quote desc:call-with-port) (quote ref) "7.6") +(putprop (quote desc:call-with-port) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:s52) (quote pageref-url) "./io.html#./io:s52") +(putprop (quote \x2E;/io:s52) (quote ref) "7.6") +(putprop (quote \x2E;/io:s52) (quote ref-url) "./io.html#g127") +(putprop (quote \x2E;/io:h7) (quote pageref-url) "./io.html#./io:h7") +(putprop (quote \x2E;/io:h7) (quote ref) "7.7") +(putprop (quote \x2E;/io:h7) (quote ref-url) "./io.html#g128") +(putprop (quote SECTINPUT) (quote pageref-url) "./io.html#SECTINPUT") +(putprop (quote SECTINPUT) (quote ref) "7.7") +(putprop (quote SECTINPUT) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s53) (quote pageref-url) "./io.html#./io:s53") +(putprop (quote \x2E;/io:s53) (quote ref) "7.7") +(putprop (quote \x2E;/io:s53) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s54) (quote pageref-url) "./io.html#./io:s54") +(putprop (quote \x2E;/io:s54) (quote ref) "7.7") +(putprop (quote \x2E;/io:s54) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s55) (quote pageref-url) "./io.html#./io:s55") +(putprop (quote \x2E;/io:s55) (quote ref) "7.7") +(putprop (quote \x2E;/io:s55) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s56) (quote pageref-url) "./io.html#./io:s56") +(putprop (quote \x2E;/io:s56) (quote ref) "7.7") +(putprop (quote \x2E;/io:s56) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s57) (quote pageref-url) "./io.html#./io:s57") +(putprop (quote \x2E;/io:s57) (quote ref) "7.7") +(putprop (quote \x2E;/io:s57) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s58) (quote pageref-url) "./io.html#./io:s58") +(putprop (quote \x2E;/io:s58) (quote ref) "7.7") +(putprop (quote \x2E;/io:s58) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s59) (quote pageref-url) "./io.html#./io:s59") +(putprop (quote \x2E;/io:s59) (quote ref) "7.7") +(putprop (quote \x2E;/io:s59) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s60) (quote pageref-url) "./io.html#./io:s60") +(putprop (quote \x2E;/io:s60) (quote ref) "7.7") +(putprop (quote \x2E;/io:s60) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s61) (quote pageref-url) "./io.html#./io:s61") +(putprop (quote \x2E;/io:s61) (quote ref) "7.7") +(putprop (quote \x2E;/io:s61) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s62) (quote pageref-url) "./io.html#./io:s62") +(putprop (quote \x2E;/io:s62) (quote ref) "7.7") +(putprop (quote \x2E;/io:s62) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s63) (quote pageref-url) "./io.html#./io:s63") +(putprop (quote \x2E;/io:s63) (quote ref) "7.7") +(putprop (quote \x2E;/io:s63) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s64) (quote pageref-url) "./io.html#./io:s64") +(putprop (quote \x2E;/io:s64) (quote ref) "7.7") +(putprop (quote \x2E;/io:s64) (quote ref-url) "./io.html#g128") +(putprop (quote backdoor-string-fill) (quote pageref-url) "./io.html#backdoor-string-fill") +(putprop (quote backdoor-string-fill) (quote ref) "7.7") +(putprop (quote backdoor-string-fill) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s65) (quote pageref-url) "./io.html#./io:s65") +(putprop (quote \x2E;/io:s65) (quote ref) "7.7") +(putprop (quote \x2E;/io:s65) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s66) (quote pageref-url) "./io.html#./io:s66") +(putprop (quote \x2E;/io:s66) (quote ref) "7.7") +(putprop (quote \x2E;/io:s66) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s67) (quote pageref-url) "./io.html#./io:s67") +(putprop (quote \x2E;/io:s67) (quote ref) "7.7") +(putprop (quote \x2E;/io:s67) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:s68) (quote pageref-url) "./io.html#./io:s68") +(putprop (quote \x2E;/io:s68) (quote ref) "7.7") +(putprop (quote \x2E;/io:s68) (quote ref-url) "./io.html#g128") +(putprop (quote \x2E;/io:h8) (quote pageref-url) "./io.html#./io:h8") +(putprop (quote \x2E;/io:h8) (quote ref) "7.8") +(putprop (quote \x2E;/io:h8) (quote ref-url) "./io.html#g129") +(putprop (quote SECTOUTPUT) (quote pageref-url) "./io.html#SECTOUTPUT") +(putprop (quote SECTOUTPUT) (quote ref) "7.8") +(putprop (quote SECTOUTPUT) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:s69) (quote pageref-url) "./io.html#./io:s69") +(putprop (quote \x2E;/io:s69) (quote ref) "7.8") +(putprop (quote \x2E;/io:s69) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:s70) (quote pageref-url) "./io.html#./io:s70") +(putprop (quote \x2E;/io:s70) (quote ref) "7.8") +(putprop (quote \x2E;/io:s70) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:s71) (quote pageref-url) "./io.html#./io:s71") +(putprop (quote \x2E;/io:s71) (quote ref) "7.8") +(putprop (quote \x2E;/io:s71) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:s72) (quote pageref-url) "./io.html#./io:s72") +(putprop (quote \x2E;/io:s72) (quote ref) "7.8") +(putprop (quote \x2E;/io:s72) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:s73) (quote pageref-url) "./io.html#./io:s73") +(putprop (quote \x2E;/io:s73) (quote ref) "7.8") +(putprop (quote \x2E;/io:s73) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:s74) (quote pageref-url) "./io.html#./io:s74") +(putprop (quote \x2E;/io:s74) (quote ref) "7.8") +(putprop (quote \x2E;/io:s74) (quote ref-url) "./io.html#g129") +(putprop (quote \x2E;/io:h9) (quote pageref-url) "./io.html#./io:h9") +(putprop (quote \x2E;/io:h9) (quote ref) "7.9") +(putprop (quote \x2E;/io:h9) (quote ref-url) "./io.html#g130") +(putprop (quote SECTCONVENIENCE) (quote pageref-url) "./io.html#SECTCONVENIENCE") +(putprop (quote SECTCONVENIENCE) (quote ref) "7.9") +(putprop (quote SECTCONVENIENCE) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s75) (quote pageref-url) "./io.html#./io:s75") +(putprop (quote \x2E;/io:s75) (quote ref) "7.9") +(putprop (quote \x2E;/io:s75) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s76) (quote pageref-url) "./io.html#./io:s76") +(putprop (quote \x2E;/io:s76) (quote ref) "7.9") +(putprop (quote \x2E;/io:s76) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s77) (quote pageref-url) "./io.html#./io:s77") +(putprop (quote \x2E;/io:s77) (quote ref) "7.9") +(putprop (quote \x2E;/io:s77) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s78) (quote pageref-url) "./io.html#./io:s78") +(putprop (quote \x2E;/io:s78) (quote ref) "7.9") +(putprop (quote \x2E;/io:s78) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s79) (quote pageref-url) "./io.html#./io:s79") +(putprop (quote \x2E;/io:s79) (quote ref) "7.9") +(putprop (quote \x2E;/io:s79) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s80) (quote pageref-url) "./io.html#./io:s80") +(putprop (quote \x2E;/io:s80) (quote ref) "7.9") +(putprop (quote \x2E;/io:s80) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s81) (quote pageref-url) "./io.html#./io:s81") +(putprop (quote \x2E;/io:s81) (quote ref) "7.9") +(putprop (quote \x2E;/io:s81) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s82) (quote pageref-url) "./io.html#./io:s82") +(putprop (quote \x2E;/io:s82) (quote ref) "7.9") +(putprop (quote \x2E;/io:s82) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s83) (quote pageref-url) "./io.html#./io:s83") +(putprop (quote \x2E;/io:s83) (quote ref) "7.9") +(putprop (quote \x2E;/io:s83) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s84) (quote pageref-url) "./io.html#./io:s84") +(putprop (quote \x2E;/io:s84) (quote ref) "7.9") +(putprop (quote \x2E;/io:s84) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s85) (quote pageref-url) "./io.html#./io:s85") +(putprop (quote \x2E;/io:s85) (quote ref) "7.9") +(putprop (quote \x2E;/io:s85) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s86) (quote pageref-url) "./io.html#./io:s86") +(putprop (quote \x2E;/io:s86) (quote ref) "7.9") +(putprop (quote \x2E;/io:s86) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s87) (quote pageref-url) "./io.html#./io:s87") +(putprop (quote \x2E;/io:s87) (quote ref) "7.9") +(putprop (quote \x2E;/io:s87) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:s88) (quote pageref-url) "./io.html#./io:s88") +(putprop (quote \x2E;/io:s88) (quote ref) "7.9") +(putprop (quote \x2E;/io:s88) (quote ref-url) "./io.html#g130") +(putprop (quote \x2E;/io:h10) (quote pageref-url) "./io.html#./io:h10") +(putprop (quote \x2E;/io:h10) (quote ref) "7.10") +(putprop (quote \x2E;/io:h10) (quote ref-url) "./io.html#g131") +(putprop (quote SECTFILESYSTEM) (quote pageref-url) "./io.html#SECTFILESYSTEM") +(putprop (quote SECTFILESYSTEM) (quote ref) "7.10") +(putprop (quote SECTFILESYSTEM) (quote ref-url) "./io.html#g131") +(putprop (quote \x2E;/io:s89) (quote pageref-url) "./io.html#./io:s89") +(putprop (quote \x2E;/io:s89) (quote ref) "7.10") +(putprop (quote \x2E;/io:s89) (quote ref-url) "./io.html#g131") +(putprop (quote \x2E;/io:s90) (quote pageref-url) "./io.html#./io:s90") +(putprop (quote \x2E;/io:s90) (quote ref) "7.10") +(putprop (quote \x2E;/io:s90) (quote ref-url) "./io.html#g131") +(putprop (quote \x2E;/io:h11) (quote pageref-url) "./io.html#./io:h11") +(putprop (quote \x2E;/io:h11) (quote ref) "7.11") +(putprop (quote \x2E;/io:h11) (quote ref-url) "./io.html#g132") +(putprop (quote SECTBSCONVS) (quote pageref-url) "./io.html#SECTBSCONVS") +(putprop (quote SECTBSCONVS) (quote ref) "7.11") +(putprop (quote SECTBSCONVS) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/io:s91) (quote pageref-url) "./io.html#./io:s91") +(putprop (quote \x2E;/io:s91) (quote ref) "7.11") +(putprop (quote \x2E;/io:s91) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/io:s92) (quote pageref-url) "./io.html#./io:s92") +(putprop (quote \x2E;/io:s92) (quote ref) "7.11") +(putprop (quote \x2E;/io:s92) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/io:s93) (quote pageref-url) "./io.html#./io:s93") +(putprop (quote \x2E;/io:s93) (quote ref) "7.11") +(putprop (quote \x2E;/io:s93) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/io:s94) (quote pageref-url) "./io.html#./io:s94") +(putprop (quote \x2E;/io:s94) (quote ref) "7.11") +(putprop (quote \x2E;/io:s94) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/io:s95) (quote pageref-url) "./io.html#./io:s95") +(putprop (quote \x2E;/io:s95) (quote ref) "7.11") +(putprop (quote \x2E;/io:s95) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/io:s96) (quote pageref-url) "./io.html#./io:s96") +(putprop (quote \x2E;/io:s96) (quote ref) "7.11") +(putprop (quote \x2E;/io:s96) (quote ref-url) "./io.html#g132") +(putprop (quote \x2E;/syntax:h0) (quote pageref-url) "./syntax.html#./syntax:h0") +(putprop (quote \x2E;/syntax:h0) (quote ref) "8") +(putprop (quote \x2E;/syntax:h0) (quote ref-url) "./syntax.html#g133") +(putprop (quote CHPTSYNTAX) (quote pageref-url) "./syntax.html#CHPTSYNTAX") +(putprop (quote CHPTSYNTAX) (quote ref) "8") +(putprop (quote CHPTSYNTAX) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s0) (quote pageref-url) "./syntax.html#./syntax:s0") +(putprop (quote \x2E;/syntax:s0) (quote ref) "8") +(putprop (quote \x2E;/syntax:s0) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s1) (quote pageref-url) "./syntax.html#./syntax:s1") +(putprop (quote \x2E;/syntax:s1) (quote ref) "8") +(putprop (quote \x2E;/syntax:s1) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s2) (quote pageref-url) "./syntax.html#./syntax:s2") +(putprop (quote \x2E;/syntax:s2) (quote ref) "8") +(putprop (quote \x2E;/syntax:s2) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s3) (quote pageref-url) "./syntax.html#./syntax:s3") +(putprop (quote \x2E;/syntax:s3) (quote ref) "8") +(putprop (quote \x2E;/syntax:s3) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s4) (quote pageref-url) "./syntax.html#./syntax:s4") +(putprop (quote \x2E;/syntax:s4) (quote ref) "8") +(putprop (quote \x2E;/syntax:s4) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s5) (quote pageref-url) "./syntax.html#./syntax:s5") +(putprop (quote \x2E;/syntax:s5) (quote ref) "8") +(putprop (quote \x2E;/syntax:s5) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s6) (quote pageref-url) "./syntax.html#./syntax:s6") +(putprop (quote \x2E;/syntax:s6) (quote ref) "8") +(putprop (quote \x2E;/syntax:s6) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s7) (quote pageref-url) "./syntax.html#./syntax:s7") +(putprop (quote \x2E;/syntax:s7) (quote ref) "8") +(putprop (quote \x2E;/syntax:s7) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s8) (quote pageref-url) "./syntax.html#./syntax:s8") +(putprop (quote \x2E;/syntax:s8) (quote ref) "8") +(putprop (quote \x2E;/syntax:s8) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s9) (quote pageref-url) "./syntax.html#./syntax:s9") +(putprop (quote \x2E;/syntax:s9) (quote ref) "8") +(putprop (quote \x2E;/syntax:s9) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:s10) (quote pageref-url) "./syntax.html#./syntax:s10") +(putprop (quote \x2E;/syntax:s10) (quote ref) "8") +(putprop (quote \x2E;/syntax:s10) (quote ref-url) "./syntax.html#g133") +(putprop (quote \x2E;/syntax:h1) (quote pageref-url) "./syntax.html#./syntax:h1") +(putprop (quote \x2E;/syntax:h1) (quote ref) "8.1") +(putprop (quote \x2E;/syntax:h1) (quote ref-url) "./syntax.html#g134") +(putprop (quote SECTSYNTAXDEFINITIONS) (quote pageref-url) "./syntax.html#SECTSYNTAXDEFINITIONS") +(putprop (quote SECTSYNTAXDEFINITIONS) (quote ref) "8.1") +(putprop (quote SECTSYNTAXDEFINITIONS) (quote ref-url) "./syntax.html#g134") +(putprop (quote \x2E;/syntax:s11) (quote pageref-url) "./syntax.html#./syntax:s11") +(putprop (quote \x2E;/syntax:s11) (quote ref) "8.1") +(putprop (quote \x2E;/syntax:s11) (quote ref-url) "./syntax.html#g134") +(putprop (quote \x2E;/syntax:s12) (quote pageref-url) "./syntax.html#./syntax:s12") +(putprop (quote \x2E;/syntax:s12) (quote ref) "8.1") +(putprop (quote \x2E;/syntax:s12) (quote ref-url) "./syntax.html#g134") +(putprop (quote body-expansion) (quote pageref-url) "./syntax.html#body-expansion") +(putprop (quote body-expansion) (quote ref) "8.1") +(putprop (quote body-expansion) (quote ref-url) "./syntax.html#g134") +(putprop (quote \x2E;/syntax:s13) (quote pageref-url) "./syntax.html#./syntax:s13") +(putprop (quote \x2E;/syntax:s13) (quote ref) "8.1") +(putprop (quote \x2E;/syntax:s13) (quote ref-url) "./syntax.html#g134") +(putprop (quote letsyntaximplicitbegin) (quote pageref-url) "./syntax.html#letsyntaximplicitbegin") +(putprop (quote letsyntaximplicitbegin) (quote ref) "8.1") +(putprop (quote letsyntaximplicitbegin) (quote ref-url) "./syntax.html#g134") +(putprop (quote \x2E;/syntax:h2) (quote pageref-url) "./syntax.html#./syntax:h2") +(putprop (quote \x2E;/syntax:h2) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:h2) (quote ref-url) "./syntax.html#g135") +(putprop (quote SECTSYNTAXRULES) (quote pageref-url) "./syntax.html#SECTSYNTAXRULES") +(putprop (quote SECTSYNTAXRULES) (quote ref) "8.2") +(putprop (quote SECTSYNTAXRULES) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s14) (quote pageref-url) "./syntax.html#./syntax:s14") +(putprop (quote \x2E;/syntax:s14) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s14) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s15) (quote pageref-url) "./syntax.html#./syntax:s15") +(putprop (quote \x2E;/syntax:s15) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s15) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s16) (quote pageref-url) "./syntax.html#./syntax:s16") +(putprop (quote \x2E;/syntax:s16) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s16) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s17) (quote pageref-url) "./syntax.html#./syntax:s17") +(putprop (quote \x2E;/syntax:s17) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s17) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s18) (quote pageref-url) "./syntax.html#./syntax:s18") +(putprop (quote \x2E;/syntax:s18) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s18) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s19) (quote pageref-url) "./syntax.html#./syntax:s19") +(putprop (quote \x2E;/syntax:s19) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s19) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s20) (quote pageref-url) "./syntax.html#./syntax:s20") +(putprop (quote \x2E;/syntax:s20) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s20) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s21) (quote pageref-url) "./syntax.html#./syntax:s21") +(putprop (quote \x2E;/syntax:s21) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s21) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s22) (quote pageref-url) "./syntax.html#./syntax:s22") +(putprop (quote \x2E;/syntax:s22) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s22) (quote ref-url) "./syntax.html#g135") +(putprop (quote patterns) (quote pageref-url) "./syntax.html#patterns") +(putprop (quote patterns) (quote ref) "8.2") +(putprop (quote patterns) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s23) (quote pageref-url) "./syntax.html#./syntax:s23") +(putprop (quote \x2E;/syntax:s23) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s23) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s24) (quote pageref-url) "./syntax.html#./syntax:s24") +(putprop (quote \x2E;/syntax:s24) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s24) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s25) (quote pageref-url) "./syntax.html#./syntax:s25") +(putprop (quote \x2E;/syntax:s25) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s25) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s26) (quote pageref-url) "./syntax.html#./syntax:s26") +(putprop (quote \x2E;/syntax:s26) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s26) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s27) (quote pageref-url) "./syntax.html#./syntax:s27") +(putprop (quote \x2E;/syntax:s27) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s27) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:s28) (quote pageref-url) "./syntax.html#./syntax:s28") +(putprop (quote \x2E;/syntax:s28) (quote ref) "8.2") +(putprop (quote \x2E;/syntax:s28) (quote ref-url) "./syntax.html#g135") +(putprop (quote \x2E;/syntax:h3) (quote pageref-url) "./syntax.html#./syntax:h3") +(putprop (quote \x2E;/syntax:h3) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:h3) (quote ref-url) "./syntax.html#g136") +(putprop (quote SECTSYNTAXCASE) (quote pageref-url) "./syntax.html#SECTSYNTAXCASE") +(putprop (quote SECTSYNTAXCASE) (quote ref) "8.3") +(putprop (quote SECTSYNTAXCASE) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s29) (quote pageref-url) "./syntax.html#./syntax:s29") +(putprop (quote \x2E;/syntax:s29) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s29) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s30) (quote pageref-url) "./syntax.html#./syntax:s30") +(putprop (quote \x2E;/syntax:s30) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s30) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s31) (quote pageref-url) "./syntax.html#./syntax:s31") +(putprop (quote \x2E;/syntax:s31) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s31) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s32) (quote pageref-url) "./syntax.html#./syntax:s32") +(putprop (quote \x2E;/syntax:s32) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s32) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s33) (quote pageref-url) "./syntax.html#./syntax:s33") +(putprop (quote \x2E;/syntax:s33) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s33) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s34) (quote pageref-url) "./syntax.html#./syntax:s34") +(putprop (quote \x2E;/syntax:s34) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s34) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s35) (quote pageref-url) "./syntax.html#./syntax:s35") +(putprop (quote \x2E;/syntax:s35) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s35) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s36) (quote pageref-url) "./syntax.html#./syntax:s36") +(putprop (quote \x2E;/syntax:s36) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s36) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s37) (quote pageref-url) "./syntax.html#./syntax:s37") +(putprop (quote \x2E;/syntax:s37) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s37) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s38) (quote pageref-url) "./syntax.html#./syntax:s38") +(putprop (quote \x2E;/syntax:s38) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s38) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s39) (quote pageref-url) "./syntax.html#./syntax:s39") +(putprop (quote \x2E;/syntax:s39) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s39) (quote ref-url) "./syntax.html#g136") +(putprop (quote defn:cond) (quote pageref-url) "./syntax.html#defn:cond") +(putprop (quote defn:cond) (quote ref) "8.3") +(putprop (quote defn:cond) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s40) (quote pageref-url) "./syntax.html#./syntax:s40") +(putprop (quote \x2E;/syntax:s40) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s40) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s41) (quote pageref-url) "./syntax.html#./syntax:s41") +(putprop (quote \x2E;/syntax:s41) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s41) (quote ref-url) "./syntax.html#g136") +(putprop (quote defn:case) (quote pageref-url) "./syntax.html#defn:case") +(putprop (quote defn:case) (quote ref) "8.3") +(putprop (quote defn:case) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s42) (quote pageref-url) "./syntax.html#./syntax:s42") +(putprop (quote \x2E;/syntax:s42) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s42) (quote ref-url) "./syntax.html#g136") +(putprop (quote desc:make-variable-transformer) (quote pageref-url) "./syntax.html#desc:make-variable-transformer") +(putprop (quote desc:make-variable-transformer) (quote ref) "8.3") +(putprop (quote desc:make-variable-transformer) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s43) (quote pageref-url) "./syntax.html#./syntax:s43") +(putprop (quote \x2E;/syntax:s43) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s43) (quote ref-url) "./syntax.html#g136") +(putprop (quote defn:identifier-syntax) (quote pageref-url) "./syntax.html#defn:identifier-syntax") +(putprop (quote defn:identifier-syntax) (quote ref) "8.3") +(putprop (quote defn:identifier-syntax) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s44) (quote pageref-url) "./syntax.html#./syntax:s44") +(putprop (quote \x2E;/syntax:s44) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s44) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s45) (quote pageref-url) "./syntax.html#./syntax:s45") +(putprop (quote \x2E;/syntax:s45) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s45) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s46) (quote pageref-url) "./syntax.html#./syntax:s46") +(putprop (quote \x2E;/syntax:s46) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s46) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s47) (quote pageref-url) "./syntax.html#./syntax:s47") +(putprop (quote \x2E;/syntax:s47) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s47) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s48) (quote pageref-url) "./syntax.html#./syntax:s48") +(putprop (quote \x2E;/syntax:s48) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s48) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s49) (quote pageref-url) "./syntax.html#./syntax:s49") +(putprop (quote \x2E;/syntax:s49) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s49) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s50) (quote pageref-url) "./syntax.html#./syntax:s50") +(putprop (quote \x2E;/syntax:s50) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s50) (quote ref-url) "./syntax.html#g136") +(putprop (quote defn:letrec) (quote pageref-url) "./syntax.html#defn:letrec") +(putprop (quote defn:letrec) (quote ref) "8.3") +(putprop (quote defn:letrec) (quote ref-url) "./syntax.html#g136") +(putprop (quote fullletvalues) (quote pageref-url) "./syntax.html#fullletvalues") +(putprop (quote fullletvalues) (quote ref) "8.3") +(putprop (quote fullletvalues) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:s51) (quote pageref-url) "./syntax.html#./syntax:s51") +(putprop (quote \x2E;/syntax:s51) (quote ref) "8.3") +(putprop (quote \x2E;/syntax:s51) (quote ref-url) "./syntax.html#g136") +(putprop (quote \x2E;/syntax:h4) (quote pageref-url) "./syntax.html#./syntax:h4") +(putprop (quote \x2E;/syntax:h4) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:h4) (quote ref-url) "./syntax.html#g137") +(putprop (quote SECTSYNTAXEXAMPLES) (quote pageref-url) "./syntax.html#SECTSYNTAXEXAMPLES") +(putprop (quote SECTSYNTAXEXAMPLES) (quote ref) "8.4") +(putprop (quote SECTSYNTAXEXAMPLES) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s52) (quote pageref-url) "./syntax.html#./syntax:s52") +(putprop (quote \x2E;/syntax:s52) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s52) (quote ref-url) "./syntax.html#g137") +(putprop (quote defn:let) (quote pageref-url) "./syntax.html#defn:let") +(putprop (quote defn:let) (quote ref) "8.4") +(putprop (quote defn:let) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s53) (quote pageref-url) "./syntax.html#./syntax:s53") +(putprop (quote \x2E;/syntax:s53) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s53) (quote ref-url) "./syntax.html#g137") +(putprop (quote defn:do) (quote pageref-url) "./syntax.html#defn:do") +(putprop (quote defn:do) (quote ref) "8.4") +(putprop (quote defn:do) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s54) (quote pageref-url) "./syntax.html#./syntax:s54") +(putprop (quote \x2E;/syntax:s54) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s54) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s55) (quote pageref-url) "./syntax.html#./syntax:s55") +(putprop (quote \x2E;/syntax:s55) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s55) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s56) (quote pageref-url) "./syntax.html#./syntax:s56") +(putprop (quote \x2E;/syntax:s56) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s56) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s57) (quote pageref-url) "./syntax.html#./syntax:s57") +(putprop (quote \x2E;/syntax:s57) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s57) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s58) (quote pageref-url) "./syntax.html#./syntax:s58") +(putprop (quote \x2E;/syntax:s58) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s58) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s59) (quote pageref-url) "./syntax.html#./syntax:s59") +(putprop (quote \x2E;/syntax:s59) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s59) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s60) (quote pageref-url) "./syntax.html#./syntax:s60") +(putprop (quote \x2E;/syntax:s60) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s60) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s61) (quote pageref-url) "./syntax.html#./syntax:s61") +(putprop (quote \x2E;/syntax:s61) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s61) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s62) (quote pageref-url) "./syntax.html#./syntax:s62") +(putprop (quote \x2E;/syntax:s62) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s62) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s63) (quote pageref-url) "./syntax.html#./syntax:s63") +(putprop (quote \x2E;/syntax:s63) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s63) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s64) (quote pageref-url) "./syntax.html#./syntax:s64") +(putprop (quote \x2E;/syntax:s64) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s64) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s65) (quote pageref-url) "./syntax.html#./syntax:s65") +(putprop (quote \x2E;/syntax:s65) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s65) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s66) (quote pageref-url) "./syntax.html#./syntax:s66") +(putprop (quote \x2E;/syntax:s66) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s66) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s67) (quote pageref-url) "./syntax.html#./syntax:s67") +(putprop (quote \x2E;/syntax:s67) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s67) (quote ref-url) "./syntax.html#g137") +(putprop (quote defn:method) (quote pageref-url) "./syntax.html#defn:method") +(putprop (quote defn:method) (quote ref) "8.4") +(putprop (quote defn:method) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s68) (quote pageref-url) "./syntax.html#./syntax:s68") +(putprop (quote \x2E;/syntax:s68) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s68) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s69) (quote pageref-url) "./syntax.html#./syntax:s69") +(putprop (quote \x2E;/syntax:s69) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s69) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s70) (quote pageref-url) "./syntax.html#./syntax:s70") +(putprop (quote \x2E;/syntax:s70) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s70) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/syntax:s71) (quote pageref-url) "./syntax.html#./syntax:s71") +(putprop (quote \x2E;/syntax:s71) (quote ref) "8.4") +(putprop (quote \x2E;/syntax:s71) (quote ref-url) "./syntax.html#g137") +(putprop (quote \x2E;/records:h0) (quote pageref-url) "./records.html#./records:h0") +(putprop (quote \x2E;/records:h0) (quote ref) "9") +(putprop (quote \x2E;/records:h0) (quote ref-url) "./records.html#g138") +(putprop (quote CHPTRECORDS) (quote pageref-url) "./records.html#CHPTRECORDS") +(putprop (quote CHPTRECORDS) (quote ref) "9") +(putprop (quote CHPTRECORDS) (quote ref-url) "./records.html#g138") +(putprop (quote \x2E;/records:s0) (quote pageref-url) "./records.html#./records:s0") +(putprop (quote \x2E;/records:s0) (quote ref) "9") +(putprop (quote \x2E;/records:s0) (quote ref-url) "./records.html#g138") +(putprop (quote \x2E;/records:s1) (quote pageref-url) "./records.html#./records:s1") +(putprop (quote \x2E;/records:s1) (quote ref) "9") +(putprop (quote \x2E;/records:s1) (quote ref-url) "./records.html#g138") +(putprop (quote \x2E;/records:s2) (quote pageref-url) "./records.html#./records:s2") +(putprop (quote \x2E;/records:s2) (quote ref) "9") +(putprop (quote \x2E;/records:s2) (quote ref-url) "./records.html#g138") +(putprop (quote \x2E;/records:h1) (quote pageref-url) "./records.html#./records:h1") +(putprop (quote \x2E;/records:h1) (quote ref) "9.1") +(putprop (quote \x2E;/records:h1) (quote ref-url) "./records.html#g139") +(putprop (quote SECTRECORDDEFINITION) (quote pageref-url) "./records.html#SECTRECORDDEFINITION") +(putprop (quote SECTRECORDDEFINITION) (quote ref) "9.1") +(putprop (quote SECTRECORDDEFINITION) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s3) (quote pageref-url) "./records.html#./records:s3") +(putprop (quote \x2E;/records:s3) (quote ref) "9.1") +(putprop (quote \x2E;/records:s3) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s4) (quote pageref-url) "./records.html#./records:s4") +(putprop (quote \x2E;/records:s4) (quote ref) "9.1") +(putprop (quote \x2E;/records:s4) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s5) (quote pageref-url) "./records.html#./records:s5") +(putprop (quote \x2E;/records:s5) (quote ref) "9.1") +(putprop (quote \x2E;/records:s5) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s6) (quote pageref-url) "./records.html#./records:s6") +(putprop (quote \x2E;/records:s6) (quote ref) "9.1") +(putprop (quote \x2E;/records:s6) (quote ref-url) "./records.html#g139") +(putprop (quote page:record-uid) (quote pageref-url) "./records.html#page:record-uid") +(putprop (quote page:record-uid) (quote ref) "9.1") +(putprop (quote page:record-uid) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s7) (quote pageref-url) "./records.html#./records:s7") +(putprop (quote \x2E;/records:s7) (quote ref) "9.1") +(putprop (quote \x2E;/records:s7) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s8) (quote pageref-url) "./records.html#./records:s8") +(putprop (quote \x2E;/records:s8) (quote ref) "9.1") +(putprop (quote \x2E;/records:s8) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s9) (quote pageref-url) "./records.html#./records:s9") +(putprop (quote \x2E;/records:s9) (quote ref) "9.1") +(putprop (quote \x2E;/records:s9) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s10) (quote pageref-url) "./records.html#./records:s10") +(putprop (quote \x2E;/records:s10) (quote ref) "9.1") +(putprop (quote \x2E;/records:s10) (quote ref-url) "./records.html#g139") +(putprop (quote page:parent-type) (quote pageref-url) "./records.html#page:parent-type") +(putprop (quote page:parent-type) (quote ref) "9.1") +(putprop (quote page:parent-type) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s11) (quote pageref-url) "./records.html#./records:s11") +(putprop (quote \x2E;/records:s11) (quote ref) "9.1") +(putprop (quote \x2E;/records:s11) (quote ref-url) "./records.html#g139") +(putprop (quote page:protocols) (quote pageref-url) "./records.html#page:protocols") +(putprop (quote page:protocols) (quote ref) "9.1") +(putprop (quote page:protocols) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s12) (quote pageref-url) "./records.html#./records:s12") +(putprop (quote \x2E;/records:s12) (quote ref) "9.1") +(putprop (quote \x2E;/records:s12) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s13) (quote pageref-url) "./records.html#./records:s13") +(putprop (quote \x2E;/records:s13) (quote ref) "9.1") +(putprop (quote \x2E;/records:s13) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s14) (quote pageref-url) "./records.html#./records:s14") +(putprop (quote \x2E;/records:s14) (quote ref) "9.1") +(putprop (quote \x2E;/records:s14) (quote ref-url) "./records.html#g139") +(putprop (quote page:sealed) (quote pageref-url) "./records.html#page:sealed") +(putprop (quote page:sealed) (quote ref) "9.1") +(putprop (quote page:sealed) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s15) (quote pageref-url) "./records.html#./records:s15") +(putprop (quote \x2E;/records:s15) (quote ref) "9.1") +(putprop (quote \x2E;/records:s15) (quote ref-url) "./records.html#g139") +(putprop (quote page:opaque) (quote pageref-url) "./records.html#page:opaque") +(putprop (quote page:opaque) (quote ref) "9.1") +(putprop (quote page:opaque) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:s16) (quote pageref-url) "./records.html#./records:s16") +(putprop (quote \x2E;/records:s16) (quote ref) "9.1") +(putprop (quote \x2E;/records:s16) (quote ref-url) "./records.html#g139") +(putprop (quote \x2E;/records:h2) (quote pageref-url) "./records.html#./records:h2") +(putprop (quote \x2E;/records:h2) (quote ref) "9.2") +(putprop (quote \x2E;/records:h2) (quote ref-url) "./records.html#g140") +(putprop (quote SECTRECORDPROCEDURAL) (quote pageref-url) "./records.html#SECTRECORDPROCEDURAL") +(putprop (quote SECTRECORDPROCEDURAL) (quote ref) "9.2") +(putprop (quote SECTRECORDPROCEDURAL) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s17) (quote pageref-url) "./records.html#./records:s17") +(putprop (quote \x2E;/records:s17) (quote ref) "9.2") +(putprop (quote \x2E;/records:s17) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s18) (quote pageref-url) "./records.html#./records:s18") +(putprop (quote \x2E;/records:s18) (quote ref) "9.2") +(putprop (quote \x2E;/records:s18) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s19) (quote pageref-url) "./records.html#./records:s19") +(putprop (quote \x2E;/records:s19) (quote ref) "9.2") +(putprop (quote \x2E;/records:s19) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s20) (quote pageref-url) "./records.html#./records:s20") +(putprop (quote \x2E;/records:s20) (quote ref) "9.2") +(putprop (quote \x2E;/records:s20) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s21) (quote pageref-url) "./records.html#./records:s21") +(putprop (quote \x2E;/records:s21) (quote ref) "9.2") +(putprop (quote \x2E;/records:s21) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s22) (quote pageref-url) "./records.html#./records:s22") +(putprop (quote \x2E;/records:s22) (quote ref) "9.2") +(putprop (quote \x2E;/records:s22) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s23) (quote pageref-url) "./records.html#./records:s23") +(putprop (quote \x2E;/records:s23) (quote ref) "9.2") +(putprop (quote \x2E;/records:s23) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s24) (quote pageref-url) "./records.html#./records:s24") +(putprop (quote \x2E;/records:s24) (quote ref) "9.2") +(putprop (quote \x2E;/records:s24) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s25) (quote pageref-url) "./records.html#./records:s25") +(putprop (quote \x2E;/records:s25) (quote ref) "9.2") +(putprop (quote \x2E;/records:s25) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s26) (quote pageref-url) "./records.html#./records:s26") +(putprop (quote \x2E;/records:s26) (quote ref) "9.2") +(putprop (quote \x2E;/records:s26) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s27) (quote pageref-url) "./records.html#./records:s27") +(putprop (quote \x2E;/records:s27) (quote ref) "9.2") +(putprop (quote \x2E;/records:s27) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s28) (quote pageref-url) "./records.html#./records:s28") +(putprop (quote \x2E;/records:s28) (quote ref) "9.2") +(putprop (quote \x2E;/records:s28) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s29) (quote pageref-url) "./records.html#./records:s29") +(putprop (quote \x2E;/records:s29) (quote ref) "9.2") +(putprop (quote \x2E;/records:s29) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s30) (quote pageref-url) "./records.html#./records:s30") +(putprop (quote \x2E;/records:s30) (quote ref) "9.2") +(putprop (quote \x2E;/records:s30) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s31) (quote pageref-url) "./records.html#./records:s31") +(putprop (quote \x2E;/records:s31) (quote ref) "9.2") +(putprop (quote \x2E;/records:s31) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:s32) (quote pageref-url) "./records.html#./records:s32") +(putprop (quote \x2E;/records:s32) (quote ref) "9.2") +(putprop (quote \x2E;/records:s32) (quote ref-url) "./records.html#g140") +(putprop (quote \x2E;/records:h3) (quote pageref-url) "./records.html#./records:h3") +(putprop (quote \x2E;/records:h3) (quote ref) "9.3") +(putprop (quote \x2E;/records:h3) (quote ref-url) "./records.html#g141") +(putprop (quote SECTRECORDINSPECTION) (quote pageref-url) "./records.html#SECTRECORDINSPECTION") +(putprop (quote SECTRECORDINSPECTION) (quote ref) "9.3") +(putprop (quote SECTRECORDINSPECTION) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s33) (quote pageref-url) "./records.html#./records:s33") +(putprop (quote \x2E;/records:s33) (quote ref) "9.3") +(putprop (quote \x2E;/records:s33) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s34) (quote pageref-url) "./records.html#./records:s34") +(putprop (quote \x2E;/records:s34) (quote ref) "9.3") +(putprop (quote \x2E;/records:s34) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s35) (quote pageref-url) "./records.html#./records:s35") +(putprop (quote \x2E;/records:s35) (quote ref) "9.3") +(putprop (quote \x2E;/records:s35) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s36) (quote pageref-url) "./records.html#./records:s36") +(putprop (quote \x2E;/records:s36) (quote ref) "9.3") +(putprop (quote \x2E;/records:s36) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s37) (quote pageref-url) "./records.html#./records:s37") +(putprop (quote \x2E;/records:s37) (quote ref) "9.3") +(putprop (quote \x2E;/records:s37) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s38) (quote pageref-url) "./records.html#./records:s38") +(putprop (quote \x2E;/records:s38) (quote ref) "9.3") +(putprop (quote \x2E;/records:s38) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s39) (quote pageref-url) "./records.html#./records:s39") +(putprop (quote \x2E;/records:s39) (quote ref) "9.3") +(putprop (quote \x2E;/records:s39) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s40) (quote pageref-url) "./records.html#./records:s40") +(putprop (quote \x2E;/records:s40) (quote ref) "9.3") +(putprop (quote \x2E;/records:s40) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/records:s41) (quote pageref-url) "./records.html#./records:s41") +(putprop (quote \x2E;/records:s41) (quote ref) "9.3") +(putprop (quote \x2E;/records:s41) (quote ref-url) "./records.html#g141") +(putprop (quote \x2E;/libraries:h0) (quote pageref-url) "./libraries.html#./libraries:h0") +(putprop (quote \x2E;/libraries:h0) (quote ref) "10") +(putprop (quote \x2E;/libraries:h0) (quote ref-url) "./libraries.html#g142") +(putprop (quote CHPTLIBRARIES) (quote pageref-url) "./libraries.html#CHPTLIBRARIES") +(putprop (quote CHPTLIBRARIES) (quote ref) "10") +(putprop (quote CHPTLIBRARIES) (quote ref-url) "./libraries.html#g142") +(putprop (quote \x2E;/libraries:s0) (quote pageref-url) "./libraries.html#./libraries:s0") +(putprop (quote \x2E;/libraries:s0) (quote ref) "10") +(putprop (quote \x2E;/libraries:s0) (quote ref-url) "./libraries.html#g142") +(putprop (quote \x2E;/libraries:s1) (quote pageref-url) "./libraries.html#./libraries:s1") +(putprop (quote \x2E;/libraries:s1) (quote ref) "10") +(putprop (quote \x2E;/libraries:s1) (quote ref-url) "./libraries.html#g142") +(putprop (quote \x2E;/libraries:h1) (quote pageref-url) "./libraries.html#./libraries:h1") +(putprop (quote \x2E;/libraries:h1) (quote ref) "10.1") +(putprop (quote \x2E;/libraries:h1) (quote ref-url) "./libraries.html#g143") +(putprop (quote \x2E;/libraries:h2) (quote pageref-url) "./libraries.html#./libraries:h2") +(putprop (quote \x2E;/libraries:h2) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:h2) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s2) (quote pageref-url) "./libraries.html#./libraries:s2") +(putprop (quote \x2E;/libraries:s2) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s2) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s3) (quote pageref-url) "./libraries.html#./libraries:s3") +(putprop (quote \x2E;/libraries:s3) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s3) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s4) (quote pageref-url) "./libraries.html#./libraries:s4") +(putprop (quote \x2E;/libraries:s4) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s4) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s5) (quote pageref-url) "./libraries.html#./libraries:s5") +(putprop (quote \x2E;/libraries:s5) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s5) (quote ref-url) "./libraries.html#g144") +(putprop (quote desc:import) (quote pageref-url) "./libraries.html#desc:import") +(putprop (quote desc:import) (quote ref) "10.2") +(putprop (quote desc:import) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s6) (quote pageref-url) "./libraries.html#./libraries:s6") +(putprop (quote \x2E;/libraries:s6) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s6) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s7) (quote pageref-url) "./libraries.html#./libraries:s7") +(putprop (quote \x2E;/libraries:s7) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s7) (quote ref-url) "./libraries.html#g144") +(putprop (quote export-level) (quote pageref-url) "./libraries.html#export-level") +(putprop (quote export-level) (quote ref) "10.2") +(putprop (quote export-level) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s8) (quote pageref-url) "./libraries.html#./libraries:s8") +(putprop (quote \x2E;/libraries:s8) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s8) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s9) (quote pageref-url) "./libraries.html#./libraries:s9") +(putprop (quote \x2E;/libraries:s9) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s9) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s10) (quote pageref-url) "./libraries.html#./libraries:s10") +(putprop (quote \x2E;/libraries:s10) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s10) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s11) (quote pageref-url) "./libraries.html#./libraries:s11") +(putprop (quote \x2E;/libraries:s11) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s11) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s12) (quote pageref-url) "./libraries.html#./libraries:s12") +(putprop (quote \x2E;/libraries:s12) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s12) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s13) (quote pageref-url) "./libraries.html#./libraries:s13") +(putprop (quote \x2E;/libraries:s13) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s13) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s14) (quote pageref-url) "./libraries.html#./libraries:s14") +(putprop (quote \x2E;/libraries:s14) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s14) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s15) (quote pageref-url) "./libraries.html#./libraries:s15") +(putprop (quote \x2E;/libraries:s15) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s15) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:s16) (quote pageref-url) "./libraries.html#./libraries:s16") +(putprop (quote \x2E;/libraries:s16) (quote ref) "10.2") +(putprop (quote \x2E;/libraries:s16) (quote ref-url) "./libraries.html#g144") +(putprop (quote \x2E;/libraries:h3) (quote pageref-url) "./libraries.html#./libraries:h3") +(putprop (quote \x2E;/libraries:h3) (quote ref) "10.3") +(putprop (quote \x2E;/libraries:h3) (quote ref-url) "./libraries.html#g145") +(putprop (quote SECTLIBPROGRAMS) (quote pageref-url) "./libraries.html#SECTLIBPROGRAMS") +(putprop (quote SECTLIBPROGRAMS) (quote ref) "10.3") +(putprop (quote SECTLIBPROGRAMS) (quote ref-url) "./libraries.html#g145") +(putprop (quote \x2E;/libraries:s17) (quote pageref-url) "./libraries.html#./libraries:s17") +(putprop (quote \x2E;/libraries:s17) (quote ref) "10.3") +(putprop (quote \x2E;/libraries:s17) (quote ref-url) "./libraries.html#g145") +(putprop (quote \x2E;/libraries:s18) (quote pageref-url) "./libraries.html#./libraries:s18") +(putprop (quote \x2E;/libraries:s18) (quote ref) "10.3") +(putprop (quote \x2E;/libraries:s18) (quote ref-url) "./libraries.html#g145") +(putprop (quote \x2E;/libraries:h4) (quote pageref-url) "./libraries.html#./libraries:h4") +(putprop (quote \x2E;/libraries:h4) (quote ref) "10.4") +(putprop (quote \x2E;/libraries:h4) (quote ref-url) "./libraries.html#g146") +(putprop (quote SECTLIBEXAMPLES) (quote pageref-url) "./libraries.html#SECTLIBEXAMPLES") +(putprop (quote SECTLIBEXAMPLES) (quote ref) "10.4") +(putprop (quote SECTLIBEXAMPLES) (quote ref-url) "./libraries.html#g146") +(putprop (quote \x2E;/exceptions:h0) (quote pageref-url) "./exceptions.html#./exceptions:h0") +(putprop (quote \x2E;/exceptions:h0) (quote ref) "11") +(putprop (quote \x2E;/exceptions:h0) (quote ref-url) "./exceptions.html#g147") +(putprop (quote CHPTEXCEPTIONS) (quote pageref-url) "./exceptions.html#CHPTEXCEPTIONS") +(putprop (quote CHPTEXCEPTIONS) (quote ref) "11") +(putprop (quote CHPTEXCEPTIONS) (quote ref-url) "./exceptions.html#g147") +(putprop (quote \x2E;/exceptions:s0) (quote pageref-url) "./exceptions.html#./exceptions:s0") +(putprop (quote \x2E;/exceptions:s0) (quote ref) "11") +(putprop (quote \x2E;/exceptions:s0) (quote ref-url) "./exceptions.html#g147") +(putprop (quote \x2E;/exceptions:s1) (quote pageref-url) "./exceptions.html#./exceptions:s1") +(putprop (quote \x2E;/exceptions:s1) (quote ref) "11") +(putprop (quote \x2E;/exceptions:s1) (quote ref-url) "./exceptions.html#g147") +(putprop (quote \x2E;/exceptions:s2) (quote pageref-url) "./exceptions.html#./exceptions:s2") +(putprop (quote \x2E;/exceptions:s2) (quote ref) "11") +(putprop (quote \x2E;/exceptions:s2) (quote ref-url) "./exceptions.html#g147") +(putprop (quote \x2E;/exceptions:h1) (quote pageref-url) "./exceptions.html#./exceptions:h1") +(putprop (quote \x2E;/exceptions:h1) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:h1) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:s3) (quote pageref-url) "./exceptions.html#./exceptions:s3") +(putprop (quote \x2E;/exceptions:s3) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:s3) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:s4) (quote pageref-url) "./exceptions.html#./exceptions:s4") +(putprop (quote \x2E;/exceptions:s4) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:s4) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:s5) (quote pageref-url) "./exceptions.html#./exceptions:s5") +(putprop (quote \x2E;/exceptions:s5) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:s5) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:s6) (quote pageref-url) "./exceptions.html#./exceptions:s6") +(putprop (quote \x2E;/exceptions:s6) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:s6) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:s7) (quote pageref-url) "./exceptions.html#./exceptions:s7") +(putprop (quote \x2E;/exceptions:s7) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:s7) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:s8) (quote pageref-url) "./exceptions.html#./exceptions:s8") +(putprop (quote \x2E;/exceptions:s8) (quote ref) "11.1") +(putprop (quote \x2E;/exceptions:s8) (quote ref-url) "./exceptions.html#g148") +(putprop (quote \x2E;/exceptions:h2) (quote pageref-url) "./exceptions.html#./exceptions:h2") +(putprop (quote \x2E;/exceptions:h2) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:h2) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s9) (quote pageref-url) "./exceptions.html#./exceptions:s9") +(putprop (quote \x2E;/exceptions:s9) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s9) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s10) (quote pageref-url) "./exceptions.html#./exceptions:s10") +(putprop (quote \x2E;/exceptions:s10) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s10) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s11) (quote pageref-url) "./exceptions.html#./exceptions:s11") +(putprop (quote \x2E;/exceptions:s11) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s11) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s12) (quote pageref-url) "./exceptions.html#./exceptions:s12") +(putprop (quote \x2E;/exceptions:s12) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s12) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s13) (quote pageref-url) "./exceptions.html#./exceptions:s13") +(putprop (quote \x2E;/exceptions:s13) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s13) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s14) (quote pageref-url) "./exceptions.html#./exceptions:s14") +(putprop (quote \x2E;/exceptions:s14) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s14) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s15) (quote pageref-url) "./exceptions.html#./exceptions:s15") +(putprop (quote \x2E;/exceptions:s15) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s15) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s16) (quote pageref-url) "./exceptions.html#./exceptions:s16") +(putprop (quote \x2E;/exceptions:s16) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s16) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s17) (quote pageref-url) "./exceptions.html#./exceptions:s17") +(putprop (quote \x2E;/exceptions:s17) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s17) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:s18) (quote pageref-url) "./exceptions.html#./exceptions:s18") +(putprop (quote \x2E;/exceptions:s18) (quote ref) "11.2") +(putprop (quote \x2E;/exceptions:s18) (quote ref-url) "./exceptions.html#g149") +(putprop (quote \x2E;/exceptions:h3) (quote pageref-url) "./exceptions.html#./exceptions:h3") +(putprop (quote \x2E;/exceptions:h3) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:h3) (quote ref-url) "./exceptions.html#g150") +(putprop (quote SECTEXCCONDTYPES) (quote pageref-url) "./exceptions.html#SECTEXCCONDTYPES") +(putprop (quote SECTEXCCONDTYPES) (quote ref) "11.3") +(putprop (quote SECTEXCCONDTYPES) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s19) (quote pageref-url) "./exceptions.html#./exceptions:s19") +(putprop (quote \x2E;/exceptions:s19) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s19) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s20) (quote pageref-url) "./exceptions.html#./exceptions:s20") +(putprop (quote \x2E;/exceptions:s20) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s20) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s21) (quote pageref-url) "./exceptions.html#./exceptions:s21") +(putprop (quote \x2E;/exceptions:s21) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s21) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s22) (quote pageref-url) "./exceptions.html#./exceptions:s22") +(putprop (quote \x2E;/exceptions:s22) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s22) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s23) (quote pageref-url) "./exceptions.html#./exceptions:s23") +(putprop (quote \x2E;/exceptions:s23) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s23) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s24) (quote pageref-url) "./exceptions.html#./exceptions:s24") +(putprop (quote \x2E;/exceptions:s24) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s24) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s25) (quote pageref-url) "./exceptions.html#./exceptions:s25") +(putprop (quote \x2E;/exceptions:s25) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s25) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s26) (quote pageref-url) "./exceptions.html#./exceptions:s26") +(putprop (quote \x2E;/exceptions:s26) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s26) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s27) (quote pageref-url) "./exceptions.html#./exceptions:s27") +(putprop (quote \x2E;/exceptions:s27) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s27) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s28) (quote pageref-url) "./exceptions.html#./exceptions:s28") +(putprop (quote \x2E;/exceptions:s28) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s28) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s29) (quote pageref-url) "./exceptions.html#./exceptions:s29") +(putprop (quote \x2E;/exceptions:s29) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s29) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s30) (quote pageref-url) "./exceptions.html#./exceptions:s30") +(putprop (quote \x2E;/exceptions:s30) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s30) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s31) (quote pageref-url) "./exceptions.html#./exceptions:s31") +(putprop (quote \x2E;/exceptions:s31) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s31) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s32) (quote pageref-url) "./exceptions.html#./exceptions:s32") +(putprop (quote \x2E;/exceptions:s32) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s32) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s33) (quote pageref-url) "./exceptions.html#./exceptions:s33") +(putprop (quote \x2E;/exceptions:s33) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s33) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s34) (quote pageref-url) "./exceptions.html#./exceptions:s34") +(putprop (quote \x2E;/exceptions:s34) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s34) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s35) (quote pageref-url) "./exceptions.html#./exceptions:s35") +(putprop (quote \x2E;/exceptions:s35) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s35) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s36) (quote pageref-url) "./exceptions.html#./exceptions:s36") +(putprop (quote \x2E;/exceptions:s36) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s36) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s37) (quote pageref-url) "./exceptions.html#./exceptions:s37") +(putprop (quote \x2E;/exceptions:s37) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s37) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s38) (quote pageref-url) "./exceptions.html#./exceptions:s38") +(putprop (quote \x2E;/exceptions:s38) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s38) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s39) (quote pageref-url) "./exceptions.html#./exceptions:s39") +(putprop (quote \x2E;/exceptions:s39) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s39) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s40) (quote pageref-url) "./exceptions.html#./exceptions:s40") +(putprop (quote \x2E;/exceptions:s40) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s40) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s41) (quote pageref-url) "./exceptions.html#./exceptions:s41") +(putprop (quote \x2E;/exceptions:s41) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s41) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s42) (quote pageref-url) "./exceptions.html#./exceptions:s42") +(putprop (quote \x2E;/exceptions:s42) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s42) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s43) (quote pageref-url) "./exceptions.html#./exceptions:s43") +(putprop (quote \x2E;/exceptions:s43) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s43) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s44) (quote pageref-url) "./exceptions.html#./exceptions:s44") +(putprop (quote \x2E;/exceptions:s44) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s44) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/exceptions:s45) (quote pageref-url) "./exceptions.html#./exceptions:s45") +(putprop (quote \x2E;/exceptions:s45) (quote ref) "11.3") +(putprop (quote \x2E;/exceptions:s45) (quote ref-url) "./exceptions.html#g150") +(putprop (quote \x2E;/examples:h0) (quote pageref-url) "./examples.html#./examples:h0") +(putprop (quote \x2E;/examples:h0) (quote ref) "12") +(putprop (quote \x2E;/examples:h0) (quote ref-url) "./examples.html#g151") +(putprop (quote CHPTEXAMPLES) (quote pageref-url) "./examples.html#CHPTEXAMPLES") +(putprop (quote CHPTEXAMPLES) (quote ref) "12") +(putprop (quote CHPTEXAMPLES) (quote ref-url) "./examples.html#g151") +(putprop (quote \x2E;/examples:s0) (quote pageref-url) "./examples.html#./examples:s0") +(putprop (quote \x2E;/examples:s0) (quote ref) "12") +(putprop (quote \x2E;/examples:s0) (quote ref-url) "./examples.html#g151") +(putprop (quote \x2E;/examples:h1) (quote pageref-url) "./examples.html#./examples:h1") +(putprop (quote \x2E;/examples:h1) (quote ref) "12.1") +(putprop (quote \x2E;/examples:h1) (quote ref-url) "./examples.html#g152") +(putprop (quote SECTEXMATMUL) (quote pageref-url) "./examples.html#SECTEXMATMUL") +(putprop (quote SECTEXMATMUL) (quote ref) "12.1") +(putprop (quote SECTEXMATMUL) (quote ref-url) "./examples.html#g152") +(putprop (quote \x2E;/examples:s1) (quote pageref-url) "./examples.html#./examples:s1") +(putprop (quote \x2E;/examples:s1) (quote ref) "12.1") +(putprop (quote \x2E;/examples:s1) (quote ref-url) "./examples.html#g152") +(putprop (quote \x2E;/examples:s2) (quote pageref-url) "./examples.html#./examples:s2") +(putprop (quote \x2E;/examples:s2) (quote ref) "12.1") +(putprop (quote \x2E;/examples:s2) (quote ref-url) "./examples.html#g152") +(putprop (quote \x2E;/examples:s3) (quote pageref-url) "./examples.html#./examples:s3") +(putprop (quote \x2E;/examples:s3) (quote ref) "12.1") +(putprop (quote \x2E;/examples:s3) (quote ref-url) "./examples.html#g152") +(putprop (quote \x2E;/examples:s4) (quote pageref-url) "./examples.html#./examples:s4") +(putprop (quote \x2E;/examples:s4) (quote ref) "12.1.1") +(putprop (quote \x2E;/examples:s4) (quote ref-url) "./examples.html#g153") +(putprop (quote \x2E;/examples:s5) (quote pageref-url) "./examples.html#./examples:s5") +(putprop (quote \x2E;/examples:s5) (quote ref) "12.1.2") +(putprop (quote \x2E;/examples:s5) (quote ref-url) "./examples.html#g154") +(putprop (quote exercise:reliable) (quote pageref-url) "./examples.html#exercise:reliable") +(putprop (quote exercise:reliable) (quote ref) "12.1.2") +(putprop (quote exercise:reliable) (quote ref-url) "./examples.html#g154") +(putprop (quote \x2E;/examples:s6) (quote pageref-url) "./examples.html#./examples:s6") +(putprop (quote \x2E;/examples:s6) (quote ref) "12.1.3") +(putprop (quote \x2E;/examples:s6) (quote ref-url) "./examples.html#g155") +(putprop (quote \x2E;/examples:s7) (quote pageref-url) "./examples.html#./examples:s7") +(putprop (quote \x2E;/examples:s7) (quote ref) "12.1.4") +(putprop (quote \x2E;/examples:s7) (quote ref-url) "./examples.html#g156") +(putprop (quote \x2E;/examples:s8) (quote pageref-url) "./examples.html#./examples:s8") +(putprop (quote \x2E;/examples:s8) (quote ref) "12.1.5") +(putprop (quote \x2E;/examples:s8) (quote ref-url) "./examples.html#g157") +(putprop (quote \x2E;/examples:h2) (quote pageref-url) "./examples.html#./examples:h2") +(putprop (quote \x2E;/examples:h2) (quote ref) "12.2") +(putprop (quote \x2E;/examples:h2) (quote ref-url) "./examples.html#g158") +(putprop (quote SECTEXSORTMERGE) (quote pageref-url) "./examples.html#SECTEXSORTMERGE") +(putprop (quote SECTEXSORTMERGE) (quote ref) "12.2") +(putprop (quote SECTEXSORTMERGE) (quote ref-url) "./examples.html#g158") +(putprop (quote \x2E;/examples:s9) (quote pageref-url) "./examples.html#./examples:s9") +(putprop (quote \x2E;/examples:s9) (quote ref) "12.2") +(putprop (quote \x2E;/examples:s9) (quote ref-url) "./examples.html#g158") +(putprop (quote \x2E;/examples:s10) (quote pageref-url) "./examples.html#./examples:s10") +(putprop (quote \x2E;/examples:s10) (quote ref) "12.2") +(putprop (quote \x2E;/examples:s10) (quote ref-url) "./examples.html#g158") +(putprop (quote \x2E;/examples:s11) (quote pageref-url) "./examples.html#./examples:s11") +(putprop (quote \x2E;/examples:s11) (quote ref) "12.2") +(putprop (quote \x2E;/examples:s11) (quote ref-url) "./examples.html#g158") +(putprop (quote \x2E;/examples:s12) (quote pageref-url) "./examples.html#./examples:s12") +(putprop (quote \x2E;/examples:s12) (quote ref) "12.2.1") +(putprop (quote \x2E;/examples:s12) (quote ref-url) "./examples.html#g159") +(putprop (quote \x2E;/examples:s13) (quote pageref-url) "./examples.html#./examples:s13") +(putprop (quote \x2E;/examples:s13) (quote ref) "12.2.2") +(putprop (quote \x2E;/examples:s13) (quote ref-url) "./examples.html#g160") +(putprop (quote \x2E;/examples:s14) (quote pageref-url) "./examples.html#./examples:s14") +(putprop (quote \x2E;/examples:s14) (quote ref) "12.2.3") +(putprop (quote \x2E;/examples:s14) (quote ref-url) "./examples.html#g161") +(putprop (quote \x2E;/examples:h3) (quote pageref-url) "./examples.html#./examples:h3") +(putprop (quote \x2E;/examples:h3) (quote ref) "12.3") +(putprop (quote \x2E;/examples:h3) (quote ref-url) "./examples.html#g162") +(putprop (quote SECTEXSETS) (quote pageref-url) "./examples.html#SECTEXSETS") +(putprop (quote SECTEXSETS) (quote ref) "12.3") +(putprop (quote SECTEXSETS) (quote ref-url) "./examples.html#g162") +(putprop (quote \x2E;/examples:s15) (quote pageref-url) "./examples.html#./examples:s15") +(putprop (quote \x2E;/examples:s15) (quote ref) "12.3") +(putprop (quote \x2E;/examples:s15) (quote ref-url) "./examples.html#g162") +(putprop (quote \x2E;/examples:s16) (quote pageref-url) "./examples.html#./examples:s16") +(putprop (quote \x2E;/examples:s16) (quote ref) "12.3") +(putprop (quote \x2E;/examples:s16) (quote ref-url) "./examples.html#g162") +(putprop (quote \x2E;/examples:s17) (quote pageref-url) "./examples.html#./examples:s17") +(putprop (quote \x2E;/examples:s17) (quote ref) "12.3") +(putprop (quote \x2E;/examples:s17) (quote ref-url) "./examples.html#g162") +(putprop (quote \x2E;/examples:s18) (quote pageref-url) "./examples.html#./examples:s18") +(putprop (quote \x2E;/examples:s18) (quote ref) "12.3") +(putprop (quote \x2E;/examples:s18) (quote ref-url) "./examples.html#g162") +(putprop (quote \x2E;/examples:s19) (quote pageref-url) "./examples.html#./examples:s19") +(putprop (quote \x2E;/examples:s19) (quote ref) "12.3.1") +(putprop (quote \x2E;/examples:s19) (quote ref-url) "./examples.html#g166") +(putprop (quote \x2E;/examples:s20) (quote pageref-url) "./examples.html#./examples:s20") +(putprop (quote \x2E;/examples:s20) (quote ref) "12.3.2") +(putprop (quote \x2E;/examples:s20) (quote ref-url) "./examples.html#g167") +(putprop (quote \x2E;/examples:s21) (quote pageref-url) "./examples.html#./examples:s21") +(putprop (quote \x2E;/examples:s21) (quote ref) "12.3.2") +(putprop (quote \x2E;/examples:s21) (quote ref-url) "./examples.html#g167") +(putprop (quote \x2E;/examples:s22) (quote pageref-url) "./examples.html#./examples:s22") +(putprop (quote \x2E;/examples:s22) (quote ref) "12.3.3") +(putprop (quote \x2E;/examples:s22) (quote ref-url) "./examples.html#g168") +(putprop (quote \x2E;/examples:h4) (quote pageref-url) "./examples.html#./examples:h4") +(putprop (quote \x2E;/examples:h4) (quote ref) "12.4") +(putprop (quote \x2E;/examples:h4) (quote ref-url) "./examples.html#g169") +(putprop (quote SECTEXWORDFREQ) (quote pageref-url) "./examples.html#SECTEXWORDFREQ") +(putprop (quote SECTEXWORDFREQ) (quote ref) "12.4") +(putprop (quote SECTEXWORDFREQ) (quote ref-url) "./examples.html#g169") +(putprop (quote \x2E;/examples:s23) (quote pageref-url) "./examples.html#./examples:s23") +(putprop (quote \x2E;/examples:s23) (quote ref) "12.4") +(putprop (quote \x2E;/examples:s23) (quote ref-url) "./examples.html#g169") +(putprop (quote \x2E;/examples:s24) (quote pageref-url) "./examples.html#./examples:s24") +(putprop (quote \x2E;/examples:s24) (quote ref) "12.4") +(putprop (quote \x2E;/examples:s24) (quote ref-url) "./examples.html#g169") +(putprop (quote \x2E;/examples:s25) (quote pageref-url) "./examples.html#./examples:s25") +(putprop (quote \x2E;/examples:s25) (quote ref) "12.4.1") +(putprop (quote \x2E;/examples:s25) (quote ref-url) "./examples.html#g170") +(putprop (quote \x2E;/examples:s26) (quote pageref-url) "./examples.html#./examples:s26") +(putprop (quote \x2E;/examples:s26) (quote ref) "12.4.2") +(putprop (quote \x2E;/examples:s26) (quote ref-url) "./examples.html#g171") +(putprop (quote \x2E;/examples:s27) (quote pageref-url) "./examples.html#./examples:s27") +(putprop (quote \x2E;/examples:s27) (quote ref) "12.4.3") +(putprop (quote \x2E;/examples:s27) (quote ref-url) "./examples.html#g172") +(putprop (quote \x2E;/examples:s28) (quote pageref-url) "./examples.html#./examples:s28") +(putprop (quote \x2E;/examples:s28) (quote ref) "12.4.4") +(putprop (quote \x2E;/examples:s28) (quote ref-url) "./examples.html#g173") +(putprop (quote \x2E;/examples:s29) (quote pageref-url) "./examples.html#./examples:s29") +(putprop (quote \x2E;/examples:s29) (quote ref) "12.4.5") +(putprop (quote \x2E;/examples:s29) (quote ref-url) "./examples.html#g174") +(putprop (quote \x2E;/examples:s30) (quote pageref-url) "./examples.html#./examples:s30") +(putprop (quote \x2E;/examples:s30) (quote ref) "12.4.6") +(putprop (quote \x2E;/examples:s30) (quote ref-url) "./examples.html#g175") +(putprop (quote \x2E;/examples:h5) (quote pageref-url) "./examples.html#./examples:h5") +(putprop (quote \x2E;/examples:h5) (quote ref) "12.5") +(putprop (quote \x2E;/examples:h5) (quote ref-url) "./examples.html#g176") +(putprop (quote SECTEXPRINTER) (quote pageref-url) "./examples.html#SECTEXPRINTER") +(putprop (quote SECTEXPRINTER) (quote ref) "12.5") +(putprop (quote SECTEXPRINTER) (quote ref-url) "./examples.html#g176") +(putprop (quote \x2E;/examples:s31) (quote pageref-url) "./examples.html#./examples:s31") +(putprop (quote \x2E;/examples:s31) (quote ref) "12.5") +(putprop (quote \x2E;/examples:s31) (quote ref-url) "./examples.html#g176") +(putprop (quote \x2E;/examples:s32) (quote pageref-url) "./examples.html#./examples:s32") +(putprop (quote \x2E;/examples:s32) (quote ref) "12.5") +(putprop (quote \x2E;/examples:s32) (quote ref-url) "./examples.html#g176") +(putprop (quote \x2E;/examples:s33) (quote pageref-url) "./examples.html#./examples:s33") +(putprop (quote \x2E;/examples:s33) (quote ref) "12.5") +(putprop (quote \x2E;/examples:s33) (quote ref-url) "./examples.html#g176") +(putprop (quote \x2E;/examples:s34) (quote pageref-url) "./examples.html#./examples:s34") +(putprop (quote \x2E;/examples:s34) (quote ref) "12.5.1") +(putprop (quote \x2E;/examples:s34) (quote ref-url) "./examples.html#g177") +(putprop (quote \x2E;/examples:s35) (quote pageref-url) "./examples.html#./examples:s35") +(putprop (quote \x2E;/examples:s35) (quote ref) "12.5.2") +(putprop (quote \x2E;/examples:s35) (quote ref-url) "./examples.html#g178") +(putprop (quote EXOBJTOSTR) (quote pageref-url) "./examples.html#EXOBJTOSTR") +(putprop (quote EXOBJTOSTR) (quote ref) "12.5.2") +(putprop (quote EXOBJTOSTR) (quote ref-url) "./examples.html#g178") +(putprop (quote \x2E;/examples:s36) (quote pageref-url) "./examples.html#./examples:s36") +(putprop (quote \x2E;/examples:s36) (quote ref) "12.5.3") +(putprop (quote \x2E;/examples:s36) (quote ref-url) "./examples.html#g179") +(putprop (quote \x2E;/examples:h6) (quote pageref-url) "./examples.html#./examples:h6") +(putprop (quote \x2E;/examples:h6) (quote ref) "12.6") +(putprop (quote \x2E;/examples:h6) (quote ref-url) "./examples.html#g180") +(putprop (quote SECTEXPRINTF) (quote pageref-url) "./examples.html#SECTEXPRINTF") +(putprop (quote SECTEXPRINTF) (quote ref) "12.6") +(putprop (quote SECTEXPRINTF) (quote ref-url) "./examples.html#g180") +(putprop (quote \x2E;/examples:s37) (quote pageref-url) "./examples.html#./examples:s37") +(putprop (quote \x2E;/examples:s37) (quote ref) "12.6") +(putprop (quote \x2E;/examples:s37) (quote ref-url) "./examples.html#g180") +(putprop (quote \x2E;/examples:s38) (quote pageref-url) "./examples.html#./examples:s38") +(putprop (quote \x2E;/examples:s38) (quote ref) "12.6") +(putprop (quote \x2E;/examples:s38) (quote ref-url) "./examples.html#g180") +(putprop (quote \x2E;/examples:s39) (quote pageref-url) "./examples.html#./examples:s39") +(putprop (quote \x2E;/examples:s39) (quote ref) "12.6") +(putprop (quote \x2E;/examples:s39) (quote ref-url) "./examples.html#g180") +(putprop (quote \x2E;/examples:s40) (quote pageref-url) "./examples.html#./examples:s40") +(putprop (quote \x2E;/examples:s40) (quote ref) "12.6.1") +(putprop (quote \x2E;/examples:s40) (quote ref-url) "./examples.html#g181") +(putprop (quote \x2E;/examples:s41) (quote pageref-url) "./examples.html#./examples:s41") +(putprop (quote \x2E;/examples:s41) (quote ref) "12.6.2") +(putprop (quote \x2E;/examples:s41) (quote ref-url) "./examples.html#g182") +(putprop (quote \x2E;/examples:s42) (quote pageref-url) "./examples.html#./examples:s42") +(putprop (quote \x2E;/examples:s42) (quote ref) "12.6.3") +(putprop (quote \x2E;/examples:s42) (quote ref-url) "./examples.html#g183") +(putprop (quote \x2E;/examples:s43) (quote pageref-url) "./examples.html#./examples:s43") +(putprop (quote \x2E;/examples:s43) (quote ref) "12.6.4") +(putprop (quote \x2E;/examples:s43) (quote ref-url) "./examples.html#g184") +(putprop (quote \x2E;/examples:s44) (quote pageref-url) "./examples.html#./examples:s44") +(putprop (quote \x2E;/examples:s44) (quote ref) "12.6.5") +(putprop (quote \x2E;/examples:s44) (quote ref-url) "./examples.html#g185") +(putprop (quote \x2E;/examples:s45) (quote pageref-url) "./examples.html#./examples:s45") +(putprop (quote \x2E;/examples:s45) (quote ref) "12.6.6") +(putprop (quote \x2E;/examples:s45) (quote ref-url) "./examples.html#g186") +(putprop (quote \x2E;/examples:h7) (quote pageref-url) "./examples.html#./examples:h7") +(putprop (quote \x2E;/examples:h7) (quote ref) "12.7") +(putprop (quote \x2E;/examples:h7) (quote ref-url) "./examples.html#g187") +(putprop (quote SECTEXINTERPRET) (quote pageref-url) "./examples.html#SECTEXINTERPRET") +(putprop (quote SECTEXINTERPRET) (quote ref) "12.7") +(putprop (quote SECTEXINTERPRET) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s46) (quote pageref-url) "./examples.html#./examples:s46") +(putprop (quote \x2E;/examples:s46) (quote ref) "12.7") +(putprop (quote \x2E;/examples:s46) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s47) (quote pageref-url) "./examples.html#./examples:s47") +(putprop (quote \x2E;/examples:s47) (quote ref) "12.7") +(putprop (quote \x2E;/examples:s47) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s48) (quote pageref-url) "./examples.html#./examples:s48") +(putprop (quote \x2E;/examples:s48) (quote ref) "12.7") +(putprop (quote \x2E;/examples:s48) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s49) (quote pageref-url) "./examples.html#./examples:s49") +(putprop (quote \x2E;/examples:s49) (quote ref) "12.7") +(putprop (quote \x2E;/examples:s49) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s50) (quote pageref-url) "./examples.html#./examples:s50") +(putprop (quote \x2E;/examples:s50) (quote ref) "12.7") +(putprop (quote \x2E;/examples:s50) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s51) (quote pageref-url) "./examples.html#./examples:s51") +(putprop (quote \x2E;/examples:s51) (quote ref) "12.7") +(putprop (quote \x2E;/examples:s51) (quote ref-url) "./examples.html#g187") +(putprop (quote \x2E;/examples:s52) (quote pageref-url) "./examples.html#./examples:s52") +(putprop (quote \x2E;/examples:s52) (quote ref) "12.7.1") +(putprop (quote \x2E;/examples:s52) (quote ref-url) "./examples.html#g188") +(putprop (quote \x2E;/examples:s53) (quote pageref-url) "./examples.html#./examples:s53") +(putprop (quote \x2E;/examples:s53) (quote ref) "12.7.2") +(putprop (quote \x2E;/examples:s53) (quote ref-url) "./examples.html#g189") +(putprop (quote \x2E;/examples:s54) (quote pageref-url) "./examples.html#./examples:s54") +(putprop (quote \x2E;/examples:s54) (quote ref) "12.7.3") +(putprop (quote \x2E;/examples:s54) (quote ref-url) "./examples.html#g190") +(putprop (quote \x2E;/examples:s55) (quote pageref-url) "./examples.html#./examples:s55") +(putprop (quote \x2E;/examples:s55) (quote ref) "12.7.4") +(putprop (quote \x2E;/examples:s55) (quote ref-url) "./examples.html#g191") +(putprop (quote \x2E;/examples:s56) (quote pageref-url) "./examples.html#./examples:s56") +(putprop (quote \x2E;/examples:s56) (quote ref) "12.7.5") +(putprop (quote \x2E;/examples:s56) (quote ref-url) "./examples.html#g192") +(putprop (quote \x2E;/examples:s57) (quote pageref-url) "./examples.html#./examples:s57") +(putprop (quote \x2E;/examples:s57) (quote ref) "12.7.5") +(putprop (quote \x2E;/examples:s57) (quote ref-url) "./examples.html#g192") +(putprop (quote \x2E;/examples:s58) (quote pageref-url) "./examples.html#./examples:s58") +(putprop (quote \x2E;/examples:s58) (quote ref) "12.7.5") +(putprop (quote \x2E;/examples:s58) (quote ref-url) "./examples.html#g192") +(putprop (quote \x2E;/examples:s59) (quote pageref-url) "./examples.html#./examples:s59") +(putprop (quote \x2E;/examples:s59) (quote ref) "12.7.5") +(putprop (quote \x2E;/examples:s59) (quote ref-url) "./examples.html#g192") +(putprop (quote \x2E;/examples:h8) (quote pageref-url) "./examples.html#./examples:h8") +(putprop (quote \x2E;/examples:h8) (quote ref) "12.8") +(putprop (quote \x2E;/examples:h8) (quote ref-url) "./examples.html#g193") +(putprop (quote SECTEXOBJECTS) (quote pageref-url) "./examples.html#SECTEXOBJECTS") +(putprop (quote SECTEXOBJECTS) (quote ref) "12.8") +(putprop (quote SECTEXOBJECTS) (quote ref-url) "./examples.html#g193") +(putprop (quote \x2E;/examples:s60) (quote pageref-url) "./examples.html#./examples:s60") +(putprop (quote \x2E;/examples:s60) (quote ref) "12.8") +(putprop (quote \x2E;/examples:s60) (quote ref-url) "./examples.html#g193") +(putprop (quote \x2E;/examples:s61) (quote pageref-url) "./examples.html#./examples:s61") +(putprop (quote \x2E;/examples:s61) (quote ref) "12.8") +(putprop (quote \x2E;/examples:s61) (quote ref-url) "./examples.html#g193") +(putprop (quote \x2E;/examples:s62) (quote pageref-url) "./examples.html#./examples:s62") +(putprop (quote \x2E;/examples:s62) (quote ref) "12.8") +(putprop (quote \x2E;/examples:s62) (quote ref-url) "./examples.html#g193") +(putprop (quote \x2E;/examples:s63) (quote pageref-url) "./examples.html#./examples:s63") +(putprop (quote \x2E;/examples:s63) (quote ref) "12.8") +(putprop (quote \x2E;/examples:s63) (quote ref-url) "./examples.html#g193") +(putprop (quote \x2E;/examples:s64) (quote pageref-url) "./examples.html#./examples:s64") +(putprop (quote \x2E;/examples:s64) (quote ref) "12.8.1") +(putprop (quote \x2E;/examples:s64) (quote ref-url) "./examples.html#g194") +(putprop (quote \x2E;/examples:s65) (quote pageref-url) "./examples.html#./examples:s65") +(putprop (quote \x2E;/examples:s65) (quote ref) "12.8.2") +(putprop (quote \x2E;/examples:s65) (quote ref-url) "./examples.html#g195") +(putprop (quote \x2E;/examples:s66) (quote pageref-url) "./examples.html#./examples:s66") +(putprop (quote \x2E;/examples:s66) (quote ref) "12.8.3") +(putprop (quote \x2E;/examples:s66) (quote ref-url) "./examples.html#g196") +(putprop (quote \x2E;/examples:s67) (quote pageref-url) "./examples.html#./examples:s67") +(putprop (quote \x2E;/examples:s67) (quote ref) "12.8.3") +(putprop (quote \x2E;/examples:s67) (quote ref-url) "./examples.html#g196") +(putprop (quote \x2E;/examples:s68) (quote pageref-url) "./examples.html#./examples:s68") +(putprop (quote \x2E;/examples:s68) (quote ref) "12.8.4") +(putprop (quote \x2E;/examples:s68) (quote ref-url) "./examples.html#g197") +(putprop (quote \x2E;/examples:h9) (quote pageref-url) "./examples.html#./examples:h9") +(putprop (quote \x2E;/examples:h9) (quote ref) "12.9") +(putprop (quote \x2E;/examples:h9) (quote ref-url) "./examples.html#g198") +(putprop (quote SECTEXFFT) (quote pageref-url) "./examples.html#SECTEXFFT") +(putprop (quote SECTEXFFT) (quote ref) "12.9") +(putprop (quote SECTEXFFT) (quote ref-url) "./examples.html#g198") +(putprop (quote \x2E;/examples:s69) (quote pageref-url) "./examples.html#./examples:s69") +(putprop (quote \x2E;/examples:s69) (quote ref) "12.9") +(putprop (quote \x2E;/examples:s69) (quote ref-url) "./examples.html#g198") +(putprop (quote \x2E;/examples:s70) (quote pageref-url) "./examples.html#./examples:s70") +(putprop (quote \x2E;/examples:s70) (quote ref) "12.9") +(putprop (quote \x2E;/examples:s70) (quote ref-url) "./examples.html#g198") +(putprop (quote \x2E;/examples:s71) (quote pageref-url) "./examples.html#./examples:s71") +(putprop (quote \x2E;/examples:s71) (quote ref) "12.9.1") +(putprop (quote \x2E;/examples:s71) (quote ref-url) "./examples.html#g199") +(putprop (quote \x2E;/examples:s72) (quote pageref-url) "./examples.html#./examples:s72") +(putprop (quote \x2E;/examples:s72) (quote ref) "12.9.2") +(putprop (quote \x2E;/examples:s72) (quote ref-url) "./examples.html#g200") +(putprop (quote \x2E;/examples:s73) (quote pageref-url) "./examples.html#./examples:s73") +(putprop (quote \x2E;/examples:s73) (quote ref) "12.9.3") +(putprop (quote \x2E;/examples:s73) (quote ref-url) "./examples.html#g201") +(putprop (quote \x2E;/examples:s74) (quote pageref-url) "./examples.html#./examples:s74") +(putprop (quote \x2E;/examples:s74) (quote ref) "12.9.4") +(putprop (quote \x2E;/examples:s74) (quote ref-url) "./examples.html#g202") +(putprop (quote \x2E;/examples:s75) (quote pageref-url) "./examples.html#./examples:s75") +(putprop (quote \x2E;/examples:s75) (quote ref) "12.9.5") +(putprop (quote \x2E;/examples:s75) (quote ref-url) "./examples.html#g203") +(putprop (quote \x2E;/examples:h10) (quote pageref-url) "./examples.html#./examples:h10") +(putprop (quote \x2E;/examples:h10) (quote ref) "12.10") +(putprop (quote \x2E;/examples:h10) (quote ref-url) "./examples.html#g204") +(putprop (quote SECTEXUNIFY) (quote pageref-url) "./examples.html#SECTEXUNIFY") +(putprop (quote SECTEXUNIFY) (quote ref) "12.10") +(putprop (quote SECTEXUNIFY) (quote ref-url) "./examples.html#g204") +(putprop (quote \x2E;/examples:s76) (quote pageref-url) "./examples.html#./examples:s76") +(putprop (quote \x2E;/examples:s76) (quote ref) "12.10") +(putprop (quote \x2E;/examples:s76) (quote ref-url) "./examples.html#g204") +(putprop (quote \x2E;/examples:s77) (quote pageref-url) "./examples.html#./examples:s77") +(putprop (quote \x2E;/examples:s77) (quote ref) "12.10") +(putprop (quote \x2E;/examples:s77) (quote ref-url) "./examples.html#g204") +(putprop (quote \x2E;/examples:s78) (quote pageref-url) "./examples.html#./examples:s78") +(putprop (quote \x2E;/examples:s78) (quote ref) "12.10") +(putprop (quote \x2E;/examples:s78) (quote ref-url) "./examples.html#g204") +(putprop (quote \x2E;/examples:s79) (quote pageref-url) "./examples.html#./examples:s79") +(putprop (quote \x2E;/examples:s79) (quote ref) "12.10.1") +(putprop (quote \x2E;/examples:s79) (quote ref-url) "./examples.html#g205") +(putprop (quote \x2E;/examples:s80) (quote pageref-url) "./examples.html#./examples:s80") +(putprop (quote \x2E;/examples:s80) (quote ref) "12.10.2") +(putprop (quote \x2E;/examples:s80) (quote ref-url) "./examples.html#g206") +(putprop (quote \x2E;/examples:s81) (quote pageref-url) "./examples.html#./examples:s81") +(putprop (quote \x2E;/examples:s81) (quote ref) "12.10.3") +(putprop (quote \x2E;/examples:s81) (quote ref-url) "./examples.html#g207") +(putprop (quote \x2E;/examples:h11) (quote pageref-url) "./examples.html#./examples:h11") +(putprop (quote \x2E;/examples:h11) (quote ref) "12.11") +(putprop (quote \x2E;/examples:h11) (quote ref-url) "./examples.html#g208") +(putprop (quote SECTEXENGINES) (quote pageref-url) "./examples.html#SECTEXENGINES") +(putprop (quote SECTEXENGINES) (quote ref) "12.11") +(putprop (quote SECTEXENGINES) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s82) (quote pageref-url) "./examples.html#./examples:s82") +(putprop (quote \x2E;/examples:s82) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s82) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s83) (quote pageref-url) "./examples.html#./examples:s83") +(putprop (quote \x2E;/examples:s83) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s83) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s84) (quote pageref-url) "./examples.html#./examples:s84") +(putprop (quote \x2E;/examples:s84) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s84) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s85) (quote pageref-url) "./examples.html#./examples:s85") +(putprop (quote \x2E;/examples:s85) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s85) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s86) (quote pageref-url) "./examples.html#./examples:s86") +(putprop (quote \x2E;/examples:s86) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s86) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s87) (quote pageref-url) "./examples.html#./examples:s87") +(putprop (quote \x2E;/examples:s87) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s87) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s88) (quote pageref-url) "./examples.html#./examples:s88") +(putprop (quote \x2E;/examples:s88) (quote ref) "12.11") +(putprop (quote \x2E;/examples:s88) (quote ref-url) "./examples.html#g208") +(putprop (quote \x2E;/examples:s89) (quote pageref-url) "./examples.html#./examples:s89") +(putprop (quote \x2E;/examples:s89) (quote ref) "1") +(putprop (quote \x2E;/examples:s89) (quote ref-url) "./examples.html#g209") +(putprop (quote \x2E;/examples:s90) (quote pageref-url) "./examples.html#./examples:s90") +(putprop (quote \x2E;/examples:s90) (quote ref) "2") +(putprop (quote \x2E;/examples:s90) (quote ref-url) "./examples.html#g210") +(putprop (quote \x2E;/examples:s91) (quote pageref-url) "./examples.html#./examples:s91") +(putprop (quote \x2E;/examples:s91) (quote ref) "3") +(putprop (quote \x2E;/examples:s91) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s92) (quote pageref-url) "./examples.html#./examples:s92") +(putprop (quote \x2E;/examples:s92) (quote ref) "3") +(putprop (quote \x2E;/examples:s92) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s93) (quote pageref-url) "./examples.html#./examples:s93") +(putprop (quote \x2E;/examples:s93) (quote ref) "3") +(putprop (quote \x2E;/examples:s93) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s94) (quote pageref-url) "./examples.html#./examples:s94") +(putprop (quote \x2E;/examples:s94) (quote ref) "3") +(putprop (quote \x2E;/examples:s94) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s95) (quote pageref-url) "./examples.html#./examples:s95") +(putprop (quote \x2E;/examples:s95) (quote ref) "3") +(putprop (quote \x2E;/examples:s95) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s96) (quote pageref-url) "./examples.html#./examples:s96") +(putprop (quote \x2E;/examples:s96) (quote ref) "3") +(putprop (quote \x2E;/examples:s96) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s97) (quote pageref-url) "./examples.html#./examples:s97") +(putprop (quote \x2E;/examples:s97) (quote ref) "3") +(putprop (quote \x2E;/examples:s97) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s98) (quote pageref-url) "./examples.html#./examples:s98") +(putprop (quote \x2E;/examples:s98) (quote ref) "3") +(putprop (quote \x2E;/examples:s98) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s99) (quote pageref-url) "./examples.html#./examples:s99") +(putprop (quote \x2E;/examples:s99) (quote ref) "3") +(putprop (quote \x2E;/examples:s99) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s100) (quote pageref-url) "./examples.html#./examples:s100") +(putprop (quote \x2E;/examples:s100) (quote ref) "3") +(putprop (quote \x2E;/examples:s100) (quote ref-url) "./examples.html#g211") +(putprop (quote \x2E;/examples:s101) (quote pageref-url) "./examples.html#./examples:s101") +(putprop (quote \x2E;/examples:s101) (quote ref) "12.11.1") +(putprop (quote \x2E;/examples:s101) (quote ref-url) "./examples.html#g212") +(putprop (quote \x2E;/examples:s102) (quote pageref-url) "./examples.html#./examples:s102") +(putprop (quote \x2E;/examples:s102) (quote ref) "12.11.2") +(putprop (quote \x2E;/examples:s102) (quote ref-url) "./examples.html#g213") +(putprop (quote \x2E;/examples:s103) (quote pageref-url) "./examples.html#./examples:s103") +(putprop (quote \x2E;/examples:s103) (quote ref) "12.11.3") +(putprop (quote \x2E;/examples:s103) (quote ref-url) "./examples.html#g214") +(putprop (quote \x2E;/examples:s104) (quote pageref-url) "./examples.html#./examples:s104") +(putprop (quote \x2E;/examples:s104) (quote ref) "12.11.4") +(putprop (quote \x2E;/examples:s104) (quote ref-url) "./examples.html#g215") +(putprop (quote \x2E;/examples:s105) (quote pageref-url) "./examples.html#./examples:s105") +(putprop (quote \x2E;/examples:s105) (quote ref) "12.11.5") +(putprop (quote \x2E;/examples:s105) (quote ref-url) "./examples.html#g216") +(putprop (quote \x2E;/examples:s106) (quote pageref-url) "./examples.html#./examples:s106") +(putprop (quote \x2E;/examples:s106) (quote ref) "12.11.5") +(putprop (quote \x2E;/examples:s106) (quote ref-url) "./examples.html#g216") +(putprop (quote \x2E;/examples:s107) (quote pageref-url) "./examples.html#./examples:s107") +(putprop (quote \x2E;/examples:s107) (quote ref) "12.11.6") +(putprop (quote \x2E;/examples:s107) (quote ref-url) "./examples.html#g217") +(putprop (quote \x2E;/examples:s108) (quote pageref-url) "./examples.html#./examples:s108") +(putprop (quote \x2E;/examples:s108) (quote ref) "12.11.7") +(putprop (quote \x2E;/examples:s108) (quote ref-url) "./examples.html#g218") +(putprop (quote \x2E;/examples:s109) (quote pageref-url) "./examples.html#./examples:s109") +(putprop (quote \x2E;/examples:s109) (quote ref) "12.11.7") +(putprop (quote \x2E;/examples:s109) (quote ref-url) "./examples.html#g218") +(putprop (quote \x2E;/bibliography:h0) (quote pageref-url) "./bibliography.html#./bibliography:h0") +(putprop (quote \x2E;/bibliography:h0) (quote ref) "12.11.7") +(putprop (quote \x2E;/bibliography:h0) (quote ref-url) "./examples.html#g218") +(putprop (quote adams:equal) (quote pageref-url) "./bibliography.html#g219") +(putprop (quote adams:equal) (quote ref) "12.11.7") +(putprop (quote adams:equal) (quote ref-url) "./examples.html#g218") +(putprop (quote ashley:mvalues) (quote pageref-url) "./bibliography.html#g220") +(putprop (quote ashley:mvalues) (quote ref) "12.11.7") +(putprop (quote ashley:mvalues) (quote ref-url) "./examples.html#g218") +(putprop (quote bawden:pepm99) (quote pageref-url) "./bibliography.html#g221") +(putprop (quote bawden:pepm99) (quote ref) "12.11.7") +(putprop (quote bawden:pepm99) (quote ref-url) "./examples.html#g218") +(putprop (quote Briggs:dft) (quote pageref-url) "./bibliography.html#g222") +(putprop (quote Briggs:dft) (quote ref) "12.11.7") +(putprop (quote Briggs:dft) (quote ref-url) "./examples.html#g218") +(putprop (quote Burger:floatprinting) (quote pageref-url) "./bibliography.html#g223") +(putprop (quote Burger:floatprinting) (quote ref) "12.11.7") +(putprop (quote Burger:floatprinting) (quote ref-url) "./examples.html#g218") +(putprop (quote Clocksin:prolog) (quote pageref-url) "./bibliography.html#g224") +(putprop (quote Clocksin:prolog) (quote ref) "12.11.7") +(putprop (quote Clocksin:prolog) (quote ref-url) "./examples.html#g218") +(putprop (quote Daniel:prolog-fft) (quote pageref-url) "./bibliography.html#g225") +(putprop (quote Daniel:prolog-fft) (quote ref) "12.11.7") +(putprop (quote Daniel:prolog-fft) (quote ref-url) "./examples.html#g218") +(putprop (quote UnicodeUAX29) (quote pageref-url) "./bibliography.html#g226") +(putprop (quote UnicodeUAX29) (quote ref) "12.11.7") +(putprop (quote UnicodeUAX29) (quote ref-url) "./examples.html#g218") +(putprop (quote Dybvig:csug8) (quote pageref-url) "./bibliography.html#g227") +(putprop (quote Dybvig:csug8) (quote ref) "12.11.7") +(putprop (quote Dybvig:csug8) (quote ref-url) "./examples.html#g218") +(putprop (quote Dybvig:engines) (quote pageref-url) "./bibliography.html#g228") +(putprop (quote Dybvig:engines) (quote ref) "12.11.7") +(putprop (quote Dybvig:engines) (quote ref-url) "./examples.html#g218") +(putprop (quote Dybvig:lambdastar) (quote pageref-url) "./bibliography.html#g229") +(putprop (quote Dybvig:lambdastar) (quote ref) "12.11.7") +(putprop (quote Dybvig:lambdastar) (quote ref-url) "./examples.html#g218") +(putprop (quote Dybvig:syntactic) (quote pageref-url) "./bibliography.html#g230") +(putprop (quote Dybvig:syntactic) (quote ref) "12.11.7") +(putprop (quote Dybvig:syntactic) (quote ref-url) "./examples.html#g218") +(putprop (quote Friedman:lisper) (quote pageref-url) "./bibliography.html#g231") +(putprop (quote Friedman:lisper) (quote ref) "12.11.7") +(putprop (quote Friedman:lisper) (quote ref-url) "./examples.html#g218") +(putprop (quote Friedman:devils) (quote pageref-url) "./bibliography.html#g232") +(putprop (quote Friedman:devils) (quote ref) "12.11.7") +(putprop (quote Friedman:devils) (quote ref-url) "./examples.html#g218") +(putprop (quote Haynes:abstracting) (quote pageref-url) "./bibliography.html#g233") +(putprop (quote Haynes:abstracting) (quote ref) "12.11.7") +(putprop (quote Haynes:abstracting) (quote ref-url) "./examples.html#g218") +(putprop (quote Haynes:obtaining) (quote pageref-url) "./bibliography.html#g234") +(putprop (quote Haynes:obtaining) (quote ref) "12.11.7") +(putprop (quote Haynes:obtaining) (quote ref-url) "./examples.html#g218") +(putprop (quote Hieb:representing) (quote pageref-url) "./bibliography.html#g235") +(putprop (quote Hieb:representing) (quote ref) "12.11.7") +(putprop (quote Hieb:representing) (quote ref-url) "./examples.html#g218") +(putprop (quote IEEE:1178) (quote pageref-url) "./bibliography.html#g236") +(putprop (quote IEEE:1178) (quote ref) "12.11.7") +(putprop (quote IEEE:1178) (quote ref-url) "./examples.html#g218") +(putprop (quote Kernighan:C) (quote pageref-url) "./bibliography.html#g237") +(putprop (quote Kernighan:C) (quote ref) "12.11.7") +(putprop (quote Kernighan:C) (quote ref-url) "./examples.html#g218") +(putprop (quote RFC4122) (quote pageref-url) "./bibliography.html#g238") +(putprop (quote RFC4122) (quote ref) "12.11.7") +(putprop (quote RFC4122) (quote ref-url) "./examples.html#g218") +(putprop (quote Naur:algol) (quote pageref-url) "./bibliography.html#g239") +(putprop (quote Naur:algol) (quote ref) "12.11.7") +(putprop (quote Naur:algol) (quote ref-url) "./examples.html#g218") +(putprop (quote Plaisted:sets) (quote pageref-url) "./bibliography.html#g240") +(putprop (quote Plaisted:sets) (quote ref) "12.11.7") +(putprop (quote Plaisted:sets) (quote ref-url) "./examples.html#g218") +(putprop (quote Robinson:unification) (quote pageref-url) "./bibliography.html#g241") +(putprop (quote Robinson:unification) (quote ref) "12.11.7") +(putprop (quote Robinson:unification) (quote ref-url) "./examples.html#g218") +(putprop (quote r6rs) (quote pageref-url) "./bibliography.html#g242") +(putprop (quote r6rs) (quote ref) "12.11.7") +(putprop (quote r6rs) (quote ref-url) "./examples.html#g218") +(putprop (quote r6rsapps) (quote pageref-url) "./bibliography.html#g243") +(putprop (quote r6rsapps) (quote ref) "12.11.7") +(putprop (quote r6rsapps) (quote ref-url) "./examples.html#g218") +(putprop (quote r6rslibs) (quote pageref-url) "./bibliography.html#g244") +(putprop (quote r6rslibs) (quote ref) "12.11.7") +(putprop (quote r6rslibs) (quote ref-url) "./examples.html#g218") +(putprop (quote Steele:common) (quote pageref-url) "./bibliography.html#g245") +(putprop (quote Steele:common) (quote ref) "12.11.7") +(putprop (quote Steele:common) (quote ref-url) "./examples.html#g218") +(putprop (quote Steele:scheme) (quote pageref-url) "./bibliography.html#g246") +(putprop (quote Steele:scheme) (quote ref) "12.11.7") +(putprop (quote Steele:scheme) (quote ref-url) "./examples.html#g218") +(putprop (quote Sussman-Steele:HOSC98) (quote pageref-url) "./bibliography.html#g247") +(putprop (quote Sussman-Steele:HOSC98) (quote ref) "12.11.7") +(putprop (quote Sussman-Steele:HOSC98) (quote ref-url) "./examples.html#g218") +(putprop (quote Unicode) (quote pageref-url) "./bibliography.html#g248") +(putprop (quote Unicode) (quote ref) "12.11.7") +(putprop (quote Unicode) (quote ref-url) "./examples.html#g218") +(putprop (quote waddell:fixing-letrec) (quote pageref-url) "./bibliography.html#g249") +(putprop (quote waddell:fixing-letrec) (quote ref) "12.11.7") +(putprop (quote waddell:fixing-letrec) (quote ref-url) "./examples.html#g218") +(putprop (quote Wand:HOSC99) (quote pageref-url) "./bibliography.html#g250") +(putprop (quote Wand:HOSC99) (quote ref) "12.11.7") +(putprop (quote Wand:HOSC99) (quote ref-url) "./examples.html#g218") +(putprop (quote \x2E;/answers:h0) (quote pageref-url) "./answers.html#./answers:h0") +(putprop (quote \x2E;/answers:h0) (quote ref) "12.11.7") +(putprop (quote \x2E;/answers:h0) (quote ref-url) "./examples.html#g218") +(putprop (quote listapply) (quote pageref-url) "./answers.html#listapply") +(putprop (quote listapply) (quote ref) "2") +(putprop (quote listapply) (quote ref-url) "./answers.html#g252") +(putprop (quote cdrapply) (quote pageref-url) "./answers.html#cdrapply") +(putprop (quote cdrapply) (quote ref) "4") +(putprop (quote cdrapply) (quote ref-url) "./answers.html#g254") +(putprop (quote \x2E;/grammar:h0) (quote pageref-url) "./grammar.html#./grammar:h0") +(putprop (quote \x2E;/grammar:h0) (quote ref) "8") +(putprop (quote \x2E;/grammar:h0) (quote ref-url) "./answers.html#g258") +(putprop (quote APPENDIXFORMALSYNTAX) (quote pageref-url) "./grammar.html#APPENDIXFORMALSYNTAX") +(putprop (quote APPENDIXFORMALSYNTAX) (quote ref) "8") +(putprop (quote APPENDIXFORMALSYNTAX) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s0) (quote pageref-url) "./grammar.html#./grammar:s0") +(putprop (quote \x2E;/grammar:s0) (quote ref) "8") +(putprop (quote \x2E;/grammar:s0) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s1) (quote pageref-url) "./grammar.html#./grammar:s1") +(putprop (quote \x2E;/grammar:s1) (quote ref) "8") +(putprop (quote \x2E;/grammar:s1) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s2) (quote pageref-url) "./grammar.html#./grammar:s2") +(putprop (quote \x2E;/grammar:s2) (quote ref) "8") +(putprop (quote \x2E;/grammar:s2) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s3) (quote pageref-url) "./grammar.html#./grammar:s3") +(putprop (quote \x2E;/grammar:s3) (quote ref) "8") +(putprop (quote \x2E;/grammar:s3) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s4) (quote pageref-url) "./grammar.html#./grammar:s4") +(putprop (quote \x2E;/grammar:s4) (quote ref) "8") +(putprop (quote \x2E;/grammar:s4) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s5) (quote pageref-url) "./grammar.html#./grammar:s5") +(putprop (quote \x2E;/grammar:s5) (quote ref) "8") +(putprop (quote \x2E;/grammar:s5) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s6) (quote pageref-url) "./grammar.html#./grammar:s6") +(putprop (quote \x2E;/grammar:s6) (quote ref) "8") +(putprop (quote \x2E;/grammar:s6) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s7) (quote pageref-url) "./grammar.html#./grammar:s7") +(putprop (quote \x2E;/grammar:s7) (quote ref) "8") +(putprop (quote \x2E;/grammar:s7) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s8) (quote pageref-url) "./grammar.html#./grammar:s8") +(putprop (quote \x2E;/grammar:s8) (quote ref) "8") +(putprop (quote \x2E;/grammar:s8) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s9) (quote pageref-url) "./grammar.html#./grammar:s9") +(putprop (quote \x2E;/grammar:s9) (quote ref) "8") +(putprop (quote \x2E;/grammar:s9) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s10) (quote pageref-url) "./grammar.html#./grammar:s10") +(putprop (quote \x2E;/grammar:s10) (quote ref) "8") +(putprop (quote \x2E;/grammar:s10) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s11) (quote pageref-url) "./grammar.html#./grammar:s11") +(putprop (quote \x2E;/grammar:s11) (quote ref) "8") +(putprop (quote \x2E;/grammar:s11) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s12) (quote pageref-url) "./grammar.html#./grammar:s12") +(putprop (quote \x2E;/grammar:s12) (quote ref) "8") +(putprop (quote \x2E;/grammar:s12) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:datums) (quote pageref-url) "./grammar.html#grammar:datums") +(putprop (quote grammar:datums) (quote ref) "8") +(putprop (quote grammar:datums) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s13) (quote pageref-url) "./grammar.html#./grammar:s13") +(putprop (quote \x2E;/grammar:s13) (quote ref) "8") +(putprop (quote \x2E;/grammar:s13) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:booleans) (quote pageref-url) "./grammar.html#grammar:booleans") +(putprop (quote grammar:booleans) (quote ref) "8") +(putprop (quote grammar:booleans) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s14) (quote pageref-url) "./grammar.html#./grammar:s14") +(putprop (quote \x2E;/grammar:s14) (quote ref) "8") +(putprop (quote \x2E;/grammar:s14) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:characters) (quote pageref-url) "./grammar.html#grammar:characters") +(putprop (quote grammar:characters) (quote ref) "8") +(putprop (quote grammar:characters) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s15) (quote pageref-url) "./grammar.html#./grammar:s15") +(putprop (quote \x2E;/grammar:s15) (quote ref) "8") +(putprop (quote \x2E;/grammar:s15) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:strings) (quote pageref-url) "./grammar.html#grammar:strings") +(putprop (quote grammar:strings) (quote ref) "8") +(putprop (quote grammar:strings) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s16) (quote pageref-url) "./grammar.html#./grammar:s16") +(putprop (quote \x2E;/grammar:s16) (quote ref) "8") +(putprop (quote \x2E;/grammar:s16) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:symbols) (quote pageref-url) "./grammar.html#grammar:symbols") +(putprop (quote grammar:symbols) (quote ref) "8") +(putprop (quote grammar:symbols) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s17) (quote pageref-url) "./grammar.html#./grammar:s17") +(putprop (quote \x2E;/grammar:s17) (quote ref) "8") +(putprop (quote \x2E;/grammar:s17) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:numbers) (quote pageref-url) "./grammar.html#grammar:numbers") +(putprop (quote grammar:numbers) (quote ref) "8") +(putprop (quote grammar:numbers) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s18) (quote pageref-url) "./grammar.html#./grammar:s18") +(putprop (quote \x2E;/grammar:s18) (quote ref) "8") +(putprop (quote \x2E;/grammar:s18) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:lists) (quote pageref-url) "./grammar.html#grammar:lists") +(putprop (quote grammar:lists) (quote ref) "8") +(putprop (quote grammar:lists) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s19) (quote pageref-url) "./grammar.html#./grammar:s19") +(putprop (quote \x2E;/grammar:s19) (quote ref) "8") +(putprop (quote \x2E;/grammar:s19) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s20) (quote pageref-url) "./grammar.html#./grammar:s20") +(putprop (quote \x2E;/grammar:s20) (quote ref) "8") +(putprop (quote \x2E;/grammar:s20) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s21) (quote pageref-url) "./grammar.html#./grammar:s21") +(putprop (quote \x2E;/grammar:s21) (quote ref) "8") +(putprop (quote \x2E;/grammar:s21) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:vectors) (quote pageref-url) "./grammar.html#grammar:vectors") +(putprop (quote grammar:vectors) (quote ref) "8") +(putprop (quote grammar:vectors) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s22) (quote pageref-url) "./grammar.html#./grammar:s22") +(putprop (quote \x2E;/grammar:s22) (quote ref) "8") +(putprop (quote \x2E;/grammar:s22) (quote ref-url) "./answers.html#g258") +(putprop (quote grammar:bytevectors) (quote pageref-url) "./grammar.html#grammar:bytevectors") +(putprop (quote grammar:bytevectors) (quote ref) "8") +(putprop (quote grammar:bytevectors) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/grammar:s23) (quote pageref-url) "./grammar.html#./grammar:s23") +(putprop (quote \x2E;/grammar:s23) (quote ref) "8") +(putprop (quote \x2E;/grammar:s23) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/summary:h0) (quote pageref-url) "./summary.html#./summary:h0") +(putprop (quote \x2E;/summary:h0) (quote ref) "8") +(putprop (quote \x2E;/summary:h0) (quote ref-url) "./answers.html#g258") +(putprop (quote \x2E;/tspl:h0) (quote pageref-url) "./tspl_1.html#./tspl:h0") +(putprop (quote \x2E;/tspl:h0) (quote ref) "8") +(putprop (quote \x2E;/tspl:h0) (quote ref-url) "./answers.html#g258") diff --git a/csug/tspl4/tspl.idx b/csug/tspl4/tspl.idx new file mode 100644 index 0000000..1faa323 --- /dev/null +++ b/csug/tspl4/tspl.idx @@ -0,0 +1,1416 @@ +\indexentry{Lisp}{ix} +\indexentry{Scheme standard}{ix} +\indexentry{Revised Reports}{ix} +\indexentry{ChezScheme@\ChezScheme}{ix} +\indexentry{PetiteChezScheme@\PetiteChezScheme}{ix} +\indexentry{Revised Reports}{3} +\indexentry{objects}{3} +\indexentry{dynamic allocation}{3} +\indexentry{garbage collector}{3} +\indexentry{first-class data values}{3} +\indexentry{pointers}{4} +\indexentry{core syntactic forms}{4} +\indexentry{primitive procedures}{4} +\indexentry{interpreter}{4} +\indexentry{compiler}{4} +\indexentry{variables}{4} +\indexentry{keywords}{4} +\indexentry{lexical scoping}{4} +\indexentry{block structure}{4} +\indexentry{binding}{4} +\indexentry{shadowing}{4} +\indexentry{procedure definition}{5} +\indexentry{lexical scoping}{5} +\indexentry{first-class procedures}{5} +\indexentry{recursion}{5} +\indexentry{tail recursion}{5} +\indexentry{iteration}{5} +\indexentry{looping}{5} +\indexentry{tail call}{5} +\indexentry{continuations}{5} +\indexentry{syntactic extensions}{5} +\indexentry{Lisp}{6} +\indexentry{Algol 60}{6} +\indexentry{Common Lisp}{6} +\indexentry{structured forms}{6} +\indexentry{identifiers}{6} +\indexentry{list constants}{7} +\indexentry{empty list}{7} +\indexentry{()@\scheme{()}}{7} +\indexentry{brackets (~[~]~)@brackets (~\scheme{[}~\scheme{]}~)}{7} +\indexentry{boolean values}{7} +\indexentry{true}{7} +\indexentry{false}{7} +\indexentry{#t@\scheme{\#t}}{7} +\indexentry{#f@\scheme{\#f}}{7} +\indexentry{expressions}{7} +\indexentry{whitespace characters}{7} +\indexentry{comments}{7} +\indexentry{; (comment)@\scheme{;} (comment)}{7} +\indexentry{semicolon (~;~)@semicolon (~\scheme{;}~)}{7} +\indexentry{naming conventions}{8} +\indexentry{? (question mark)@\scheme{?} (question mark)}{8} +\indexentry{question mark (~?~)@question mark (~\scheme{?}~)}{8} +\indexentry{predicates}{8} +\indexentry{->@\scheme{->}}{8} +\indexentry{"! (exclamation point)@\scheme{"!} (exclamation point)}{8} +\indexentry{exclamation point (~"!~)@exclamation point (~\scheme{"!}~)}{8} +\indexentry{side effects}{8} +\indexentry{unspecified}{9} +\indexentry{multiple values}{9} +\indexentry{exceptions}{9} +\indexentry{syntax violation}{9} +\indexentry{load@\scheme{load}}{13} +\indexentry{strings}{14} +\indexentry{square@\scheme{square}}{14} +\indexentry{prefix notation}{15} +\indexentry{reciprocal@\scheme{reciprocal}}{15} +\indexentry{numbers}{16} +\indexentry{+@\scheme{+}}{16} +\indexentry{-@\scheme{-}}{16} +\indexentry{*@\scheme{*}}{16} +\indexentry{/@\scheme{/}}{16} +\indexentry{procedure application}{16} +\indexentry{prefix notation}{16} +\indexentry{operator precedence}{16} +\indexentry{lists}{17} +\indexentry{procedure application}{17} +\indexentry{' (quote)@\scheme{'} (\scheme{quote})}{17} +\indexentry{quote (~'~)@\scheme{quote} (~\scheme{'}~)}{17} +\indexentry{syntactic forms}{18} +\indexentry{variables}{18} +\indexentry{symbols}{18} +\indexentry{lists}{18} +\indexentry{car@\scheme{car}}{18} +\indexentry{cdr@\scheme{cdr}}{18} +\indexentry{()@\scheme{()}}{19} +\indexentry{empty list}{19} +\indexentry{cons@\scheme{cons}}{19} +\indexentry{consing}{19} +\indexentry{pairs}{19} +\indexentry{proper list}{19} +\indexentry{improper list}{19} +\indexentry{. (dot)@\scheme{{\schdot}} (dot)}{19} +\indexentry{dot (~.~)@dot (~\scheme{{\schdot}}~)}{19} +\indexentry{dotted pair}{20} +\indexentry{list@\scheme{list}}{20} +\indexentry{constants}{21} +\indexentry{procedure application}{21} +\indexentry{' (quote)@\scheme{'} (\scheme{quote})}{22} +\indexentry{quote (~'~)@\scheme{quote} (~\scheme{'}~)}{22} +\indexentry{syntactic extensions}{22} +\indexentry{core syntactic forms}{22} +\indexentry{order of evaluation}{22} +\indexentry{variables}{23} +\indexentry{let@\scheme{let}}{23} +\indexentry{variable binding}{23} +\indexentry{let-bound variables@\scheme{let}-bound variables}{23} +\indexentry{shadowing}{25} +\indexentry{scope}{25} +\indexentry{lexical scoping}{25} +\indexentry{lambda@\scheme{lambda}}{26} +\indexentry{procedures}{26} +\indexentry{formal parameters}{26} +\indexentry{procedure application}{27} +\indexentry{actual parameters}{27} +\indexentry{double@\scheme{double}}{27} +\indexentry{double-cons@\scheme{double-cons}}{27} +\indexentry{occur free}{28} +\indexentry{free variable}{28} +\indexentry{let@\scheme{let}}{28} +\indexentry{formal parameters}{29} +\indexentry{lambda@\scheme{lambda}}{29} +\indexentry{occur free}{30} +\indexentry{top-level definitions}{30} +\indexentry{variables}{30} +\indexentry{define@\scheme{define}}{30} +\indexentry{double-any@\scheme{double-any}}{30} +\indexentry{procedure definition}{31} +\indexentry{shadowing}{31} +\indexentry{list@\scheme{list}}{31} +\indexentry{cadr@\scheme{cadr}}{31} +\indexentry{cddr@\scheme{cddr}}{31} +\indexentry{cadr@\scheme{cadr}}{32} +\indexentry{list@\scheme{list}}{32} +\indexentry{defun syntax}{33} +\indexentry{doubler@\scheme{doubler}}{33} +\indexentry{double@\scheme{double}}{33} +\indexentry{double-cons@\scheme{double-cons}}{33} +\indexentry{cadr@\scheme{cadr}}{34} +\indexentry{cddr@\scheme{cddr}}{34} +\indexentry{compose@\scheme{compose}}{34} +\indexentry{caar, cadr, \dots, cddddr@\scheme{caar,~cadr,~{\dots},~cddddr}}{34} +\indexentry{abs@\scheme{abs}}{34} +\indexentry{if@\scheme{if}}{35} +\indexentry{not@\scheme{not}}{36} +\indexentry{or@\scheme{or}}{36} +\indexentry{if@\scheme{if}}{36} +\indexentry{or@\scheme{or}}{36} +\indexentry{#t@\scheme{\#t}}{36} +\indexentry{#f@\scheme{\#f}}{36} +\indexentry{true}{36} +\indexentry{false}{36} +\indexentry{and@\scheme{and}}{37} +\indexentry{reciprocal@\scheme{reciprocal}}{37} +\indexentry{predicates}{37} +\indexentry{? (question mark)@\scheme{?} (question mark)}{37} +\indexentry{question mark (~?~)@question mark (~\scheme{?}~)}{37} +\indexentry{null?@\scheme{null?}}{37} +\indexentry{cdr@\scheme{cdr}}{38} +\indexentry{lisp-cdr@\scheme{lisp-cdr}}{38} +\indexentry{eqv?@\scheme{eqv?}}{38} +\indexentry{type predicates}{38} +\indexentry{pair?@\scheme{pair?}}{38} +\indexentry{symbol?@\scheme{symbol?}}{38} +\indexentry{number?@\scheme{number?}}{38} +\indexentry{string?@\scheme{string?}}{38} +\indexentry{pair?@\scheme{pair?}}{38} +\indexentry{reciprocal@\scheme{reciprocal}}{39} +\indexentry{cond@\scheme{cond}}{39} +\indexentry{if@\scheme{if}}{39} +\indexentry{atom?@\scheme{atom?}}{41} +\indexentry{shorter@\scheme{shorter}}{41} +\indexentry{recursion}{41} +\indexentry{recursion}{41} +\indexentry{recursive procedure}{41} +\indexentry{goodbye@\scheme{goodbye}}{41} +\indexentry{base case}{41} +\indexentry{recursion step}{41} +\indexentry{length@\scheme{length}}{42} +\indexentry{tracing}{42} +\indexentry{trace@\scheme{trace}}{42} +\indexentry{ChezScheme@\ChezScheme}{42} +\indexentry{list-copy@\scheme{list-copy}}{43} +\indexentry{memv@\scheme{memv}}{43} +\indexentry{cond@\scheme{cond}}{44} +\indexentry{remv@\scheme{remv}}{44} +\indexentry{tree-copy@\scheme{tree-copy}}{44} +\indexentry{iteration}{45} +\indexentry{mapping}{45} +\indexentry{map@\scheme{map}}{45} +\indexentry{map1@\scheme{map1}}{46} +\indexentry{append@\scheme{append}}{46} +\indexentry{make-list@\scheme{make-list}}{46} +\indexentry{shorter@\scheme{shorter}}{47} +\indexentry{shorter?@\scheme{shorter?}}{47} +\indexentry{odd?@\scheme{odd?}}{47} +\indexentry{even?@\scheme{even?}}{47} +\indexentry{map@\scheme{map}}{47} +\indexentry{assignments}{47} +\indexentry{variables}{47} +\indexentry{set"!@\scheme{set"!}}{47} +\indexentry{quadratic-formula@\scheme{quadratic-formula}}{48} +\indexentry{internal state}{49} +\indexentry{make-counter@\scheme{make-counter}}{50} +\indexentry{shhh@\scheme{shhh}}{50} +\indexentry{tell@\scheme{tell}}{50} +\indexentry{lazy evaluation}{51} +\indexentry{lazy@\scheme{lazy}}{51} +\indexentry{thunk}{51} +\indexentry{begin@\scheme{begin}}{51} +\indexentry{if@\scheme{if}}{51} +\indexentry{stack objects}{52} +\indexentry{messages}{52} +\indexentry{make-stack@\scheme{make-stack}}{52} +\indexentry{abstract objects}{53} +\indexentry{queue}{53} +\indexentry{tconc}{53} +\indexentry{make-queue@\scheme{make-queue}}{54} +\indexentry{putq"!@\scheme{putq"!}}{54} +\indexentry{getq@\scheme{getq}}{54} +\indexentry{delq"!@\scheme{delq"!}}{54} +\indexentry{make-counter@\scheme{make-counter}}{54} +\indexentry{case@\scheme{case}}{55} +\indexentry{make-stack@\scheme{make-stack}}{55} +\indexentry{vectors}{55} +\indexentry{set-cdr"!@\scheme{set-cdr"!}}{56} +\indexentry{cyclic lists}{56} +\indexentry{list?@\scheme{list?}}{56} +\indexentry{proper list}{56} +\indexentry{hare and tortoise}{56} +\indexentry{core syntactic forms}{59} +\indexentry{syntactic forms}{59} +\indexentry{syntactic extensions}{59} +\indexentry{expansion}{59} +\indexentry{' (quote)@\scheme{'} (\scheme{quote})}{59} +\indexentry{quote (~'~)@\scheme{quote} (~\scheme{'}~)}{59} +\indexentry{lambda@\scheme{lambda}}{59} +\indexentry{if@\scheme{if}}{59} +\indexentry{set"!@\scheme{set"!}}{59} +\indexentry{defun syntax}{60} +\indexentry{begin@\scheme{begin}}{60} +\indexentry{defining syntactic extensions}{60} +\indexentry{syntactic extensions}{60} +\indexentry{define-syntax@\scheme{define-syntax}}{61} +\indexentry{transformer}{61} +\indexentry{keywords}{61} +\indexentry{auxiliary keywords}{61} +\indexentry{underscore (~_~)@underscore (~\scheme{{\schunderscore}}~)}{61} +\indexentry{_ (underscore)@\scheme{{\schunderscore}} (underscore)}{61} +\indexentry{pattern variables}{61} +\indexentry{...~(ellipsis)@\scheme{{\schdot}{\schdot}{\schdot}}~(ellipsis)}{61} +\indexentry{ellipsis (~...~)@ellipsis (~\scheme{{\schdot}{\schdot}{\schdot}}~)}{61} +\indexentry{and@\scheme{and}}{62} +\indexentry{or@\scheme{or}}{63} +\indexentry{lexical scoping}{63} +\indexentry{let*@\scheme{let*}}{64} +\indexentry{when@\scheme{when}}{64} +\indexentry{unless@\scheme{unless}}{64} +\indexentry{recursion}{65} +\indexentry{let@\scheme{let}}{65} +\indexentry{sum}{65} +\indexentry{letrec@\scheme{letrec}}{65} +\indexentry{mutually recursive procedures}{66} +\indexentry{even?@\scheme{even?}}{66} +\indexentry{odd?@\scheme{odd?}}{66} +\indexentry{list?@\scheme{list?}}{66} +\indexentry{hare and tortoise}{66} +\indexentry{named let@named \scheme{let}}{67} +\indexentry{list?@\scheme{list?}}{67} +\indexentry{iteration}{68} +\indexentry{tail call}{68} +\indexentry{tail recursion}{68} +\indexentry{factorial@\scheme{factorial}}{68} +\indexentry{fibonacci@\scheme{fibonacci}}{69} +\indexentry{Fibonacci numbers}{69} +\indexentry{doubly recursive}{70} +\indexentry{named let@named \scheme{let}}{71} +\indexentry{factor@\scheme{factor}}{71} +\indexentry{factor@\scheme{factor}}{72} +\indexentry{factor@\scheme{factor}}{73} +\indexentry{continuations}{73} +\indexentry{call/cc@\scheme{call/cc}}{74} +\indexentry{product@\scheme{product}}{74} +\indexentry{factorial@\scheme{factorial}}{75} +\indexentry{retry@\scheme{retry}}{75} +\indexentry{continuation-passing style}{78} +\indexentry{CPS}{78} +\indexentry{integer-divide@\scheme{integer-divide}}{79} +\indexentry{product@\scheme{product}}{80} +\indexentry{reciprocal@\scheme{reciprocal}}{80} +\indexentry{retry@\scheme{retry}}{80} +\indexentry{define@\scheme{define}}{81} +\indexentry{internal definitions}{81} +\indexentry{even?@\scheme{even?}}{81} +\indexentry{odd?@\scheme{odd?}}{81} +\indexentry{letrec@\scheme{letrec}}{81} +\indexentry{list?@\scheme{list?}}{81} +\indexentry{variable binding}{91} +\indexentry{procedures}{91} +\indexentry{variable reference|emph}{91} +\indexentry{lambda@\scheme{lambda}|emph}{92} +\indexentry{procedures}{92} +\indexentry{formal parameters}{92} +\indexentry{internal definitions}{92} +\indexentry{actual parameters}{92} +\indexentry{formal parameters}{92} +\indexentry{lambda@\scheme{lambda}}{93} +\indexentry{optional arguments}{93} +\indexentry{case-lambda@\scheme{case-lambda}}{94} +\indexentry{lambda*@\scheme{lambda*}}{94} +\indexentry{case-lambda@\scheme{case-lambda}|emph}{94} +\indexentry{make-list@\scheme{make-list}}{94} +\indexentry{substring@\scheme{substring}}{95} +\indexentry{let@\scheme{let}|emph}{95} +\indexentry{local variable bindings}{95} +\indexentry{let*@\scheme{let*}|emph}{96} +\indexentry{nested let expressions@nested \scheme{let} expressions}{96} +\indexentry{letrec@\scheme{letrec}|emph}{97} +\indexentry{mutually recursive procedures}{97} +\indexentry{letrec*@\scheme{letrec*}|emph}{98} +\indexentry{let-values@\scheme{let-values}|emph}{99} +\indexentry{let*-values@\scheme{let*-values}|emph}{99} +\indexentry{define@\scheme{define}|emph}{100} +\indexentry{define@\scheme{define}|emph}{100} +\indexentry{define@\scheme{define}|emph}{100} +\indexentry{define@\scheme{define}|emph}{100} +\indexentry{define@\scheme{define}|emph}{100} +\indexentry{procedure definition}{100} +\indexentry{begin@\scheme{begin}}{101} +\indexentry{top-level definitions}{101} +\indexentry{set"!@\scheme{set"!}|emph}{102} +\indexentry{assignment}{102} +\indexentry{assignments}{102} +\indexentry{flip-flop@\scheme{flip-flop}}{102} +\indexentry{Fibonacci numbers}{102} +\indexentry{fibonacci@\scheme{fibonacci}}{102} +\indexentry{control structures}{107} +\indexentry{procedure application|emph}{107} +\indexentry{order of evaluation}{107} +\indexentry{apply@\scheme{apply}|emph}{107} +\indexentry{begin@\scheme{begin}|emph}{108} +\indexentry{sequencing}{108} +\indexentry{side effects}{108} +\indexentry{implicit begin@implicit \scheme{begin}}{109} +\indexentry{if@\scheme{if}|emph}{109} +\indexentry{if@\scheme{if}|emph}{109} +\indexentry{conditionals}{109} +\indexentry{not@\scheme{not}|emph}{110} +\indexentry{and@\scheme{and}|emph}{110} +\indexentry{or@\scheme{or}|emph}{110} +\indexentry{cond@\scheme{cond}|emph}{111} +\indexentry{=>@\scheme{=>}}{111} +\indexentry{else@\scheme{else}}{111} +\indexentry{else@\scheme{else}|emph}{112} +\indexentry{=>@\scheme{=>}|emph}{112} +\indexentry{when@\scheme{when}|emph}{112} +\indexentry{unless@\scheme{unless}|emph}{112} +\indexentry{case@\scheme{case}|emph}{113} +\indexentry{else@\scheme{else}}{113} +\indexentry{let@\scheme{let}|emph}{114} +\indexentry{named let@named \scheme{let}}{114} +\indexentry{iteration}{114} +\indexentry{recursion}{114} +\indexentry{divisors@\scheme{divisors}}{115} +\indexentry{do@\scheme{do}|emph}{115} +\indexentry{iteration}{115} +\indexentry{factorial@\scheme{factorial}}{116} +\indexentry{fibonacci@\scheme{fibonacci}}{116} +\indexentry{divisors@\scheme{divisors}}{116} +\indexentry{map@\scheme{map}|emph}{117} +\indexentry{mapping}{117} +\indexentry{iteration}{117} +\indexentry{for-each@\scheme{for-each}|emph}{118} +\indexentry{mapping}{118} +\indexentry{iteration}{118} +\indexentry{exists@\scheme{exists}|emph}{119} +\indexentry{for-all@\scheme{for-all}|emph}{119} +\indexentry{fold-left@\scheme{fold-left}|emph}{120} +\indexentry{folding}{120} +\indexentry{iteration}{120} +\indexentry{fold-right@\scheme{fold-right}|emph}{121} +\indexentry{folding}{121} +\indexentry{iteration}{121} +\indexentry{vector-map@\scheme{vector-map}|emph}{121} +\indexentry{mapping}{121} +\indexentry{iteration}{121} +\indexentry{vector-for-each@\scheme{vector-for-each}|emph}{122} +\indexentry{mapping}{122} +\indexentry{iteration}{122} +\indexentry{string-for-each@\scheme{string-for-each}|emph}{122} +\indexentry{mapping}{122} +\indexentry{iteration}{122} +\indexentry{call/cc@\scheme{call/cc}}{122} +\indexentry{call/cc@\scheme{call/cc}|emph}{123} +\indexentry{call-with-current-continuation@\scheme{call-with-current-continuation}|emph}{123} +\indexentry{nonlocal exits}{123} +\indexentry{dynamic-wind@\scheme{dynamic-wind}|emph}{124} +\indexentry{continuations}{124} +\indexentry{thunk}{124} +\indexentry{unwind-protect (in Lisp)}{124} +\indexentry{nonlocal exits}{124} +\indexentry{fluid binding}{125} +\indexentry{call/cc@\scheme{call/cc}}{126} +\indexentry{winders|see{\scheme{dynamic-wind}}}{127} +\indexentry{lazy evaluation}{127} +\indexentry{delay@\scheme{delay}|emph}{128} +\indexentry{force@\scheme{force}|emph}{128} +\indexentry{streams}{128} +\indexentry{make-promise@\scheme{make-promise}}{129} +\indexentry{values@\scheme{values}}{130} +\indexentry{call-with-values@\scheme{call-with-values}}{130} +\indexentry{values@\scheme{values}|emph}{131} +\indexentry{call-with-values@\scheme{call-with-values}|emph}{131} +\indexentry{dxdy@\scheme{dxdy}}{131} +\indexentry{segment-length@\scheme{segment-length}}{132} +\indexentry{segment-slope@\scheme{segment-slope}}{132} +\indexentry{describe-segment@\scheme{describe-segment}}{132} +\indexentry{split@\scheme{split}}{133} +\indexentry{call/cc@\scheme{call/cc}}{133} +\indexentry{let-values@\scheme{let-values}}{134} +\indexentry{let*-values@\scheme{let*-values}}{134} +\indexentry{eval@\scheme{eval}|emph}{136} +\indexentry{environment@\scheme{environment}|emph}{137} +\indexentry{null-environment@\scheme{null-environment}|emph}{137} +\indexentry{scheme-report-environment@\scheme{scheme-report-environment}|emph}{137} +\indexentry{operations on objects}{141} +\indexentry{constant|emph}{141} +\indexentry{quote (~'~)@\scheme{quote} (~\scheme{'}~)|emph}{141} +\indexentry{' (quote)@\scheme{'} (\scheme{quote})|emph}{141} +\indexentry{data}{141} +\indexentry{constants}{141} +\indexentry{quasiquote (~`~)@\scheme{quasiquote} (~\scheme{`}~)|emph}{142} +\indexentry{` (quasiquote)@\scheme{`} (\scheme{quasiquote})|emph}{142} +\indexentry{unquote (~,~)@\scheme{unquote} (~\scheme{,}~)|emph}{142} +\indexentry{, (unquote)@\scheme{,} (\scheme{unquote})|emph}{142} +\indexentry{unquote-splicing (~,"@~)@\scheme{unquote-splicing} (~\scheme{,{\schatsign}}~)|emph}{142} +\indexentry{,"@ (unquote-splicing)@\scheme{,{\schatsign}} (\scheme{unquote-splicing})|emph}{142} +\indexentry{predicates}{143} +\indexentry{#t@\scheme{\#t}}{143} +\indexentry{#f@\scheme{\#f}}{143} +\indexentry{equivalence predicates}{143} +\indexentry{eq?@\scheme{eq?}|emph}{143} +\indexentry{object identity}{144} +\indexentry{eqv?@\scheme{eqv?}|emph}{146} +\indexentry{equal?@\scheme{equal?}|emph}{148} +\indexentry{boolean?@\scheme{boolean?}|emph}{150} +\indexentry{null?@\scheme{null?}|emph}{151} +\indexentry{pair?@\scheme{pair?}|emph}{151} +\indexentry{number?@\scheme{number?}|emph}{151} +\indexentry{complex?@\scheme{complex?}|emph}{151} +\indexentry{real?@\scheme{real?}|emph}{151} +\indexentry{rational?@\scheme{rational?}|emph}{151} +\indexentry{integer?@\scheme{integer?}|emph}{151} +\indexentry{real-valued?@\scheme{real-valued?}|emph}{153} +\indexentry{rational-valued?@\scheme{rational-valued?}|emph}{153} +\indexentry{integer-valued?@\scheme{integer-valued?}|emph}{153} +\indexentry{char?@\scheme{char?}|emph}{154} +\indexentry{string?@\scheme{string?}|emph}{154} +\indexentry{vector?@\scheme{vector?}|emph}{154} +\indexentry{symbol?@\scheme{symbol?}|emph}{154} +\indexentry{procedure?@\scheme{procedure?}|emph}{155} +\indexentry{bytevector?@\scheme{bytevector?}|emph}{155} +\indexentry{hashtable?@\scheme{hashtable?}|emph}{155} +\indexentry{pairs}{155} +\indexentry{cons cell}{155} +\indexentry{lists}{155} +\indexentry{cdr@\scheme{cdr}}{155} +\indexentry{car@\scheme{car}}{155} +\indexentry{proper list}{155} +\indexentry{improper list}{155} +\indexentry{binary trees}{155} +\indexentry{brackets (~[~]~)@brackets (~\scheme{[}~\scheme{]}~)}{155} +\indexentry{dotted pair}{155} +\indexentry{circular lists}{156} +\indexentry{cons@\scheme{cons}|emph}{156} +\indexentry{car@\scheme{car}|emph}{156} +\indexentry{cdr@\scheme{cdr}|emph}{156} +\indexentry{set-car"!@\scheme{set-car"!}|emph}{157} +\indexentry{set-cdr"!@\scheme{set-cdr"!}|emph}{157} +\indexentry{caar@\scheme{caar}|emph}{157} +\indexentry{cadr@\scheme{cadr}|emph}{157} +\indexentry{cdar@\scheme{cdar}|emph}{157} +\indexentry{cddr@\scheme{cddr}|emph}{157} +\indexentry{caaar@\scheme{caaar}|emph}{157} +\indexentry{caadr@\scheme{caadr}|emph}{157} +\indexentry{cadar@\scheme{cadar}|emph}{157} +\indexentry{caddr@\scheme{caddr}|emph}{157} +\indexentry{cdaar@\scheme{cdaar}|emph}{157} +\indexentry{cdadr@\scheme{cdadr}|emph}{157} +\indexentry{cddar@\scheme{cddar}|emph}{157} +\indexentry{cdddr@\scheme{cdddr}|emph}{157} +\indexentry{caaaar@\scheme{caaaar}|emph}{157} +\indexentry{caaadr@\scheme{caaadr}|emph}{157} +\indexentry{caadar@\scheme{caadar}|emph}{157} +\indexentry{caaddr@\scheme{caaddr}|emph}{157} +\indexentry{cadaar@\scheme{cadaar}|emph}{157} +\indexentry{cadadr@\scheme{cadadr}|emph}{157} +\indexentry{caddar@\scheme{caddar}|emph}{157} +\indexentry{cadddr@\scheme{cadddr}|emph}{157} +\indexentry{cdaaar@\scheme{cdaaar}|emph}{157} +\indexentry{cdaadr@\scheme{cdaadr}|emph}{157} +\indexentry{cdadar@\scheme{cdadar}|emph}{157} +\indexentry{cdaddr@\scheme{cdaddr}|emph}{157} +\indexentry{cddaar@\scheme{cddaar}|emph}{157} +\indexentry{cddadr@\scheme{cddadr}|emph}{157} +\indexentry{cdddar@\scheme{cdddar}|emph}{157} +\indexentry{cddddr@\scheme{cddddr}|emph}{157} +\indexentry{list@\scheme{list}|emph}{158} +\indexentry{cons*@\scheme{cons*}|emph}{158} +\indexentry{list?@\scheme{list?}|emph}{158} +\indexentry{length@\scheme{length}|emph}{159} +\indexentry{list-ref@\scheme{list-ref}|emph}{159} +\indexentry{list-tail@\scheme{list-tail}|emph}{160} +\indexentry{append@\scheme{append}|emph}{160} +\indexentry{append@\scheme{append}|emph}{160} +\indexentry{reverse@\scheme{reverse}|emph}{161} +\indexentry{memq@\scheme{memq}|emph}{161} +\indexentry{memv@\scheme{memv}|emph}{161} +\indexentry{member@\scheme{member}|emph}{161} +\indexentry{memp@\scheme{memp}|emph}{163} +\indexentry{remq@\scheme{remq}|emph}{163} +\indexentry{remv@\scheme{remv}|emph}{163} +\indexentry{remove@\scheme{remove}|emph}{163} +\indexentry{remp@\scheme{remp}|emph}{163} +\indexentry{filter@\scheme{filter}|emph}{164} +\indexentry{partition@\scheme{partition}|emph}{164} +\indexentry{find@\scheme{find}|emph}{165} +\indexentry{assq@\scheme{assq}|emph}{165} +\indexentry{assv@\scheme{assv}|emph}{165} +\indexentry{assoc@\scheme{assoc}|emph}{165} +\indexentry{association list}{165} +\indexentry{assp@\scheme{assp}|emph}{166} +\indexentry{association list}{166} +\indexentry{list-sort@\scheme{list-sort}|emph}{167} +\indexentry{numbers}{167} +\indexentry{integers}{167} +\indexentry{rational numbers}{167} +\indexentry{real numbers}{167} +\indexentry{complex numbers}{167} +\indexentry{integer?@\scheme{integer?}}{167} +\indexentry{rational?@\scheme{rational?}}{167} +\indexentry{real?@\scheme{real?}}{167} +\indexentry{complex?@\scheme{complex?}}{167} +\indexentry{exactness}{167} +\indexentry{exact?@\scheme{exact?}}{167} +\indexentry{inexact?@\scheme{inexact?}}{167} +\indexentry{exactness preserving}{167} +\indexentry{arbitrary precision}{167} +\indexentry{floating point}{167} +\indexentry{#b (binary)@\scheme{\#b} (binary)}{169} +\indexentry{#o (octal)@\scheme{\#o} (octal)}{169} +\indexentry{#d (decimal)@\scheme{\#d} (decimal)}{169} +\indexentry{#x (hexadecimal)@\scheme{\#x} (hexadecimal)}{169} +\indexentry{s (short)@\scheme{s} (short)}{169} +\indexentry{f (single)@\scheme{f} (single)}{169} +\indexentry{d (double)@\scheme{d} (double)}{169} +\indexentry{l (long)@\scheme{l} (long)}{169} +\indexentry{exact?@\scheme{exact?}|emph}{170} +\indexentry{inexact?@\scheme{inexact?}|emph}{170} +\indexentry{=@\scheme{=}|emph}{170} +\indexentry{<@\scheme{<}|emph}{170} +\indexentry{>@\scheme{>}|emph}{170} +\indexentry{<=@\scheme{<=}|emph}{170} +\indexentry{>=@\scheme{>=}|emph}{170} +\indexentry{+@\scheme{+}|emph}{171} +\indexentry{-@\scheme{-}|emph}{172} +\indexentry{-@\scheme{-}|emph}{172} +\indexentry{*@\scheme{*}|emph}{172} +\indexentry{/@\scheme{/}|emph}{172} +\indexentry{/@\scheme{/}|emph}{172} +\indexentry{zero?@\scheme{zero?}|emph}{173} +\indexentry{positive?@\scheme{positive?}|emph}{173} +\indexentry{negative?@\scheme{negative?}|emph}{173} +\indexentry{even?@\scheme{even?}|emph}{174} +\indexentry{odd?@\scheme{odd?}|emph}{174} +\indexentry{finite?@\scheme{finite?}|emph}{174} +\indexentry{infinite?@\scheme{infinite?}|emph}{174} +\indexentry{nan?@\scheme{nan?}|emph}{174} +\indexentry{quotient@\scheme{quotient}|emph}{175} +\indexentry{remainder@\scheme{remainder}|emph}{175} +\indexentry{modulo@\scheme{modulo}|emph}{175} +\indexentry{div@\scheme{div}|emph}{175} +\indexentry{mod@\scheme{mod}|emph}{175} +\indexentry{div-and-mod@\scheme{div-and-mod}|emph}{175} +\indexentry{div0@\scheme{div0}|emph}{176} +\indexentry{mod0@\scheme{mod0}|emph}{176} +\indexentry{div0-and-mod0@\scheme{div0-and-mod0}|emph}{176} +\indexentry{truncate@\scheme{truncate}|emph}{177} +\indexentry{floor@\scheme{floor}|emph}{177} +\indexentry{ceiling@\scheme{ceiling}|emph}{177} +\indexentry{round@\scheme{round}|emph}{178} +\indexentry{abs@\scheme{abs}|emph}{178} +\indexentry{magnitude@\scheme{magnitude}}{178} +\indexentry{max@\scheme{max}|emph}{178} +\indexentry{min@\scheme{min}|emph}{178} +\indexentry{gcd@\scheme{gcd}|emph}{179} +\indexentry{lcm@\scheme{lcm}|emph}{179} +\indexentry{expt@\scheme{expt}|emph}{179} +\indexentry{inexact@\scheme{inexact}|emph}{180} +\indexentry{exactness}{180} +\indexentry{exact@\scheme{exact}|emph}{180} +\indexentry{exactness}{180} +\indexentry{exact->inexact@\scheme{exact->inexact}|emph}{181} +\indexentry{inexact->exact@\scheme{inexact->exact}|emph}{181} +\indexentry{rationalize@\scheme{rationalize}|emph}{181} +\indexentry{numerator@\scheme{numerator}|emph}{181} +\indexentry{denominator@\scheme{denominator}|emph}{181} +\indexentry{real-part@\scheme{real-part}|emph}{182} +\indexentry{imag-part@\scheme{imag-part}|emph}{182} +\indexentry{make-rectangular@\scheme{make-rectangular}|emph}{182} +\indexentry{make-polar@\scheme{make-polar}|emph}{183} +\indexentry{angle@\scheme{angle}|emph}{183} +\indexentry{magnitude@\scheme{magnitude}|emph}{183} +\indexentry{abs@\scheme{abs}}{183} +\indexentry{sqrt@\scheme{sqrt}|emph}{183} +\indexentry{exact-integer-sqrt@\scheme{exact-integer-sqrt}|emph}{184} +\indexentry{exp@\scheme{exp}|emph}{184} +\indexentry{log@\scheme{log}|emph}{184} +\indexentry{log@\scheme{log}|emph}{184} +\indexentry{sin@\scheme{sin}|emph}{185} +\indexentry{cos@\scheme{cos}|emph}{185} +\indexentry{tan@\scheme{tan}|emph}{185} +\indexentry{asin@\scheme{asin}|emph}{185} +\indexentry{acos@\scheme{acos}|emph}{185} +\indexentry{atan@\scheme{atan}|emph}{185} +\indexentry{atan@\scheme{atan}|emph}{185} +\indexentry{bitwise-not@\scheme{bitwise-not}|emph}{186} +\indexentry{bitwise-and@\scheme{bitwise-and}|emph}{186} +\indexentry{bitwise-ior@\scheme{bitwise-ior}|emph}{186} +\indexentry{bitwise-xor@\scheme{bitwise-xor}|emph}{186} +\indexentry{bitwise-if@\scheme{bitwise-if}|emph}{186} +\indexentry{bitwise-bit-count@\scheme{bitwise-bit-count}|emph}{187} +\indexentry{bitwise-length@\scheme{bitwise-length}|emph}{187} +\indexentry{bitwise-first-bit-set@\scheme{bitwise-first-bit-set}|emph}{187} +\indexentry{bitwise-bit-set?@\scheme{bitwise-bit-set?}|emph}{188} +\indexentry{bitwise-copy-bit@\scheme{bitwise-copy-bit}|emph}{188} +\indexentry{bitwise-bit-field@\scheme{bitwise-bit-field}|emph}{189} +\indexentry{bitwise-copy-bit-field@\scheme{bitwise-copy-bit-field}|emph}{189} +\indexentry{bitwise-arithmetic-shift-right@\scheme{bitwise-arithmetic-shift-right}|emph}{189} +\indexentry{bitwise-arithmetic-shift-left@\scheme{bitwise-arithmetic-shift-left}|emph}{189} +\indexentry{bitwise-arithmetic-shift@\scheme{bitwise-arithmetic-shift}|emph}{190} +\indexentry{bitwise-rotate-bit-field@\scheme{bitwise-rotate-bit-field}|emph}{190} +\indexentry{bitwise-reverse-bit-field@\scheme{bitwise-reverse-bit-field}|emph}{191} +\indexentry{string->number@\scheme{string->number}|emph}{191} +\indexentry{string->number@\scheme{string->number}|emph}{191} +\indexentry{number->string@\scheme{number->string}|emph}{191} +\indexentry{number->string@\scheme{number->string}|emph}{191} +\indexentry{number->string@\scheme{number->string}|emph}{191} +\indexentry{fixnum}{192} +\indexentry{fixnum?@\scheme{fixnum?}|emph}{193} +\indexentry{least-fixnum@\scheme{least-fixnum}|emph}{193} +\indexentry{greatest-fixnum@\scheme{greatest-fixnum}|emph}{193} +\indexentry{fixnum-width@\scheme{fixnum-width}|emph}{193} +\indexentry{fx=?@\scheme{fx=?}|emph}{193} +\indexentry{fx?@\scheme{fx>?}|emph}{193} +\indexentry{fx<=?@\scheme{fx<=?}|emph}{193} +\indexentry{fx>=?@\scheme{fx>=?}|emph}{193} +\indexentry{fxzero?@\scheme{fxzero?}|emph}{194} +\indexentry{fxpositive?@\scheme{fxpositive?}|emph}{194} +\indexentry{fxnegative?@\scheme{fxnegative?}|emph}{194} +\indexentry{fxeven?@\scheme{fxeven?}|emph}{194} +\indexentry{fxodd?@\scheme{fxodd?}|emph}{194} +\indexentry{fxmin@\scheme{fxmin}|emph}{195} +\indexentry{fxmax@\scheme{fxmax}|emph}{195} +\indexentry{fx+@\scheme{fx+}|emph}{195} +\indexentry{fx-@\scheme{fx-}|emph}{195} +\indexentry{fx-@\scheme{fx-}|emph}{195} +\indexentry{fx*@\scheme{fx*}|emph}{195} +\indexentry{fxdiv@\scheme{fxdiv}|emph}{196} +\indexentry{fxmod@\scheme{fxmod}|emph}{196} +\indexentry{fxdiv-and-mod@\scheme{fxdiv-and-mod}|emph}{196} +\indexentry{fxdiv0@\scheme{fxdiv0}|emph}{196} +\indexentry{fxmod0@\scheme{fxmod0}|emph}{196} +\indexentry{fxdiv0-and-mod0@\scheme{fxdiv0-and-mod0}|emph}{196} +\indexentry{fx+/carry@\scheme{fx+/carry}|emph}{197} +\indexentry{fx-/carry@\scheme{fx-/carry}|emph}{197} +\indexentry{fx*/carry@\scheme{fx*/carry}|emph}{197} +\indexentry{fxnot@\scheme{fxnot}|emph}{197} +\indexentry{fxand@\scheme{fxand}|emph}{197} +\indexentry{fxior@\scheme{fxior}|emph}{197} +\indexentry{fxxor@\scheme{fxxor}|emph}{197} +\indexentry{fxif@\scheme{fxif}|emph}{198} +\indexentry{fxbit-count@\scheme{fxbit-count}|emph}{198} +\indexentry{fxlength@\scheme{fxlength}|emph}{198} +\indexentry{fxfirst-bit-set@\scheme{fxfirst-bit-set}|emph}{199} +\indexentry{fxbit-set?@\scheme{fxbit-set?}|emph}{199} +\indexentry{fxcopy-bit@\scheme{fxcopy-bit}|emph}{200} +\indexentry{fxbit-field@\scheme{fxbit-field}|emph}{200} +\indexentry{fxcopy-bit-field@\scheme{fxcopy-bit-field}|emph}{200} +\indexentry{fxarithmetic-shift-right@\scheme{fxarithmetic-shift-right}|emph}{201} +\indexentry{fxarithmetic-shift-left@\scheme{fxarithmetic-shift-left}|emph}{201} +\indexentry{fxarithmetic-shift@\scheme{fxarithmetic-shift}|emph}{201} +\indexentry{fxrotate-bit-field@\scheme{fxrotate-bit-field}|emph}{201} +\indexentry{fxreverse-bit-field@\scheme{fxreverse-bit-field}|emph}{202} +\indexentry{flonum}{202} +\indexentry{flonum?@\scheme{flonum?}|emph}{203} +\indexentry{fl=?@\scheme{fl=?}|emph}{203} +\indexentry{fl?@\scheme{fl>?}|emph}{203} +\indexentry{fl<=?@\scheme{fl<=?}|emph}{203} +\indexentry{fl>=?@\scheme{fl>=?}|emph}{203} +\indexentry{flzero?@\scheme{flzero?}|emph}{204} +\indexentry{flpositive?@\scheme{flpositive?}|emph}{204} +\indexentry{flnegative?@\scheme{flnegative?}|emph}{204} +\indexentry{flinteger?@\scheme{flinteger?}|emph}{204} +\indexentry{flfinite?@\scheme{flfinite?}|emph}{205} +\indexentry{flinfinite?@\scheme{flinfinite?}|emph}{205} +\indexentry{flnan?@\scheme{flnan?}|emph}{205} +\indexentry{fleven?@\scheme{fleven?}|emph}{205} +\indexentry{flodd?@\scheme{flodd?}|emph}{205} +\indexentry{flmin@\scheme{flmin}|emph}{205} +\indexentry{flmax@\scheme{flmax}|emph}{205} +\indexentry{fl+@\scheme{fl+}|emph}{206} +\indexentry{fl-@\scheme{fl-}|emph}{206} +\indexentry{fl-@\scheme{fl-}|emph}{206} +\indexentry{fl*@\scheme{fl*}|emph}{207} +\indexentry{fl/@\scheme{fl/}|emph}{207} +\indexentry{fl/@\scheme{fl/}|emph}{207} +\indexentry{fldiv@\scheme{fldiv}|emph}{207} +\indexentry{flmod@\scheme{flmod}|emph}{207} +\indexentry{fldiv-and-mod@\scheme{fldiv-and-mod}|emph}{207} +\indexentry{fldiv0@\scheme{fldiv0}|emph}{208} +\indexentry{flmod0@\scheme{flmod0}|emph}{208} +\indexentry{fldiv0-and-mod0@\scheme{fldiv0-and-mod0}|emph}{208} +\indexentry{flround@\scheme{flround}|emph}{208} +\indexentry{fltruncate@\scheme{fltruncate}|emph}{208} +\indexentry{flfloor@\scheme{flfloor}|emph}{208} +\indexentry{flceiling@\scheme{flceiling}|emph}{208} +\indexentry{flnumerator@\scheme{flnumerator}|emph}{209} +\indexentry{fldenominator@\scheme{fldenominator}|emph}{209} +\indexentry{flabs@\scheme{flabs}|emph}{209} +\indexentry{flexp@\scheme{flexp}|emph}{209} +\indexentry{fllog@\scheme{fllog}|emph}{209} +\indexentry{fllog@\scheme{fllog}|emph}{209} +\indexentry{flsin@\scheme{flsin}|emph}{210} +\indexentry{flcos@\scheme{flcos}|emph}{210} +\indexentry{fltan@\scheme{fltan}|emph}{210} +\indexentry{flasin@\scheme{flasin}|emph}{210} +\indexentry{flacos@\scheme{flacos}|emph}{210} +\indexentry{flatan@\scheme{flatan}|emph}{210} +\indexentry{flatan@\scheme{flatan}|emph}{210} +\indexentry{flsqrt@\scheme{flsqrt}|emph}{210} +\indexentry{flexpt@\scheme{flexpt}|emph}{210} +\indexentry{fixnum->flonum@\scheme{fixnum->flonum}|emph}{211} +\indexentry{real->flonum@\scheme{real->flonum}|emph}{211} +\indexentry{characters}{211} +\indexentry{#\@\scheme{\#{\schbackslash}}}{211} +\indexentry{char=?@\scheme{char=?}|emph}{212} +\indexentry{char?@\scheme{char>?}|emph}{212} +\indexentry{char<=?@\scheme{char<=?}|emph}{212} +\indexentry{char>=?@\scheme{char>=?}|emph}{212} +\indexentry{char-ci=?@\scheme{char-ci=?}|emph}{212} +\indexentry{char-ci?@\scheme{char-ci>?}|emph}{212} +\indexentry{char-ci<=?@\scheme{char-ci<=?}|emph}{212} +\indexentry{char-ci>=?@\scheme{char-ci>=?}|emph}{212} +\indexentry{char-alphabetic?@\scheme{char-alphabetic?}|emph}{213} +\indexentry{char-numeric?@\scheme{char-numeric?}|emph}{213} +\indexentry{char-whitespace?@\scheme{char-whitespace?}|emph}{213} +\indexentry{char-lower-case?@\scheme{char-lower-case?}|emph}{213} +\indexentry{char-upper-case?@\scheme{char-upper-case?}|emph}{213} +\indexentry{char-title-case?@\scheme{char-title-case?}|emph}{213} +\indexentry{char-general-category@\scheme{char-general-category}|emph}{214} +\indexentry{char-upcase@\scheme{char-upcase}|emph}{214} +\indexentry{char-downcase@\scheme{char-downcase}|emph}{214} +\indexentry{char-titlecase@\scheme{char-titlecase}|emph}{214} +\indexentry{char-foldcase@\scheme{char-foldcase}|emph}{215} +\indexentry{char->integer@\scheme{char->integer}|emph}{215} +\indexentry{integer->char@\scheme{integer->char}|emph}{215} +\indexentry{strings}{216} +\indexentry{"" (double quote)@\scheme{""} (double quote)}{216} +\indexentry{double quotes}{216} +\indexentry{string=?@\scheme{string=?}|emph}{216} +\indexentry{string?@\scheme{string>?}|emph}{216} +\indexentry{string<=?@\scheme{string<=?}|emph}{216} +\indexentry{string>=?@\scheme{string>=?}|emph}{216} +\indexentry{string-ci=?@\scheme{string-ci=?}|emph}{217} +\indexentry{string-ci?@\scheme{string-ci>?}|emph}{217} +\indexentry{string-ci<=?@\scheme{string-ci<=?}|emph}{217} +\indexentry{string-ci>=?@\scheme{string-ci>=?}|emph}{217} +\indexentry{string@\scheme{string}|emph}{218} +\indexentry{make-string@\scheme{make-string}|emph}{218} +\indexentry{make-string@\scheme{make-string}|emph}{218} +\indexentry{string-length@\scheme{string-length}|emph}{218} +\indexentry{string-ref@\scheme{string-ref}|emph}{218} +\indexentry{string-set"!@\scheme{string-set"!}|emph}{219} +\indexentry{string-copy@\scheme{string-copy}|emph}{219} +\indexentry{string-append@\scheme{string-append}|emph}{219} +\indexentry{substring@\scheme{substring}|emph}{220} +\indexentry{string-fill"!@\scheme{string-fill"!}|emph}{220} +\indexentry{string-upcase@\scheme{string-upcase}|emph}{221} +\indexentry{string-downcase@\scheme{string-downcase}|emph}{221} +\indexentry{string-foldcase@\scheme{string-foldcase}|emph}{221} +\indexentry{string-titlecase@\scheme{string-titlecase}|emph}{221} +\indexentry{string-normalize-nfd@\scheme{string-normalize-nfd}|emph}{222} +\indexentry{string-normalize-nfkd@\scheme{string-normalize-nfkd}|emph}{222} +\indexentry{string-normalize-nfc@\scheme{string-normalize-nfc}|emph}{222} +\indexentry{string-normalize-nfkc@\scheme{string-normalize-nfkc}|emph}{222} +\indexentry{string->list@\scheme{string->list}|emph}{222} +\indexentry{list->string@\scheme{list->string}|emph}{223} +\indexentry{vectors}{223} +\indexentry{vector@\scheme{vector}|emph}{224} +\indexentry{make-vector@\scheme{make-vector}|emph}{224} +\indexentry{make-vector@\scheme{make-vector}|emph}{224} +\indexentry{vector-length@\scheme{vector-length}|emph}{224} +\indexentry{vector-ref@\scheme{vector-ref}|emph}{224} +\indexentry{vector-set"!@\scheme{vector-set"!}|emph}{225} +\indexentry{vector-fill"!@\scheme{vector-fill"!}|emph}{225} +\indexentry{vector->list@\scheme{vector->list}|emph}{225} +\indexentry{list->vector@\scheme{list->vector}|emph}{226} +\indexentry{vector-sort@\scheme{vector-sort}|emph}{226} +\indexentry{vector-sort"!@\scheme{vector-sort"!}|emph}{226} +\indexentry{endianness@\scheme{endianness}|emph}{228} +\indexentry{native-endianness@\scheme{native-endianness}|emph}{228} +\indexentry{make-bytevector@\scheme{make-bytevector}|emph}{228} +\indexentry{make-bytevector@\scheme{make-bytevector}|emph}{228} +\indexentry{bytevector-length@\scheme{bytevector-length}|emph}{229} +\indexentry{bytevector=?@\scheme{bytevector=?}|emph}{229} +\indexentry{bytevector-fill"!@\scheme{bytevector-fill"!}|emph}{229} +\indexentry{bytevector-copy@\scheme{bytevector-copy}|emph}{229} +\indexentry{bytevector-copy"!@\scheme{bytevector-copy"!}|emph}{230} +\indexentry{bytevector-u8-ref@\scheme{bytevector-u8-ref}|emph}{230} +\indexentry{bytevector-s8-ref@\scheme{bytevector-s8-ref}|emph}{231} +\indexentry{bytevector-u8-set"!@\scheme{bytevector-u8-set"!}|emph}{231} +\indexentry{bytevector-s8-set"!@\scheme{bytevector-s8-set"!}|emph}{231} +\indexentry{bytevector->u8-list@\scheme{bytevector->u8-list}|emph}{232} +\indexentry{u8-list->bytevector@\scheme{u8-list->bytevector}|emph}{232} +\indexentry{bytevector-u16-native-ref@\scheme{bytevector-u16-native-ref}|emph}{232} +\indexentry{bytevector-s16-native-ref@\scheme{bytevector-s16-native-ref}|emph}{232} +\indexentry{bytevector-u32-native-ref@\scheme{bytevector-u32-native-ref}|emph}{232} +\indexentry{bytevector-s32-native-ref@\scheme{bytevector-s32-native-ref}|emph}{232} +\indexentry{bytevector-u64-native-ref@\scheme{bytevector-u64-native-ref}|emph}{232} +\indexentry{bytevector-s64-native-ref@\scheme{bytevector-s64-native-ref}|emph}{232} +\indexentry{bytevector-u16-native-set"!@\scheme{bytevector-u16-native-set"!}|emph}{233} +\indexentry{bytevector-s16-native-set"!@\scheme{bytevector-s16-native-set"!}|emph}{233} +\indexentry{bytevector-u32-native-set"!@\scheme{bytevector-u32-native-set"!}|emph}{233} +\indexentry{bytevector-s32-native-set"!@\scheme{bytevector-s32-native-set"!}|emph}{233} +\indexentry{bytevector-u64-native-set"!@\scheme{bytevector-u64-native-set"!}|emph}{233} +\indexentry{bytevector-s64-native-set"!@\scheme{bytevector-s64-native-set"!}|emph}{233} +\indexentry{bytevector-u16-ref@\scheme{bytevector-u16-ref}|emph}{235} +\indexentry{bytevector-s16-ref@\scheme{bytevector-s16-ref}|emph}{235} +\indexentry{bytevector-u32-ref@\scheme{bytevector-u32-ref}|emph}{235} +\indexentry{bytevector-s32-ref@\scheme{bytevector-s32-ref}|emph}{235} +\indexentry{bytevector-u64-ref@\scheme{bytevector-u64-ref}|emph}{235} +\indexentry{bytevector-s64-ref@\scheme{bytevector-s64-ref}|emph}{235} +\indexentry{bytevector-u16-set"!@\scheme{bytevector-u16-set"!}|emph}{236} +\indexentry{bytevector-s16-set"!@\scheme{bytevector-s16-set"!}|emph}{236} +\indexentry{bytevector-u32-set"!@\scheme{bytevector-u32-set"!}|emph}{236} +\indexentry{bytevector-s32-set"!@\scheme{bytevector-s32-set"!}|emph}{236} +\indexentry{bytevector-u64-set"!@\scheme{bytevector-u64-set"!}|emph}{236} +\indexentry{bytevector-s64-set"!@\scheme{bytevector-s64-set"!}|emph}{236} +\indexentry{bytevector-uint-ref@\scheme{bytevector-uint-ref}|emph}{237} +\indexentry{bytevector-sint-ref@\scheme{bytevector-sint-ref}|emph}{237} +\indexentry{bytevector-uint-set"!@\scheme{bytevector-uint-set"!}|emph}{238} +\indexentry{bytevector-sint-set"!@\scheme{bytevector-sint-set"!}|emph}{238} +\indexentry{bytevector->uint-list@\scheme{bytevector->uint-list}|emph}{238} +\indexentry{bytevector->sint-list@\scheme{bytevector->sint-list}|emph}{238} +\indexentry{uint-list->bytevector@\scheme{uint-list->bytevector}|emph}{239} +\indexentry{sint-list->bytevector@\scheme{sint-list->bytevector}|emph}{239} +\indexentry{bytevector-ieee-single-native-ref@\scheme{bytevector-ieee-single-native-ref}|emph}{239} +\indexentry{bytevector-ieee-double-native-ref@\scheme{bytevector-ieee-double-native-ref}|emph}{239} +\indexentry{bytevector-ieee-single-native-set"!@\scheme{bytevector-ieee-single-native-set"!}|emph}{239} +\indexentry{bytevector-ieee-double-native-set"!@\scheme{bytevector-ieee-double-native-set"!}|emph}{239} +\indexentry{bytevector-ieee-single-ref@\scheme{bytevector-ieee-single-ref}|emph}{240} +\indexentry{bytevector-ieee-double-ref@\scheme{bytevector-ieee-double-ref}|emph}{240} +\indexentry{bytevector-ieee-single-set"!@\scheme{bytevector-ieee-single-set"!}|emph}{240} +\indexentry{bytevector-ieee-double-set"!@\scheme{bytevector-ieee-double-set"!}|emph}{240} +\indexentry{symbols}{241} +\indexentry{symbol table}{241} +\indexentry{symbol=?@\scheme{symbol=?}|emph}{242} +\indexentry{string->symbol@\scheme{string->symbol}|emph}{242} +\indexentry{symbol->string@\scheme{symbol->string}|emph}{242} +\indexentry{boolean=?@\scheme{boolean=?}|emph}{243} +\indexentry{hashtables}{243} +\indexentry{association list}{243} +\indexentry{make-eq-hashtable@\scheme{make-eq-hashtable}|emph}{243} +\indexentry{make-eq-hashtable@\scheme{make-eq-hashtable}|emph}{243} +\indexentry{make-eqv-hashtable@\scheme{make-eqv-hashtable}|emph}{244} +\indexentry{make-eqv-hashtable@\scheme{make-eqv-hashtable}|emph}{244} +\indexentry{make-hashtable@\scheme{make-hashtable}|emph}{244} +\indexentry{make-hashtable@\scheme{make-hashtable}|emph}{244} +\indexentry{hashtable-mutable?@\scheme{hashtable-mutable?}|emph}{245} +\indexentry{hashtable-hash-function@\scheme{hashtable-hash-function}|emph}{245} +\indexentry{hashtable-equivalence-function@\scheme{hashtable-equivalence-function}|emph}{245} +\indexentry{equal-hash@\scheme{equal-hash}|emph}{245} +\indexentry{string-hash@\scheme{string-hash}|emph}{245} +\indexentry{string-ci-hash@\scheme{string-ci-hash}|emph}{245} +\indexentry{symbol-hash@\scheme{symbol-hash}|emph}{245} +\indexentry{hashtable-set"!@\scheme{hashtable-set"!}|emph}{246} +\indexentry{hashtable-ref@\scheme{hashtable-ref}|emph}{246} +\indexentry{hashtable-contains?@\scheme{hashtable-contains?}|emph}{246} +\indexentry{hashtable-update"!@\scheme{hashtable-update"!}|emph}{247} +\indexentry{hashtable-delete"!@\scheme{hashtable-delete"!}|emph}{248} +\indexentry{hashtable-size@\scheme{hashtable-size}|emph}{248} +\indexentry{hashtable-copy@\scheme{hashtable-copy}|emph}{248} +\indexentry{hashtable-copy@\scheme{hashtable-copy}|emph}{248} +\indexentry{hashtable-clear"!@\scheme{hashtable-clear"!}|emph}{249} +\indexentry{hashtable-clear"!@\scheme{hashtable-clear"!}|emph}{249} +\indexentry{hashtable-keys@\scheme{hashtable-keys}|emph}{249} +\indexentry{hashtable-entries@\scheme{hashtable-entries}|emph}{250} +\indexentry{define-enumeration@\scheme{define-enumeration}|emph}{250} +\indexentry{make-enumeration@\scheme{make-enumeration}|emph}{251} +\indexentry{enum-set-constructor@\scheme{enum-set-constructor}|emph}{251} +\indexentry{enum-set-universe@\scheme{enum-set-universe}|emph}{252} +\indexentry{enum-set->list@\scheme{enum-set->list}|emph}{252} +\indexentry{enum-set-subset?@\scheme{enum-set-subset?}|emph}{252} +\indexentry{enum-set=?@\scheme{enum-set=?}|emph}{252} +\indexentry{enum-set-member?@\scheme{enum-set-member?}|emph}{253} +\indexentry{enum-set-union@\scheme{enum-set-union}|emph}{253} +\indexentry{enum-set-intersection@\scheme{enum-set-intersection}|emph}{253} +\indexentry{enum-set-difference@\scheme{enum-set-difference}|emph}{253} +\indexentry{enum-set-complement@\scheme{enum-set-complement}|emph}{254} +\indexentry{enum-set-projection@\scheme{enum-set-projection}|emph}{254} +\indexentry{enum-set-indexer@\scheme{enum-set-indexer}|emph}{254} +\indexentry{port}{257} +\indexentry{input port}{257} +\indexentry{output port}{257} +\indexentry{file}{257} +\indexentry{eof object}{257} +\indexentry{eof-object?@\scheme{eof-object?}}{257} +\indexentry{binary port}{257} +\indexentry{textual port}{257} +\indexentry{octet}{257} +\indexentry{transcoder}{257} +\indexentry{codec}{257} +\indexentry{latin-1}{257} +\indexentry{utf-8}{257} +\indexentry{utf-16}{257} +\indexentry{eol style}{257} +\indexentry{error handling mode}{258} +\indexentry{buffer modes}{258} +\indexentry{block buffering}{258} +\indexentry{line buffering}{258} +\indexentry{make-transcoder@\scheme{make-transcoder}|emph}{259} +\indexentry{make-transcoder@\scheme{make-transcoder}|emph}{259} +\indexentry{make-transcoder@\scheme{make-transcoder}|emph}{259} +\indexentry{transcoder-codec@\scheme{transcoder-codec}|emph}{259} +\indexentry{transcoder-eol-style@\scheme{transcoder-eol-style}|emph}{259} +\indexentry{transcoder-error-handling-mode@\scheme{transcoder-error-handling-mode}|emph}{259} +\indexentry{native-transcoder@\scheme{native-transcoder}|emph}{259} +\indexentry{latin-1-codec@\scheme{latin-1-codec}|emph}{259} +\indexentry{utf-8-codec@\scheme{utf-8-codec}|emph}{259} +\indexentry{utf-16-codec@\scheme{utf-16-codec}|emph}{259} +\indexentry{eol-style@\scheme{eol-style}|emph}{259} +\indexentry{native-eol-style@\scheme{native-eol-style}|emph}{260} +\indexentry{error-handling-mode@\scheme{error-handling-mode}|emph}{260} +\indexentry{file-options@\scheme{file-options}|emph}{261} +\indexentry{buffer-mode@\scheme{buffer-mode}|emph}{261} +\indexentry{buffer-mode?@\scheme{buffer-mode?}|emph}{262} +\indexentry{open-file-input-port@\scheme{open-file-input-port}|emph}{262} +\indexentry{open-file-input-port@\scheme{open-file-input-port}|emph}{262} +\indexentry{open-file-input-port@\scheme{open-file-input-port}|emph}{262} +\indexentry{open-file-input-port@\scheme{open-file-input-port}|emph}{262} +\indexentry{open-file-output-port@\scheme{open-file-output-port}|emph}{262} +\indexentry{open-file-output-port@\scheme{open-file-output-port}|emph}{262} +\indexentry{open-file-output-port@\scheme{open-file-output-port}|emph}{262} +\indexentry{open-file-output-port@\scheme{open-file-output-port}|emph}{262} +\indexentry{open-file-input/output-port@\scheme{open-file-input/output-port}|emph}{263} +\indexentry{open-file-input/output-port@\scheme{open-file-input/output-port}|emph}{263} +\indexentry{open-file-input/output-port@\scheme{open-file-input/output-port}|emph}{263} +\indexentry{open-file-input/output-port@\scheme{open-file-input/output-port}|emph}{263} +\indexentry{current-input-port@\scheme{current-input-port}|emph}{263} +\indexentry{current-output-port@\scheme{current-output-port}|emph}{263} +\indexentry{current-error-port@\scheme{current-error-port}|emph}{263} +\indexentry{standard-input-port@\scheme{standard-input-port}|emph}{264} +\indexentry{standard-output-port@\scheme{standard-output-port}|emph}{264} +\indexentry{standard-error-port@\scheme{standard-error-port}|emph}{264} +\indexentry{open-bytevector-input-port@\scheme{open-bytevector-input-port}|emph}{264} +\indexentry{open-bytevector-input-port@\scheme{open-bytevector-input-port}|emph}{264} +\indexentry{open-string-input-port@\scheme{open-string-input-port}|emph}{265} +\indexentry{open-bytevector-output-port@\scheme{open-bytevector-output-port}|emph}{265} +\indexentry{open-bytevector-output-port@\scheme{open-bytevector-output-port}|emph}{265} +\indexentry{open-string-output-port@\scheme{open-string-output-port}|emph}{266} +\indexentry{call-with-bytevector-output-port@\scheme{call-with-bytevector-output-port}|emph}{266} +\indexentry{call-with-bytevector-output-port@\scheme{call-with-bytevector-output-port}|emph}{266} +\indexentry{call-with-string-output-port@\scheme{call-with-string-output-port}|emph}{267} +\indexentry{object->string@\scheme{object->string}}{267} +\indexentry{make-custom-binary-input-port@\scheme{make-custom-binary-input-port}|emph}{267} +\indexentry{make-custom-binary-output-port@\scheme{make-custom-binary-output-port}|emph}{267} +\indexentry{make-custom-binary-input/output-port@\scheme{make-custom-binary-input/output-port}|emph}{267} +\indexentry{make-custom-textual-input-port@\scheme{make-custom-textual-input-port}|emph}{268} +\indexentry{make-custom-textual-output-port@\scheme{make-custom-textual-output-port}|emph}{268} +\indexentry{make-custom-textual-input/output-port@\scheme{make-custom-textual-input/output-port}|emph}{268} +\indexentry{port?@\scheme{port?}|emph}{270} +\indexentry{input-port?@\scheme{input-port?}|emph}{270} +\indexentry{output-port?@\scheme{output-port?}|emph}{270} +\indexentry{binary-port?@\scheme{binary-port?}|emph}{270} +\indexentry{textual-port?@\scheme{textual-port?}|emph}{270} +\indexentry{close-port@\scheme{close-port}|emph}{270} +\indexentry{transcoded-port@\scheme{transcoded-port}|emph}{271} +\indexentry{port-transcoder@\scheme{port-transcoder}|emph}{271} +\indexentry{port-position@\scheme{port-position}|emph}{271} +\indexentry{port-has-port-position?@\scheme{port-has-port-position?}|emph}{271} +\indexentry{set-port-position"!@\scheme{set-port-position"!}|emph}{272} +\indexentry{port-has-set-port-position"!?@\scheme{port-has-set-port-position"!?}|emph}{272} +\indexentry{call-with-port@\scheme{call-with-port}|emph}{272} +\indexentry{output-port-buffer-mode@\scheme{output-port-buffer-mode}|emph}{273} +\indexentry{eof-object?@\scheme{eof-object?}|emph}{273} +\indexentry{eof-object@\scheme{eof-object}|emph}{273} +\indexentry{get-u8@\scheme{get-u8}|emph}{274} +\indexentry{lookahead-u8@\scheme{lookahead-u8}|emph}{274} +\indexentry{get-bytevector-n@\scheme{get-bytevector-n}|emph}{274} +\indexentry{get-bytevector-n"!@\scheme{get-bytevector-n"!}|emph}{274} +\indexentry{get-bytevector-some@\scheme{get-bytevector-some}|emph}{275} +\indexentry{get-bytevector-all@\scheme{get-bytevector-all}|emph}{275} +\indexentry{get-char@\scheme{get-char}|emph}{275} +\indexentry{lookahead-char@\scheme{lookahead-char}|emph}{275} +\indexentry{get-string-n@\scheme{get-string-n}|emph}{276} +\indexentry{get-string-n"!@\scheme{get-string-n"!}|emph}{276} +\indexentry{get-string-all@\scheme{get-string-all}|emph}{277} +\indexentry{get-line@\scheme{get-line}|emph}{277} +\indexentry{get-datum@\scheme{get-datum}|emph}{278} +\indexentry{port-eof?@\scheme{port-eof?}|emph}{278} +\indexentry{put-u8@\scheme{put-u8}|emph}{278} +\indexentry{put-bytevector@\scheme{put-bytevector}|emph}{279} +\indexentry{put-bytevector@\scheme{put-bytevector}|emph}{279} +\indexentry{put-bytevector@\scheme{put-bytevector}|emph}{279} +\indexentry{put-char@\scheme{put-char}|emph}{279} +\indexentry{put-string@\scheme{put-string}|emph}{279} +\indexentry{put-string@\scheme{put-string}|emph}{279} +\indexentry{put-string@\scheme{put-string}|emph}{279} +\indexentry{put-datum@\scheme{put-datum}|emph}{279} +\indexentry{flush-output-port@\scheme{flush-output-port}|emph}{280} +\indexentry{open-input-file@\scheme{open-input-file}|emph}{280} +\indexentry{open-output-file@\scheme{open-output-file}|emph}{281} +\indexentry{call-with-input-file@\scheme{call-with-input-file}|emph}{281} +\indexentry{call-with-output-file@\scheme{call-with-output-file}|emph}{282} +\indexentry{with-input-from-file@\scheme{with-input-from-file}|emph}{283} +\indexentry{with-output-to-file@\scheme{with-output-to-file}|emph}{283} +\indexentry{read@\scheme{read}|emph}{284} +\indexentry{read@\scheme{read}|emph}{284} +\indexentry{read-char@\scheme{read-char}|emph}{284} +\indexentry{read-char@\scheme{read-char}|emph}{284} +\indexentry{peek-char@\scheme{peek-char}|emph}{284} +\indexentry{peek-char@\scheme{peek-char}|emph}{284} +\indexentry{write@\scheme{write}|emph}{284} +\indexentry{write@\scheme{write}|emph}{284} +\indexentry{display@\scheme{display}|emph}{285} +\indexentry{display@\scheme{display}|emph}{285} +\indexentry{write-char@\scheme{write-char}|emph}{285} +\indexentry{write-char@\scheme{write-char}|emph}{285} +\indexentry{newline@\scheme{newline}|emph}{285} +\indexentry{newline@\scheme{newline}|emph}{285} +\indexentry{close-input-port@\scheme{close-input-port}|emph}{285} +\indexentry{close-output-port@\scheme{close-output-port}|emph}{285} +\indexentry{file-exists?@\scheme{file-exists?}|emph}{286} +\indexentry{delete-file@\scheme{delete-file}|emph}{286} +\indexentry{bytevector->string@\scheme{bytevector->string}|emph}{286} +\indexentry{string->bytevector@\scheme{string->bytevector}|emph}{287} +\indexentry{string->utf8@\scheme{string->utf8}|emph}{287} +\indexentry{string->utf16@\scheme{string->utf16}|emph}{287} +\indexentry{string->utf16@\scheme{string->utf16}|emph}{287} +\indexentry{string->utf32@\scheme{string->utf32}|emph}{287} +\indexentry{string->utf32@\scheme{string->utf32}|emph}{287} +\indexentry{utf8->string@\scheme{utf8->string}|emph}{287} +\indexentry{utf16->string@\scheme{utf16->string}|emph}{288} +\indexentry{utf16->string@\scheme{utf16->string}|emph}{288} +\indexentry{utf32->string@\scheme{utf32->string}|emph}{288} +\indexentry{utf32->string@\scheme{utf32->string}|emph}{288} +\indexentry{syntactic extensions}{291} +\indexentry{syntactic forms}{291} +\indexentry{macros}{291} +\indexentry{define-syntax@\scheme{define-syntax}}{291} +\indexentry{let-syntax@\scheme{let-syntax}}{291} +\indexentry{letrec-syntax@\scheme{letrec-syntax}}{291} +\indexentry{syntax-rules@\scheme{syntax-rules}}{291} +\indexentry{syntax-case@\scheme{syntax-case}}{291} +\indexentry{syntax@\scheme{syntax}}{291} +\indexentry{identifier-syntax@\scheme{identifier-syntax}}{291} +\indexentry{make-variable-transformer@\scheme{make-variable-transformer}}{291} +\indexentry{keywords}{291} +\indexentry{define-syntax@\scheme{define-syntax}|emph}{292} +\indexentry{let-syntax@\scheme{let-syntax}|emph}{293} +\indexentry{letrec-syntax@\scheme{letrec-syntax}|emph}{293} +\indexentry{syntax-rules@\scheme{syntax-rules}|emph}{294} +\indexentry{literals}{294} +\indexentry{patterns}{294} +\indexentry{pattern variable}{294} +\indexentry{_~(underscore)@\scheme{{\schunderscore}}~(underscore)}{294} +\indexentry{underscore~(_)@underscore~(\scheme{{\schunderscore}})}{294} +\indexentry{...~(ellipsis)@\scheme{{\schdot}{\schdot}{\schdot}}~(ellipsis)}{294} +\indexentry{ellipsis (~...~)@ellipsis (~\scheme{{\schdot}{\schdot}{\schdot}}~)}{294} +\indexentry{auxiliary keywords}{294} +\indexentry{templates}{295} +\indexentry{underscore (~_~)@underscore (~\scheme{{\schunderscore}}~)}{296} +\indexentry{_ (underscore)@\scheme{{\schunderscore}} (underscore)}{296} +\indexentry{_~(underscore)@\scheme{{\schunderscore}}~(underscore)|emph}{297} +\indexentry{...~(ellipsis)@\scheme{{\schdot}{\schdot}{\schdot}}~(ellipsis)|emph}{297} +\indexentry{identifier-syntax@\scheme{identifier-syntax}|emph}{297} +\indexentry{identifier-syntax@\scheme{identifier-syntax}|emph}{297} +\indexentry{make-variable-transformer@\scheme{make-variable-transformer}}{298} +\indexentry{syntax object}{298} +\indexentry{syntax-case@\scheme{syntax-case}|emph}{299} +\indexentry{fenders}{299} +\indexentry{pattern variables}{299} +\indexentry{syntax (~#'~)@\scheme{syntax} (~\scheme{\#'}~)|emph}{300} +\indexentry{#' (syntax)@\scheme{\#'} (\scheme{syntax})|emph}{300} +\indexentry{syntax-rules@\scheme{syntax-rules}}{300} +\indexentry{identifier?@\scheme{identifier?}|emph}{301} +\indexentry{fenders}{301} +\indexentry{free-identifier=?@\scheme{free-identifier=?}|emph}{302} +\indexentry{bound-identifier=?@\scheme{bound-identifier=?}|emph}{302} +\indexentry{with-syntax@\scheme{with-syntax}|emph}{304} +\indexentry{cond@\scheme{cond}}{304} +\indexentry{quasisyntax (~#`~)@\scheme{quasisyntax} (~\scheme{\#`}~)|emph}{305} +\indexentry{#` (quasisyntax)@\scheme{\#`} (\scheme{quasisyntax})|emph}{305} +\indexentry{unsyntax (~#,~)@\scheme{unsyntax} (~\scheme{\#,}~)|emph}{305} +\indexentry{#, (unsyntax)@\scheme{\#,} (\scheme{unsyntax})|emph}{305} +\indexentry{unsyntax-splicing (~#,"@~)@\scheme{unsyntax-splicing} (~\scheme{\#,{\schatsign}}~)|emph}{305} +\indexentry{#,"@ (unsyntax-splicing)@\scheme{\#,{\schatsign}} (\scheme{unsyntax-splicing})|emph}{305} +\indexentry{case@\scheme{case}}{306} +\indexentry{make-variable-transformer@\scheme{make-variable-transformer}|emph}{306} +\indexentry{identifier-syntax@\scheme{identifier-syntax}}{307} +\indexentry{syntax->datum@\scheme{syntax->datum}|emph}{308} +\indexentry{datum->syntax@\scheme{datum->syntax}|emph}{308} +\indexentry{loop@\scheme{loop}}{308} +\indexentry{break@\scheme{break}}{308} +\indexentry{include@\scheme{include}}{309} +\indexentry{generate-temporaries@\scheme{generate-temporaries}|emph}{310} +\indexentry{letrec@\scheme{letrec}}{310} +\indexentry{let-values@\scheme{let-values}}{310} +\indexentry{rec@\scheme{rec}}{311} +\indexentry{do@\scheme{do}}{312} +\indexentry{be-like-begin@\scheme{be-like-begin}}{313} +\indexentry{sequence@\scheme{sequence}}{313} +\indexentry{letrec-syntax@\scheme{letrec-syntax}}{314} +\indexentry{let-syntax@\scheme{let-syntax}}{314} +\indexentry{underscore (~_~)@underscore (~\scheme{{\schunderscore}}~)}{315} +\indexentry{_ (underscore)@\scheme{{\schunderscore}} (underscore)}{315} +\indexentry{integrable procedures}{315} +\indexentry{define-integrable@\scheme{define-integrable}}{315} +\indexentry{identifier-syntax@\scheme{identifier-syntax}}{316} +\indexentry{x++@\scheme{x++}}{316} +\indexentry{identifier-syntax@\scheme{identifier-syntax}}{317} +\indexentry{datum->syntax@\scheme{datum->syntax}}{317} +\indexentry{object-oriented programming}{317} +\indexentry{method@\scheme{method}}{317} +\indexentry{identifier-syntax@\scheme{identifier-syntax}}{317} +\indexentry{structures}{318} +\indexentry{define-structure@\scheme{define-structure}}{318} +\indexentry{datum->syntax@\scheme{datum->syntax}}{320} +\indexentry{records}{323} +\indexentry{define-record-type@\scheme{define-record-type}}{323} +\indexentry{make-record-type-descriptor@\scheme{make-record-type-descriptor}}{323} +\indexentry{record generativity}{324} +\indexentry{generative}{324} +\indexentry{nongenerative}{324} +\indexentry{record uid}{325} +\indexentry{record inheritance}{325} +\indexentry{inheritance in records}{325} +\indexentry{parent type}{325} +\indexentry{child type}{325} +\indexentry{protocol for records}{326} +\indexentry{default protocol}{327} +\indexentry{define-record-type@\scheme{define-record-type}|emph}{328} +\indexentry{define-record-type@\scheme{define-record-type}|emph}{328} +\indexentry{sealed record type}{330} +\indexentry{opaque record type}{330} +\indexentry{fields@\scheme{fields}|emph}{331} +\indexentry{mutable@\scheme{mutable}|emph}{331} +\indexentry{immutable@\scheme{immutable}|emph}{331} +\indexentry{parent@\scheme{parent}|emph}{331} +\indexentry{protocol@\scheme{protocol}|emph}{331} +\indexentry{sealed@\scheme{sealed}|emph}{331} +\indexentry{opaque@\scheme{opaque}|emph}{331} +\indexentry{nongenerative@\scheme{nongenerative}|emph}{331} +\indexentry{parent-rtd@\scheme{parent-rtd}|emph}{331} +\indexentry{record-type descriptor}{331} +\indexentry{rtd}{331} +\indexentry{make-record-type-descriptor@\scheme{make-record-type-descriptor}}{331} +\indexentry{make-record-type-descriptor@\scheme{make-record-type-descriptor}|emph}{331} +\indexentry{record-type descriptor}{331} +\indexentry{rtd}{331} +\indexentry{record-type-descriptor?@\scheme{record-type-descriptor?}|emph}{332} +\indexentry{make-record-constructor-descriptor@\scheme{make-record-constructor-descriptor}|emph}{332} +\indexentry{record-constructor descriptor}{332} +\indexentry{rcd}{332} +\indexentry{protocol for records}{332} +\indexentry{record-type-descriptor@\scheme{record-type-descriptor}|emph}{333} +\indexentry{record-constructor-descriptor@\scheme{record-constructor-descriptor}|emph}{333} +\indexentry{record-constructor@\scheme{record-constructor}|emph}{333} +\indexentry{record-predicate@\scheme{record-predicate}|emph}{333} +\indexentry{record-accessor@\scheme{record-accessor}|emph}{334} +\indexentry{record-mutator@\scheme{record-mutator}|emph}{334} +\indexentry{opaque record type}{336} +\indexentry{record-type-name@\scheme{record-type-name}|emph}{336} +\indexentry{record-type-parent@\scheme{record-type-parent}|emph}{336} +\indexentry{record-type-uid@\scheme{record-type-uid}|emph}{336} +\indexentry{record-type-generative?@\scheme{record-type-generative?}|emph}{337} +\indexentry{record-type-sealed?@\scheme{record-type-sealed?}|emph}{337} +\indexentry{record-type-opaque?@\scheme{record-type-opaque?}|emph}{337} +\indexentry{record-type-field-names@\scheme{record-type-field-names}|emph}{337} +\indexentry{record-field-mutable?@\scheme{record-field-mutable?}|emph}{338} +\indexentry{record?@\scheme{record?}|emph}{338} +\indexentry{record-rtd@\scheme{record-rtd}|emph}{338} +\indexentry{libraries}{343} +\indexentry{top-level programs}{343} +\indexentry{library version}{344} +\indexentry{export@\scheme{export}}{345} +\indexentry{import@\scheme{import}}{345} +\indexentry{import spec}{345} +\indexentry{import level}{345} +\indexentry{export level}{345} +\indexentry{import spec}{346} +\indexentry{only import set@\scheme{only} import set}{346} +\indexentry{except import set@\scheme{except} import set}{346} +\indexentry{prefix import set@\scheme{prefix} import set}{346} +\indexentry{rename import set@\scheme{rename} import set}{346} +\indexentry{library version reference}{347} +\indexentry{library body}{348} +\indexentry{indirect exports}{349} +\indexentry{immutability of exports}{349} +\indexentry{command-line@\scheme{command-line}|emph}{350} +\indexentry{exit@\scheme{exit}|emph}{350} +\indexentry{exit@\scheme{exit}|emph}{350} +\indexentry{exceptions}{357} +\indexentry{conditions}{357} +\indexentry{current exception handler}{357} +\indexentry{raise@\scheme{raise}|emph}{357} +\indexentry{raise-continuable@\scheme{raise-continuable}|emph}{357} +\indexentry{error@\scheme{error}|emph}{358} +\indexentry{assertion-violation@\scheme{assertion-violation}|emph}{358} +\indexentry{assert@\scheme{assert}|emph}{359} +\indexentry{syntax-violation@\scheme{syntax-violation}|emph}{359} +\indexentry{syntax-violation@\scheme{syntax-violation}|emph}{359} +\indexentry{with-exception-handler@\scheme{with-exception-handler}|emph}{360} +\indexentry{guard@\scheme{guard}|emph}{361} +\indexentry{condition object}{361} +\indexentry{condition type}{361} +\indexentry{compound condition}{362} +\indexentry{simple condition}{362} +\indexentry{&condition@\scheme{\&condition}|emph}{362} +\indexentry{condition?@\scheme{condition?}|emph}{362} +\indexentry{condition@\scheme{condition}|emph}{362} +\indexentry{simple-conditions@\scheme{simple-conditions}|emph}{363} +\indexentry{define-condition-type@\scheme{define-condition-type}|emph}{364} +\indexentry{condition-predicate@\scheme{condition-predicate}|emph}{365} +\indexentry{condition-accessor@\scheme{condition-accessor}|emph}{365} +\indexentry{&serious@\scheme{\&serious}|emph}{366} +\indexentry{make-serious-condition@\scheme{make-serious-condition}|emph}{366} +\indexentry{serious-condition?@\scheme{serious-condition?}|emph}{366} +\indexentry{&violation@\scheme{\&violation}|emph}{366} +\indexentry{make-violation@\scheme{make-violation}|emph}{366} +\indexentry{violation?@\scheme{violation?}|emph}{366} +\indexentry{&assertion@\scheme{\&assertion}|emph}{366} +\indexentry{make-assertion-violation@\scheme{make-assertion-violation}|emph}{366} +\indexentry{assertion-violation?@\scheme{assertion-violation?}|emph}{366} +\indexentry{&error@\scheme{\&error}|emph}{367} +\indexentry{make-error@\scheme{make-error}|emph}{367} +\indexentry{error?@\scheme{error?}|emph}{367} +\indexentry{&warning@\scheme{\&warning}|emph}{367} +\indexentry{make-warning@\scheme{make-warning}|emph}{367} +\indexentry{warning?@\scheme{warning?}|emph}{367} +\indexentry{&message@\scheme{\&message}|emph}{368} +\indexentry{make-message-condition@\scheme{make-message-condition}|emph}{368} +\indexentry{message-condition?@\scheme{message-condition?}|emph}{368} +\indexentry{condition-message@\scheme{condition-message}|emph}{368} +\indexentry{&irritants@\scheme{\&irritants}|emph}{368} +\indexentry{make-irritants-condition@\scheme{make-irritants-condition}|emph}{368} +\indexentry{irritants-condition?@\scheme{irritants-condition?}|emph}{368} +\indexentry{condition-irritants@\scheme{condition-irritants}|emph}{368} +\indexentry{&who@\scheme{\&who}|emph}{369} +\indexentry{make-who-condition@\scheme{make-who-condition}|emph}{369} +\indexentry{who-condition?@\scheme{who-condition?}|emph}{369} +\indexentry{condition-who@\scheme{condition-who}|emph}{369} +\indexentry{&non-continuable@\scheme{\&non-continuable}|emph}{369} +\indexentry{make-non-continuable-violation@\scheme{make-non-continuable-violation}|emph}{369} +\indexentry{non-continuable-violation?@\scheme{non-continuable-violation?}|emph}{369} +\indexentry{&implementation-restriction@\scheme{\&implementation-restriction}|emph}{369} +\indexentry{make-implementation-restriction-violation@\scheme{make-implementation-restriction-violation}|emph}{369} +\indexentry{implementation-restriction-violation?@\scheme{implementation-restriction-violation?}|emph}{369} +\indexentry{&lexical@\scheme{\&lexical}|emph}{370} +\indexentry{make-lexical-violation@\scheme{make-lexical-violation}|emph}{370} +\indexentry{lexical-violation?@\scheme{lexical-violation?}|emph}{370} +\indexentry{&syntax@\scheme{\&syntax}|emph}{370} +\indexentry{make-syntax-violation@\scheme{make-syntax-violation}|emph}{370} +\indexentry{syntax-violation?@\scheme{syntax-violation?}|emph}{370} +\indexentry{syntax-violation-form@\scheme{syntax-violation-form}|emph}{370} +\indexentry{syntax-violation-subform@\scheme{syntax-violation-subform}|emph}{370} +\indexentry{&undefined@\scheme{\&undefined}|emph}{371} +\indexentry{make-undefined-violation@\scheme{make-undefined-violation}|emph}{371} +\indexentry{undefined-violation?@\scheme{undefined-violation?}|emph}{371} +\indexentry{&i/o@\scheme{\&i/o}|emph}{371} +\indexentry{make-i/o-error@\scheme{make-i/o-error}|emph}{371} +\indexentry{i/o-error?@\scheme{i/o-error?}|emph}{371} +\indexentry{&i/o-read@\scheme{\&i/o-read}|emph}{372} +\indexentry{make-i/o-read-error@\scheme{make-i/o-read-error}|emph}{372} +\indexentry{i/o-read-error?@\scheme{i/o-read-error?}|emph}{372} +\indexentry{&i/o-write@\scheme{\&i/o-write}|emph}{372} +\indexentry{make-i/o-write-error@\scheme{make-i/o-write-error}|emph}{372} +\indexentry{i/o-write-error?@\scheme{i/o-write-error?}|emph}{372} +\indexentry{&i/o-invalid-position@\scheme{\&i/o-invalid-position}|emph}{372} +\indexentry{make-i/o-invalid-position-error@\scheme{make-i/o-invalid-position-error}|emph}{372} +\indexentry{i/o-invalid-position-error?@\scheme{i/o-invalid-position-error?}|emph}{372} +\indexentry{i/o-error-position@\scheme{i/o-error-position}|emph}{372} +\indexentry{&i/o-filename@\scheme{\&i/o-filename}|emph}{373} +\indexentry{make-i/o-filename-error@\scheme{make-i/o-filename-error}|emph}{373} +\indexentry{i/o-filename-error?@\scheme{i/o-filename-error?}|emph}{373} +\indexentry{i/o-error-filename@\scheme{i/o-error-filename}|emph}{373} +\indexentry{&i/o-file-protection@\scheme{\&i/o-file-protection}|emph}{373} +\indexentry{make-i/o-file-protection-error@\scheme{make-i/o-file-protection-error}|emph}{373} +\indexentry{i/o-file-protection-error?@\scheme{i/o-file-protection-error?}|emph}{373} +\indexentry{&i/o-file-is-read-only@\scheme{\&i/o-file-is-read-only}|emph}{374} +\indexentry{make-i/o-file-is-read-only-error@\scheme{make-i/o-file-is-read-only-error}|emph}{374} +\indexentry{i/o-file-is-read-only-error?@\scheme{i/o-file-is-read-only-error?}|emph}{374} +\indexentry{&i/o-file-already-exists@\scheme{\&i/o-file-already-exists}|emph}{374} +\indexentry{make-i/o-file-already-exists-error@\scheme{make-i/o-file-already-exists-error}|emph}{374} +\indexentry{i/o-file-already-exists-error?@\scheme{i/o-file-already-exists-error?}|emph}{374} +\indexentry{&i/o-file-does-not-exist@\scheme{\&i/o-file-does-not-exist}|emph}{374} +\indexentry{make-i/o-file-does-not-exist-error@\scheme{make-i/o-file-does-not-exist-error}|emph}{374} +\indexentry{i/o-file-does-not-exist-error?@\scheme{i/o-file-does-not-exist-error?}|emph}{374} +\indexentry{&i/o-port@\scheme{\&i/o-port}|emph}{375} +\indexentry{make-i/o-port-error@\scheme{make-i/o-port-error}|emph}{375} +\indexentry{i/o-port-error?@\scheme{i/o-port-error?}|emph}{375} +\indexentry{i/o-error-port@\scheme{i/o-error-port}|emph}{375} +\indexentry{&i/o-decoding@\scheme{\&i/o-decoding}|emph}{375} +\indexentry{make-i/o-decoding-error@\scheme{make-i/o-decoding-error}|emph}{375} +\indexentry{i/o-decoding-error?@\scheme{i/o-decoding-error?}|emph}{375} +\indexentry{&i/o-encoding@\scheme{\&i/o-encoding}|emph}{376} +\indexentry{make-i/o-encoding-error@\scheme{make-i/o-encoding-error}|emph}{376} +\indexentry{i/o-encoding-error?@\scheme{i/o-encoding-error?}|emph}{376} +\indexentry{i/o-encoding-error-char@\scheme{i/o-encoding-error-char}|emph}{376} +\indexentry{&no-infinities@\scheme{\&no-infinities}|emph}{376} +\indexentry{make-no-infinities-violation@\scheme{make-no-infinities-violation}|emph}{376} +\indexentry{no-infinities-violation?@\scheme{no-infinities-violation?}|emph}{376} +\indexentry{&no-nans@\scheme{\&no-nans}|emph}{377} +\indexentry{make-no-nans-violation@\scheme{make-no-nans-violation}|emph}{377} +\indexentry{no-nans-violation?@\scheme{no-nans-violation?}|emph}{377} +\indexentry{extended examples}{381} +\indexentry{matrix multiplication}{381} +\indexentry{mul@\scheme{mul}}{382} +\indexentry{vectors}{383} +\indexentry{list-sort@\scheme{list-sort}}{387} +\indexentry{sort@\scheme{sort}}{387} +\indexentry{merge@\scheme{merge}}{387} +\indexentry{set-of@\scheme{set-of}}{389} +\indexentry{sets}{389} +\indexentry{define-syntax@\scheme{define-syntax}}{389} +\indexentry{syntax-rules@\scheme{syntax-rules}}{389} +\indexentry{map@\scheme{map}}{392} +\indexentry{C}{393} +\indexentry{frequency@\scheme{frequency}}{393} +\indexentry{put-datum@\scheme{put-datum}}{397} +\indexentry{write@\scheme{write}}{397} +\indexentry{display@\scheme{display}}{397} +\indexentry{formatted output}{401} +\indexentry{fprintf@\scheme{fprintf}}{401} +\indexentry{printf@\scheme{printf}}{401} +\indexentry{interpret@\scheme{interpret}}{404} +\indexentry{meta-circular interpreter}{404} +\indexentry{interpreter}{404} +\indexentry{environment}{404} +\indexentry{association list}{404} +\indexentry{core syntactic forms}{404} +\indexentry{call-by-value}{407} +\indexentry{call-by-name}{408} +\indexentry{delayed evaluation}{408} +\indexentry{abstract objects}{408} +\indexentry{object-oriented programming}{408} +\indexentry{messages}{408} +\indexentry{define-object@\scheme{define-object}}{408} +\indexentry{inheritance}{412} +\indexentry{complex numbers}{412} +\indexentry{fast Fourier transform (FFT)}{412} +\indexentry{unification}{417} +\indexentry{continuation-passing style}{418} +\indexentry{unify@\scheme{unify}}{418} +\indexentry{engines}{421} +\indexentry{timed preemption}{421} +\indexentry{multiprocessing}{421} +\indexentry{light-weight threads}{421} +\indexentry{threads}{421} +\indexentry{nondeterministic computations}{421} +\indexentry{continuations}{421} +\indexentry{ticks@\var{ticks}|see{engines}}{421} +\indexentry{complete@\var{complete}|see{engines}}{421} +\indexentry{expire@\var{expire}|see{engines}}{421} +\indexentry{fibonacci@\scheme{fibonacci}}{422} +\indexentry{round-robin@\scheme{round-robin}}{423} +\indexentry{operating system}{423} +\indexentry{nondeterministic computations}{424} +\indexentry{por (parallel-or)@\scheme{por} (parallel-or)}{424} +\indexentry{timer interrupts}{425} +\indexentry{call/cc@\scheme{call/cc}}{425} +\indexentry{call-with-current-continuation@\scheme{call-with-current-continuation}}{426} +\indexentry{call/cc@\scheme{call/cc}}{426} +\indexentry{operating system}{429} +\indexentry{nested engines}{429} +\indexentry{datum syntax}{455} +\indexentry{tokens}{455} +\indexentry{whitespace}{455} +\indexentry{line ending}{455} +\indexentry{intraline whitespace}{455} +\indexentry{comments}{455} +\indexentry{; (comment)@\scheme{;} (comment)}{455} +\indexentry{semicolon (~;~)@semicolon (~\scheme{;}~)}{455} +\indexentry{#; (datum comment)@\scheme{\#;} (datum comment)}{455} +\indexentry{datum comment (~#;~)@datum comment (~\scheme{\#;}~)}{455} +\indexentry{#"|\dots"|# (block comment)@\scheme{\#"|{\dots}"|\#} (block comment)}{455} +\indexentry{block comment (~#"|\dots"|#~)@block comment (~\scheme{\#"|{\dots}"|\#}~)}{455} +\indexentry{#"!r6rs@\scheme{\#"!r6rs}}{456} +\indexentry{datum syntax}{456} +\indexentry{boolean syntax}{457} +\indexentry{character syntax}{457} +\indexentry{string syntax}{458} +\indexentry{symbol syntax}{458} +\indexentry{number syntax}{459} +\indexentry{list syntax}{460} +\indexentry{. (dot)@\scheme{{\schdot}} (dot)}{460} +\indexentry{dot (~.~)@dot (~\scheme{{\schdot}}~)}{460} +\indexentry{vector syntax}{461} +\indexentry{bytevector syntax}{461} diff --git a/csug/tspl4/tspl.rfm b/csug/tspl4/tspl.rfm new file mode 100644 index 0000000..433ca0a --- /dev/null +++ b/csug/tspl4/tspl.rfm @@ -0,0 +1,773 @@ +"variable reference" \sfentry{\scheme{\var{variable}}}{\categorysyntax}{\pageref{./binding:s2}} +"lambda" \sfentry{\scheme{(lambda~\var{formals}~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s3}} +"case-lambda" \sfentry{\scheme{(case-lambda~\var{clause}~{\dots})}}{\categorysyntax}{\pageref{./binding:s13}} +"let" \sfentry{\scheme{(let~((\var{var}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s16}} +"let*" \sfentry{\scheme{(let*~((\var{var}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s18}} +"letrec" \sfentry{\scheme{(letrec~((\var{var}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s20}} +"letrec*" \sfentry{\scheme{(letrec*~((\var{var}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s22}} +"let-values" \sfentry{\scheme{(let-values~((\var{formals}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s23}} +"let*-values" \sfentry{\scheme{(let*-values~((\var{formals}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s23}} +"define" \sfentry{\scheme{(define~\var{var}~\var{expr})}}{\categorysyntax}{\pageref{./binding:s24}} +"define" \sfentry{\scheme{(define~\var{var})}}{\categorysyntax}{\pageref{./binding:s24}} +"define" \sfentry{\scheme{(define~(\var{var$_0$}~\var{var$_1$}~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s24}} +"define" \sfentry{\scheme{(define~(\var{var$_0$}~{\schdot}~\var{var$_r$})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s24}} +"define" \sfentry{\scheme{(define~(\var{var$_0$}~\var{var$_1$}~\var{var$_2$}~{\dots}~{\schdot}~\var{var$_r$})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./binding:s24}} +"set!" \sfentry{\scheme{(set!~\var{var}~\var{expr})}}{\categorysyntax}{\pageref{./binding:s28}} +"procedure application" \sfentry{\scheme{(\var{expr$_0$}~\var{expr$_1$}~{\dots})}}{\categorysyntax}{\pageref{./control:s1}} +"apply" \sfentry{\scheme{(apply~\var{procedure}~\var{obj}~{\dots}~\var{list})}}{\categoryprocedure}{\pageref{./control:s3}} +"begin" \sfentry{\scheme{(begin~\var{expr$_1$}~\var{expr$_2$}~{\dots})}}{\categorysyntax}{\pageref{./control:s4}} +"if" \sfentry{\scheme{(if~\var{test}~\var{consequent}~\var{alternative})}}{\categorysyntax}{\pageref{./control:s8}} +"if" \sfentry{\scheme{(if~\var{test}~\var{consequent})}}{\categorysyntax}{\pageref{./control:s8}} +"not" \sfentry{\scheme{(not~\var{obj})}}{\categoryprocedure}{\pageref{./control:s10}} +"and" \sfentry{\scheme{(and~\var{expr}~{\dots})}}{\categorysyntax}{\pageref{./control:s11}} +"or" \sfentry{\scheme{(or~\var{expr}~{\dots})}}{\categorysyntax}{\pageref{./control:s12}} +"cond" \sfentry{\scheme{(cond~\var{clause$_1$}~\var{clause$_2$}~{\dots})}}{\categorysyntax}{\pageref{./control:s13}} +"else" \sfentry{\scheme{else}}{\categorysyntax}{\pageref{./control:s16}} +"!E=>" \sfentry{\scheme{=>}}{\categorysyntax}{\pageref{./control:s16}} +"when" \sfentry{\scheme{(when~\var{test-expr}~\var{expr$_1$}~\var{expr$_2$}~{\dots})}}{\categorysyntax}{\pageref{./control:s17}} +"unless" \sfentry{\scheme{(unless~\var{test-expr}~\var{expr$_1$}~\var{expr$_2$}~{\dots})}}{\categorysyntax}{\pageref{./control:s17}} +"case" \sfentry{\scheme{(case~\var{expr$_0$}~\var{clause$_1$}~\var{clause$_2$}~{\dots})}}{\categorysyntax}{\pageref{./control:s18}} +"let" \sfentry{\scheme{(let~\var{name}~((\var{var}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./control:s20}} +"do" \sfentry{\scheme{(do~((\var{var}~\var{init}~\var{update})~{\dots})~(\var{test}~\var{result}~{\dots})~\var{expr}~{\dots})}}{\categorysyntax}{\pageref{./control:s25}} +"map" \sfentry{\scheme{(map~\var{procedure}~\var{list$_1$}~\var{list$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s30}} +"for-each" \sfentry{\scheme{(for-each~\var{procedure}~\var{list$_1$}~\var{list$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s33}} +"exists" \sfentry{\scheme{(exists~\var{procedure}~\var{list$_1$}~\var{list$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s36}} +"for-all" \sfentry{\scheme{(for-all~\var{procedure}~\var{list$_1$}~\var{list$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s37}} +"fold-left" \sfentry{\scheme{(fold-left~\var{procedure}~\var{obj}~\var{list$_1$}~\var{list$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s38}} +"fold-right" \sfentry{\scheme{(fold-right~\var{procedure}~\var{obj}~\var{list$_1$}~\var{list$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s41}} +"vector-map" \sfentry{\scheme{(vector-map~\var{procedure}~\var{vector$_1$}~\var{vector$_1$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s44}} +"vector-for-each" \sfentry{\scheme{(vector-for-each~\var{procedure}~\var{vector$_1$}~\var{vector$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s47}} +"string-for-each" \sfentry{\scheme{(string-for-each~\var{procedure}~\var{string$_1$}~\var{string$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./control:s50}} +"call/cc" \sfentry{\scheme{(call/cc~\var{procedure})}}{\categoryprocedure}{\pageref{./control:s54}} +"call-with-current-continuation" \sfentry{\scheme{(call-with-current-continuation~\var{procedure})}}{\categoryprocedure}{\pageref{./control:s54}} +"dynamic-wind" \sfentry{\scheme{(dynamic-wind~\var{in}~\var{body}~\var{out})}}{\categoryprocedure}{\pageref{./control:s56}} +"delay" \sfentry{\scheme{(delay~\var{expr})}}{\categorysyntax}{\pageref{./control:s65}} +"force" \sfentry{\scheme{(force~\var{promise})}}{\categoryprocedure}{\pageref{./control:s65}} +"values" \sfentry{\scheme{(values~\var{obj}~{\dots})}}{\categoryprocedure}{\pageref{./control:s70}} +"call-with-values" \sfentry{\scheme{(call-with-values~\var{producer}~\var{consumer})}}{\categoryprocedure}{\pageref{./control:s71}} +"eval" \sfentry{\scheme{(eval~\var{obj}~\var{environment})}}{\categoryprocedure}{\pageref{./control:s80}} +"environment" \sfentry{\scheme{(environment~\var{import-spec}~{\dots})}}{\categoryprocedure}{\pageref{./control:s81}} +"null-environment" \sfentry{\scheme{(null-environment~\var{version})}}{\categoryprocedure}{\pageref{./control:s82}} +"scheme-report-environment" \sfentry{\scheme{(scheme-report-environment~\var{version})}}{\categoryprocedure}{\pageref{./control:s82}} +"constant" \sfentry{\scheme{\var{constant}}}{\categorysyntax}{\pageref{./objects:s1}} +"quote (~'~)" \sfentry{\scheme{(quote~\var{obj})}}{\categorysyntax}{\pageref{./objects:s2}} +"!A' (quote)" \sfentry{\scheme{'\var{obj}}}{\categorysyntax}{\pageref{./objects:s2}} +"quasiquote (~`~)" \sfentry{\scheme{(quasiquote~\var{obj}~{\dots})}}{\categorysyntax}{\pageref{./objects:s5}} +"!B` (quasiquote)" \sfentry{\scheme{`\var{obj}}}{\categorysyntax}{\pageref{./objects:s5}} +"unquote (~,~)" \sfentry{\scheme{(unquote~\var{obj}~{\dots})}}{\categorysyntax}{\pageref{./objects:s5}} +"!C, (unquote)" \sfentry{\scheme{,\var{obj}}}{\categorysyntax}{\pageref{./objects:s5}} +"unquote-splicing (~,@~)" \sfentry{\scheme{(unquote-splicing~\var{obj}~{\dots})}}{\categorysyntax}{\pageref{./objects:s5}} +"!D,@ (unquote-splicing)" \sfentry{\scheme{,{\schatsign}\var{obj}}}{\categorysyntax}{\pageref{./objects:s5}} +"eq?" \sfentry{\scheme{(eq?~\var{obj$_1$}~\var{obj$_2$})}}{\categoryprocedure}{\pageref{./objects:s10}} +"eqv?" \sfentry{\scheme{(eqv?~\var{obj$_1$}~\var{obj$_2$})}}{\categoryprocedure}{\pageref{./objects:s12}} +"equal?" \sfentry{\scheme{(equal?~\var{obj$_1$}~\var{obj$_2$})}}{\categoryprocedure}{\pageref{./objects:s13}} +"boolean?" \sfentry{\scheme{(boolean?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s14}} +"null?" \sfentry{\scheme{(null?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s15}} +"pair?" \sfentry{\scheme{(pair?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s16}} +"number?" \sfentry{\scheme{(number?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s17}} +"complex?" \sfentry{\scheme{(complex?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s17}} +"real?" \sfentry{\scheme{(real?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s17}} +"rational?" \sfentry{\scheme{(rational?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s17}} +"integer?" \sfentry{\scheme{(integer?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s17}} +"real-valued?" \sfentry{\scheme{(real-valued?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s18}} +"rational-valued?" \sfentry{\scheme{(rational-valued?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s18}} +"integer-valued?" \sfentry{\scheme{(integer-valued?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s18}} +"char?" \sfentry{\scheme{(char?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s19}} +"string?" \sfentry{\scheme{(string?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s20}} +"vector?" \sfentry{\scheme{(vector?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s21}} +"symbol?" \sfentry{\scheme{(symbol?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s22}} +"procedure?" \sfentry{\scheme{(procedure?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s23}} +"bytevector?" \sfentry{\scheme{(bytevector?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s24}} +"hashtable?" \sfentry{\scheme{(hashtable?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s25}} +"cons" \sfentry{\scheme{(cons~\var{obj$_1$}~\var{obj$_2$})}}{\categoryprocedure}{\pageref{./objects:s37}} +"car" \sfentry{\scheme{(car~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s38}} +"cdr" \sfentry{\scheme{(cdr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s39}} +"set-car!" \sfentry{\scheme{(set-car!~\var{pair}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s40}} +"set-cdr!" \sfentry{\scheme{(set-cdr!~\var{pair}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s41}} +"caar" \sfentry{\scheme{(caar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cadr" \sfentry{\scheme{(cadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdar" \sfentry{\scheme{(cdar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cddr" \sfentry{\scheme{(cddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caaar" \sfentry{\scheme{(caaar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caadr" \sfentry{\scheme{(caadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cadar" \sfentry{\scheme{(cadar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caddr" \sfentry{\scheme{(caddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdaar" \sfentry{\scheme{(cdaar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdadr" \sfentry{\scheme{(cdadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cddar" \sfentry{\scheme{(cddar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdddr" \sfentry{\scheme{(cdddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caaaar" \sfentry{\scheme{(caaaar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caaadr" \sfentry{\scheme{(caaadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caadar" \sfentry{\scheme{(caadar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caaddr" \sfentry{\scheme{(caaddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cadaar" \sfentry{\scheme{(cadaar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cadadr" \sfentry{\scheme{(cadadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"caddar" \sfentry{\scheme{(caddar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cadddr" \sfentry{\scheme{(cadddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdaaar" \sfentry{\scheme{(cdaaar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdaadr" \sfentry{\scheme{(cdaadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdadar" \sfentry{\scheme{(cdadar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdaddr" \sfentry{\scheme{(cdaddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cddaar" \sfentry{\scheme{(cddaar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cddadr" \sfentry{\scheme{(cddadr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cdddar" \sfentry{\scheme{(cdddar~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"cddddr" \sfentry{\scheme{(cddddr~\var{pair})}}{\categoryprocedure}{\pageref{./objects:s42}} +"list" \sfentry{\scheme{(list~\var{obj}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s43}} +"cons*" \sfentry{\scheme{(cons*~\var{obj}~{\dots}~\var{final-obj})}}{\categoryprocedure}{\pageref{./objects:s44}} +"list?" \sfentry{\scheme{(list?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s45}} +"length" \sfentry{\scheme{(length~\var{list})}}{\categoryprocedure}{\pageref{./objects:s46}} +"list-ref" \sfentry{\scheme{(list-ref~\var{list}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s47}} +"list-tail" \sfentry{\scheme{(list-tail~\var{list}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s48}} +"append" \sfentry{\scheme{(append)}}{\categoryprocedure}{\pageref{./objects:s49}} +"append" \sfentry{\scheme{(append~\var{list}~{\dots}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s49}} +"reverse" \sfentry{\scheme{(reverse~\var{list})}}{\categoryprocedure}{\pageref{./objects:s50}} +"memq" \sfentry{\scheme{(memq~\var{obj}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s51}} +"memv" \sfentry{\scheme{(memv~\var{obj}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s51}} +"member" \sfentry{\scheme{(member~\var{obj}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s51}} +"memp" \sfentry{\scheme{(memp~\var{procedure}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s52}} +"remq" \sfentry{\scheme{(remq~\var{obj}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s53}} +"remv" \sfentry{\scheme{(remv~\var{obj}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s53}} +"remove" \sfentry{\scheme{(remove~\var{obj}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s53}} +"remp" \sfentry{\scheme{(remp~\var{procedure}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s54}} +"filter" \sfentry{\scheme{(filter~\var{procedure}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s55}} +"partition" \sfentry{\scheme{(partition~\var{procedure}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s56}} +"find" \sfentry{\scheme{(find~\var{procedure}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s57}} +"assq" \sfentry{\scheme{(assq~\var{obj}~\var{alist})}}{\categoryprocedure}{\pageref{./objects:s58}} +"assv" \sfentry{\scheme{(assv~\var{obj}~\var{alist})}}{\categoryprocedure}{\pageref{./objects:s58}} +"assoc" \sfentry{\scheme{(assoc~\var{obj}~\var{alist})}}{\categoryprocedure}{\pageref{./objects:s58}} +"assp" \sfentry{\scheme{(assp~\var{procedure}~\var{alist})}}{\categoryprocedure}{\pageref{./objects:s60}} +"list-sort" \sfentry{\scheme{(list-sort~\var{predicate}~\var{list})}}{\categoryprocedure}{\pageref{./objects:s62}} +"exact?" \sfentry{\scheme{(exact?~\var{num})}}{\categoryprocedure}{\pageref{./objects:s86}} +"inexact?" \sfentry{\scheme{(inexact?~\var{num})}}{\categoryprocedure}{\pageref{./objects:s87}} +"=" \sfentry{\scheme{(=~\var{num$_1$}~\var{num$_2$}~\var{num$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s88}} +"<" \sfentry{\scheme{(<~\var{real$_1$}~\var{real$_2$}~\var{real$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s88}} +">" \sfentry{\scheme{(>~\var{real$_1$}~\var{real$_2$}~\var{real$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s88}} +"<=" \sfentry{\scheme{(<=~\var{real$_1$}~\var{real$_2$}~\var{real$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s88}} +">=" \sfentry{\scheme{(>=~\var{real$_1$}~\var{real$_2$}~\var{real$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s88}} +"+" \sfentry{\scheme{(+~\var{num}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s89}} +"-" \sfentry{\scheme{(-~\var{num})}}{\categoryprocedure}{\pageref{./objects:s90}} +"-" \sfentry{\scheme{(-~\var{num$_1$}~\var{num$_2$}~\var{num$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s90}} +"*" \sfentry{\scheme{(*~\var{num}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s91}} +"/" \sfentry{\scheme{(/~\var{num})}}{\categoryprocedure}{\pageref{./objects:s92}} +"/" \sfentry{\scheme{(/~\var{num$_1$}~\var{num$_2$}~\var{num$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s92}} +"zero?" \sfentry{\scheme{(zero?~\var{num})}}{\categoryprocedure}{\pageref{./objects:s93}} +"positive?" \sfentry{\scheme{(positive?~\var{real})}}{\categoryprocedure}{\pageref{./objects:s94}} +"negative?" \sfentry{\scheme{(negative?~\var{real})}}{\categoryprocedure}{\pageref{./objects:s95}} +"even?" \sfentry{\scheme{(even?~\var{int})}}{\categoryprocedure}{\pageref{./objects:s96}} +"odd?" \sfentry{\scheme{(odd?~\var{int})}}{\categoryprocedure}{\pageref{./objects:s96}} +"finite?" \sfentry{\scheme{(finite?~\var{real})}}{\categoryprocedure}{\pageref{./objects:s97}} +"infinite?" \sfentry{\scheme{(infinite?~\var{real})}}{\categoryprocedure}{\pageref{./objects:s97}} +"nan?" \sfentry{\scheme{(nan?~\var{real})}}{\categoryprocedure}{\pageref{./objects:s97}} +"quotient" \sfentry{\scheme{(quotient~\var{int$_1$}~\var{int$_2$})}}{\categoryprocedure}{\pageref{./objects:s98}} +"remainder" \sfentry{\scheme{(remainder~\var{int$_1$}~\var{int$_2$})}}{\categoryprocedure}{\pageref{./objects:s98}} +"modulo" \sfentry{\scheme{(modulo~\var{int$_1$}~\var{int$_2$})}}{\categoryprocedure}{\pageref{./objects:s98}} +"div" \sfentry{\scheme{(div~\var{x$_1$}~\var{x$_2$})}}{\categoryprocedure}{\pageref{./objects:s99}} +"mod" \sfentry{\scheme{(mod~\var{x$_1$}~\var{x$_2$})}}{\categoryprocedure}{\pageref{./objects:s99}} +"div-and-mod" \sfentry{\scheme{(div-and-mod~\var{x$_1$}~\var{x$_2$})}}{\categoryprocedure}{\pageref{./objects:s99}} +"div0" \sfentry{\scheme{(div0~\var{x$_1$}~\var{x$_2$})}}{\categoryprocedure}{\pageref{./objects:s100}} +"mod0" \sfentry{\scheme{(mod0~\var{x$_1$}~\var{x$_2$})}}{\categoryprocedure}{\pageref{./objects:s100}} +"div0-and-mod0" \sfentry{\scheme{(div0-and-mod0~\var{x$_1$}~\var{x$_2$})}}{\categoryprocedure}{\pageref{./objects:s100}} +"truncate" \sfentry{\scheme{(truncate~\var{real})}}{\categoryprocedure}{\pageref{./objects:s101}} +"floor" \sfentry{\scheme{(floor~\var{real})}}{\categoryprocedure}{\pageref{./objects:s102}} +"ceiling" \sfentry{\scheme{(ceiling~\var{real})}}{\categoryprocedure}{\pageref{./objects:s103}} +"round" \sfentry{\scheme{(round~\var{real})}}{\categoryprocedure}{\pageref{./objects:s104}} +"abs" \sfentry{\scheme{(abs~\var{real})}}{\categoryprocedure}{\pageref{./objects:s105}} +"max" \sfentry{\scheme{(max~\var{real$_1$}~\var{real$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s107}} +"min" \sfentry{\scheme{(min~\var{real$_1$}~\var{real$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s108}} +"gcd" \sfentry{\scheme{(gcd~\var{int}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s109}} +"lcm" \sfentry{\scheme{(lcm~\var{int}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s110}} +"expt" \sfentry{\scheme{(expt~\var{num$_1$}~\var{num$_2$})}}{\categoryprocedure}{\pageref{./objects:s111}} +"inexact" \sfentry{\scheme{(inexact~\var{num})}}{\categoryprocedure}{\pageref{./objects:s112}} +"exact" \sfentry{\scheme{(exact~\var{num})}}{\categoryprocedure}{\pageref{./objects:s114}} +"exact->inexact" \sfentry{\scheme{(exact->inexact~\var{num})}}{\categoryprocedure}{\pageref{./objects:s116}} +"inexact->exact" \sfentry{\scheme{(inexact->exact~\var{num})}}{\categoryprocedure}{\pageref{./objects:s116}} +"rationalize" \sfentry{\scheme{(rationalize~\var{real$_1$}~\var{real$_2$})}}{\categoryprocedure}{\pageref{./objects:s117}} +"numerator" \sfentry{\scheme{(numerator~\var{rat})}}{\categoryprocedure}{\pageref{./objects:s118}} +"denominator" \sfentry{\scheme{(denominator~\var{rat})}}{\categoryprocedure}{\pageref{./objects:s119}} +"real-part" \sfentry{\scheme{(real-part~\var{num})}}{\categoryprocedure}{\pageref{./objects:s120}} +"imag-part" \sfentry{\scheme{(imag-part~\var{num})}}{\categoryprocedure}{\pageref{./objects:s121}} +"make-rectangular" \sfentry{\scheme{(make-rectangular~\var{real$_1$}~\var{real$_2$})}}{\categoryprocedure}{\pageref{./objects:s122}} +"make-polar" \sfentry{\scheme{(make-polar~\var{real$_1$}~\var{real$_2$})}}{\categoryprocedure}{\pageref{./objects:s123}} +"angle" \sfentry{\scheme{(angle~\var{num})}}{\categoryprocedure}{\pageref{./objects:s124}} +"magnitude" \sfentry{\scheme{(magnitude~\var{num})}}{\categoryprocedure}{\pageref{./objects:s125}} +"sqrt" \sfentry{\scheme{(sqrt~\var{num})}}{\categoryprocedure}{\pageref{./objects:s127}} +"exact-integer-sqrt" \sfentry{\scheme{(exact-integer-sqrt~\var{n})}}{\categoryprocedure}{\pageref{./objects:s128}} +"exp" \sfentry{\scheme{(exp~\var{num})}}{\categoryprocedure}{\pageref{./objects:s129}} +"log" \sfentry{\scheme{(log~\var{num})}}{\categoryprocedure}{\pageref{./objects:s130}} +"log" \sfentry{\scheme{(log~\var{num$_1$}~\var{num$_2$})}}{\categoryprocedure}{\pageref{./objects:s130}} +"sin" \sfentry{\scheme{(sin~\var{num})}}{\categoryprocedure}{\pageref{./objects:s131}} +"cos" \sfentry{\scheme{(cos~\var{num})}}{\categoryprocedure}{\pageref{./objects:s131}} +"tan" \sfentry{\scheme{(tan~\var{num})}}{\categoryprocedure}{\pageref{./objects:s131}} +"asin" \sfentry{\scheme{(asin~\var{num})}}{\categoryprocedure}{\pageref{./objects:s132}} +"acos" \sfentry{\scheme{(acos~\var{num})}}{\categoryprocedure}{\pageref{./objects:s132}} +"atan" \sfentry{\scheme{(atan~\var{num})}}{\categoryprocedure}{\pageref{./objects:s133}} +"atan" \sfentry{\scheme{(atan~\var{real$_1$}~\var{real$_2$})}}{\categoryprocedure}{\pageref{./objects:s133}} +"bitwise-not" \sfentry{\scheme{(bitwise-not~\var{exint})}}{\categoryprocedure}{\pageref{./objects:s134}} +"bitwise-and" \sfentry{\scheme{(bitwise-and~\var{exint}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s134}} +"bitwise-ior" \sfentry{\scheme{(bitwise-ior~\var{exint}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s134}} +"bitwise-xor" \sfentry{\scheme{(bitwise-xor~\var{exint}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s134}} +"bitwise-if" \sfentry{\scheme{(bitwise-if~\var{exint$_1$}~\var{exint$_2$}~\var{exint$_3$})}}{\categoryprocedure}{\pageref{./objects:s135}} +"bitwise-bit-count" \sfentry{\scheme{(bitwise-bit-count~\var{exint})}}{\categoryprocedure}{\pageref{./objects:s136}} +"bitwise-length" \sfentry{\scheme{(bitwise-length~\var{exint})}}{\categoryprocedure}{\pageref{./objects:s137}} +"bitwise-first-bit-set" \sfentry{\scheme{(bitwise-first-bit-set~\var{exint})}}{\categoryprocedure}{\pageref{./objects:s138}} +"bitwise-bit-set?" \sfentry{\scheme{(bitwise-bit-set?~\var{exint$_1$}~\var{exint$_2$})}}{\categoryprocedure}{\pageref{./objects:s139}} +"bitwise-copy-bit" \sfentry{\scheme{(bitwise-copy-bit~\var{exint$_1$}~\var{exint$_2$}~\var{exint$_3$})}}{\categoryprocedure}{\pageref{./objects:s140}} +"bitwise-bit-field" \sfentry{\scheme{(bitwise-bit-field~\var{exint$_1$}~\var{exint$_2$}~\var{exint$_3$})}}{\categoryprocedure}{\pageref{./objects:s141}} +"bitwise-copy-bit-field" \sfentry{\scheme{(bitwise-copy-bit-field~\var{exint$_1$}~\var{exint$_2$}~\var{exint$_3$}~\var{exint$_4$})}}{\categoryprocedure}{\pageref{./objects:s142}} +"bitwise-arithmetic-shift-right" \sfentry{\scheme{(bitwise-arithmetic-shift-right~\var{exint$_1$}~\var{exint$_2$})}}{\categoryprocedure}{\pageref{./objects:s143}} +"bitwise-arithmetic-shift-left" \sfentry{\scheme{(bitwise-arithmetic-shift-left~\var{exint$_1$}~\var{exint$_2$})}}{\categoryprocedure}{\pageref{./objects:s143}} +"bitwise-arithmetic-shift" \sfentry{\scheme{(bitwise-arithmetic-shift~\var{exint$_1$}~\var{exint$_2$})}}{\categoryprocedure}{\pageref{./objects:s144}} +"bitwise-rotate-bit-field" \sfentry{\scheme{(bitwise-rotate-bit-field~\var{exint$_1$}~\var{exint$_2$}~\var{exint$_3$}~\var{exint$_4$})}}{\categoryprocedure}{\pageref{./objects:s145}} +"bitwise-reverse-bit-field" \sfentry{\scheme{(bitwise-reverse-bit-field~\var{exint$_1$}~\var{exint$_2$}~\var{exint$_3$})}}{\categoryprocedure}{\pageref{./objects:s146}} +"string->number" \sfentry{\scheme{(string->number~\var{string})}}{\categoryprocedure}{\pageref{./objects:s147}} +"string->number" \sfentry{\scheme{(string->number~\var{string}~\var{radix})}}{\categoryprocedure}{\pageref{./objects:s147}} +"number->string" \sfentry{\scheme{(number->string~\var{num})}}{\categoryprocedure}{\pageref{./objects:s148}} +"number->string" \sfentry{\scheme{(number->string~\var{num}~\var{radix})}}{\categoryprocedure}{\pageref{./objects:s148}} +"number->string" \sfentry{\scheme{(number->string~\var{num}~\var{radix}~\var{precision})}}{\categoryprocedure}{\pageref{./objects:s148}} +"fixnum?" \sfentry{\scheme{(fixnum?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s150}} +"least-fixnum" \sfentry{\scheme{(least-fixnum)}}{\categoryprocedure}{\pageref{./objects:s151}} +"greatest-fixnum" \sfentry{\scheme{(greatest-fixnum)}}{\categoryprocedure}{\pageref{./objects:s151}} +"fixnum-width" \sfentry{\scheme{(fixnum-width)}}{\categoryprocedure}{\pageref{./objects:s152}} +"fx=?" \sfentry{\scheme{(fx=?~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s153}} +"fx?" \sfentry{\scheme{(fx>?~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s153}} +"fx<=?" \sfentry{\scheme{(fx<=?~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s153}} +"fx>=?" \sfentry{\scheme{(fx>=?~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s153}} +"fxzero?" \sfentry{\scheme{(fxzero?~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s154}} +"fxpositive?" \sfentry{\scheme{(fxpositive?~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s154}} +"fxnegative?" \sfentry{\scheme{(fxnegative?~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s154}} +"fxeven?" \sfentry{\scheme{(fxeven?~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s155}} +"fxodd?" \sfentry{\scheme{(fxodd?~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s155}} +"fxmin" \sfentry{\scheme{(fxmin~\var{fx$_1$}~\var{fx$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s156}} +"fxmax" \sfentry{\scheme{(fxmax~\var{fx$_1$}~\var{fx$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s156}} +"fx+" \sfentry{\scheme{(fx+~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s157}} +"fx-" \sfentry{\scheme{(fx-~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s158}} +"fx-" \sfentry{\scheme{(fx-~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s158}} +"fx*" \sfentry{\scheme{(fx*~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s159}} +"fxdiv" \sfentry{\scheme{(fxdiv~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s160}} +"fxmod" \sfentry{\scheme{(fxmod~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s160}} +"fxdiv-and-mod" \sfentry{\scheme{(fxdiv-and-mod~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s160}} +"fxdiv0" \sfentry{\scheme{(fxdiv0~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s161}} +"fxmod0" \sfentry{\scheme{(fxmod0~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s161}} +"fxdiv0-and-mod0" \sfentry{\scheme{(fxdiv0-and-mod0~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s161}} +"fx+/carry" \sfentry{\scheme{(fx+/carry~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s162}} +"fx-/carry" \sfentry{\scheme{(fx-/carry~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s162}} +"fx*/carry" \sfentry{\scheme{(fx*/carry~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s162}} +"fxnot" \sfentry{\scheme{(fxnot~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s163}} +"fxand" \sfentry{\scheme{(fxand~\var{fx}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s163}} +"fxior" \sfentry{\scheme{(fxior~\var{fx}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s163}} +"fxxor" \sfentry{\scheme{(fxxor~\var{fx}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s163}} +"fxif" \sfentry{\scheme{(fxif~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s164}} +"fxbit-count" \sfentry{\scheme{(fxbit-count~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s165}} +"fxlength" \sfentry{\scheme{(fxlength~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s166}} +"fxfirst-bit-set" \sfentry{\scheme{(fxfirst-bit-set~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s167}} +"fxbit-set?" \sfentry{\scheme{(fxbit-set?~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s168}} +"fxcopy-bit" \sfentry{\scheme{(fxcopy-bit~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s169}} +"fxbit-field" \sfentry{\scheme{(fxbit-field~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s170}} +"fxcopy-bit-field" \sfentry{\scheme{(fxcopy-bit-field~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$}~\var{fx$_4$})}}{\categoryprocedure}{\pageref{./objects:s171}} +"fxarithmetic-shift-right" \sfentry{\scheme{(fxarithmetic-shift-right~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s172}} +"fxarithmetic-shift-left" \sfentry{\scheme{(fxarithmetic-shift-left~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s172}} +"fxarithmetic-shift" \sfentry{\scheme{(fxarithmetic-shift~\var{fx$_1$}~\var{fx$_2$})}}{\categoryprocedure}{\pageref{./objects:s173}} +"fxrotate-bit-field" \sfentry{\scheme{(fxrotate-bit-field~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$}~\var{fx$_4$})}}{\categoryprocedure}{\pageref{./objects:s174}} +"fxreverse-bit-field" \sfentry{\scheme{(fxreverse-bit-field~\var{fx$_1$}~\var{fx$_2$}~\var{fx$_3$})}}{\categoryprocedure}{\pageref{./objects:s175}} +"flonum?" \sfentry{\scheme{(flonum?~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s177}} +"fl=?" \sfentry{\scheme{(fl=?~\var{fl$_1$}~\var{fl$_2$}~\var{fl$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s178}} +"fl?" \sfentry{\scheme{(fl>?~\var{fl$_1$}~\var{fl$_2$}~\var{fl$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s178}} +"fl<=?" \sfentry{\scheme{(fl<=?~\var{fl$_1$}~\var{fl$_2$}~\var{fl$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s178}} +"fl>=?" \sfentry{\scheme{(fl>=?~\var{fl$_1$}~\var{fl$_2$}~\var{fl$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s178}} +"flzero?" \sfentry{\scheme{(flzero?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s179}} +"flpositive?" \sfentry{\scheme{(flpositive?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s179}} +"flnegative?" \sfentry{\scheme{(flnegative?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s179}} +"flinteger?" \sfentry{\scheme{(flinteger?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s180}} +"flfinite?" \sfentry{\scheme{(flfinite?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s181}} +"flinfinite?" \sfentry{\scheme{(flinfinite?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s181}} +"flnan?" \sfentry{\scheme{(flnan?~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s181}} +"fleven?" \sfentry{\scheme{(fleven?~\var{fl-int})}}{\categoryprocedure}{\pageref{./objects:s182}} +"flodd?" \sfentry{\scheme{(flodd?~\var{fl-int})}}{\categoryprocedure}{\pageref{./objects:s182}} +"flmin" \sfentry{\scheme{(flmin~\var{fl$_1$}~\var{fl$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s183}} +"flmax" \sfentry{\scheme{(flmax~\var{fl$_1$}~\var{fl$_2$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s183}} +"fl+" \sfentry{\scheme{(fl+~\var{fl}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s184}} +"fl-" \sfentry{\scheme{(fl-~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s185}} +"fl-" \sfentry{\scheme{(fl-~\var{fl$_1$}~\var{fl$_2$}~\var{fl$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s185}} +"fl*" \sfentry{\scheme{(fl*~\var{fl}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s186}} +"fl/" \sfentry{\scheme{(fl/~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s187}} +"fl/" \sfentry{\scheme{(fl/~\var{fl$_1$}~\var{fl$_2$}~\var{fl$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s187}} +"fldiv" \sfentry{\scheme{(fldiv~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s188}} +"flmod" \sfentry{\scheme{(flmod~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s188}} +"fldiv-and-mod" \sfentry{\scheme{(fldiv-and-mod~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s188}} +"fldiv0" \sfentry{\scheme{(fldiv0~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s189}} +"flmod0" \sfentry{\scheme{(flmod0~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s189}} +"fldiv0-and-mod0" \sfentry{\scheme{(fldiv0-and-mod0~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s189}} +"flround" \sfentry{\scheme{(flround~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s190}} +"fltruncate" \sfentry{\scheme{(fltruncate~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s190}} +"flfloor" \sfentry{\scheme{(flfloor~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s190}} +"flceiling" \sfentry{\scheme{(flceiling~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s190}} +"flnumerator" \sfentry{\scheme{(flnumerator~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s191}} +"fldenominator" \sfentry{\scheme{(fldenominator~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s191}} +"flabs" \sfentry{\scheme{(flabs~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s192}} +"flexp" \sfentry{\scheme{(flexp~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s193}} +"fllog" \sfentry{\scheme{(fllog~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s193}} +"fllog" \sfentry{\scheme{(fllog~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s193}} +"flsin" \sfentry{\scheme{(flsin~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s194}} +"flcos" \sfentry{\scheme{(flcos~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s194}} +"fltan" \sfentry{\scheme{(fltan~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s194}} +"flasin" \sfentry{\scheme{(flasin~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s195}} +"flacos" \sfentry{\scheme{(flacos~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s195}} +"flatan" \sfentry{\scheme{(flatan~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s195}} +"flatan" \sfentry{\scheme{(flatan~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s195}} +"flsqrt" \sfentry{\scheme{(flsqrt~\var{fl})}}{\categoryprocedure}{\pageref{./objects:s196}} +"flexpt" \sfentry{\scheme{(flexpt~\var{fl$_1$}~\var{fl$_2$})}}{\categoryprocedure}{\pageref{./objects:s197}} +"fixnum->flonum" \sfentry{\scheme{(fixnum->flonum~\var{fx})}}{\categoryprocedure}{\pageref{./objects:s198}} +"real->flonum" \sfentry{\scheme{(real->flonum~\var{real})}}{\categoryprocedure}{\pageref{./objects:s198}} +"char=?" \sfentry{\scheme{(char=?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s201}} +"char?" \sfentry{\scheme{(char>?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s201}} +"char<=?" \sfentry{\scheme{(char<=?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s201}} +"char>=?" \sfentry{\scheme{(char>=?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s201}} +"char-ci=?" \sfentry{\scheme{(char-ci=?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s202}} +"char-ci?" \sfentry{\scheme{(char-ci>?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s202}} +"char-ci<=?" \sfentry{\scheme{(char-ci<=?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s202}} +"char-ci>=?" \sfentry{\scheme{(char-ci>=?~\var{char$_1$}~\var{char$_2$}~\var{char$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s202}} +"char-alphabetic?" \sfentry{\scheme{(char-alphabetic?~\var{char})}}{\categoryprocedure}{\pageref{./objects:s203}} +"char-numeric?" \sfentry{\scheme{(char-numeric?~\var{char})}}{\categoryprocedure}{\pageref{./objects:s203}} +"char-whitespace?" \sfentry{\scheme{(char-whitespace?~\var{char})}}{\categoryprocedure}{\pageref{./objects:s203}} +"char-lower-case?" \sfentry{\scheme{(char-lower-case?~\var{char})}}{\categoryprocedure}{\pageref{./objects:s204}} +"char-upper-case?" \sfentry{\scheme{(char-upper-case?~\var{char})}}{\categoryprocedure}{\pageref{./objects:s204}} +"char-title-case?" \sfentry{\scheme{(char-title-case?~\var{char})}}{\categoryprocedure}{\pageref{./objects:s204}} +"char-general-category" \sfentry{\scheme{(char-general-category~\var{char})}}{\categoryprocedure}{\pageref{./objects:s205}} +"char-upcase" \sfentry{\scheme{(char-upcase~\var{char})}}{\categoryprocedure}{\pageref{./objects:s206}} +"char-downcase" \sfentry{\scheme{(char-downcase~\var{char})}}{\categoryprocedure}{\pageref{./objects:s207}} +"char-titlecase" \sfentry{\scheme{(char-titlecase~\var{char})}}{\categoryprocedure}{\pageref{./objects:s208}} +"char-foldcase" \sfentry{\scheme{(char-foldcase~\var{char})}}{\categoryprocedure}{\pageref{./objects:s209}} +"char->integer" \sfentry{\scheme{(char->integer~\var{char})}}{\categoryprocedure}{\pageref{./objects:s210}} +"integer->char" \sfentry{\scheme{(integer->char~\var{n})}}{\categoryprocedure}{\pageref{./objects:s211}} +"string=?" \sfentry{\scheme{(string=?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s215}} +"string?" \sfentry{\scheme{(string>?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s215}} +"string<=?" \sfentry{\scheme{(string<=?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s215}} +"string>=?" \sfentry{\scheme{(string>=?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s215}} +"string-ci=?" \sfentry{\scheme{(string-ci=?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s216}} +"string-ci?" \sfentry{\scheme{(string-ci>?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s216}} +"string-ci<=?" \sfentry{\scheme{(string-ci<=?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s216}} +"string-ci>=?" \sfentry{\scheme{(string-ci>=?~\var{string$_1$}~\var{string$_2$}~\var{string$_3$}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s216}} +"string" \sfentry{\scheme{(string~\var{char}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s217}} +"make-string" \sfentry{\scheme{(make-string~\var{n})}}{\categoryprocedure}{\pageref{./objects:s218}} +"make-string" \sfentry{\scheme{(make-string~\var{n}~\var{char})}}{\categoryprocedure}{\pageref{./objects:s218}} +"string-length" \sfentry{\scheme{(string-length~\var{string})}}{\categoryprocedure}{\pageref{./objects:s219}} +"string-ref" \sfentry{\scheme{(string-ref~\var{string}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s220}} +"string-set!" \sfentry{\scheme{(string-set!~\var{string}~\var{n}~\var{char})}}{\categoryprocedure}{\pageref{./objects:s221}} +"string-copy" \sfentry{\scheme{(string-copy~\var{string})}}{\categoryprocedure}{\pageref{./objects:s222}} +"string-append" \sfentry{\scheme{(string-append~\var{string}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s223}} +"substring" \sfentry{\scheme{(substring~\var{string}~\var{start}~\var{end})}}{\categoryprocedure}{\pageref{./objects:s224}} +"string-fill!" \sfentry{\scheme{(string-fill!~\var{string}~\var{char})}}{\categoryprocedure}{\pageref{./objects:s225}} +"string-upcase" \sfentry{\scheme{(string-upcase~\var{string})}}{\categoryprocedure}{\pageref{./objects:s226}} +"string-downcase" \sfentry{\scheme{(string-downcase~\var{string})}}{\categoryprocedure}{\pageref{./objects:s226}} +"string-foldcase" \sfentry{\scheme{(string-foldcase~\var{string})}}{\categoryprocedure}{\pageref{./objects:s226}} +"string-titlecase" \sfentry{\scheme{(string-titlecase~\var{string})}}{\categoryprocedure}{\pageref{./objects:s226}} +"string-normalize-nfd" \sfentry{\scheme{(string-normalize-nfd~\var{string})}}{\categoryprocedure}{\pageref{./objects:s227}} +"string-normalize-nfkd" \sfentry{\scheme{(string-normalize-nfkd~\var{string})}}{\categoryprocedure}{\pageref{./objects:s227}} +"string-normalize-nfc" \sfentry{\scheme{(string-normalize-nfc~\var{string})}}{\categoryprocedure}{\pageref{./objects:s227}} +"string-normalize-nfkc" \sfentry{\scheme{(string-normalize-nfkc~\var{string})}}{\categoryprocedure}{\pageref{./objects:s227}} +"string->list" \sfentry{\scheme{(string->list~\var{string})}}{\categoryprocedure}{\pageref{./objects:s228}} +"list->string" \sfentry{\scheme{(list->string~\var{list})}}{\categoryprocedure}{\pageref{./objects:s229}} +"vector" \sfentry{\scheme{(vector~\var{obj}~{\dots})}}{\categoryprocedure}{\pageref{./objects:s231}} +"make-vector" \sfentry{\scheme{(make-vector~\var{n})}}{\categoryprocedure}{\pageref{./objects:s232}} +"make-vector" \sfentry{\scheme{(make-vector~\var{n}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s232}} +"vector-length" \sfentry{\scheme{(vector-length~\var{vector})}}{\categoryprocedure}{\pageref{./objects:s233}} +"vector-ref" \sfentry{\scheme{(vector-ref~\var{vector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s234}} +"vector-set!" \sfentry{\scheme{(vector-set!~\var{vector}~\var{n}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s235}} +"vector-fill!" \sfentry{\scheme{(vector-fill!~\var{vector}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s236}} +"vector->list" \sfentry{\scheme{(vector->list~\var{vector})}}{\categoryprocedure}{\pageref{./objects:s237}} +"list->vector" \sfentry{\scheme{(list->vector~\var{list})}}{\categoryprocedure}{\pageref{./objects:s238}} +"vector-sort" \sfentry{\scheme{(vector-sort~\var{predicate}~\var{vector})}}{\categoryprocedure}{\pageref{./objects:s239}} +"vector-sort!" \sfentry{\scheme{(vector-sort!~\var{predicate}~\var{vector})}}{\categoryprocedure}{\pageref{./objects:s239}} +"endianness" \sfentry{\scheme{(endianness~\var{symbol})}}{\categorysyntax}{\pageref{./objects:s240}} +"native-endianness" \sfentry{\scheme{(native-endianness)}}{\categoryprocedure}{\pageref{./objects:s241}} +"make-bytevector" \sfentry{\scheme{(make-bytevector~\var{n})}}{\categoryprocedure}{\pageref{./objects:s242}} +"make-bytevector" \sfentry{\scheme{(make-bytevector~\var{n}~\var{fill})}}{\categoryprocedure}{\pageref{./objects:s242}} +"bytevector-length" \sfentry{\scheme{(bytevector-length~\var{bytevector})}}{\categoryprocedure}{\pageref{./objects:s243}} +"bytevector=?" \sfentry{\scheme{(bytevector=?~\var{bytevector$_1$}~\var{bytevector$_2$})}}{\categoryprocedure}{\pageref{./objects:s244}} +"bytevector-fill!" \sfentry{\scheme{(bytevector-fill!~\var{bytevector}~\var{fill})}}{\categoryprocedure}{\pageref{./objects:s245}} +"bytevector-copy" \sfentry{\scheme{(bytevector-copy~\var{bytevector})}}{\categoryprocedure}{\pageref{./objects:s246}} +"bytevector-copy!" \sfentry{\scheme{(bytevector-copy!~\var{src}~\var{src-start}~\var{dst}~\var{dst-start}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s247}} +"bytevector-u8-ref" \sfentry{\scheme{(bytevector-u8-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s248}} +"bytevector-s8-ref" \sfentry{\scheme{(bytevector-s8-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s249}} +"bytevector-u8-set!" \sfentry{\scheme{(bytevector-u8-set!~\var{bytevector}~\var{n}~\var{u8})}}{\categoryprocedure}{\pageref{./objects:s250}} +"bytevector-s8-set!" \sfentry{\scheme{(bytevector-s8-set!~\var{bytevector}~\var{n}~\var{s8})}}{\categoryprocedure}{\pageref{./objects:s251}} +"bytevector->u8-list" \sfentry{\scheme{(bytevector->u8-list~\var{bytevector})}}{\categoryprocedure}{\pageref{./objects:s252}} +"u8-list->bytevector" \sfentry{\scheme{(u8-list->bytevector~\var{list})}}{\categoryprocedure}{\pageref{./objects:s253}} +"bytevector-u16-native-ref" \sfentry{\scheme{(bytevector-u16-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s254}} +"bytevector-s16-native-ref" \sfentry{\scheme{(bytevector-s16-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s254}} +"bytevector-u32-native-ref" \sfentry{\scheme{(bytevector-u32-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s254}} +"bytevector-s32-native-ref" \sfentry{\scheme{(bytevector-s32-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s254}} +"bytevector-u64-native-ref" \sfentry{\scheme{(bytevector-u64-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s254}} +"bytevector-s64-native-ref" \sfentry{\scheme{(bytevector-s64-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s254}} +"bytevector-u16-native-set!" \sfentry{\scheme{(bytevector-u16-native-set!~\var{bytevector}~\var{n}~\var{u16})}}{\categoryprocedure}{\pageref{./objects:s255}} +"bytevector-s16-native-set!" \sfentry{\scheme{(bytevector-s16-native-set!~\var{bytevector}~\var{n}~\var{s16})}}{\categoryprocedure}{\pageref{./objects:s255}} +"bytevector-u32-native-set!" \sfentry{\scheme{(bytevector-u32-native-set!~\var{bytevector}~\var{n}~\var{u32})}}{\categoryprocedure}{\pageref{./objects:s255}} +"bytevector-s32-native-set!" \sfentry{\scheme{(bytevector-s32-native-set!~\var{bytevector}~\var{n}~\var{s32})}}{\categoryprocedure}{\pageref{./objects:s255}} +"bytevector-u64-native-set!" \sfentry{\scheme{(bytevector-u64-native-set!~\var{bytevector}~\var{n}~\var{u64})}}{\categoryprocedure}{\pageref{./objects:s255}} +"bytevector-s64-native-set!" \sfentry{\scheme{(bytevector-s64-native-set!~\var{bytevector}~\var{n}~\var{s64})}}{\categoryprocedure}{\pageref{./objects:s255}} +"bytevector-u16-ref" \sfentry{\scheme{(bytevector-u16-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s256}} +"bytevector-s16-ref" \sfentry{\scheme{(bytevector-s16-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s256}} +"bytevector-u32-ref" \sfentry{\scheme{(bytevector-u32-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s256}} +"bytevector-s32-ref" \sfentry{\scheme{(bytevector-s32-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s256}} +"bytevector-u64-ref" \sfentry{\scheme{(bytevector-u64-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s256}} +"bytevector-s64-ref" \sfentry{\scheme{(bytevector-s64-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s256}} +"bytevector-u16-set!" \sfentry{\scheme{(bytevector-u16-set!~\var{bytevector}~\var{n}~\var{u16}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s257}} +"bytevector-s16-set!" \sfentry{\scheme{(bytevector-s16-set!~\var{bytevector}~\var{n}~\var{s16}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s257}} +"bytevector-u32-set!" \sfentry{\scheme{(bytevector-u32-set!~\var{bytevector}~\var{n}~\var{u32}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s257}} +"bytevector-s32-set!" \sfentry{\scheme{(bytevector-s32-set!~\var{bytevector}~\var{n}~\var{s32}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s257}} +"bytevector-u64-set!" \sfentry{\scheme{(bytevector-u64-set!~\var{bytevector}~\var{n}~\var{u64}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s257}} +"bytevector-s64-set!" \sfentry{\scheme{(bytevector-s64-set!~\var{bytevector}~\var{n}~\var{s64}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s257}} +"bytevector-uint-ref" \sfentry{\scheme{(bytevector-uint-ref~\var{bytevector}~\var{n}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s258}} +"bytevector-sint-ref" \sfentry{\scheme{(bytevector-sint-ref~\var{bytevector}~\var{n}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s258}} +"bytevector-uint-set!" \sfentry{\scheme{(bytevector-uint-set!~\var{bytevector}~\var{n}~\var{uint}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s259}} +"bytevector-sint-set!" \sfentry{\scheme{(bytevector-sint-set!~\var{bytevector}~\var{n}~\var{sint}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s259}} +"bytevector->uint-list" \sfentry{\scheme{(bytevector->uint-list~\var{bytevector}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s260}} +"bytevector->sint-list" \sfentry{\scheme{(bytevector->sint-list~\var{bytevector}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s260}} +"uint-list->bytevector" \sfentry{\scheme{(uint-list->bytevector~\var{list}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s261}} +"sint-list->bytevector" \sfentry{\scheme{(sint-list->bytevector~\var{list}~\var{eness}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s261}} +"bytevector-ieee-single-native-ref" \sfentry{\scheme{(bytevector-ieee-single-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s262}} +"bytevector-ieee-double-native-ref" \sfentry{\scheme{(bytevector-ieee-double-native-ref~\var{bytevector}~\var{n})}}{\categoryprocedure}{\pageref{./objects:s262}} +"bytevector-ieee-single-native-set!" \sfentry{\scheme{(bytevector-ieee-single-native-set!~\var{bytevector}~\var{n}~\var{x})}}{\categoryprocedure}{\pageref{./objects:s263}} +"bytevector-ieee-double-native-set!" \sfentry{\scheme{(bytevector-ieee-double-native-set!~\var{bytevector}~\var{n}~\var{x})}}{\categoryprocedure}{\pageref{./objects:s263}} +"bytevector-ieee-single-ref" \sfentry{\scheme{(bytevector-ieee-single-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s264}} +"bytevector-ieee-double-ref" \sfentry{\scheme{(bytevector-ieee-double-ref~\var{bytevector}~\var{n}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s264}} +"bytevector-ieee-single-set!" \sfentry{\scheme{(bytevector-ieee-single-set!~\var{bytevector}~\var{n}~\var{x}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s265}} +"bytevector-ieee-double-set!" \sfentry{\scheme{(bytevector-ieee-double-set!~\var{bytevector}~\var{n}~\var{x}~\var{eness})}}{\categoryprocedure}{\pageref{./objects:s265}} +"symbol=?" \sfentry{\scheme{(symbol=?~\var{symbol$_1$}~\var{symbol$_2$})}}{\categoryprocedure}{\pageref{./objects:s268}} +"string->symbol" \sfentry{\scheme{(string->symbol~\var{string})}}{\categoryprocedure}{\pageref{./objects:s269}} +"symbol->string" \sfentry{\scheme{(symbol->string~\var{symbol})}}{\categoryprocedure}{\pageref{./objects:s270}} +"boolean=?" \sfentry{\scheme{(boolean=?~\var{boolean$_1$}~\var{boolean$_2$})}}{\categoryprocedure}{\pageref{./objects:s271}} +"make-eq-hashtable" \sfentry{\scheme{(make-eq-hashtable)}}{\categoryprocedure}{\pageref{./objects:s274}} +"make-eq-hashtable" \sfentry{\scheme{(make-eq-hashtable~\var{size})}}{\categoryprocedure}{\pageref{./objects:s274}} +"make-eqv-hashtable" \sfentry{\scheme{(make-eqv-hashtable)}}{\categoryprocedure}{\pageref{./objects:s275}} +"make-eqv-hashtable" \sfentry{\scheme{(make-eqv-hashtable~\var{size})}}{\categoryprocedure}{\pageref{./objects:s275}} +"make-hashtable" \sfentry{\scheme{(make-hashtable~\var{hash}~\var{equiv?})}}{\categoryprocedure}{\pageref{./objects:s276}} +"make-hashtable" \sfentry{\scheme{(make-hashtable~\var{hash}~\var{equiv?}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s276}} +"hashtable-mutable?" \sfentry{\scheme{(hashtable-mutable?~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s277}} +"hashtable-hash-function" \sfentry{\scheme{(hashtable-hash-function~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s278}} +"hashtable-equivalence-function" \sfentry{\scheme{(hashtable-equivalence-function~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s278}} +"equal-hash" \sfentry{\scheme{(equal-hash~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s279}} +"string-hash" \sfentry{\scheme{(string-hash~\var{string})}}{\categoryprocedure}{\pageref{./objects:s279}} +"string-ci-hash" \sfentry{\scheme{(string-ci-hash~\var{string})}}{\categoryprocedure}{\pageref{./objects:s279}} +"symbol-hash" \sfentry{\scheme{(symbol-hash~\var{symbol})}}{\categoryprocedure}{\pageref{./objects:s279}} +"hashtable-set!" \sfentry{\scheme{(hashtable-set!~\var{hashtable}~\var{key}~\var{obj})}}{\categoryprocedure}{\pageref{./objects:s280}} +"hashtable-ref" \sfentry{\scheme{(hashtable-ref~\var{hashtable}~\var{key}~\var{default})}}{\categoryprocedure}{\pageref{./objects:s281}} +"hashtable-contains?" \sfentry{\scheme{(hashtable-contains?~\var{hashtable}~\var{key})}}{\categoryprocedure}{\pageref{./objects:s282}} +"hashtable-update!" \sfentry{\scheme{(hashtable-update!~\var{hashtable}~\var{key}~\var{procedure}~\var{default})}}{\categoryprocedure}{\pageref{./objects:s283}} +"hashtable-delete!" \sfentry{\scheme{(hashtable-delete!~\var{hashtable}~\var{key})}}{\categoryprocedure}{\pageref{./objects:s284}} +"hashtable-size" \sfentry{\scheme{(hashtable-size~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s285}} +"hashtable-copy" \sfentry{\scheme{(hashtable-copy~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s286}} +"hashtable-copy" \sfentry{\scheme{(hashtable-copy~\var{hashtable}~\var{mutable?})}}{\categoryprocedure}{\pageref{./objects:s286}} +"hashtable-clear!" \sfentry{\scheme{(hashtable-clear!~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s287}} +"hashtable-clear!" \sfentry{\scheme{(hashtable-clear!~\var{hashtable}~\var{size})}}{\categoryprocedure}{\pageref{./objects:s287}} +"hashtable-keys" \sfentry{\scheme{(hashtable-keys~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s288}} +"hashtable-entries" \sfentry{\scheme{(hashtable-entries~\var{hashtable})}}{\categoryprocedure}{\pageref{./objects:s289}} +"define-enumeration" \sfentry{\scheme{(define-enumeration~\var{name}~(\var{symbol}~{\dots})~\var{constructor})}}{\categorysyntax}{\pageref{./objects:s290}} +"make-enumeration" \sfentry{\scheme{(make-enumeration~\var{symbol-list})}}{\categoryprocedure}{\pageref{./objects:s291}} +"enum-set-constructor" \sfentry{\scheme{(enum-set-constructor~\var{enum-set})}}{\categoryprocedure}{\pageref{./objects:s292}} +"enum-set-universe" \sfentry{\scheme{(enum-set-universe~\var{enum-set})}}{\categoryprocedure}{\pageref{./objects:s293}} +"enum-set->list" \sfentry{\scheme{(enum-set->list~\var{enum-set})}}{\categoryprocedure}{\pageref{./objects:s294}} +"enum-set-subset?" \sfentry{\scheme{(enum-set-subset?~\var{enum-set$_1$}~\var{enum-set$_2$})}}{\categoryprocedure}{\pageref{./objects:s295}} +"enum-set=?" \sfentry{\scheme{(enum-set=?~\var{enum-set$_1$}~\var{enum-set$_2$})}}{\categoryprocedure}{\pageref{./objects:s296}} +"enum-set-member?" \sfentry{\scheme{(enum-set-member?~\var{symbol}~\var{enum-set})}}{\categoryprocedure}{\pageref{./objects:s297}} +"enum-set-union" \sfentry{\scheme{(enum-set-union~\var{enum-set$_1$}~\var{enum-set$_2$})}}{\categoryprocedure}{\pageref{./objects:s298}} +"enum-set-intersection" \sfentry{\scheme{(enum-set-intersection~\var{enum-set$_1$}~\var{enum-set$_2$})}}{\categoryprocedure}{\pageref{./objects:s298}} +"enum-set-difference" \sfentry{\scheme{(enum-set-difference~\var{enum-set$_1$}~\var{enum-set$_2$})}}{\categoryprocedure}{\pageref{./objects:s298}} +"enum-set-complement" \sfentry{\scheme{(enum-set-complement~\var{enum-set})}}{\categoryprocedure}{\pageref{./objects:s299}} +"enum-set-projection" \sfentry{\scheme{(enum-set-projection~\var{enum-set$_1$}~\var{enum-set$_2$})}}{\categoryprocedure}{\pageref{./objects:s300}} +"enum-set-indexer" \sfentry{\scheme{(enum-set-indexer~\var{enum-set})}}{\categoryprocedure}{\pageref{./objects:s301}} +"make-transcoder" \sfentry{\scheme{(make-transcoder~\var{codec})}}{\categoryprocedure}{\pageref{./io:s19}} +"make-transcoder" \sfentry{\scheme{(make-transcoder~\var{codec}~\var{eol-style})}}{\categoryprocedure}{\pageref{./io:s19}} +"make-transcoder" \sfentry{\scheme{(make-transcoder~\var{codec}~\var{eol-style}~\var{error-handling-mode})}}{\categoryprocedure}{\pageref{./io:s19}} +"transcoder-codec" \sfentry{\scheme{(transcoder-codec~\var{transcoder})}}{\categoryprocedure}{\pageref{./io:s20}} +"transcoder-eol-style" \sfentry{\scheme{(transcoder-eol-style~\var{transcoder})}}{\categoryprocedure}{\pageref{./io:s20}} +"transcoder-error-handling-mode" \sfentry{\scheme{(transcoder-error-handling-mode~\var{transcoder})}}{\categoryprocedure}{\pageref{./io:s20}} +"native-transcoder" \sfentry{\scheme{(native-transcoder)}}{\categoryprocedure}{\pageref{./io:s21}} +"latin-1-codec" \sfentry{\scheme{(latin-1-codec)}}{\categoryprocedure}{\pageref{./io:s22}} +"utf-8-codec" \sfentry{\scheme{(utf-8-codec)}}{\categoryprocedure}{\pageref{./io:s22}} +"utf-16-codec" \sfentry{\scheme{(utf-16-codec)}}{\categoryprocedure}{\pageref{./io:s22}} +"eol-style" \sfentry{\scheme{(eol-style~\var{symbol})}}{\categorysyntax}{\pageref{./io:s23}} +"native-eol-style" \sfentry{\scheme{(native-eol-style)}}{\categoryprocedure}{\pageref{./io:s24}} +"error-handling-mode" \sfentry{\scheme{(error-handling-mode~\var{symbol})}}{\categorysyntax}{\pageref{./io:s25}} +"file-options" \sfentry{\scheme{(file-options~\var{symbol}~{\dots})}}{\categorysyntax}{\pageref{./io:s26}} +"buffer-mode" \sfentry{\scheme{(buffer-mode~\var{symbol})}}{\categorysyntax}{\pageref{./io:s27}} +"buffer-mode?" \sfentry{\scheme{(buffer-mode?~\var{obj})}}{\categorysyntax}{\pageref{./io:s28}} +"open-file-input-port" \sfentry{\scheme{(open-file-input-port~\var{path})}}{\categoryprocedure}{\pageref{./io:s29}} +"open-file-input-port" \sfentry{\scheme{(open-file-input-port~\var{path}~\var{options})}}{\categoryprocedure}{\pageref{./io:s29}} +"open-file-input-port" \sfentry{\scheme{(open-file-input-port~\var{path}~\var{options}~\var{b-mode})}}{\categoryprocedure}{\pageref{./io:s29}} +"open-file-input-port" \sfentry{\scheme{(open-file-input-port~\var{path}~\var{options}~\var{b-mode}~\var{?transcoder})}}{\categoryprocedure}{\pageref{./io:s29}} +"open-file-output-port" \sfentry{\scheme{(open-file-output-port~\var{path})}}{\categoryprocedure}{\pageref{./io:s30}} +"open-file-output-port" \sfentry{\scheme{(open-file-output-port~\var{path}~\var{options})}}{\categoryprocedure}{\pageref{./io:s30}} +"open-file-output-port" \sfentry{\scheme{(open-file-output-port~\var{path}~\var{options}~\var{b-mode})}}{\categoryprocedure}{\pageref{./io:s30}} +"open-file-output-port" \sfentry{\scheme{(open-file-output-port~\var{path}~\var{options}~\var{b-mode}~\var{?transcoder})}}{\categoryprocedure}{\pageref{./io:s30}} +"open-file-input/output-port" \sfentry{\scheme{(open-file-input/output-port~\var{path})}}{\categoryprocedure}{\pageref{./io:s31}} +"open-file-input/output-port" \sfentry{\scheme{(open-file-input/output-port~\var{path}~\var{options})}}{\categoryprocedure}{\pageref{./io:s31}} +"open-file-input/output-port" \sfentry{\scheme{(open-file-input/output-port~\var{path}~\var{options}~\var{b-mode})}}{\categoryprocedure}{\pageref{./io:s31}} +"open-file-input/output-port" \sfentry{\scheme{(open-file-input/output-port~\var{path}~\var{options}~\var{b-mode}~\var{?transcoder})}}{\categoryprocedure}{\pageref{./io:s31}} +"current-input-port" \sfentry{\scheme{(current-input-port)}}{\categoryprocedure}{\pageref{./io:s32}} +"current-output-port" \sfentry{\scheme{(current-output-port)}}{\categoryprocedure}{\pageref{./io:s32}} +"current-error-port" \sfentry{\scheme{(current-error-port)}}{\categoryprocedure}{\pageref{./io:s32}} +"standard-input-port" \sfentry{\scheme{(standard-input-port)}}{\categoryprocedure}{\pageref{./io:s33}} +"standard-output-port" \sfentry{\scheme{(standard-output-port)}}{\categoryprocedure}{\pageref{./io:s33}} +"standard-error-port" \sfentry{\scheme{(standard-error-port)}}{\categoryprocedure}{\pageref{./io:s33}} +"open-bytevector-input-port" \sfentry{\scheme{(open-bytevector-input-port~\var{bytevector})}}{\categoryprocedure}{\pageref{./io:s34}} +"open-bytevector-input-port" \sfentry{\scheme{(open-bytevector-input-port~\var{bytevector}~\var{?transcoder})}}{\categoryprocedure}{\pageref{./io:s34}} +"open-string-input-port" \sfentry{\scheme{(open-string-input-port~\var{string})}}{\categoryprocedure}{\pageref{./io:s35}} +"open-bytevector-output-port" \sfentry{\scheme{(open-bytevector-output-port)}}{\categoryprocedure}{\pageref{./io:s36}} +"open-bytevector-output-port" \sfentry{\scheme{(open-bytevector-output-port~\var{?transcoder})}}{\categoryprocedure}{\pageref{./io:s36}} +"open-string-output-port" \sfentry{\scheme{(open-string-output-port)}}{\categoryprocedure}{\pageref{./io:s37}} +"call-with-bytevector-output-port" \sfentry{\scheme{(call-with-bytevector-output-port~\var{procedure})}}{\categoryprocedure}{\pageref{./io:s38}} +"call-with-bytevector-output-port" \sfentry{\scheme{(call-with-bytevector-output-port~\var{procedure}~\var{?transcoder})}}{\categoryprocedure}{\pageref{./io:s38}} +"call-with-string-output-port" \sfentry{\scheme{(call-with-string-output-port~\var{procedure})}}{\categoryprocedure}{\pageref{./io:s39}} +"make-custom-binary-input-port" \sfentry{\scheme{(make-custom-binary-input-port~\var{id}~\var{r!}~\var{gp}~\var{sp!}~\var{close})}}{\categoryprocedure}{\pageref{./io:s41}} +"make-custom-binary-output-port" \sfentry{\scheme{(make-custom-binary-output-port~\var{id}~\var{w!}~\var{gp}~\var{sp!}~\var{close})}}{\categoryprocedure}{\pageref{./io:s41}} +"make-custom-binary-input/output-port" \sfentry{\scheme{(make-custom-binary-input/output-port~\var{id}~\var{r!}~\var{w!}~\var{gp}~\var{sp!}~\var{close})}}{\categoryprocedure}{\pageref{./io:s41}} +"make-custom-textual-input-port" \sfentry{\scheme{(make-custom-textual-input-port~\var{id}~\var{r!}~\var{gp}~\var{sp!}~\var{close})}}{\categoryprocedure}{\pageref{./io:s42}} +"make-custom-textual-output-port" \sfentry{\scheme{(make-custom-textual-output-port~\var{id}~\var{w!}~\var{gp}~\var{sp!}~\var{close})}}{\categoryprocedure}{\pageref{./io:s42}} +"make-custom-textual-input/output-port" \sfentry{\scheme{(make-custom-textual-input/output-port~\var{id}~\var{r!}~\var{w!}~\var{gp}~\var{sp!}~\var{close})}}{\categoryprocedure}{\pageref{./io:s42}} +"port?" \sfentry{\scheme{(port?~\var{obj})}}{\categoryprocedure}{\pageref{./io:s43}} +"input-port?" \sfentry{\scheme{(input-port?~\var{obj})}}{\categoryprocedure}{\pageref{./io:s44}} +"output-port?" \sfentry{\scheme{(output-port?~\var{obj})}}{\categoryprocedure}{\pageref{./io:s44}} +"binary-port?" \sfentry{\scheme{(binary-port?~\var{obj})}}{\categoryprocedure}{\pageref{./io:s45}} +"textual-port?" \sfentry{\scheme{(textual-port?~\var{obj})}}{\categoryprocedure}{\pageref{./io:s45}} +"close-port" \sfentry{\scheme{(close-port~\var{port})}}{\categoryprocedure}{\pageref{./io:s46}} +"transcoded-port" \sfentry{\scheme{(transcoded-port~\var{binary-port}~\var{transcoder})}}{\categoryprocedure}{\pageref{./io:s47}} +"port-transcoder" \sfentry{\scheme{(port-transcoder~\var{port})}}{\categoryprocedure}{\pageref{./io:s48}} +"port-position" \sfentry{\scheme{(port-position~\var{port})}}{\categoryprocedure}{\pageref{./io:s49}} +"port-has-port-position?" \sfentry{\scheme{(port-has-port-position?~\var{port})}}{\categoryprocedure}{\pageref{./io:s49}} +"set-port-position!" \sfentry{\scheme{(set-port-position!~\var{port}~\var{pos})}}{\categoryprocedure}{\pageref{./io:s50}} +"port-has-set-port-position!?" \sfentry{\scheme{(port-has-set-port-position!?~\var{port})}}{\categoryprocedure}{\pageref{./io:s50}} +"call-with-port" \sfentry{\scheme{(call-with-port~\var{port}~\var{procedure})}}{\categoryprocedure}{\pageref{./io:s51}} +"output-port-buffer-mode" \sfentry{\scheme{(output-port-buffer-mode~\var{port})}}{\categoryprocedure}{\pageref{./io:s52}} +"eof-object?" \sfentry{\scheme{(eof-object?~\var{obj})}}{\categoryprocedure}{\pageref{./io:s53}} +"eof-object" \sfentry{\scheme{(eof-object)}}{\categoryprocedure}{\pageref{./io:s54}} +"get-u8" \sfentry{\scheme{(get-u8~\var{binary-input-port})}}{\categoryprocedure}{\pageref{./io:s55}} +"lookahead-u8" \sfentry{\scheme{(lookahead-u8~\var{binary-input-port})}}{\categoryprocedure}{\pageref{./io:s56}} +"get-bytevector-n" \sfentry{\scheme{(get-bytevector-n~\var{binary-input-port}~\var{n})}}{\categoryprocedure}{\pageref{./io:s57}} +"get-bytevector-n!" \sfentry{\scheme{(get-bytevector-n!~\var{binary-input-port}~\var{bytevector}~\var{start}~\var{n})}}{\categoryprocedure}{\pageref{./io:s58}} +"get-bytevector-some" \sfentry{\scheme{(get-bytevector-some~\var{binary-input-port})}}{\categoryprocedure}{\pageref{./io:s59}} +"get-bytevector-all" \sfentry{\scheme{(get-bytevector-all~\var{binary-input-port})}}{\categoryprocedure}{\pageref{./io:s60}} +"get-char" \sfentry{\scheme{(get-char~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s61}} +"lookahead-char" \sfentry{\scheme{(lookahead-char~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s62}} +"get-string-n" \sfentry{\scheme{(get-string-n~\var{textual-input-port}~\var{n})}}{\categoryprocedure}{\pageref{./io:s63}} +"get-string-n!" \sfentry{\scheme{(get-string-n!~\var{textual-input-port}~\var{string}~\var{start}~\var{n})}}{\categoryprocedure}{\pageref{./io:s64}} +"get-string-all" \sfentry{\scheme{(get-string-all~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s65}} +"get-line" \sfentry{\scheme{(get-line~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s66}} +"get-datum" \sfentry{\scheme{(get-datum~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s67}} +"port-eof?" \sfentry{\scheme{(port-eof?~\var{input-port})}}{\categoryprocedure}{\pageref{./io:s68}} +"put-u8" \sfentry{\scheme{(put-u8~\var{binary-output-port}~\var{octet})}}{\categoryprocedure}{\pageref{./io:s69}} +"put-bytevector" \sfentry{\scheme{(put-bytevector~\var{binary-output-port}~\var{bytevector})}}{\categoryprocedure}{\pageref{./io:s70}} +"put-bytevector" \sfentry{\scheme{(put-bytevector~\var{binary-output-port}~\var{bytevector}~\var{start})}}{\categoryprocedure}{\pageref{./io:s70}} +"put-bytevector" \sfentry{\scheme{(put-bytevector~\var{binary-output-port}~\var{bytevector}~\var{start}~\var{n})}}{\categoryprocedure}{\pageref{./io:s70}} +"put-char" \sfentry{\scheme{(put-char~\var{textual-output-port}~\var{char})}}{\categoryprocedure}{\pageref{./io:s71}} +"put-string" \sfentry{\scheme{(put-string~\var{textual-output-port}~\var{string})}}{\categoryprocedure}{\pageref{./io:s72}} +"put-string" \sfentry{\scheme{(put-string~\var{textual-output-port}~\var{string}~\var{start})}}{\categoryprocedure}{\pageref{./io:s72}} +"put-string" \sfentry{\scheme{(put-string~\var{textual-output-port}~\var{string}~\var{start}~\var{n})}}{\categoryprocedure}{\pageref{./io:s72}} +"put-datum" \sfentry{\scheme{(put-datum~\var{textual-output-port}~\var{obj})}}{\categoryprocedure}{\pageref{./io:s73}} +"flush-output-port" \sfentry{\scheme{(flush-output-port~\var{output-port})}}{\categoryprocedure}{\pageref{./io:s74}} +"open-input-file" \sfentry{\scheme{(open-input-file~\var{path})}}{\categoryprocedure}{\pageref{./io:s75}} +"open-output-file" \sfentry{\scheme{(open-output-file~\var{path})}}{\categoryprocedure}{\pageref{./io:s76}} +"call-with-input-file" \sfentry{\scheme{(call-with-input-file~\var{path}~\var{procedure})}}{\categoryprocedure}{\pageref{./io:s77}} +"call-with-output-file" \sfentry{\scheme{(call-with-output-file~\var{path}~\var{procedure})}}{\categoryprocedure}{\pageref{./io:s78}} +"with-input-from-file" \sfentry{\scheme{(with-input-from-file~\var{path}~\var{thunk})}}{\categoryprocedure}{\pageref{./io:s79}} +"with-output-to-file" \sfentry{\scheme{(with-output-to-file~\var{path}~\var{thunk})}}{\categoryprocedure}{\pageref{./io:s80}} +"read" \sfentry{\scheme{(read)}}{\categoryprocedure}{\pageref{./io:s81}} +"read" \sfentry{\scheme{(read~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s81}} +"read-char" \sfentry{\scheme{(read-char)}}{\categoryprocedure}{\pageref{./io:s82}} +"read-char" \sfentry{\scheme{(read-char~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s82}} +"peek-char" \sfentry{\scheme{(peek-char)}}{\categoryprocedure}{\pageref{./io:s83}} +"peek-char" \sfentry{\scheme{(peek-char~\var{textual-input-port})}}{\categoryprocedure}{\pageref{./io:s83}} +"write" \sfentry{\scheme{(write~\var{obj})}}{\categoryprocedure}{\pageref{./io:s84}} +"write" \sfentry{\scheme{(write~\var{obj}~\var{textual-output-port})}}{\categoryprocedure}{\pageref{./io:s84}} +"display" \sfentry{\scheme{(display~\var{obj})}}{\categoryprocedure}{\pageref{./io:s85}} +"display" \sfentry{\scheme{(display~\var{obj}~\var{textual-output-port})}}{\categoryprocedure}{\pageref{./io:s85}} +"write-char" \sfentry{\scheme{(write-char~\var{char})}}{\categoryprocedure}{\pageref{./io:s86}} +"write-char" \sfentry{\scheme{(write-char~\var{char}~\var{textual-output-port})}}{\categoryprocedure}{\pageref{./io:s86}} +"newline" \sfentry{\scheme{(newline)}}{\categoryprocedure}{\pageref{./io:s87}} +"newline" \sfentry{\scheme{(newline~\var{textual-output-port})}}{\categoryprocedure}{\pageref{./io:s87}} +"close-input-port" \sfentry{\scheme{(close-input-port~\var{input-port})}}{\categoryprocedure}{\pageref{./io:s88}} +"close-output-port" \sfentry{\scheme{(close-output-port~\var{output-port})}}{\categoryprocedure}{\pageref{./io:s88}} +"file-exists?" \sfentry{\scheme{(file-exists?~\var{path})}}{\categoryprocedure}{\pageref{./io:s89}} +"delete-file" \sfentry{\scheme{(delete-file~\var{path})}}{\categoryprocedure}{\pageref{./io:s90}} +"bytevector->string" \sfentry{\scheme{(bytevector->string~\var{bytevector}~\var{transcoder})}}{\categoryprocedure}{\pageref{./io:s91}} +"string->bytevector" \sfentry{\scheme{(string->bytevector~\var{string}~\var{transcoder})}}{\categoryprocedure}{\pageref{./io:s92}} +"string->utf8" \sfentry{\scheme{(string->utf8~\var{string})}}{\categoryprocedure}{\pageref{./io:s93}} +"string->utf16" \sfentry{\scheme{(string->utf16~\var{string})}}{\categoryprocedure}{\pageref{./io:s94}} +"string->utf16" \sfentry{\scheme{(string->utf16~\var{string}~\var{endianness})}}{\categoryprocedure}{\pageref{./io:s94}} +"string->utf32" \sfentry{\scheme{(string->utf32~\var{string})}}{\categoryprocedure}{\pageref{./io:s94}} +"string->utf32" \sfentry{\scheme{(string->utf32~\var{string}~\var{endianness})}}{\categoryprocedure}{\pageref{./io:s94}} +"utf8->string" \sfentry{\scheme{(utf8->string~\var{bytevector})}}{\categoryprocedure}{\pageref{./io:s95}} +"utf16->string" \sfentry{\scheme{(utf16->string~\var{bytevector}~\var{endianness})}}{\categoryprocedure}{\pageref{./io:s96}} +"utf16->string" \sfentry{\scheme{(utf16->string~\var{bytevector}~\var{endianness}~\var{endianness-mandatory?})}}{\categoryprocedure}{\pageref{./io:s96}} +"utf32->string" \sfentry{\scheme{(utf32->string~\var{bytevector}~\var{endianness})}}{\categoryprocedure}{\pageref{./io:s96}} +"utf32->string" \sfentry{\scheme{(utf32->string~\var{bytevector}~\var{endianness}~\var{endianness-mandatory?})}}{\categoryprocedure}{\pageref{./io:s96}} +"define-syntax" \sfentry{\scheme{(define-syntax~\var{keyword}~\var{expr})}}{\categorysyntax}{\pageref{./syntax:s12}} +"let-syntax" \sfentry{\scheme{(let-syntax~((\var{keyword}~\var{expr})~{\dots})~\var{form$_1$}~\var{form$_2$}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s13}} +"letrec-syntax" \sfentry{\scheme{(letrec-syntax~((\var{keyword}~\var{expr})~{\dots})~\var{form$_1$}~\var{form$_2$}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s13}} +"syntax-rules" \sfentry{\scheme{(syntax-rules~(\var{literal}~{\dots})~\var{clause}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s14}} +"!F_ (underscore)" \sfentry{\scheme{{\schunderscore}}}{\categorysyntax}{\pageref{./syntax:s26}} +"!G... (ellipsis)" \sfentry{\scheme{{\schdot}{\schdot}{\schdot}}}{\categorysyntax}{\pageref{./syntax:s26}} +"identifier-syntax" \sfentry{\scheme{(identifier-syntax~\var{tmpl})}}{\categorysyntax}{\pageref{./syntax:s27}} +"identifier-syntax" \sfentry{\scheme{(identifier-syntax~(\var{id$_1$}~\var{tmpl$_1$})~((set!~\var{id$_2$}~\var{e$_2$})~\var{tmpl$_2$}))}}{\categorysyntax}{\pageref{./syntax:s27}} +"syntax-case" \sfentry{\scheme{(syntax-case~\var{expr}~(\var{literal}~{\dots})~\var{clause}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s30}} +"syntax (~#'~)" \sfentry{\scheme{(syntax~\var{template})}}{\categorysyntax}{\pageref{./syntax:s33}} +"!H#' (syntax)" \sfentry{\scheme{\#'\var{template}}}{\categorysyntax}{\pageref{./syntax:s33}} +"identifier?" \sfentry{\scheme{(identifier?~\var{obj})}}{\categoryprocedure}{\pageref{./syntax:s35}} +"free-identifier=?" \sfentry{\scheme{(free-identifier=?~\var{identifier$_1$}~\var{identifier$_2$})}}{\categoryprocedure}{\pageref{./syntax:s37}} +"bound-identifier=?" \sfentry{\scheme{(bound-identifier=?~\var{identifier$_1$}~\var{identifier$_2$})}}{\categoryprocedure}{\pageref{./syntax:s37}} +"with-syntax" \sfentry{\scheme{(with-syntax~((\var{pattern}~\var{expr})~{\dots})~\var{body$_1$}~\var{body$_2$}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s38}} +"quasisyntax (~#`~)" \sfentry{\scheme{(quasisyntax~\var{template}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s40}} +"!I#` (quasisyntax)" \sfentry{\scheme{\#`\var{template}}}{\categorysyntax}{\pageref{./syntax:s40}} +"unsyntax (~#,~)" \sfentry{\scheme{(unsyntax~\var{template}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s40}} +"!J#, (unsyntax)" \sfentry{\scheme{\#,\var{template}}}{\categorysyntax}{\pageref{./syntax:s40}} +"unsyntax-splicing (~#,@~)" \sfentry{\scheme{(unsyntax-splicing~\var{template}~{\dots})}}{\categorysyntax}{\pageref{./syntax:s40}} +"!K#,@ (unsyntax-splicing)" \sfentry{\scheme{\#,{\schatsign}\var{template}}}{\categorysyntax}{\pageref{./syntax:s40}} +"make-variable-transformer" \sfentry{\scheme{(make-variable-transformer~\var{procedure})}}{\categoryprocedure}{\pageref{./syntax:s42}} +"syntax->datum" \sfentry{\scheme{(syntax->datum~\var{obj})}}{\categoryprocedure}{\pageref{./syntax:s44}} +"datum->syntax" \sfentry{\scheme{(datum->syntax~\var{template-identifier}~\var{obj})}}{\categoryprocedure}{\pageref{./syntax:s45}} +"generate-temporaries" \sfentry{\scheme{(generate-temporaries~\var{list})}}{\categoryprocedure}{\pageref{./syntax:s49}} +"define-record-type" \sfentry{\scheme{(define-record-type~\var{record-name}~\var{clause}~{\dots})}}{\categorysyntax}{\pageref{./records:s13}} +"define-record-type" \sfentry{\scheme{(define-record-type~(\var{record-name}~\var{constructor}~\var{pred})~\var{clause}~{\dots})}}{\categorysyntax}{\pageref{./records:s13}} +"fields" \sfentry{\scheme{fields}}{\categorysyntax}{\pageref{./records:s16}} +"mutable" \sfentry{\scheme{mutable}}{\categorysyntax}{\pageref{./records:s16}} +"immutable" \sfentry{\scheme{immutable}}{\categorysyntax}{\pageref{./records:s16}} +"parent" \sfentry{\scheme{parent}}{\categorysyntax}{\pageref{./records:s16}} +"protocol" \sfentry{\scheme{protocol}}{\categorysyntax}{\pageref{./records:s16}} +"sealed" \sfentry{\scheme{sealed}}{\categorysyntax}{\pageref{./records:s16}} +"opaque" \sfentry{\scheme{opaque}}{\categorysyntax}{\pageref{./records:s16}} +"nongenerative" \sfentry{\scheme{nongenerative}}{\categorysyntax}{\pageref{./records:s16}} +"parent-rtd" \sfentry{\scheme{parent-rtd}}{\categorysyntax}{\pageref{./records:s16}} +"make-record-type-descriptor" \sfentry{\scheme{(make-record-type-descriptor~\var{name}~\var{parent}~\var{uid}~\var{s?}~\var{o?}~\var{fields})}}{\categoryprocedure}{\pageref{./records:s20}} +"record-type-descriptor?" \sfentry{\scheme{(record-type-descriptor?~\var{obj})}}{\categoryprocedure}{\pageref{./records:s23}} +"make-record-constructor-descriptor" \sfentry{\scheme{(make-record-constructor-descriptor~\var{rtd}~\var{parent-rcd}~\var{protocol})}}{\categoryprocedure}{\pageref{./records:s24}} +"record-type-descriptor" \sfentry{\scheme{(record-type-descriptor~\var{record-name})}}{\categorysyntax}{\pageref{./records:s28}} +"record-constructor-descriptor" \sfentry{\scheme{(record-constructor-descriptor~\var{record-name})}}{\categorysyntax}{\pageref{./records:s28}} +"record-constructor" \sfentry{\scheme{(record-constructor~\var{rcd})}}{\categoryprocedure}{\pageref{./records:s29}} +"record-predicate" \sfentry{\scheme{(record-predicate~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s30}} +"record-accessor" \sfentry{\scheme{(record-accessor~\var{rtd}~\var{idx})}}{\categoryprocedure}{\pageref{./records:s31}} +"record-mutator" \sfentry{\scheme{(record-mutator~\var{rtd}~\var{idx})}}{\categoryprocedure}{\pageref{./records:s32}} +"record-type-name" \sfentry{\scheme{(record-type-name~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s34}} +"record-type-parent" \sfentry{\scheme{(record-type-parent~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s35}} +"record-type-uid" \sfentry{\scheme{(record-type-uid~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s36}} +"record-type-generative?" \sfentry{\scheme{(record-type-generative?~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s37}} +"record-type-sealed?" \sfentry{\scheme{(record-type-sealed?~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s37}} +"record-type-opaque?" \sfentry{\scheme{(record-type-opaque?~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s37}} +"record-type-field-names" \sfentry{\scheme{(record-type-field-names~\var{rtd})}}{\categoryprocedure}{\pageref{./records:s38}} +"record-field-mutable?" \sfentry{\scheme{(record-field-mutable?~\var{rtd}~\var{idx})}}{\categoryprocedure}{\pageref{./records:s39}} +"record?" \sfentry{\scheme{(record?~\var{obj})}}{\categoryprocedure}{\pageref{./records:s40}} +"record-rtd" \sfentry{\scheme{(record-rtd~\var{record})}}{\categoryprocedure}{\pageref{./records:s41}} +"command-line" \sfentry{\scheme{(command-line)}}{\categoryprocedure}{\pageref{./libraries:s17}} +"exit" \sfentry{\scheme{(exit)}}{\categoryprocedure}{\pageref{./libraries:s18}} +"exit" \sfentry{\scheme{(exit~\var{obj})}}{\categoryprocedure}{\pageref{./libraries:s18}} +"raise" \sfentry{\scheme{(raise~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s3}} +"raise-continuable" \sfentry{\scheme{(raise-continuable~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s3}} +"error" \sfentry{\scheme{(error~\var{who}~\var{msg}~\var{irritant}~{\dots})}}{\categoryprocedure}{\pageref{./exceptions:s4}} +"assertion-violation" \sfentry{\scheme{(assertion-violation~\var{who}~\var{msg}~\var{irritant}~{\dots})}}{\categoryprocedure}{\pageref{./exceptions:s4}} +"assert" \sfentry{\scheme{(assert~\var{expression})}}{\categorysyntax}{\pageref{./exceptions:s5}} +"syntax-violation" \sfentry{\scheme{(syntax-violation~\var{who}~\var{msg}~\var{form})}}{\categoryprocedure}{\pageref{./exceptions:s6}} +"syntax-violation" \sfentry{\scheme{(syntax-violation~\var{who}~\var{msg}~\var{form}~\var{subform})}}{\categoryprocedure}{\pageref{./exceptions:s6}} +"with-exception-handler" \sfentry{\scheme{(with-exception-handler~\var{procedure}~\var{thunk})}}{\categoryprocedure}{\pageref{./exceptions:s7}} +"guard" \sfentry{\scheme{(guard~(\var{var}~\var{clause$_1$}~\var{clause$_2$}~{\dots})~\var{b1}~\var{b2}~{\dots})}}{\categorysyntax}{\pageref{./exceptions:s8}} +"&condition" \sfentry{\scheme{\&condition}}{\categorysyntax}{\pageref{./exceptions:s13}} +"condition?" \sfentry{\scheme{(condition?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s14}} +"condition" \sfentry{\scheme{(condition~\var{condition}~{\dots})}}{\categoryprocedure}{\pageref{./exceptions:s15}} +"simple-conditions" \sfentry{\scheme{(simple-conditions~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s16}} +"define-condition-type" \sfentry{\scheme{(define-condition-type~\var{name}~\var{parent}~\var{constructor}~\var{pred}~\var{field}~{\dots})}}{\categorysyntax}{\pageref{./exceptions:s17}} +"condition-predicate" \sfentry{\scheme{(condition-predicate~\var{rtd})}}{\categoryprocedure}{\pageref{./exceptions:s18}} +"condition-accessor" \sfentry{\scheme{(condition-accessor~\var{rtd}~\var{procedure})}}{\categoryprocedure}{\pageref{./exceptions:s18}} +"&serious" \sfentry{\scheme{\&serious}}{\categorysyntax}{\pageref{./exceptions:s19}} +"make-serious-condition" \sfentry{\scheme{(make-serious-condition)}}{\categoryprocedure}{\pageref{./exceptions:s19}} +"serious-condition?" \sfentry{\scheme{(serious-condition?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s19}} +"&violation" \sfentry{\scheme{\&violation}}{\categorysyntax}{\pageref{./exceptions:s20}} +"make-violation" \sfentry{\scheme{(make-violation)}}{\categoryprocedure}{\pageref{./exceptions:s20}} +"violation?" \sfentry{\scheme{(violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s20}} +"&assertion" \sfentry{\scheme{\&assertion}}{\categorysyntax}{\pageref{./exceptions:s21}} +"make-assertion-violation" \sfentry{\scheme{(make-assertion-violation)}}{\categoryprocedure}{\pageref{./exceptions:s21}} +"assertion-violation?" \sfentry{\scheme{(assertion-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s21}} +"&error" \sfentry{\scheme{\&error}}{\categorysyntax}{\pageref{./exceptions:s22}} +"make-error" \sfentry{\scheme{(make-error)}}{\categoryprocedure}{\pageref{./exceptions:s22}} +"error?" \sfentry{\scheme{(error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s22}} +"&warning" \sfentry{\scheme{\&warning}}{\categorysyntax}{\pageref{./exceptions:s23}} +"make-warning" \sfentry{\scheme{(make-warning)}}{\categoryprocedure}{\pageref{./exceptions:s23}} +"warning?" \sfentry{\scheme{(warning?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s23}} +"&message" \sfentry{\scheme{\&message}}{\categorysyntax}{\pageref{./exceptions:s24}} +"make-message-condition" \sfentry{\scheme{(make-message-condition~\var{message})}}{\categoryprocedure}{\pageref{./exceptions:s24}} +"message-condition?" \sfentry{\scheme{(message-condition?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s24}} +"condition-message" \sfentry{\scheme{(condition-message~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s24}} +"&irritants" \sfentry{\scheme{\&irritants}}{\categorysyntax}{\pageref{./exceptions:s25}} +"make-irritants-condition" \sfentry{\scheme{(make-irritants-condition~\var{irritants})}}{\categoryprocedure}{\pageref{./exceptions:s25}} +"irritants-condition?" \sfentry{\scheme{(irritants-condition?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s25}} +"condition-irritants" \sfentry{\scheme{(condition-irritants~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s25}} +"&who" \sfentry{\scheme{\&who}}{\categorysyntax}{\pageref{./exceptions:s26}} +"make-who-condition" \sfentry{\scheme{(make-who-condition~\var{who})}}{\categoryprocedure}{\pageref{./exceptions:s26}} +"who-condition?" \sfentry{\scheme{(who-condition?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s26}} +"condition-who" \sfentry{\scheme{(condition-who~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s26}} +"&non-continuable" \sfentry{\scheme{\&non-continuable}}{\categorysyntax}{\pageref{./exceptions:s27}} +"make-non-continuable-violation" \sfentry{\scheme{(make-non-continuable-violation)}}{\categoryprocedure}{\pageref{./exceptions:s27}} +"non-continuable-violation?" \sfentry{\scheme{(non-continuable-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s27}} +"&implementation-restriction" \sfentry{\scheme{\&implementation-restriction}}{\categorysyntax}{\pageref{./exceptions:s28}} +"make-implementation-restriction-violation" \sfentry{\scheme{(make-implementation-restriction-violation)}}{\categoryprocedure}{\pageref{./exceptions:s28}} +"implementation-restriction-violation?" \sfentry{\scheme{(implementation-restriction-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s28}} +"&lexical" \sfentry{\scheme{\&lexical}}{\categorysyntax}{\pageref{./exceptions:s29}} +"make-lexical-violation" \sfentry{\scheme{(make-lexical-violation)}}{\categoryprocedure}{\pageref{./exceptions:s29}} +"lexical-violation?" \sfentry{\scheme{(lexical-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s29}} +"&syntax" \sfentry{\scheme{\&syntax}}{\categorysyntax}{\pageref{./exceptions:s30}} +"make-syntax-violation" \sfentry{\scheme{(make-syntax-violation~\var{form}~\var{subform})}}{\categoryprocedure}{\pageref{./exceptions:s30}} +"syntax-violation?" \sfentry{\scheme{(syntax-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s30}} +"syntax-violation-form" \sfentry{\scheme{(syntax-violation-form~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s30}} +"syntax-violation-subform" \sfentry{\scheme{(syntax-violation-subform~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s30}} +"&undefined" \sfentry{\scheme{\&undefined}}{\categorysyntax}{\pageref{./exceptions:s31}} +"make-undefined-violation" \sfentry{\scheme{(make-undefined-violation)}}{\categoryprocedure}{\pageref{./exceptions:s31}} +"undefined-violation?" \sfentry{\scheme{(undefined-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s31}} +"&i/o" \sfentry{\scheme{\&i/o}}{\categorysyntax}{\pageref{./exceptions:s32}} +"make-i/o-error" \sfentry{\scheme{(make-i/o-error)}}{\categoryprocedure}{\pageref{./exceptions:s32}} +"i/o-error?" \sfentry{\scheme{(i/o-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s32}} +"&i/o-read" \sfentry{\scheme{\&i/o-read}}{\categorysyntax}{\pageref{./exceptions:s33}} +"make-i/o-read-error" \sfentry{\scheme{(make-i/o-read-error)}}{\categoryprocedure}{\pageref{./exceptions:s33}} +"i/o-read-error?" \sfentry{\scheme{(i/o-read-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s33}} +"&i/o-write" \sfentry{\scheme{\&i/o-write}}{\categorysyntax}{\pageref{./exceptions:s34}} +"make-i/o-write-error" \sfentry{\scheme{(make-i/o-write-error)}}{\categoryprocedure}{\pageref{./exceptions:s34}} +"i/o-write-error?" \sfentry{\scheme{(i/o-write-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s34}} +"&i/o-invalid-position" \sfentry{\scheme{\&i/o-invalid-position}}{\categorysyntax}{\pageref{./exceptions:s35}} +"make-i/o-invalid-position-error" \sfentry{\scheme{(make-i/o-invalid-position-error~\var{position})}}{\categoryprocedure}{\pageref{./exceptions:s35}} +"i/o-invalid-position-error?" \sfentry{\scheme{(i/o-invalid-position-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s35}} +"i/o-error-position" \sfentry{\scheme{(i/o-error-position~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s35}} +"&i/o-filename" \sfentry{\scheme{\&i/o-filename}}{\categorysyntax}{\pageref{./exceptions:s36}} +"make-i/o-filename-error" \sfentry{\scheme{(make-i/o-filename-error~\var{filename})}}{\categoryprocedure}{\pageref{./exceptions:s36}} +"i/o-filename-error?" \sfentry{\scheme{(i/o-filename-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s36}} +"i/o-error-filename" \sfentry{\scheme{(i/o-error-filename~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s36}} +"&i/o-file-protection" \sfentry{\scheme{\&i/o-file-protection}}{\categorysyntax}{\pageref{./exceptions:s37}} +"make-i/o-file-protection-error" \sfentry{\scheme{(make-i/o-file-protection-error~\var{filename})}}{\categoryprocedure}{\pageref{./exceptions:s37}} +"i/o-file-protection-error?" \sfentry{\scheme{(i/o-file-protection-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s37}} +"&i/o-file-is-read-only" \sfentry{\scheme{\&i/o-file-is-read-only}}{\categorysyntax}{\pageref{./exceptions:s38}} +"make-i/o-file-is-read-only-error" \sfentry{\scheme{(make-i/o-file-is-read-only-error~\var{filename})}}{\categoryprocedure}{\pageref{./exceptions:s38}} +"i/o-file-is-read-only-error?" \sfentry{\scheme{(i/o-file-is-read-only-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s38}} +"&i/o-file-already-exists" \sfentry{\scheme{\&i/o-file-already-exists}}{\categorysyntax}{\pageref{./exceptions:s39}} +"make-i/o-file-already-exists-error" \sfentry{\scheme{(make-i/o-file-already-exists-error~\var{filename})}}{\categoryprocedure}{\pageref{./exceptions:s39}} +"i/o-file-already-exists-error?" \sfentry{\scheme{(i/o-file-already-exists-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s39}} +"&i/o-file-does-not-exist" \sfentry{\scheme{\&i/o-file-does-not-exist}}{\categorysyntax}{\pageref{./exceptions:s40}} +"make-i/o-file-does-not-exist-error" \sfentry{\scheme{(make-i/o-file-does-not-exist-error~\var{filename})}}{\categoryprocedure}{\pageref{./exceptions:s40}} +"i/o-file-does-not-exist-error?" \sfentry{\scheme{(i/o-file-does-not-exist-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s40}} +"&i/o-port" \sfentry{\scheme{\&i/o-port}}{\categorysyntax}{\pageref{./exceptions:s41}} +"make-i/o-port-error" \sfentry{\scheme{(make-i/o-port-error~\var{pobj})}}{\categoryprocedure}{\pageref{./exceptions:s41}} +"i/o-port-error?" \sfentry{\scheme{(i/o-port-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s41}} +"i/o-error-port" \sfentry{\scheme{(i/o-error-port~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s41}} +"&i/o-decoding" \sfentry{\scheme{\&i/o-decoding}}{\categorysyntax}{\pageref{./exceptions:s42}} +"make-i/o-decoding-error" \sfentry{\scheme{(make-i/o-decoding-error~\var{pobj})}}{\categoryprocedure}{\pageref{./exceptions:s42}} +"i/o-decoding-error?" \sfentry{\scheme{(i/o-decoding-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s42}} +"&i/o-encoding" \sfentry{\scheme{\&i/o-encoding}}{\categorysyntax}{\pageref{./exceptions:s43}} +"make-i/o-encoding-error" \sfentry{\scheme{(make-i/o-encoding-error~\var{pobj}~\var{cobj})}}{\categoryprocedure}{\pageref{./exceptions:s43}} +"i/o-encoding-error?" \sfentry{\scheme{(i/o-encoding-error?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s43}} +"i/o-encoding-error-char" \sfentry{\scheme{(i/o-encoding-error-char~\var{condition})}}{\categoryprocedure}{\pageref{./exceptions:s43}} +"&no-infinities" \sfentry{\scheme{\&no-infinities}}{\categorysyntax}{\pageref{./exceptions:s44}} +"make-no-infinities-violation" \sfentry{\scheme{(make-no-infinities-violation)}}{\categoryprocedure}{\pageref{./exceptions:s44}} +"no-infinities-violation?" \sfentry{\scheme{(no-infinities-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s44}} +"&no-nans" \sfentry{\scheme{\&no-nans}}{\categorysyntax}{\pageref{./exceptions:s45}} +"make-no-nans-violation" \sfentry{\scheme{(make-no-nans-violation)}}{\categoryprocedure}{\pageref{./exceptions:s45}} +"no-nans-violation?" \sfentry{\scheme{(no-nans-violation?~\var{obj})}}{\categoryprocedure}{\pageref{./exceptions:s45}} diff --git a/csug/use.stex b/csug/use.stex new file mode 100644 index 0000000..7749071 --- /dev/null +++ b/csug/use.stex @@ -0,0 +1,1861 @@ +% Copyright 2005-2018 Cisco Systems, Inc. +% +% Licensed under the Apache License, Version 2.0 (the "License"); +% you may not use this file except in compliance with the License. +% You may obtain a copy of the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, +% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +% See the License for the specific language governing permissions and +% limitations under the License. +\chapter{Using Chez Scheme\label{CHPTUSE}} + +{\ChezScheme} is often used interactively to support program development +and debugging, yet it may also be used to create stand-alone applications +with no interactive component. +This chapter describes the various ways in which {\ChezScheme} is +typically used and, more generally, how to get the most out of the +system. +Sections~\ref{SECTUSEINTERACTION}, \ref{SECTUSEEXPEDITOR}, +and~\ref{SECTUSEINTERACTIONENVIRONMENT} describe how +one uses {\ChezScheme} interactively. +Section~\ref{SECTUSELIBRARIES} discusses how libraries and RNRS +top-level programs are used in {\ChezScheme}. +Section~\ref{SECTUSESCRIPTING} covers support for writing and running +Scheme scripts, including compiled scripts and compiled +RNRS top-level programs. +Section~\ref{SECTUSEOPTIMIZATION} describes how to structure +and compile an application to get the most efficient code possible out +of the compiler. +Section~\ref{SECTUSECUSTOMIZATION} describes how one can customize the +startup process, e.g., to alter or eliminate the command-line options, +to preload Scheme or foreign code, or to run {\ChezScheme} as a subordinate +program of another program. +Section~\ref{SECTUSEAPPLICATIONS} describes how to build applications +using {\ChezScheme} with {\PetiteChezScheme} for run-time support. +Finally, Section~\ref{SECTUSECOMMANDLINE} covers command-line options used when +invoking {\ChezScheme}. + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Interacting with Chez Scheme\label{SECTUSEINTERACTION}} + +One of the simplest and most effective ways to write and test Scheme +programs is to compose them using a text editor, like \scheme{vi} or +\scheme{emacs}, and test them interactively with {\ChezScheme} running in +a shell window. +When {\ChezScheme} is installed with default options, entering the command +\scheme{scheme} at the shell's prompt starts an interactive Scheme +session. +The command \scheme{petite} does the same for {\PetiteChezScheme}. +After entering this command, you should see a short greeting followed +by an angle-bracket on a line by itself, like this: + +\schemedisplay +Chez Scheme Version 9.5.1 +Copyright 1984-2017 Cisco Systems, Inc. + +> +\endschemedisplay + +You also should see that the cursor is sitting one space to the +right of the angle-bracket. +The angle-bracket is a prompt issued by the system's ``REPL,'' +which stands for ``Read Eval Print Loop,'' so called because it +reads, evaluates, and prints an expression, then loops back to +read, evaluate, and print the next, and so on. +(In {\ChezScheme}, the REPL is also called a waiter.) + +In response to the prompt, you can type any Scheme expression. +If the expression is well-formed, the REPL will run the expression +and print the value. +Here are a few examples: + +\schemedisplay +> 3 +3 +> (+ 3 4) +7 +> (cons 'a '(b c d)) +(a b c d) +\endschemedisplay + +The reader used by the REPL is more sophisticated than an ordinary +reader. +In fact, it's a full-blown ``expression editor'' (``expeditor'' for short) +like a regular text editor but for just one expression at a time. +One thing you might soon notice is that the system automatically indents +the second and subsequent lines of an expression. +For example, let's say we want to define \scheme{fact}, a procedure that +implements the factorial function. +If we type \scheme{(define fact} followed by the enter key, the cursor +should be sitting under the first \scheme{e} in \scheme{define}, so that +if we then type \scheme{(lambda (x)}, we should see: + +\schemedisplay +> (define fact + (lambda (x) +\endschemedisplay + +The expeditor also allows us to move around within the expression +(even across lines) and edit the expression to correct mistakes. +After typing: + +\schemedisplay +> (define fact + (lambda (x) + (if (= n 0) + 0 + (* n (fact +\endschemedisplay + +we might notice that the procedure's argument is named \scheme{x} +but we have been referencing it as \scheme{n}. +We can move back to the second line using the arrow keys, +remove the offending \scheme{x} with the backspace key, and +replace it with \scheme{n}. + +\schemedisplay +> (define fact + (lambda (n) + (if (= n 0) + 0 + (* n (fact +\endschemedisplay + +We can then return to the end of the expression with the arrow +keys and complete the definition. + +\schemedisplay +> (define fact + (lambda (n) + (if (= n 0) + 0 + (* n (fact (- n 1)))))) +\endschemedisplay + +Now that we have a complete form with balanced parentheses, +if we hit enter with the cursor just after the final parenthesis, +the expeditor will send it on to the evaluator. +We'll know that it has accepted the definition when we get another +right-angle prompt. + +Now we can test our definition by entering, say, \scheme{(fact 6)} +in response to the prompt: + +\schemedisplay +> (fact 6) +0 +\endschemedisplay + +The printed value isn't what we'd hoped for, since $6!$ is actually $720$. +The problem, of course, is that the base-case return-value \scheme{0} +should have been \scheme{1}. +Fortunately, we don't have to retype the definition to correct the +mistake. +Instead, we can use the expeditor's history mechanism to retrieve the +earlier definition. +The up-arrow key moves backward through the history. +In this case, the first up-arrow retrieves \scheme{(fact 6)}, and +the second retrieves the \scheme{fact} definition. + +As we move back through the history, the expression editor shows us +only the first line, so after two up arrows, this is all we see of +the definition: + +\schemedisplay +> (define fact +\endschemedisplay + +We can force the expeditor to show the entire expression by typing +\scheme{^L} (control \scheme{L}, i.e., the control and \scheme{L} keys +pressed together): + +\schemedisplay +> (define fact + (lambda (n) + (if (= n 0) + 0 + (* n (fact (- n 1)))))) +\endschemedisplay + +Now we can move to the fourth line and change the \scheme{0} to a +\scheme{1}. + +\schemedisplay +> (define fact + (lambda (n) + (if (= n 0) + 1 + (* n (fact (- n 1)))))) +\endschemedisplay + +We're now ready to enter the corrected definition. +If the cursor is on the fourth line and we hit enter, however, it will +just open up a new line between the old fourth and fifth lines. +This is useful in other circumstances, but not now. +Of course, we can work around this by using the arrow keys to move +to the end of the expression, but an easier way is to type +\scheme{^J}, which forces the expression to be entered immediately +no matter where the cursor is. + +Finally, we can bring back \scheme{(fact 6)} with another two +hits of the up-arrow key and try it again: + +\schemedisplay +> (fact 6) +720 +\endschemedisplay + +To exit from the REPL and return back to the shell, we can type +\scheme{^D} or call the \scheme{exit} procedure. + +The interaction described above uses just a few of the expeditor's +features. +The expeditor's remaining features are described in the following +section. + +Running programs may be interrupted by typing the interrupt +character (typically \scheme{^C}). +In response, the +system enters a debug handler, which prompts for input with a +\scheme{break>} prompt. +One of several commands may be issued to the break handler (followed by a +newline), including +\begin{description} +\item[``e''] or end-of-file to exit from the handler and continue, +\item[``r''] to stop execution and reset to the current caf\'e, +\item[``a''] to abort {\ChezScheme}, +\item[``n''] to enter a new caf\'e (see below), +\item[``i''] to inspect the current continuation, +\item[``s''] to display statistics about the interrupted program, and +\item[``?''] to display a list of these options. +\end{description} + +When an exception other than a warning occurs, the default exception +handler prints a message that describes the exception to the console +error port. +If a REPL is running, the exception handler then returns to the REPL, +where the programmer can call the \scheme{debug} procedure to start up the +debug handler, if desired. +The debug handler is similar to the break handler and allows the +programmer to inspect the continuation (control +stack) of the exception to help determine the cause of the problem. +If no REPL is running, as is the case for a script or top-level program +run via the \index{\scheme{--script} command-line option}\scheme{--script} +or \index{\scheme{--program} command-line option}\scheme{--program} +command-line options, the default exception handler exits from the script +or program after printing the message. +To allow scripts and top-level programs to be debugged, +the default exception handler can be forced via the +\index{\scheme{debug-on-exception}}\scheme{debug-on-exception} +parameter or the +\index{\scheme{--debug-on-exception} command-line option}\scheme{--debug-on-exception} command-line option +to invoke \scheme{debug} directly. + +Developing a large program entirely in the REPL is unmanageable, and we +usually even want to store smaller programs in a file for future use. +(The expeditor's history is saved across Scheme sessions, but there is a +limit on the number of items, so it is not a good idea to count on a +program remaining in the history indefinitely.) +Thus, a Scheme programmer typically creates a file containing Scheme +source code using a text editor, such as \scheme{vi}, and loads the file +into {\ChezScheme} to test them. +The conventional filename extension for {\ChezScheme} source files is +``\scheme{.ss},'' but the file can have any extension or even no extension +at all. +A source file can be loaded during an interactive session by typing +\index{\scheme{load}}\scheme{(load "\var{path}")}. +Files to be loaded can also be named on the command line when the +system is started. +Any form that can be typed interactively can be placed in a file to be loaded. + +{\ChezScheme} compiles source forms as it sees them to machine +code before evaluating them, i.e., ``just in time.'' +In order to speed loading of a large file or group of files, each file +can be compiled ahead of time via +\index{\scheme{compile-file}}\scheme{compile-file}, which puts the +compiled code into a separate object file. +For example, \scheme{(compile-file "\var{path}")} compiles +the forms in the file \var{path}.ss and places the +resulting object code in the file \var{path}.so. +Loading a pre-compiled file is essentially no different from +loading the source file, except that loading is faster since +compilation has already been done. + +\index{\scheme{compile-file}}When compiling a file or set of files, it is often more convenient to +use a shell command than to enter {\ChezScheme} interactively to perform +the compilation. +This is easily accomplished by ``piping'' in the command to compile +the file as shown below. + +\schemedisplay +echo '(compile-file "\var{filename}")' | scheme -q +\endschemedisplay + +The \scheme{-q} option suppresses the system's greeting messages for more +compact output, which is especially useful when compiling numerous +files. +The single-quote marks surrounding the \scheme{compile-file} call +should be left off for Windows shells. + +When running in this ``batch'' mode, especially from within ``make'' +files, it is often desirable to force the default exception handler to exit +immediately to the shell with a nonzero exit status. +This may be accomplished by setting the +\index{\scheme{reset-handler}}\scheme{reset-handler} to +\scheme{abort}. + +\schemedisplay +echo '(reset-handler abort) (compile-file "\var{filename}")' | scheme -q +\endschemedisplay + +One can also redefine the +\index{\scheme{base-exception-handler}}\scheme{base-exception-handler} +(Section~\ref{SECTSYSTEMEXCEPTIONS}) to achieve a similar effect +while exercising more control over the format of the messages that +are produced. + + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Expression Editor\label{SECTUSEEXPEDITOR}} + +When Chez Scheme is used interactively in a shell window, as described +above, or when \scheme{new-cafe} is invoked explicitly from a top-level +program or script run via \scheme{--program} or \scheme{--script}, the +waiter's ``prompt and read'' procedure employs an expression editor that +permits entry and editing of single- and multiple-line expressions, +automatically indents expressions as they are entered, supports +identifier completion outside string constants based on the identifiers defined +in the interactive environment, and supports filename completion within +string constants. +The expression editor also maintains a history of expressions typed during +and across sessions and supports tcsh-like history movement and search +commands. +Other editing commands include simple cursor movement via +arrow keys, deletion of characters via backspace and delete, and +movement, deletion, and other commands using mostly +emacs key bindings. + +The expression editor does not run if the TERM environment variable is not +set (on Unix-based systems), if the standard input or output files have +been redirected, or if the \scheme{--eedisable} command-line option +(Section~\ref{SECTUSECOMMANDLINE}) has been used. +The history is saved across sessions, by default, in the file +``.chezscheme\_history'' in the user's home directory. +The \scheme{--eehistory} command-line option +(Section~\ref{SECTUSECOMMANDLINE}) can be used to specify a different +location for the history file or to disable the saving and restoring of +the history file. + +Keys for nearly all printing characters (letters, digits, and special +characters) are ``self inserting'' by default. +The open parenthesis, close parenthesis, open bracket, and close bracket +keys are self inserting as well, but also cause the editor to ``flash'' +to the matching delimiter, if any. +Furthermore, when a close parenthesis or close bracket is typed, it is +automatically corrected to match the corresponding open delimiter, if any. + +Key bindings for other keys and key sequences initially recognized by +the expression editor are given below, organized into groups by function. +Some keys or key sequences serve more than one purpose depending upon +context. +For example, tab is used for identifier completion, filename completion, +and indentation. +Such bindings are shown in each applicable functional group. + +Multiple-key sequences are displayed with hyphens between the keys of +the sequences, but these hyphens should not be entered. +When two or more key sequences perform the same operation, the sequences +are shown separated by commas. + +Detailed descriptions of the editing commands are given in +Chapter~\ref{CHPTEXPEDITOR}, which also describes parameters that allow +control over the expression editor, mechanisms for adding or changing key +bindings, and mechanisms for creating new commands. + + +\xdef\cntl#1{\scheme{^#1}} +\newenvironment{expeditorblock}[1] + {\iflatex\par\smallskip\null\vbox\bgroup\fi #1:\par\begin{tabular}{ll}} + {\iflatex\\[-1em]\phantom{xxxxxxxxxxxxxxxxxxxxx}\fi\end{tabular}\iflatex\removelastskip\egroup\fi\par} + +\bigskip +\begin{expeditorblock}{Newlines, acceptance, exiting, and redisplay} +enter, \cntl{M} & accept balanced entry if used at end of entry;\\ + & else add a newline before the cursor and indent\\ +\cntl{J} & accept entry unconditionally\\ +\cntl{O} & insert newline after the cursor and indent\\ +\cntl{D} & exit from the waiter if entry is empty;\\ + & else delete character under cursor\\ +\cntl{Z} & suspend to shell if shell supports job control\\ +\cntl{L} & redisplay entry\\ +\cntl{L}-\cntl{L} & clear screen and redisplay entry +\end{expeditorblock} + +\begin{expeditorblock}{Basic movement and deletion} +leftarrow, \cntl{B} & move cursor left\\ +rightarrow, \cntl{F} & move cursor right\\ +uparrow, \cntl{P} & move cursor up; from top of unmodified entry,\\ + & move to preceding history entry.\\ +downarrow, \cntl{N} & move cursor down; from bottom of unmodified entry,\\ + & move to next history entry\\ +\cntl{D} & delete character under cursor if entry not empty,\\ + & else exit from the waiter\\ +backspace, \cntl{H} & delete character before cursor\\ +delete & delete character under cursor +\end{expeditorblock} + +\begin{expeditorblock}{Line movement and deletion} +home, \cntl{A} & move cursor to beginning of line\\ +end, \cntl{E} & move cursor to end of line\\ +\cntl{K}, +esc-k & delete to end of line or, if cursor is at the end\\ + & of a line, join with next line\\ +\cntl{U} & delete contents of current line +\end{expeditorblock} + +When used on the first line of a multiline entry of which only the first line +is displayed, i.e., immediately after history movement, \cntl{U} deletes the +contents of the entire entry, like \cntl{G} (described below). + +\begin{expeditorblock}{Expression movement and deletion} +esc-\cntl{F} & move cursor to next expression\\ +esc-\cntl{B} & move cursor to preceding expression\\ +esc-\scheme{]} & move cursor to matching delimiter\\ +\cntl{]} & flash cursor to matching delimiter\\ +esc-\cntl{K}, +esc-delete & delete next expression\\ +esc-backspace, +esc-\cntl{H} & delete preceding expression +\end{expeditorblock} + +\begin{expeditorblock}{Entry movement and deletion} +esc-\scheme{<} & move cursor to beginning of entry\\ +esc-\scheme{>} & move cursor to end of entry\\ +\cntl{G} & delete current entry contents\\ +\cntl{C} & delete current entry contents; reset to end of history +\end{expeditorblock} + +\begin{expeditorblock}{Indentation} +tab & re-indent current line if identifier/filename prefix\\ + & not just entered; else insert completion\\ +esc-tab & re-indent current line unconditionally\\ +esc-\scheme{q}, + esc-\scheme{Q}, + esc-\cntl{Q} & re-indent each line of entry +\end{expeditorblock} + +\begin{expeditorblock}{Identifier/filename completion} +tab & insert completion if identifier/filename prefix just\\ + & entered; else re-indent current line\\ +tab-tab & show possible identifier/filename completions at end\\ + & of identifier/filename just typed, else re-indent\\ +\cntl{R} & insert next identifier/filename completion +\end{expeditorblock} + +Identifier completion is performed outside of a string constant, and filename +completion is performed within a string constant. +(In determining whether the cursor is within a string constant, the +expression editor looks only at the current line and so can be fooled +by string constants that span multiple lines.) +If at end of existing identifier or filename, i.e., not one just typed, the first tab +re-indents, the second tab inserts identifier completion, and the third +shows possible completions. + +\begin{expeditorblock}{History movement} +uparrow, \cntl{P} & move to preceding entry if at top of unmodified\\ + & entry; else move up within entry\\ +downarrow, \cntl{N} & move to next entry if at bottom of unmodified\\ + & entry; else move down within entry\\ +esc-uparrow, + esc-\cntl{P} & move to preceding entry from unmodified entry\\ +esc-downarrow, + esc-\cntl{N} & move to next entry from unmodified entry\\ +esc-p & search backward through history for given prefix\\ +esc-n & search forward through history for given prefix\\ +esc-P & search backward through history for given string\\ +esc-N & search forward through history for given string +\end{expeditorblock} + +To search, enter a prefix or string followed by one of the search key +sequences. +Follow with additional search key sequences to search further backward or +forward in the history. +For example, enter ``(define'' followed by one or more esc-p key sequences +to search backward for entries that are definitions, or ``(define'' +followed by one or more esc-P key sequences for entries that contain +definitions. + +\begin{expeditorblock}{Word and page movement} +esc-\scheme{f}, + esc-\scheme{F} & move cursor to end of next word\\ +esc-\scheme{b}, + esc-\scheme{B} & move cursor to start of preceding word\\ +\cntl{X}-\scheme{[} & move cursor up one screen page\\ +\cntl{X}-\scheme{]} & move cursor down one screen page +\end{expeditorblock} + +\begin{expeditorblock}{Inserting saved text} +\cntl{Y} & insert most recently deleted text\\ +\cntl{V} & insert contents of window selection/paste buffer +\end{expeditorblock} + +\begin{expeditorblock}{Mark operations} +\cntl{@}, + \cntl{}space, + \cntl{^} & set mark to current cursor position\\ +\cntl{X}-\cntl{X} & move cursor to mark, leave mark at old cursor position\\ +\cntl{W} & delete between current cursor position and mark +\end{expeditorblock} + +\begin{expeditorblock}{Command repetition} +esc-\cntl{U} & repeat next command four times\\ +esc-\cntl{U}-$n$ & repeat next command $n$ times +\end{expeditorblock} + + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{The Interaction Environment\label{SECTUSEINTERACTIONENVIRONMENT}} + +\index{top-level programs}\index{interactive top level}\index{interaction environment}% +In the language of the Revised$^6$ Report, code is structured into +libraries and ``top-level programs.'' +The Revised$^6$ Report does not require an implementation to support +interactive use, and it does not specify how an interactive top level +should operate, leaving such details up to the implementation. + +In {\ChezScheme}, when one enters definitions or expressions at the +prompt or loads them from a file, they operate on an +interaction environment, which is a mutable environment that initially +holds bindings only for built-in keywords and primitives. +It may be augmented by user-defined identifier bindings via top-level +definitions. +The interaction environment is also referred to as the top-level +environment, because it is at the top level for purposes of scoping. +Programs entered at the prompt or loaded from a file via \scheme{load} +should not be confused with RNRS top-level programs, which are +actually more similar to libraries in their behavior. +In particular, while the same identifier can be defined multiple times +in the interaction environment, to support incremental program +development, an identifier can be defined at most once in an RNRS +top-level program. + +The default interaction environment used for any code that occurs outside +of an RNRS top-level program or library (including such code typed at +a prompt or loaded from a file) contains all of the bindings of the +\scheme{(chezscheme)} library (or \scheme{scheme} module, which exports the +same set of bindings). +This set contains a number of bindings that are not in the RNRS libraries. +It also contains a number of bindings that extend the RNRS counterparts in +some way and are thus not strictly compatible with the RNRS bindings for +the same identifiers. +To replace these with bindings strictly compatible with RNRS, simply +import the \scheme{rnrs} libraries into the interaction environment by +typing the following into the REPL or loading it from a file: + +\schemedisplay +(import + (rnrs) + (rnrs eval) + (rnrs mutable-pairs) + (rnrs mutable-strings) + (rnrs r5rs)) +\endschemedisplay + +\index{\scheme{interaction-environment}}% +To obtain an interaction environment that contains all \emph{and only} +RNRS bindings, use the following. + +\schemedisplay +(interaction-environment + (copy-environment + (environment + '(rnrs) + '(rnrs eval) + '(rnrs mutable-pairs) + '(rnrs mutable-strings) + '(rnrs r5rs)) + #t)) +\endschemedisplay + +To be useful for most purposes, \scheme{library} and \scheme{import} +should probably also be included, from the \scheme{(chezscheme)} library. + +\schemedisplay +(interaction-environment + (copy-environment + (environment + '(rnrs) + '(rnrs eval) + '(rnrs mutable-pairs) + '(rnrs mutable-strings) + '(rnrs r5rs) + '(only (chezscheme) library import)) + #t)) +\endschemedisplay + +It might also be useful to include \scheme{debug} in the set of +identifiers imported from \scheme{(chezscheme)} to allow the debugger to be +entered after an exception is raised. + +Most of the identifiers bound in the default interaction environment that +are not strictly compatible with the Revised$^6$ Report are variables bound to +procedures with extended interfaces, i.e., optional arguments or extended +argument domains. +The others are keywords bound to transformers that extend the Revised$^6$ +Report syntax in some way. +This should not be a problem except for programs that count on +exceptions being raised in cases that coincide with the extensions. +For example, if a program passes the \scheme{=} procedure a single numeric +argument and expects an exception to be raised, it will fail in the +initial interaction environment because \scheme{=} returns \scheme{#t} +when passed a single numeric argument. + +Within the default interaction environment and those created as described +above, variables that name built-in procedures are read-only, i.e., +cannot be assigned, since they resolve to the read-only bindings exported +from the \scheme{(chezscheme)} library or some other library: + +\schemedisplay +(set! cons +) ;=> \var{exception: cons is immutable} +\endschemedisplay + +Before assigning a variable bound to the name of a built-in +procedure, the programmer must first define the variable. +For example, + +\schemedisplay +(define cons-count 0) +(define original-cons cons) +(define cons + (lambda (x y) + (set! cons-count (+ cons-count 1)) + (original-cons x y))) +\endschemedisplay + +redefines \scheme{cons} to count the number of times it is called, and + +\schemedisplay +(set! cons original-cons) +\endschemedisplay + +assigns \scheme{cons} to its original value. +Once a variable has been defined in the interaction environment using +\scheme{define}, a subsequent definition of the same variable is equivalent +to a \scheme{set!}, so + +\schemedisplay +(define cons original-cons) +\endschemedisplay + +has the same effect as the \scheme{set!} above. +The expression + +\schemedisplay +(import (only (chezscheme) cons)) +\endschemedisplay + +also binds \scheme{cons} to its original value. +It also returns it to its original read-only state. + +The simpler redefinition + +\schemedisplay +(define cons (let () (import scheme) cons)) +\endschemedisplay + +turns \scheme{cons} into a mutable variable with the same value as it +originally had. +Doing so, however, prevents the compiler from generating efficient code +for calls to \scheme{cons} or producing warning messages when +\scheme{cons} is passed the wrong number of arguments. + +All identifiers not bound in the initial interaction environment and +not defined by the programmer are treated as ``potentially bound'' as +variables to facilitate the definition of mutually recursive +procedures. +For example, assuming that \scheme{yin} and \scheme{yang} have not +been defined, + +\schemedisplay +(define yin (lambda () (- (yang) 1))) +\endschemedisplay + +defines \scheme{yin} at top level as a variable bound to a procedure that calls +the value of the top-level variable \scheme{yang}, even though \scheme{yang} +has not yet been defined. +If this is followed by + +\schemedisplay +(define yang (lambda () (+ (yin) 1))) +\endschemedisplay + +the result is a mutually recursive pair of procedures that, when called, +will loop indefinitely or until the system runs out of space to hold the +recursion stack. +If \scheme{yang} must be defined as anything other than a variable, its +definition should precede the definition of \scheme{yin}, since the compiler +assumes \scheme{yang} is a variable in the absence of any indication to +the contrary when \scheme{yang} has not yet been defined. + +\index{\scheme{free-identifier=?}}% +A subtle consequence of this useful quirk of the interaction environment is that +the procedure +\scheme{free-identifier=?} (Section~\ref{TSPL:SECTSYNTAXCASE} of {\TSPLFOUR}) +does not consider unbound library identifiers to be equivalent to (as yet) +undefined top-level identifiers, even if they have the +same name, because the latter are actually assumed to be valid variable bindings. + +\schemedisplay +(library (A) (export a) + (import (rnrs)) + (define-syntax a + (lambda (x) + (syntax-case x () + [(_ id) (free-identifier=? #'id #'undefined)])))) +(let () (import (A)) (a undefined)) ;=> #f +\endschemedisplay + +\index{auxiliary keywords}% +If it is necessary that they have the same binding, as in the case where +an identifier is used as an auxiliary keyword in a syntactic abstraction +exported from a library and used at top level, the library should define +and export a binding for the identifier. + +\schemedisplay +(library (A) (export a aux-a) + (import (rnrs) (only (chezscheme) syntax-error)) + (define-syntax aux-a + (lambda (x) + (syntax-error x "invalid context"))) + (define-syntax a + (lambda (x) + (syntax-case x (aux-a) + [(_ aux-a) #''okay] + [(_ _) #''oops])))) +(let () (import (A)) (a aux-a)) ;=> okay +(let () (import (only (A) a)) (a aux-a)) ;=> oops +\endschemedisplay + +This issue does not arise when libraries are used entirely within other +libraries or within RNRS top-level programs, since the interaction +environment does not come into play. + + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Using Libraries and Top-Level Programs\label{SECTUSELIBRARIES}} + +\index{libraries}% +\index{top-level-programs}% +An R6RS library can be defined directly in the REPL, loaded explicitly +from a file (using \scheme{load} or \scheme{load-library}), or loaded +implicitly from a file via \scheme{import}. +When defined directly in the REPL or loaded explicitly from a file, a +library form can be used to redefine an existing library, but +\scheme{import} never reloads a library once it has been defined. + +A library to be loaded implicitly via \scheme{import} +must reside in a file whose name reflects the name of the library. +For example, if the library's name is \scheme{(tools sorting)}, the +base name of the file must be \scheme{sorting} with a valid extension, and +the file must be in a directory named \scheme{tools} which itself resides +in one of the directories searched by \scheme{import}. +The set of directories searched by \scheme{import} is determined by +the +\index{\scheme{library-directories}}\scheme{library-directories} +parameter, and the set of +extensions is determined by the +\index{\scheme{library-extensions}}\scheme{library-extensions} +parameter. + +The values of both parameters are lists of pairs of strings. +The first string in each \scheme{library-directories} pair identifies a +source-file base directory, and the second identifies the corresponding +object-file base directory. +Similarly, the first string in each \scheme{library-extensions} pair +identifies a source-file extension, and the second identifies the +corresponding object-file extension. +The full path of a library source or object file consists of the source or +object base followed by the components of the library name, separated by +slashes, with the library extension added on the end. +For example, for base \scheme{/usr/lib/scheme}, library name +\scheme{(app lib1)}, and extension \scheme{.sls}, the full path is +\scheme{/usr/lib/scheme/app/lib1.sls}. +So, if \scheme{(library-directories)} contains the pathnames +\scheme{"/usr/lib/scheme/libraries"} and \scheme{"."}, and +\scheme{(library-extensions)} contains the extensions \scheme{.ss} +and \scheme{.sls}, the path of the \scheme{(tools sorting)} +library must be one of the following. + +\schemedisplay +/usr/lib/scheme/libraries/tools/sorting.ss +/usr/lib/scheme/libraries/tools/sorting.sls +./tools/sorting.ss +./tools/sorting.sls +\endschemedisplay + +When searching for a library, \scheme{import} first constructs a partial +name from the list of components in the library name, e.g., \scheme{a/b} +for library \scheme{(a b)}. +It then searches for the partial name in each pair +of base directories, in order, trying each of the source extensions then +each of the object extensions in turn before moving onto the next pair of +base directories. +If the partial name is an absolute pathname, e.g., \scheme{~/.myappinit} +for a library named \scheme{(~/.myappinit)}, only the specified absolute +path is searched, first with each source extension, then with each object +extension. +If the expander finds both a source file and its corresponding object +file, and the object file is not older than the source file, the +expander loads the object file. +If the object file does not exist, if the object file is older, or +if after loading the object file, the expander determines it was +built using a library or include file that has changed, the source +file is loaded or compiled, depending on the value of the parameter +\index{\scheme{compile-imported-libraries}}\scheme{compile-imported-libraries}. +If \scheme{compile-imported-libraries} +is set to \scheme{#t}, the expander +compiles the library via the value of the \scheme{compile-library-handler} +parameter, which by default calls \scheme{compile-library} (which is described below). +Otherwise, the expander loads the source file. +(Loading the source file actually causes the code to be compiled, +assuming the default value of \scheme{current-eval}, but the compiled +code is not saved to an object file.) +An exception is raised during this process if a +source or object file exists but is not readable or if an object +file cannot be created. + +\index{\scheme{--import-notify} command-line option}% +\index{\scheme{import-notify}}% +The search process used by the expander when processing an \scheme{import} +for a library that has not yet been loaded can be monitored by +setting the parameter \scheme{import-notify} to \scheme{#t}. +This parameter can be set from the command line via the +\scheme{--import-notify} command-line option. + +Whenever the expander determines it must compile a library to a file or +load one from source, it adds the directory in which the file resides to +the front of the +\index{\scheme{source-directories}}\scheme{source-directories} +list while compiling or loading the library. +This allows a library to include files stored in or relative to its +own directory. + +When \scheme{import} compiles a library as described above, it does not +also load the compiled library, because this would cause portions of +library to be reevaluated. +Because of this, run-time expressions in the file outside of a +\scheme{library} form will not be evaluated. +If such expressions are present and should be evaluated, the library +should be compiled ahead of time or loaded explicitly. + +\index{\scheme{compile-library}}% +\index{\scheme{compile-imported-libraries}}% +A file containing a library may be compiled with \scheme{compile-file} +or \scheme{compile-library}. +The only difference between the two is that the latter treats the source +file as if it were prefixed by an implicit \scheme{#!r6rs}, which +disables {\ChezScheme} lexical extensions unless an explicit +\scheme{#!chezscheme} marker appears in the file. +Any libraries upon which the library depends must be compiled first. +If one of the libraries imported by the library is subsequently +recompiled (say because it was modified), the importing library must also +be recompiled. +Compilation and recompilation of imported libraries must be done +explicitly by default but is done automatically when the parameter +\scheme{compile-imported-libraries} is set to \scheme{#t} before +compiling the importing library. + +As with \scheme{compile-file}, \scheme{compile-library} can be used +in ``batch'' mode via a shell command: + +\schemedisplay +echo '(compile-library "\var{filename}")' | scheme -q +\endschemedisplay + +with single-quote marks surrounding the \scheme{compile-library} call +omitted for Windows shells. + +An RNRS top-level-program usually resides in a file, but one can also +enter one directly into the REPL using the \scheme{top-level-program} +forms, e.g.: + +\schemedisplay +(top-level-program + (import (rnrs)) + (display "What's up?\n")) +\endschemedisplay + +A top-level program stored in a file does not have the \scheme{top-level-program} +wrapper, so the same top-level program in a file is just: + +\schemedisplay +(import (rnrs)) +(display "What's up?\n") +\endschemedisplay + +A top-level program stored in a file can be loaded from the file via the +\scheme{load-program} procedure. +A top-level program can also be loaded via \scheme{load}, but not without +affecting the semantics. +A program loaded via \scheme{load} is scoped at top level, where it can +see all top-level bindings, whereas a top-level program loaded via +\scheme{load-program} is self-contained, i.e., it can see only the +bindings made visible by the leading \scheme{import} form. +Also, the variable bindings in a program loaded via \scheme{load} also +become top-level bindings, whereas they are local to the program when +the program is loaded via \scheme{load-program}. +Moreover, \scheme{load-program}, like \scheme{load-library}, treats the +source file as if it were prefixed by an implicit \scheme{#!r6rs}, which +disables {\ChezScheme} lexical extensions unless an explicit +\scheme{#!chezscheme} marker appears in the file. +A program loaded via \scheme{load} is also likely to be less efficient. +Since the program's variables are not local to the program, the compiler +must assume they could change at any time, which inhibits many of its +optimizations. + +\index{\scheme{compile-program}}% +Top-level programs may be compiled using +\index{\scheme{compile-program}}\scheme{compile-program}, which is like +\scheme{compile-file} but, as with \scheme{load-program}, properly +implements the semantics and lexical restrictions of top-level programs. +\scheme{compile-program} also copies the leading \scheme{#!} line, +if any, from the source file to the object file, resulting in an +executable object file. +Any libraries upon which the top-level program depends, other than +built-in libraries, must be compiled first. +The program must be recompiled if any of the libraries upon which +it depends are recompiled. +Compilation and recompilation of imported libraries must be done +explicitly by default but is done automatically when the parameter +\scheme{compile-imported-libraries} is set to \scheme{#t} before +compiling the importing library. + +As with \scheme{compile-file} and \scheme{compile-library}, +\scheme{compile-program} can be used in ``batch'' mode via a shell +command: + +\schemedisplay +echo '(compile-program "\var{filename}")' | scheme -q +\endschemedisplay + +with single-quote marks surrounding the \scheme{compile-program} call +omitted for Windows shells. + +\scheme{compile-program} returns a list of libraries directly invoked by +the compiled top-level program. +When combined with the +\index{\scheme{library-requirements}}\scheme{library-requirements} and +\index{\scheme{library-object-filename}}\scheme{library-object-filename} +procedures, the list of libraries returned by \scheme{compile-program} can +be used to determine the set of files that must be distributed with the +compiled program file. + +When run, a compiled program automatically loads the run-time code for +each library upon which it depends, as if via \scheme{revisit}. +If the program also imports one of the same libraries at run time, e.g., +via the \scheme{environment} procedure, the system will attempt to load +the compile-time information from the same file. +The compile-time information can also be loaded explicitly from the +same or a different file via \scheme{load} or \scheme{visit}. + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Scheme Shell Scripts\label{SECTUSESCRIPTING}} + +\index{\scheme{--script} command-line option}% +\index{Scheme shell scripts}% +\index{scripting}% +When the \scheme{--script} command-line option is present, the named file is +treated as a Scheme shell script, and the command-line is made +available via the parameter +\scheme{command-line}. +This is primarily useful on Unix-based systems, where the script file +itself may be made executable. +To support executable shell scripts, the system ignores the first +line of a loaded script if it begins with \scheme{#!} followed by +a space or forward slash. +For example, assuming that the {\ChezScheme} executable has been +installed as /usr/bin/scheme, the following script prints its command-line +arguments. + +\schemedisplay +#! /usr/bin/scheme --script +(for-each + (lambda (x) (display x) (newline)) + (cdr (command-line))) +\endschemedisplay + +The following script implements the traditional Unix \scheme{echo} +command. + +\schemedisplay +#! /usr/bin/scheme --script +(let ([args (cdr (command-line))]) + (unless (null? args) + (let-values ([(newline? args) + (if (equal? (car args) "-n") + (values #f (cdr args)) + (values #t args))]) + (do ([args args (cdr args)] [sep "" " "]) + ((null? args)) + (printf "~a~a" sep (car args))) + (when newline? (newline))))) +\endschemedisplay + +Scripts may be compiled using \index{\scheme{compile-script}}\scheme{compile-script}, which is like +\scheme{compile-file} but differs in that it +copies the leading \scheme{#!} line from the source-file script +into the object file. + +If {\PetiteChezScheme} is installed, but not {\ChezScheme}, +\scheme{/usr/bin/scheme} may be +replaced with \scheme{/usr/bin/petite}. + +\index{\scheme{--program} command-line option}% +\index{top-level programs}% +The \scheme{--program} command-line option is like \scheme{--script} +except that the script file is treated as an RNRS top-level program +(Chapter~\ref{CHPTLIBRARIES}). +The following RNRS top-level program implements the traditional Unix +\scheme{echo} command, as with the script above. + +\schemedisplay +#! /usr/bin/scheme --program +(import (rnrs)) +(let ([args (cdr (command-line))]) + (unless (null? args) + (let-values ([(newline? args) + (if (equal? (car args) "-n") + (values #f (cdr args)) + (values #t args))]) + (do ([args args (cdr args)] [sep "" " "]) + ((null? args)) + (display sep) + (display (car args))) + (when newline? (newline))))) +\endschemedisplay + +Again, if only {\PetiteChezScheme} is installed, \scheme{/usr/bin/scheme} +may be replaced with \scheme{/usr/bin/petite}. + +\scheme{scheme-script} may be used in place of \scheme{scheme --program} +or \scheme{petite --program}, i.e., + +\schemedisplay +#! /usr/bin/scheme-script +\endschemedisplay + +\scheme{scheme-script} runs {\ChezScheme}, if available, +otherwise {\PetiteChezScheme}. + +It is also possible to use \scheme{/usr/bin/env}, as recommended in the +Revised$^6$ Report nonnormative appendices, which allows +\scheme{scheme-script} to appear anywhere in the user's path. + +\schemedisplay +#! /usr/bin/env scheme-script +\endschemedisplay + +\index{\scheme{--libdirs} command-line option}% +\index{\scheme{--libexts} command-line option}% +If a top-level program depends on libraries other than those built into +{\ChezScheme}, the \scheme{--libdirs} option can be used to specify +which source and object directories to search. +Similarly, if a library upon which a top-level program depends has an +extension other than one of the standard extensions, the +\scheme{--libexts} option can be used to specify additional extensions +to search. + +\index{\scheme{library-directories}}% +\index{\scheme{library-extensions}}% +These options set the corresponding {\ChezScheme} parameters +\scheme{library-directories} and \scheme{library-extensions}, +which are described in Section~\ref{SECTUSELIBRARIES}. +The format of the arguments to \scheme{--libdirs} and +\scheme{--libexts} is the same: +a sequence of substrings separated by a single separator +character. +The separator character is a colon (:), except under Windows where it is a +semi-colon (;). +Between single separators, the source and object strings, if both are +specified, are separated by two separator characters. +If a single separator character appears at the end of the string, +the specified pairs are added to the front of the existing list; +otherwise, the specified pairs replace the existing list. + +For example, where the separator is a colon, + +\schemedisplay +scheme --libdirs "/home/moi/lib:" +\endschemedisplay + +adds the source/object directory pair + +\schemedisplay +("/home/moi/lib" . "/home/moi/lib") +\endschemedisplay + +to the front of the default set of library directories, and + +\schemedisplay +scheme --libdirs "/home/moi/libsrc::/home/moi/libobj:" +\endschemedisplay + +adds the source/object directory pair + +\schemedisplay +("/home/moi/libsrc" . "/home/moi/libobj") +\endschemedisplay + +to the front of the default set of library directories. +The parameters are set after all boot files have been loaded. + +\index{CHEZSCHEMELIBDIRS}\index{CHEZSCHEMELIBEXTS}% +If no \scheme{--libdirs} option appears and the CHEZSCHEMELIBDIRS +environment variable is set, the string value of CHEZSCHEMELIBDIRS is +treated as if it were specified by a \scheme{--libdirs} option. +Similarly, if no \scheme{--libexts} option appears and the CHEZSCHEMELIBEXTS +environment variable is set, the string value of CHEZSCHEMELIBEXTS is +treated as if it were specified by a \scheme{--libexts} option. + + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Optimization\label{SECTUSEOPTIMIZATION}} + +\index{optimization}To get the most out of the {\ChezScheme} compiler, it is necessary to +give it a little bit of help. +The most important assistance is to avoid the use of top-level +(interaction-environment) bindings. +Top-level bindings are convenient and appropriate during program +development, since they simplify testing, redefinition, and tracing +(Section~\ref{SECTDEBUGTRACING}) of individual procedures and +syntactic forms. +This convenience comes at a sizable price, however. + +\index{copy propagation}\index{inlining}The compiler can propagate copies (of one variable to another or of +a constant to a variable) and inline procedures bound to local, +unassigned variables within a single top-level expression. +For the procedures it does not inline, it can avoid constructing and +passing unneeded closures, bypass argument-count checks, branch to the +proper entry point in a case-lambda, and build rest arguments (more +efficiently) on the caller side, where the length of the rest list is +known at compile time. +It can also discard the definitions of unreferenced variables, so there's +no penalty for including a large library of routines, only a few of +which are actually used. + +It cannot do any of this with top-level variable bindings, since the +top-level bindings can change at any time and new references to those +bindings can be introduced at any time. + +\index{libraries}% +\index{top-level-programs}% +Fortunately, it is easy to restructure a program to avoid top-level +bindings. +This is naturally accomplished for portable code by placing the +code into a single RNRS top-level program or by placing a portion +of the code in a top-level program and the remainder in one or +more separate libraries. +Although not portable, one can also put all of the code into a +single top-level \scheme{module} form or \scheme{let} expression, +perhaps using \scheme{include} to bring in portions of the +code from separate files. +The compiler performs some optimization even across library +boundaries, so the penalty for breaking a program up in this +manner is generally acceptable. +The compiler also supports whole-program optimization (via +\scheme{compile-whole-program}), which can be used to eliminate all +overhead for placing portions of a program into separate libraries. + +Once an application's code has been placed into a single top-level program or into +a top-level program and one or more libraries, the code can be loaded +from source via \scheme{load-program} or compiled via +\index{\scheme{compile-program}}\scheme{compile-program} +and +\index{\scheme{compile-library}}\scheme{compile-library}, +as described in Section~\ref{SECTUSELIBRARIES}. +Be sure not to use \scheme{compile-file} for the top-level program +since this does not preserve the semantics nor result in code that +is as efficient. + +With an application structured as a single top-level program or as a +top-level program and one or more libraries that do not interact +frequently, we have done most of what can be done to help the compiler, +but there are still a few more things we can do. + +\index{safety}\index{\scheme{optimize-level}}% +First, we can allow the compiler to generate ``unsafe'' code, i.e., +allow the compiler to generate code in which the usual run-time type +checks have been disabled. +We do this by using the compiler's ``optimize level 3'' when compiling +the program and library files. +This can be accomplished by setting the parameter \scheme{optimize-level} +to 3 while compiling the library or +program, e.g.: + +\schemedisplay +(parameterize ([optimize-level 3]) (compile-program "\var{filename}")) +\endschemedisplay + +\index{\scheme{--optimize-level} command-line option}% +or in batch mode via the \scheme{--optimize-level} command-line option: + +\schemedisplay +echo '(compile-program "\var{filename}")' | scheme -q --optimize-level 3 +\endschemedisplay + +It may also be useful to experiment with some of the other compiler +control parameters and also with the storage manager's run-time +operation. +The compiler-control parameters, including \scheme{optimize-level}, are +described in Section~\ref{SECTMISCOPTIMIZE}, and the storage manager +control parameters are described in Section~\ref{SECTSMGMTGC}. + +\index{profiling}% +Finally, it is often useful to ``profile'' your code to determine that +parts of the code that are executed most frequently. +While this will not help the system optimize your code, it can help +you identify ``hot spots'' where you need to concentrate your own +hand-optimization efforts. +In these hot spots, consider using more efficient operators, like +fixnum or flonum operators in place of generic arithmetic operators, +and using explicit loops rather than nested combinations of +linear list-processing operators like \scheme{append}, \scheme{reverse}, +and \scheme{map}. +These operators can make code more readable when used judiciously, +but they can slow down time-critical code. + +Section~\ref{SECTMISCPROFILE} describes how to use the compiler's support +for automatic profiling. +Be sure that profiling is not enabled when you compile your production +code, since the code introduced into the generated code to perform the +profiling adds significant run-time overhead. + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Customization\label{SECTUSECUSTOMIZATION}} + +\index{customization}% +\index{kernel}% +\index{petite.boot}% +\index{scheme.boot}% +{\ChezScheme} and {\PetiteChezScheme} are built from several +subsystems: a ``kernel'' encapsulated in a static or shared +library (dynamic link library) that contains operating-system +interface and low-level storage management code, +an executable that parses command-line arguments and calls +into the kernel to initialize and run the system, a base +boot file (petite.boot) that contains the bulk of the run-time library code, +and an additional boot file (scheme.boot), for {\ChezScheme} only, +that contains the compiler. + +While the kernel and base boot file are essential to the +operation of all programs, the executable may be replaced or +even eliminated, and the compiler boot file need be loaded only +if the compiler is actually used. +In fact, the compiler is typically not loaded for distributed +applications unless the application creates and executes code at run time. + +The kernel exports a set of entry points that are used to initialize +the Scheme system, load boot or heap files, run an interactive Scheme +session, run script files, and deinitialize the system. +In the threaded versions of the system, the kernel also exports +entry points for activating, deactivating, and destroying threads. +These entry points may be used to create your own executable image +that has different (or no) command-line options or to run Scheme +as a subordinate program within another program, i.e., for use as +an extension language. + +These entry points are described in Section~\ref{SECTFOREIGNCLIB}, +along with other entry points for accessing and modifying Scheme +data structures and calling Scheme procedures. + +\index{main.c}% +The file main.c in the 'c' subdirectory contains the +``main'' routine for the distributed executable image; look at +this file to gain an understanding of how the system startup +entry points are used. + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Building and Distributing Applications\label{SECTUSEAPPLICATIONS}} + +\index{applications}% +\index{distributing applications}% +Although useful as a stand-alone Scheme system, +{\PetiteChezScheme} was conceived as a run-time system for compiled +{\ChezScheme} applications. +The remainder of +this section describes how to create and distribute such applications +using {\PetiteChezScheme}. +It begins with a discussion of the characteristics of +{\PetiteChezScheme} and how it compares with {\ChezScheme}, +then describes how to prepare application source code, +how to build and run applications, and how to distribute them. + +\parheader{Petite Chez Scheme Characteristics} +Although interpreter-based, {\PetiteChezScheme} evaluates Scheme source +code faster than might be expected. +Some of the reasons for this are listed below. + +\begin{itemize} +\item The run-time system is fully compiled, so library implementations +of primitives ranging from \scheme{+} and \scheme{car} to \scheme{sort} +and \scheme{printf} are just as efficient as in {\ChezScheme}, although +they cannot be open-coded as in code compiled by {\ChezScheme}. + +\item The interpreter is itself a compiled Scheme application. +Because it is written in Scheme, it directly benefits from various +characteristics of Scheme that would have to be dealt with explicitly +and with additional overhead in most other languages, including +proper treatment of tail calls, first-class procedures, automatic +storage management, and continuations. + +\item The interpreter employs a preprocessor that +converts the code into a form that can be interpreted +efficiently. +In fact, the preprocessor shares its front end with the compiler, and +this front end performs a variety of source-level optimizations. +\end{itemize} + +\noindent +Nevertheless, compiled code is still more efficient for most +applications. +The difference between the speed of interpreted and compiled code +varies significantly from one application to another, but often amounts +to a factor of five and sometimes to a factor of ten or more. + +Several additional limitations result from the fact that +{\PetiteChezScheme} does not include the compiler: + +\begin{itemize} +\item The compiler must be present to process \scheme{foreign-procedure} +and \scheme{foreign-callable} expressions, even when these forms are +evaluated by the interpreter. +These forms cannot be processed by the interpreter alone, so +they cannot appear in source code to be processed by {\PetiteChezScheme}. +Compiled versions of \scheme{foreign-procedure} and \scheme{foreign-callable} +forms may, however, be included +in compiled code loaded into {\PetiteChezScheme}. + +\item Inspector information is attached to code objects, which are +generated only by the compiler, so source information and variable names +are not available for interpreted procedures or continuations into +interpreted procedures. +This makes the inspector less effective for debugging interpreted code +than it is for debugging compiled code. + +\item Procedure names are also attached to code objects, so while +the compiler associates a name with each procedure when +an appropriate name can be determined, the interpreter does not do so. +This mostly impacts the quality of error messages, e.g., an error message +might read ``incorrect number of arguments to \scheme{#}'' +rather than the likely more useful ``incorrect number of arguments to +\scheme{#}.'' + +\item The compiler detects, at compile time, some potential errors +that the interpreter does not detect and reports them via compile-time +warnings that identify the expression or the location in the source +file, if any, where the expression appears. + +\item Automatic profiling cannot be enabled for interpreted code as it +is for compiled code when \scheme{compile-profile} is set to \scheme{#t}. +\end{itemize} + +Except as noted above, {\PetiteChezScheme} does not restrict what +programs can do, and like {\ChezScheme}, it places essentially no +limits on the size of programs or the memory images they create, +beyond the inherent limitations of the underlying hardware or +operating system. + +\parheader{Compiled scripts and programs} + +One simple mechanism for distributing an application is to structure it as +a script or RNRS top-level program, use +\index{\scheme{compile-script}}\scheme{compile-script} or +\index{\scheme{compile-program}}\scheme{compile-program}, as appropriate +to compile it as described in Section~\ref{SECTUSESCRIPTING}, and +distribute the resulting object file along with a complete distribution of +{\PetiteChezScheme}. +When this mechanism is used on Unix-based systems, if the source file +begins with \scheme{#!} and the path that follows is the path to the +{\ChezScheme} executable, e.g., \scheme{/usr/bin/scheme}, the one at the +front of the object file should be replaced with the path to the +{\PetiteChezScheme} executable, e.g., \scheme{/usr/bin/petite}. +The path may have to be adjusted by the application's installation +program based on where {\PetiteChezScheme} is installed on the target +system. +When used under Windows, the application's installation program should +set up an appropriate shortcut that starts {\PetiteChezScheme} with the +\scheme{--script} or \scheme{--program} option, as appropriate, followed +by the path to the object file. + +The remainder of this section describes how to distribute applications +that do not require {\PetiteChezScheme} to be installed as a stand-alone +system on the target machine. + +\parheader{Preparing Application Code} +While it is possible to distribute applications in source-code form, +i.e., as a set of Scheme source files to be loaded into {\PetiteChezScheme} +by the end user, distributing compiled code has two major +advantages over distributing source code. +First, compiled code is usually much more efficient, as discussed in +the preceding section, and second, compiled code is in binary form and +thus provides more protection for proprietary application code. + +Application source code generally consists of a set of Scheme source +files possibly augmented by foreign code developed specifically for the +application and packaged in shared libraries (also known as shared +objects or, on Windows, dynamic link libraries). +The following assumes that any shared-library source code has been +converted into object form; how to do this varies by platform. +(Some hints are given in Section~\ref{SECTFOREIGNACCESS}.) +The result is a set of one or more shared libraries that are loaded +explicitly by the Scheme source code during program initialization. + +Once the shared libraries have been created, the next step is to +compile the Scheme source files into a set of Scheme object files. +Doing so typically involves simply invoking \index{\scheme{compile-file}}\scheme{compile-file}, +\index{\scheme{compile-library}}\scheme{compile-library}, +or +\index{\scheme{compile-program}}\scheme{compile-program}, +as appropriate, +on each source file to produce the corresponding object file. +This may be done within a build script or ``make'' file via a +command line such as the following: + +\schemedisplay +echo '(compile-file "\var{filename}")' | scheme +\endschemedisplay + +\noindent +which produces the object file \scheme{filename.so} from the source +file \scheme{filename.ss}. + +If the application code has been developed interactively or is usually +loaded directly from source, +it may be necessary to make some adjustments to a file to be +compiled if the file contains expressions or definitions that +affect the compilation of subsequent forms in the file. +This can be accomplished via \scheme{eval-when} +(Section~\ref{SECTMISCCOMPILEEVAL}). +This is not typically necessary or desirable if the application consists +of a set of RNRS libraries and programs. + +You may also wish to disable generation of inspector information +both to reduce the size of the compiled application code and to +prevent others from having access to the expanded source code that +is retained as part of the inspector information. +To do so, set the parameter +\index{\scheme{generate-inspector-information}}\scheme{generate-inspector-information} +to \scheme{#f} while compiling each file +The downside of disabling inspector information is that the information +will not be present if you need to debug your application, so it is +usually desirable to disable inspector information only for production +builds of your application. +An alternative is to compile the code with inspector information enabled +and strip out the debugging information later with +\index{\scheme{strip-fasl-file}}\scheme{strip-fasl-file}. + +The Scheme startup procedure determines what the system does when +it is started. +The default startup procedure loads the files listed on the command +line (via \scheme{load}) and starts up a new caf\'e, like this. + +\schemedisplay +(lambda fns (for-each load fns) (new-cafe)) +\endschemedisplay + +The startup procedure may be changed via the parameter +\index{\scheme{scheme-start}}\scheme{scheme-start}. +The following example demonstrates the installation of a variant of the +default startup procedure that prints the name of each file before +loading it. + +\schemedisplay +(scheme-start + (lambda fns + (for-each + (lambda (fn) + (printf "loading ~a ..." fn) + (load fn) + (printf "~%")) + fns) + (new-cafe))) +\endschemedisplay + +A typical application startup procedure would first invoke the +application's initialization procedure(s) and then start the +application itself: + +\schemedisplay +(scheme-start + (lambda fns + (initialize-application) + (start-application fns))) +\endschemedisplay + +Any shared libraries that must be present during the running of an +application must be loaded during initialization. +In addition, all foreign procedure expressions must be executed +after the shared libraries are loaded so that the addresses +of foreign routines are available to be recorded with the resulting foreign +procedures. +The following demonstrates one way in which initialization might be +accomplished for an application that links to a foreign procedure +\scheme{show_state} in the Windows shared library \scheme{state.dll}: + +\schemedisplay +(define show-state) + +(define app-init + (lambda () + (load-shared-object "state.dll") + (set! show-state + (foreign-procedure "show_state" (integer-32) + integer-32)))) + +(scheme-start + (lambda fns + (app-init) + (app-run fns))) +\endschemedisplay + +\parheader{Building and Running the Application} +Building and running an application is straightforward once all shared +libraries have been built and Scheme source files have been compiled +to object code. + +Although not strictly necessary, we suggest that you concatenate your +object files, if you have more than one, into a single object file +via the \scheme{concatenate-object-files} procedure. +Placing all of the object code into a single file +simplifies both building and distribution of applications. + +For top-level programs with separate libraries, +\index{\scheme{compile-whole-program}}\scheme{compile-whole-program} +can be used to produce a single, fully optimized object file. +Otherwise, when concatenating object files, put each library after the +libraries it depends upon, with the program last. + +With the Scheme object code contained within a single composite object file, +it is possible to run the application simply by loading the composite +object file into {\PetiteChezScheme}, e.g.: + +\schemedisplay +petite app.so +\endschemedisplay + +\noindent +where \scheme{app.so} is the name of the composite object file, +and invoking the startup procedure to restart the system: + +\schemedisplay +> ((scheme-start)) +\endschemedisplay + +\noindent +The point of setting \scheme{scheme-start}, however, is to allow the +set of object files to be converted into a +\index{boot files}\emph{boot file}. +Boot files are loaded during the process of building the initial heap. +Because of this, boot files have the following advantages over ordinary +object files. + +\begin{itemize} +\item Any code and data structures contained in the boot file or created +while it is loaded is automatically compacted along with the base run-time +library code and made static. +Static code and data are never collected by the storage manager, so +garbage collection overhead is reduced. +(It is also possible to make code and data static explicitly at any +time via the \scheme{collect} procedure.) + +\item The system looks for boot files automatically in a set of standard +directories based on the name of the executable image, so you can +install a copy of the {\PetiteChezScheme} executable image under your +application's name and spare your users from supplying any command-line +arguments or running a separate script to load the application code. +\end{itemize} + +\index{\scheme{scheme-start}}% +When an application is packaged into a boot file, the source code +that is compiled and converted into a boot file should set +\scheme{scheme-start} to a procedure that starts the application, +as shown in the example above. +The application should not be started directly from the boot file, +because boot files are loaded before final initialization of the +Scheme system. +The value of \scheme{scheme-start} is invoked automatically after +final initialization. + +A boot file is simply an object file containing the code for +one or more source files, prefixed by a boot header. +The boot header identifies a base boot file upon which the application +directly depends, or possibly two or more alternatives upon which the +application can be run. +In most cases, petite.boot will be identified as the base boot +file, but in a layered application it may be another boot file of your +creation that in turn depends upon petite.boot. +The base boot file, and its base boot file, if any, are loaded +automatically when your application boot file is loaded. + +Boot files are created with \index{\scheme{make-boot-file}}\scheme{make-boot-file}. +This procedure accepts two or more arguments. +The first is a string naming the file into which the boot header and +object code should be placed, the second is a list of strings naming base +boot files, and the remainder are strings naming input files. +For example, the call: + +\schemedisplay +(make-boot-file "app.boot" '("petite") "app1.so" "app2.ss" "app3.so") +\endschemedisplay + +creates the boot file app.boot that identifies a dependency upon petite.boot +and contains the object code for app1.so, the object code resulting from +compiling app2.ss, and the object code for app3.so. +The call: + +\schemedisplay +(make-boot-file "app.boot" '("scheme" "petite") "app.so") +\endschemedisplay + +creates a header file that identifies a dependency upon either +scheme.boot or petite.boot, with the object code from app.so. +In the former case, the system will automatically load petite.boot +when the application boot file is loaded, and in the latter it will +load scheme.boot if it can find it, otherwise petite.boot. +This would allow your application to run on top of the full +{\ChezScheme} if present, otherwise {\PetiteChezScheme}. + +In most cases, you can construct your application +so it does not depend upon features of scheme.boot (specifically, +the compiler) by specifying only \scheme{"petite"} in the call to +\scheme{make-boot-file}. +If your application calls \scheme{eval}, however, and you wish to +allow users to be able to take +advantage of the faster execution speed of compiled code, then specifying +both \scheme{"scheme"} and \scheme{"petite"} +is appropriate. + +Here is how we might create and run a simple ``echo'' application +from a Linux shell: + +\schemedisplay +echo '(suppress-greeting #t)' > myecho.ss +echo '(scheme-start (lambda fns (printf "~{~a~^ ~}\n" fns)))' >> myecho.ss +echo '(compile-file "myecho.ss") \ + (make-boot-file "myecho.boot" (quote ("petite")) "myecho.so")' \ + | scheme -q +scheme -b myecho.boot hello world +\endschemedisplay + +If we take the extra step of installing a copy of the {\PetiteChezScheme} +executable as \scheme{myecho} and copying \scheme{myecho.boot} into +the same directory as \scheme{petite.boot} (or set SCHEMEHEAPDIRS to +include the directory containing myecho.boot), we can simply invoke +\scheme{myecho} to run our echo application: + +\schemedisplay +myecho hello world +\endschemedisplay + +\parheader{Distributing the Application} +Distributing an application can be as simple as creating a +distribution package that includes the following items: + +\begin{itemize} +\item the {\PetiteChezScheme} distribution, +\item the application boot file, +\item any application-specific shared libraries, +\item an application installation script. +\end{itemize} + +\noindent +The application installation script should install {\PetiteChezScheme} +if not already installed on the target system. +It should install the application boot file in the same directory as +the {\PetiteChezScheme} boot file petite.boot is installed, +and it should install the application shared libraries, if any, +either in the same location or in a standard location for shared libraries +on the target system. +It should also create a link to or copy of the {\PetiteChezScheme} +executable under the name of your application, i.e., the name given +to your application boot file. +Where appropriate, it should also install desktop and start-menu +shortcuts to run the executable. + +%---------------------------------------------------------------------------- +%---------------------------------------------------------------------------- +\section{Command-Line Options\label{SECTUSECOMMANDLINE}} + +\index{command-line options}% +\index{\scheme{-q} command-line option}% +\index{\scheme{--quiet} command-line option}% +\index{\scheme{--script} command-line option}% +\index{\scheme{--program} command-line option}% +\index{\scheme{--libdirs} command-line option}% +\index{\scheme{--libexts} command-line option}% +\index{\scheme{--compile-imported-libraries} command-line option}% +\index{\scheme{--import-notify} command-line option}% +\index{\scheme{--optimize-level} command-line option}% +\index{\scheme{--debug-on-exception} command-line option}% +\index{\scheme{--eedisable} command-line-option}% +\index{\scheme{--eehistory} command-line-option}% +\index{\scheme{--enable-object-counts} command-line-option}% +\index{\scheme{--retain-static-relocation} command-line option}% +\index{\scheme{-b} command-line option}% +\index{\scheme{--boot} command-line option}% +\index{\scheme{--verbose} command-line option}% +\index{\scheme{--version} command-line option}% +\index{\scheme{--help} command-line option}% +\index{\scheme{--} command-line option}% +{\ChezScheme} recognizes the following command-line options. + +\begin{tabular}{ll} +\scheme{-q}, \scheme{--quiet} + & ~~suppress greeting and prompt\\ +\scheme{--script \var{path}} + & ~~run as shell script\\ +\scheme{--program \var{path}} + & ~~run rnrs top-level program as shell script\\ +\scheme{--libdirs \var{dir}:...} + & ~~set library directories\\ +\scheme{--libexts \var{ext}:...} + & ~~set library extensions\\ +\scheme{--compile-imported-libraries} + & ~~compile libraries before loading\\ +\scheme{--import-notify} + & ~~enable import search messages\\ +\scheme{--optimize-level 0 | 1 | 2 | 3} + & ~~set initial optimize level\\ +\scheme{--debug-on-exception} + & ~~on uncaught exception, call \scheme{debug}\\ +\scheme{--eedisable} + & ~~disable expression editor\\ +\scheme{--eehistory off | \var{path}} + & ~~expression-editor history file\\ +\scheme{--enable-object-counts} + & ~~have collector maintain object counts\\ +\scheme{--retain-static-relocation} + & ~~keep reloc info for compute-size, etc.\\ +\scheme{-b \var{path}}, \scheme{--boot \var{path}} + & ~~load boot file\\ +\scheme{--verbose} + & ~~trace boot-file search process\\ +\scheme{--version} + & ~~print version and exit\\ +\scheme{--help} + & ~~print help and exit\\ +\scheme{--} + & ~~pass through remaining args\\ +\end{tabular} + +\index{\scheme{-h} command-line option}% +\index{\scheme{--heap} command-line option}% +\index{\scheme{-s} command-line option}% +\index{\scheme{--saveheap} command-line option}% +\index{\scheme{-c} command-line option}% +\index{\scheme{--compact} command-line option}% +The following options are recognized but cause the system to print an +error message and exit because saved heaps are no longer supported. + +\begin{tabular}{ll} +\scheme{-h \var{path}}, \scheme{--heap \var{path}} + & ~~load heap file\\ +\scheme{-s[\var{n}] \var{path}}, \scheme{--saveheap[\var{n}] \var{path}} + & ~~save heap file\\ +\scheme{-c}, \scheme{--compact} + & ~~toggle compaction flag\\ +\end{tabular} + +With the default \scheme{scheme-start} procedure (Section~\ref{SECTUSEAPPLICATIONS}), +any remaining command-line arguments are treated as the names of files +to be loaded before {\ChezScheme} begins interacting with the user, unless +the \scheme{--script} or \scheme{--program} is present, in which case the +remaining arguments are made available to the script via the \scheme{command-line} +parameter (Section~\ref{SECTUSEINTERACTION}). + +Most of the options are described elsewhere in this chapter, and a few +are self-explanatory. +The remainder pertain to the loading of boot files at system start-up +time and are described below. + +\index{boot files}% +\index{heap files}% +When {\ChezScheme} is run, it looks for one or more boot files +to load. +Boot files contain the compiled Scheme code that implements most of +the Scheme system, including the interpreter, compiler, and most +libraries. +Boot +files may be specified explicitly on the command +line via \scheme{-b} +options or implicitly. +In the simplest case, no \scheme{-b} +options +are given and the necessary boot +files are loaded +automatically based on the name of the executable. + +For example, if the executable name is ``frob'', the +system looks for +``frob.boot'' in a set of standard directories. +It also looks for and loads any subordinate +boot files required +by +``frob.boot''. + +Subordinate +boot files are also loaded automatically for the +first boot file +explicitly specified via the command line. +Each boot file must be listed before those that depend upon it. + +The \scheme{--verbose} option may be used to trace the +file searching process and must appear before any boot +arguments for which search tracing is desired. + +Ordinarily, the search for +boot files is limited to a set of +installation directories, but this may be overridden by setting +the environment variable \index{\scheme{SCHEMEHEAPDIRS}}\scheme{SCHEMEHEAPDIRS}. +\scheme{SCHEMEHEAPDIRS} should be a colon-separated list of directories, listed in +the order in which they should be searched. +Within each directory, the two-character escape sequence ``\scheme{%v}'' +is replaced by the current version, and the two-character escape sequence +``\scheme{%m}'' is replaced by the machine type. +A percent followed by any other character is replaced by the second +character; in particular, ``\scheme{%%}'' is replaced by ``\scheme{%}'', and +``\scheme{%:}'' is replaced by ``\scheme{:}''. +If \scheme{SCHEMEHEAPDIRS} ends in a non-escaped colon, the default directories are +searched after those in \scheme{SCHEMEHEAPDIRS}; otherwise, only those listed in +\scheme{SCHEMEHEAPDIRS} are searched. + +Under Windows, semi-colons are used in place of colons, and one additional +escape is recognized: ``\scheme{%x},'' which is replaced by the directory in +which the executable file resides. +The default search path under Windows consists of ``\scheme{%x}'' +and ``\scheme{%x\..\..\boot\%m}.'' +The registry key \scheme{HeapSearchPath} in +\scheme{HKLM\SOFTWARE\Chez Scheme\csv\var{version}}, where +\var{version} is the {\ChezScheme} version number, e.g., +\scheme{7.9.4}, can be set to override the default search path, +and the \scheme{SCHEMEHEAPDIRS} environment variable +overrides both the default and the registry setting, if any. + +Boot files consist of ordinary compiled code and consist of +a boot header and the compiled code for one or more +source files. +See Section~\ref{SECTUSEAPPLICATIONS} for instructions on how to create +boot files. + diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 index 0000000..3edfdd0 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,28 @@ +# Unix make file to compile the examples. +# Compilation is not necessary since the examples may be loaded from +# source, but this gives an example of how to use make for Scheme. +# * To compile files not already compiled, type "make". Only those +# files in the object list below and not yet compiled will be compiled. +# * To compile all files, type "make all". Only those files in the object +# list below will be compiled. +# * To compile one file, say "fumble.ss", type "make fumble.so". The +# file need not be in the object list below. +# * To remove the object files, type "make clean". +# * To print the examples, type "make print". + +src = def.ss edit.ss fact.ss fatfib.ss fft.ss fib.ss freq.ss interpret.ss\ + m4.ss macro.ss matrix.ss object.ss power.ss queue.ss rabbit.ss rsa.ss\ + scons.ss setof.ss socket.ss unify.ss compat.ss ez-grammar-test.ss +obj = ${src:%.ss=%.so} + +Scheme = ../bin/scheme -q + +.SUFFIXES: +.SUFFIXES: .ss .so +.ss.so: ; echo '(time (compile-file "$*"))' | ${Scheme} + +needed: ${obj} + +all: ; echo "(time (for-each compile-file (map symbol->string '(${src}))))" | ${Scheme} + +clean: ; rm -f $(obj) expr.md diff --git a/examples/compat.ss b/examples/compat.ss new file mode 100644 index 0000000..43ec014 --- /dev/null +++ b/examples/compat.ss @@ -0,0 +1,291 @@ +;;; compat.ss +;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; miscellaneous definitions to make this version compatible +;;; (where possible) with previous versions...and to a small extent with +;;; other versions of scheme and other dialects of lisp as well + +;;; use only those items that you need to avoid introducing accidental +;;; dependencies on other items. + +(define-syntax define! + (syntax-rules () + ((_ x v) (begin (set! x v) 'x)))) + +(define-syntax defrec! + (syntax-rules () + ((_ x v) (define! x (rec x v))))) + +(define-syntax begin0 + (syntax-rules () + ((_ x y ...) (let ((t x)) y ... t)))) + +(define-syntax recur + (syntax-rules () + ((_ f ((i v) ...) e1 e2 ...) + (let f ((i v) ...) e1 e2 ...)))) + +(define-syntax trace-recur + (syntax-rules () + ((_ f ((x v) ...) e1 e2 ...) + (trace-let f ((x v) ...) e1 e2 ...)))) + +(define swap-box! + (lambda (b v) + (if (box? b) + (let ((x (unbox b))) (set-box! b v) x) + (error 'swap-box! "~s is not a box" b)))) + +(define cull + (lambda (pred? ls) + (unless (procedure? pred?) + (error 'cull "~s is not a procedure" pred?)) + (let f ([l ls]) + (cond + [(pair? l) + (if (pred? (car l)) + (cons (car l) (f (cdr l))) + (f (cdr l)))] + [(null? l) '()] + [else (error 'cull "~s is not a proper list" ls)])))) + +(define cull! cull) + +(define mem + (lambda (pred? ls) + (unless (procedure? pred?) + (error 'mem "~s is not a procedure" pred?)) + (let f ([l ls]) + (cond + [(pair? l) (if (pred? (car l)) l (f (cdr l)))] + [(null? l) #f] + [else (error 'mem "~s is not a proper list" ls)])))) + +(define rem + (lambda (pred? ls) + (unless (procedure? pred?) + (error 'rem "~s is not a procedure" pred?)) + (let f ([l ls]) + (cond + [(pair? l) + (if (pred? (car l)) + (f (cdr l)) + (cons (car l) (f (cdr l))))] + [(null? l) '()] + [else (error 'rem "~s is not a proper list" ls)])))) + +(define rem! + (lambda (pred? ls) + (unless (procedure? pred?) + (error 'rem! "~s is not a procedure" pred?)) + (let f ([l ls]) + (cond + [(pair? l) + (if (pred? (car l)) + (f (cdr l)) + (begin + (set-cdr! l (f (cdr l))) + l))] + [(null? l) '()] + [else (error 'rem! "~s is not a proper list" ls)])))) + +(define ass + (lambda (pred? alist) + (unless (procedure? pred?) + (error 'ass "~s is not a procedure" pred?)) + (let loop ([l alist]) + (cond + [(and (pair? l) (pair? (car l))) + (if (pred? (caar l)) + (car l) + (loop (cdr l)))] + [(null? l) #f] + [else (error 'ass "improperly formed alist ~s" alist)])))) + +(define prompt-read + (lambda (fmt . args) + (apply printf fmt args) + (read))) + +(define tree-copy + (rec tree-copy + (lambda (x) + (if (pair? x) + (cons (tree-copy (car x)) (tree-copy (cdr x))) + x)))) + +(define ferror error) + +(define *most-negative-short-integer* (most-negative-fixnum)) +(define *most-positive-short-integer* (most-positive-fixnum)) + +(define *most-negative-fixnum* (most-negative-fixnum)) +(define *most-positive-fixnum* (most-positive-fixnum)) + +(define *eof* (read-char (open-input-string ""))) + +(define short-integer? fixnum?) +(define big-integer? bignum?) +(define ratio? ratnum?) +(define float? flonum?) + +(define bound? top-level-bound?) +(define global-value top-level-value) +(define set-global-value! set-top-level-value!) +(define define-global-value define-top-level-value) +(define symbol-value top-level-value) +(define set-symbol-value! set-top-level-value!) + +(define put putprop) +(define get getprop) + +(define copy-list list-copy) +(define copy-tree tree-copy) +(define copy-string string-copy) +(define copy-vector vector-copy) + +(define intern string->symbol) +(define symbol-name symbol->string) +(define string->uninterned-symbol gensym) +(define make-temp-symbol string->uninterned-symbol) +(define uninterned-symbol? gensym?) +(define temp-symbol? uninterned-symbol?) + +(define compile-eval compile) + +(define closure? procedure?) + +(define =? =) +(define ? >) +(define <=? <=) +(define >=? >=) + +(define float exact->inexact) +(define rational inexact->exact) + +(define char-equal? char=?) +(define char-less? charsyntax-object #'k + (let ((g (gensym))) + `(lambda (,g) + (let ,(parse (datum args) `(cdr ,g)) + ,@(datum forms))))))) + #'(define-syntax name + (lambda (x) + (syntax-case x () + ((k1 . r) + (datum->syntax-object #'k1 + (proc (syntax-object->datum x)))))))))]))) + +(alias define-macro define-macro!) +(alias defmacro define-macro!) + +(define-macro! define-struct! (name . slots) + `(begin + (define ,name + (lambda ,slots + (vector ',name ,@slots))) + (define ,(string->symbol (format "~a?" name)) + (lambda (x) + (and (vector? x) + (= (vector-length x) (1+ ,(length slots))) + (eq? ',name (vector-ref x 0))))) + ,@(\#make-accessors name slots) + ',name)) + +(define \#make-accessors + (lambda (name slots) + (recur f ((n 1) (slots slots)) + (if (not (null? slots)) + (let* + ((afn (string->symbol (format "~a-~a" name (car slots)))) + (sfn (string->symbol (format "~a!" afn)))) + `((define-macro! ,afn (x) `(vector-ref ,x ,,n)) + (define-macro! ,sfn (x v) `(vector-set! ,x ,,n ,v)) + ,@(f (1+ n) (cdr slots)))) + '())))) diff --git a/examples/crepl.c b/examples/crepl.c new file mode 100644 index 0000000..13a8c1e --- /dev/null +++ b/examples/crepl.c @@ -0,0 +1,86 @@ +/* crepl.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/* +This is a variant of main.c that implements a Scheme repl in C. +It's not at all useful, but it highlights how to invoke Scheme +without going through Sscheme_start. + +Test in a workarea's examples subdirectory with: + +( cd ../c ; ln -sf ../examples/crepl.c . ) +( cd ../c ; make mainsrc=crepl.c ) +sh -c 'SCHEMEHEAPDIRS=../boot/%m ../bin/scheme' + */ + +#include "scheme.h" +#include +#include + +#define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who))) +#define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg) + +static void custom_init(void) {} + +int main(int argc, char *argv[]) { + int n, new_argc = 1, ignoreflags = 0; + ptr p; + + Sscheme_init(NULL); + + /* process command-line arguments, registering boot and heap files */ + for (n = 1; n < argc; n += 1) { + if (!ignoreflags && *argv[n] == '-') { + switch (*(argv[n]+1)) { + case '-': /* pass through remaining options */ + if (*(argv[n]+2) != 0) break; + ignoreflags = 1; + continue; + case 'b': /* boot option, expects boot file pathname */ + if (*(argv[n]+2) != 0) break; + if (++n == argc) { + (void) fprintf(stderr,"\n-b option requires argument\n"); + exit(1); + } + Sregister_boot_file(argv[n]); + continue; + default: + break; + } + } + argv[new_argc++] = argv[n]; + } + + /* must call Sscheme_heap after registering boot and heap files + * Sscheme_heap() completes the initialization of the Scheme system + * and loads the boot or heap files. Before loading boot files, + * it calls custom_init(). */ + Sbuild_heap(argv[0], custom_init); + + for (;;) { + CALL1("display", Sstring("* ")); + p = CALL0("read"); + if (Seof_objectp(p)) break; + p = CALL1("eval", p); + if (p != Svoid) CALL1("pretty-print", p); + } + CALL0("newline"); + + /* must call Scheme_deinit after saving the heap and before exiting */ + Sscheme_deinit(); + + exit(0); +} diff --git a/examples/csocket.c b/examples/csocket.c new file mode 100644 index 0000000..f2821ef --- /dev/null +++ b/examples/csocket.c @@ -0,0 +1,103 @@ +/*/ csocket.c +R. Kent Dybvig May 1998 +Updated by Jamie Taylor, Sept 2016 +Public Domain +/*/ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* c_write attempts to write the entire buffer, pushing through + interrupts, socket delays, and partial-buffer writes */ +int c_write(int fd, char *buf, ssize_t start, ssize_t n) { + ssize_t i, m; + + buf += start; + m = n; + while (m > 0) { + if ((i = write(fd, buf, m)) < 0) { + if (errno != EAGAIN && errno != EINTR) + return i; + } else { + m -= i; + buf += i; + } + } + return n; +} + +/* c_read pushes through interrupts and socket delays */ +int c_read(int fd, char *buf, size_t start, size_t n) { + int i; + + buf += start; + for (;;) { + i = read(fd, buf, n); + if (i >= 0) return i; + if (errno != EAGAIN && errno != EINTR) return -1; + } +} + +/* bytes_ready(fd) returns true if there are bytes available + to be read from the socket identified by fd */ +int bytes_ready(int fd) { + int n; + + (void) ioctl(fd, FIONREAD, &n); + return n; +} + +/* socket support */ + +/* do_socket() creates a new AF_UNIX socket */ +int do_socket(void) { + + return socket(AF_UNIX, SOCK_STREAM, 0); +} + +/* do_bind(s, name) binds name to the socket s */ +int do_bind(int s, char *name) { + struct sockaddr_un sun; + int length; + + sun.sun_family = AF_UNIX; + (void) strcpy(sun.sun_path, name); + length = sizeof(sun.sun_family) + sizeof(sun.sun_path); + + return bind(s, (struct sockaddr*)(&sun), length); +} + +/* do_accept accepts a connection on socket s */ +int do_accept(int s) { + struct sockaddr_un sun; + socklen_t length; + + length = sizeof(sun.sun_family) + sizeof(sun.sun_path); + + return accept(s, (struct sockaddr*)(&sun), &length); +} + +/* do_connect initiates a socket connection */ +int do_connect(int s, char *name) { + struct sockaddr_un sun; + int length; + + sun.sun_family = AF_UNIX; + (void) strcpy(sun.sun_path, name); + length = sizeof(sun.sun_family) + sizeof(sun.sun_path); + + return connect(s, (struct sockaddr*)(&sun), length); +} + +/* get_error returns the operating system's error status */ +char* get_error(void) { + extern int errno; + return strerror(errno); +} diff --git a/examples/def.ss b/examples/def.ss new file mode 100644 index 0000000..a39dde2 --- /dev/null +++ b/examples/def.ss @@ -0,0 +1,125 @@ +;;; def.ss +;;; Copyright (C) 1987 R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; Prototype code for definition facility that remembers definitions and +;;; allows you to pretty-print or edit them (using the structure editor +;;; defined in the file "edit.ss"). + +;;; def can be in place of define at top level (i.e., not within a lambda, +;;; let, let*, or letrec body). It saves the source for the definition +;;; as well as performing the defintion. Type (ls-def) for a list of +;;; variables defined this session, and (pp-def variable) to return the +;;; definition of a particular variable. + +;;; Possible exercises/enhancements: +;;; +;;; 1) Write a "dskout" function that pretty-prints the definitions of +;;; all or selected variables defined this session to a file. +;;; +;;; 2) In place of "def", write a modified "load" that remembers where +;;; (that is, in which file) it saw the definition for each variable +;;; defined in a particular session. This would be used instead of +;;; the "def" form. "ls-def" would be similar to what it is now. +;;; "pp-def" could be similar to what it is now, or it could involve +;;; rereading the corresponding file. "ed-def" could invoke the +;;; structure editor and (as an option) print the modified definition +;;; back to the corresponding file, or "ed-def" could invoke a host +;;; editor (such as Unix "vi" or VMS "edit") on the corresponding +;;; source file, with an option to reload. If this tool is smart +;;; enough, it could get around the limitation that definitions use +;;; define at top-level, i.e., (let ([x #f]) (set! foo (lambda () x))) +;;; could be recognized as a definition for foo. + +(define-syntax def + ;; only makes sense for "top level" definitions + (syntax-rules () + [(_ (var . formals) . body) + (begin (define (var . formals) . body) + (insert-def! 'var '(def (var . formals) . body) var) + 'var)] + [(_ var exp) + (begin (define var exp) + (insert-def! 'var '(def var exp) var) + 'var)])) + +(define-syntax pp-def + (syntax-rules (quote) + ; allow var to be unquoted or quoted + [(_ var) (pp-def-help 'var var)] + [(_ 'var) (pp-def-help 'var var)])) + +(define-syntax ed-def + (syntax-rules (quote) + ; allow var to be unquoted or quoted + [(_ var) (ed-def-help 'var var)] + [(_ 'var) (ed-def-help 'var var)])) + + +(define insert-def! #f) ; assigned within the let below +(define ls-def #f) ; assigned within the let below +(define pp-def-help #f) ; assigned within the let below +(define ed-def-help #f) ; assigned within the let below +(let ([defs '()]) + (define tree-copy + (rec tree-copy + (lambda (x) + (if (pair? x) + (cons (tree-copy (car x)) (tree-copy (cdr x))) + x)))) + (set! insert-def! + (lambda (var defn val) + (unless (symbol? var) + (error 'insert-def! "~s is not a symbol" var)) + (let ([a (assq var defs)]) + (if a + (set-cdr! a (cons defn val)) + (set! defs (cons (cons var (cons defn val)) defs)))))) + (set! ls-def + (lambda () + (map car defs))) + (set! pp-def-help + (lambda (var val) + (unless (symbol? var) + (error 'pp-def "~s is not a symbol" var)) + (let ([a (assq var defs)]) + (unless a + (error 'pp-def + "~s has not been defined during this session" + var)) + (unless (eq? (cddr a) val) + (printf "Warning: ~s has been reassigned since definition" + var)) + (cadr a)))) + (set! ed-def-help + (lambda (var val) + (unless (symbol? var) + (error 'ed-def "~s is not a symbol" var)) + (let ([a (assq var defs)]) + (unless a + (error 'ed-def + "~s has not been defined during this session" + var)) + (unless (eq? (cddr a) val) + (printf "Warning: ~s reassigned since last definition" + var)) + ; edit is destructive; the copy allows the defined name to + ; be changed without affecting the old name's definition + (eval (edit (tree-copy (cadr a)))))))) diff --git a/examples/edit.ss b/examples/edit.ss new file mode 100644 index 0000000..68acd04 --- /dev/null +++ b/examples/edit.ss @@ -0,0 +1,464 @@ +;;; edit.ss +;;; Copyright (C) 1987 R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; This file contains an implementation of a simple interactive structure +;;; editor for Scheme. The editor is invoked with an expression as it's +;;; single argument. It prompts for, reads, and processes editor commands. + +;;; The editor commands recognized are those documented in the Texas +;;; Instruments' PC Scheme manual. They are summarized below. + +;;; Command syntax Action +;;; +;;; q or Quit the editor, returning edited expression. +;;; +;;; p Write the current expression. +;;; +;;; ? Write to level 2, length 10. +;;; +;;; pp Pretty print the current expression. +;;; +;;; ?? Pretty print to level 2, length 10. +;;; +;;; Move to subexpression of current expression +;;; = 0 is the current expression, > 0 +;;; is the numbered subexpression (1 for first, 2 +;;; for second, ...), < 0 is the numbered +;;; subexpression from the right (-1 for last, -2 +;;; for second to last, ...), and = * is the +;;; "last cdr" of the current expression. If +;;; is not 0, the current expression must be a list. +;;; +;;; b Move back to parent expression. +;;; +;;; t Move to top-level expression. +;;; +;;; pr Move to expression on the left (previous). +;;; +;;; n Move to expression on the right (next). +;;; +;;; (f ) Find within or to the right of the current +;;; expression using equal?. +;;; +;;; f or (f) Find of last (f ) command. +;;; +;;; (d ) Delete the expression at position . +;;; +;;; (r ) Replace the expression at position with +;;; . +;;; +;;; (s ) Replace all occurrences of by +;;; within the current expression. +;;; +;;; (dp ) Remove parens from around expression at position +;;; . +;;; +;;; (ap ) Insert parens around expressions from position +;;; through (inclusive). If is +;;; 0 or *, is ignored and may be omitted. +;;; +;;; (ib ) Insert before expression at position . +;;; +;;; (ia ) Insert after expression at position . +;;; +;;; (sb ) Splice before expression at position . +;;; +;;; (sa ) Splice after expression at position . + +;;; Possible exercises/enhancements: +;;; +;;; 1) Implement an infinite undo ("u") command in the editor. This +;;; can be done by creating an "inverse" function for each operation +;;; that causes a side-effect, i.e, a closure that "remembers" the +;;; list cells involved and knows how to put them back the way they +;;; were. An undo (u) variable could then be added to the editor's +;;; main loop; it would be bound to a list containing the set of +;;; registers at the point of the last side-effect (similarly to the +;;; "back" (b) variable) and the undo function for the side-effect. +;;; +;;; 2) Implement an infinite redo ("r") command in the editor. This +;;; can be done by remembering the undo functions and registers for +;;; the undo's since the last non-undo command. +;;; +;;; 3) Handle circular structures better in the editor. Specifically, +;;; modify the find ("f") command so that it always terminates, and +;;; devise a method for printing circular structures with the "p" +;;; and "pp" commands. Cure the bug mentioned in the overview of +;;; the code given later in the file. +;;; +;;; 4) Add a help ("h") command to the editor. This could be as simple +;;; as listing the available commands. +;;; +;;; 5) Make the editor "extensible" via user-defined macros or editor +;;; commands written in Scheme. +;;; +;;; 6) Modify the editor to provide more descriptive error messages that +;;; diagnose the problem and attempt to give some help. For example, +;;; if the editor receives "(r 1)" it might respond with: +;;; "Two few arguments: +;;; Type (r pos exp) to replace the expression at position pos +;;; with the expression exp." +;;; This should be implemented in conjunction with the help command. +;;; Should it be possible to disable such verbose error messages? + +;;; Implementation: +;;; +;;; The main editor loop and many of the help functions operate on a +;;; set of "registers". These registers are described below: +;;; +;;; s The current find object. s is initially #f, and is bound to a +;;; pair containing the find object when the first (f ) command +;;; is seen. The identical f and (f) commands use the saved object. +;;; +;;; p The parent of the current expression. This is initially a list +;;; of one element, the argument to edit. It is updated by various +;;; movement commands. +;;; +;;; i The index of the current expression in the parent (p). This is +;;; initially 0. It is updated by various movement commands. +;;; +;;; b The "back" chain; actually a list containing the registers p, i +;;; and b for the parent of the current expression. It is initially +;;; (). It is updated by various movement commands. +;;; +;;; Bugs: +;;; +;;; When editing a circular structure, it is possible for the editor to +;;; get lost. That is, when the parent node of the current expression +;;; is changed by a command operating on a subexpression of the current +;;; expression, the index for the current expression may become incorrect. +;;; This can result in abnormal termination of the editor. It would be +;;; fairly simple to check for this (in list-ref) and reset the editor, +;;; and it may be possible to use a different set of registers to avoid +;;; the problem altogether. + +(define edit #f) ; assigned within the let expression below +(let () + (define cmdeq? + ;; used to check command syntax + (lambda (cmd pat) + (and (pair? cmd) + (eq? (car cmd) (car pat)) + (let okargs? ([cmd (cdr cmd)] [pat (cdr pat)]) + (if (null? pat) + (null? cmd) + (and (not (null? cmd)) + (okargs? (cdr cmd) (cdr pat)))))))) + (define find + ;; find expression within or to right of current expression + (lambda (s0 p0 i0 b0) + (define check + (lambda (p i b) + (if (equal? (list-ref p i) (car s0)) + (wrlev s0 p i b) + (continue p i b)))) + (define continue + (lambda (p i b) + (let ([e (list-ref p i)]) + (if (atom? e) + (let next ([p p] [i i] [b b]) + (let ([n (maxref p)]) + (if (or (not n) (< i n)) + (check p (+ i 1) b) + (if (null? b) + (search-failed s0 p0 i0 b0) + (apply next b))))) + (check e 0 (list p i b)))))) + (continue p0 i0 b0))) + (define maxref + ;; use "hare and tortoise" algorithm to check for circular lists. + ;; return maximum reference index (zero-based) for a list x. return + ;; -1 for atoms and #f for circular lists. + (lambda (x) + (let f ([hare x] [tortoise x] [n -1]) + (cond + [(atom? hare) n] + [(atom? (cdr hare)) (+ n 1)] + [(eq? (cdr hare) tortoise) #f] + [else (f (cddr hare) (cdr tortoise) (+ n 2))])))) + (define move + ;; move to subexpression specified by x and pass current state to k. + (lambda (x s p i b k) + (cond + [(eqv? x 0) (k s p i b)] + [(eq? x '*) + (let ([m (maxref (list-ref p i))]) + (if m + (k s (list-ref p i) '* (list p i b)) + (invalid-movement s p i b)))] + [(> x 0) + (let ([m (maxref (list-ref p i))] [x (- x 1)]) + (if (or (not m) (>= m x)) + (k s (list-ref p i) x (list p i b)) + (invalid-movement s p i b)))] + [else + (let ([m (maxref (list-ref p i))] [x (- -1 x)]) + (if (and m (>= m x)) + (let ([x (- m x)]) + (k s (list-ref p i) x (list p i b))) + (invalid-movement s p i b)))]))) + (define proper-list? + ;; return #t if x is a proper list. + (lambda (x) + (and (maxref x) + (or (null? x) (null? (cdr (last-pair x))))))) + (define list-ref + ;; reference list ls element i. i may be *, in which case return + ;; the last pair of ls. + (lambda (ls i) + (if (eq? i '*) + (cdr (last-pair ls)) + (car (list-tail ls i))))) + (define list-set! + ;; change element i of ls to x. + (lambda (ls i x) + (if (eq? i '*) + (set-cdr! (last-pair ls) x) + (set-car! (list-tail ls i) x)))) + (define list-cut! + ;; remove element i from ls. + (lambda (ls i) + (let ([a (cons '() ls)]) + (set-cdr! (list-tail a i) (list-tail a (+ i 2))) + (cdr a)))) + (define list-splice! + ;; insert ls2 into ls1 in place of element i. + (lambda (ls1 i ls2) + (let ([a (list-tail ls1 i)]) + (unless (null? (cdr a)) + (set-cdr! (last-pair ls2) (cdr a))) + (set-car! a (car ls2)) + (set-cdr! a (cdr ls2))) + ls1)) + (define list-ap*! + ;; place parens from element i through last pair of ls. + (lambda (ls i) + (let ([a (list-tail ls i)]) + (let ([c (cons (car a) (cdr a))]) + (set-car! a c) + (set-cdr! a '()))) + ls)) + (define list-ap! + ;; place parens from element i0 through element i1. + (lambda (ls i0 i1) + (let ([a (list-tail ls i0)] [b (list-tail ls i1)]) + (let ([c (cons (car a) (cdr a))]) + (set-car! a c) + (if (eq? a b) + (set-cdr! c '()) + (begin (set-cdr! a (cdr b)) + (set-cdr! b '()))))) + ls)) + (define wrlev + ;; write current expression to level 2, length 10 and continue. + (lambda (s p i b) + (parameterize ([print-level 2] [print-length 10]) + (printf "~s~%" (list-ref p i))) + (edit-loop s p i b))) + (define wr + ;; write current expression and continue. + (lambda (s p i b) + (printf "~s~%" (list-ref p i)) + (edit-loop s p i b))) + (define pplev + ;; pretty print current expression to level 2, length 10 and continue. + (lambda (s p i b) + (parameterize ([print-level 2] [print-length 10]) + (pretty-print (list-ref p i))) + (edit-loop s p i b))) + (define pp + ;; pretty print current expression and continue. + (lambda (s p i b) + (pretty-print (list-ref p i)) + (edit-loop s p i b))) + (define not-a-proper-list + ;; complain and continue. + (lambda (s p i b) + (printf "structure is not a proper list~%") + (edit-loop s p i b))) + (define cannot-dp-zero + ;; complain and continue. + (lambda (s p i b) + (printf "cannot remove parens from current expression~%") + (edit-loop s p i b))) + (define pos2-before-pos1 + ;; complain and continue. + (lambda (s p i b) + (printf "second position before first~%") + (edit-loop s p i b))) + (define invalid-movement + ;; complain and continue. + (lambda (s p i b) + (printf "no such position~%") + (edit-loop s p i b))) + (define unrecognized-command-syntax + ;; complain and continue. + (lambda (s p i b) + (printf "unrecognized command syntax~%") + (edit-loop s p i b))) + (define search-failed + ;; complain and continue. + (lambda (s p i b) + (printf "search failed~%") + (edit-loop s p i b))) + (define no-previous-find + ;; complain and continue. + (lambda (s p i b) + (printf "no previous find command~%") + (edit-loop s p i b))) + (define edit-loop + ;; read command and process. + (lambda (s p i b) + (let ([x (begin (printf "edit> ") (read))]) + (cond + [(eof-object? x) (newline)] ; need newline after eof + [(eq? x 'q)] ; do not need newline after q + [(eq? x 'p) (wr s p i b)] + [(eq? x '?) (wrlev s p i b)] + [(eq? x 'pp) (pp s p i b)] + [(eq? x '??) (pplev s p i b)] + [(or (integer? x) (eqv? x '*)) (move x s p i b wrlev)] + [(eq? x 't) + (let f ([p p] [i i] [b b]) + (if (null? b) + (wrlev s p i b) + (apply f b)))] + [(eq? x 'b) + (if (pair? b) + (apply wrlev s b) + (invalid-movement s p i b))] + [(eq? x 'n) + (let ([n (maxref p)]) + (if (and (not (eq? i '*)) (or (not n) (< i n))) + (wrlev s p (+ i 1) b) + (invalid-movement s p i b)))] + [(eq? x 'pr) + (if (and (not (eq? i '*)) (> i 0)) + (wrlev s p (- i 1) b) + (invalid-movement s p i b))] + [(or (eq? x 'f) (cmdeq? x '(f))) + (if s + (find s p i b) + (no-previous-find s p i b))] + [(cmdeq? x '(f x)) + (find (cons (cadr x) '()) p i b)] + [(and (cmdeq? x '(r x x)) + (or (integer? (cadr x)) (eq? (cadr x) '*))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-set! p0 i0 (caddr x)))) + (wrlev s p i b)] + [(cmdeq? x '(s x x)) + (list-set! p i (subst! (caddr x) (cadr x) (list-ref p i))) + (wrlev s p i b)] + [(and (cmdeq? x '(d x)) (eqv? (cadr x) 0)) + (list-set! p i '()) + (wrlev s p i b)] + [(and (cmdeq? x '(d x)) (eq? (cadr x) '*)) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (set-cdr! (last-pair p0) '()) + (wrlev s p i b)))] + [(and (cmdeq? x '(d x)) (integer? (cadr x))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-set! p i (list-cut! p0 i0)) + (wrlev s p i b)))] + [(and (cmdeq? x '(dp x)) (eqv? (cadr x) 0)) + (let ([e (list-ref p i)]) + (if (and (pair? e) (null? (cdr e))) + (begin (list-set! p i (car e)) + (wrlev s p i b)) + (cannot-dp-zero s p i b)))] + [(and (cmdeq? x '(dp x)) + (and (integer? (cadr x)) (not (= (cadr x) 0)))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (let ([e0 (list-ref p0 i0)]) + (if (or (proper-list? e0) + (and (pair? e0) (eqv? i0 (maxref p0)))) + (begin (if (null? e0) + (list-set! p i (list-cut! p0 i0)) + (list-splice! p0 i0 e0)) + (wrlev s p i b)) + (not-a-proper-list s p i b)))))] + [(and (or (cmdeq? x '(ap x)) (cmdeq? x '(ap x x))) + (memv (cadr x) '(0 *))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-set! p0 i0 (list (list-ref p0 i0))) + (wrlev s p i b)))] + [(and (cmdeq? x '(ap x x)) + (and (integer? (cadr x)) (not (= (cadr x) 0))) + (eq? (caddr x) '*)) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-ap*! p0 i0) + (wrlev s p i b)))] + [(and (cmdeq? x '(ap x x)) + (and (integer? (cadr x)) (not (= (cadr x) 0))) + (and (integer? (caddr x)) (not (= (caddr x) 0)))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (move (caddr x) s p i b + (lambda (s1 p1 i1 b1) + (if (>= i1 i0) + (begin (list-ap! p0 i0 i1) + (wrlev s p i b)) + (pos2-before-pos1 s p i b))))))] + [(and (cmdeq? x '(ib x x)) + (and (integer? (cadr x)) (not (= (cadr x) 0)))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-splice! p0 i0 (list (caddr x) (list-ref p0 i0))) + (wrlev s p i b)))] + [(and (cmdeq? x '(ia x x)) + (and (integer? (cadr x)) (not (= (cadr x) 0)))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-splice! p0 i0 (list (list-ref p0 i0) (caddr x))) + (wrlev s p i b)))] + [(and (cmdeq? x '(sb x x)) + (and (integer? (cadr x)) (not (= (cadr x) 0)))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-splice! p0 i0 + (append (caddr x) (list (list-ref p0 i0)))) + (wrlev s p i b)))] + [(and (cmdeq? x '(sa x x)) + (and (integer? (cadr x)) (not (= (cadr x) 0)))) + (move (cadr x) s p i b + (lambda (s0 p0 i0 b0) + (list-splice! p0 i0 (cons (list-ref p0 i0) (caddr x))) + (wrlev s p i b)))] + [else + (unrecognized-command-syntax s p i b)])))) + (set! edit + ;; set up keyboard interrupt handler and go. + (lambda (e) + (let ([p (cons e '())]) + (let ([k (call/cc (lambda (k) k))]) ; return here on interrupt + (parameterize ([keyboard-interrupt-handler + (lambda () + (printf "reset~%") + (k k))]) + (wrlev #f p 0 '()) + (car p))))))) diff --git a/examples/ez-grammar-test.ss b/examples/ez-grammar-test.ss new file mode 100644 index 0000000..3dd4871 --- /dev/null +++ b/examples/ez-grammar-test.ss @@ -0,0 +1,570 @@ +;;; Copyright 2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; This file contains a sample parser defined via the ez-grammar system +;;; and a simple test of the parser. + +;;; This file is organized as follows: +;;; +;;; - (streams) library providing the required exports for ez-grammar and +;;; the parser. +;;; +;;; - (state-case) library exporting the state-case macro, copped from +;;; cmacros.ss, for use by the lexer. +;;; +;;; - (lexer) library providing a simple lexer that reads characters +;;; from a port and produces a corresponding stream of tokens. +;;; +;;; - (parser) library providing the sample parser. +;;; +;;; - ez-grammar-test procedure that tests the sample parser. +;;; +;;; Instructions for running the test are at the end of this file. + +(library (streams) + (export stream-cons stream-car stream-cdr stream-nil stream-null? + stream-map stream stream-append2 stream-append-all stream-last-forced) + (import (chezscheme)) + + (define stream-cons + (lambda (x thunk) + (cons x thunk))) + + (define stream-car + (lambda (x) + (car x))) + + (define stream-cdr + (lambda (x) + (when (procedure? (cdr x)) (set-cdr! x ((cdr x)))) + (cdr x))) + + (define stream-nil '()) + + (define stream-null? + (lambda (x) + (null? x))) + + (define stream-map + (lambda (f x) + (if (stream-null? x) + '() + (stream-cons (f (stream-car x)) + (lambda () + (stream-map f (stream-cdr x))))))) + + (define stream + (lambda xs + xs)) + + (define stream-append2 + (lambda (xs thunk) + (if (null? xs) + (thunk) + (stream-cons (stream-car xs) + (lambda () + (stream-append2 (stream-cdr xs) thunk)))))) + + (define stream-append-all + (lambda (stream$) ;; stream of streams + (if (stream-null? stream$) + stream$ + (stream-append2 (stream-car stream$) + (lambda () (stream-append-all (stream-cdr stream$))))))) + + (define stream-last-forced + (lambda (x) + (and (not (null? x)) + (let loop ([x x]) + (let ([next (cdr x)]) + (if (pair? next) + (loop next) + (car x))))))) +) + +(library (state-case) + (export state-case eof) + (import (chezscheme)) + + ;;; from Chez Scheme Version 9.5.1 cmacros.ss + (define-syntax state-case + (lambda (x) + (define state-case-test + (lambda (cvar k) + (with-syntax ((cvar cvar)) + (syntax-case k (-) + (char + (char? (datum char)) + #'(char=? cvar char)) + ((char1 - char2) + (and (char? (datum char1)) (char? (datum char2))) + #'(char<=? char1 cvar char2)) + (predicate + (identifier? #'predicate) + #'(predicate cvar)))))) + (define state-case-help + (lambda (cvar clauses) + (syntax-case clauses (else) + (((else exp1 exp2 ...)) + #'(begin exp1 exp2 ...)) + ((((k ...) exp1 exp2 ...) . more) + (with-syntax (((test ...) + (map (lambda (k) (state-case-test cvar k)) + #'(k ...))) + (rest (state-case-help cvar #'more))) + #'(if (or test ...) (begin exp1 exp2 ...) rest))) + (((k exp1 exp2 ...) . more) + (with-syntax ((test (state-case-test cvar #'k)) + (rest (state-case-help cvar #'more))) + #'(if test (begin exp1 exp2 ...) rest)))))) + (syntax-case x (eof) + ((_ cvar (eof exp1 exp2 ...) more ...) + (identifier? #'cvar) + (with-syntax ((rest (state-case-help #'cvar #'(more ...)))) + #'(if (eof-object? cvar) + (begin exp1 exp2 ...) + rest)))))) + + (define-syntax eof + (lambda (x) + (syntax-error x "misplaced aux keyword"))) +) + +(library (lexer) + (export token? token-type token-value token-bfp token-efp lexer) + (import (chezscheme) (state-case) (streams)) + + (define-record-type token + (nongenerative) + (fields type value bfp efp)) + + ;; test lexer + (define lexer + (lambda (fn ip) + (define $prev-pos 0) + (define $pos 0) + (define ($get-char) + (set! $pos (+ $pos 1)) + (get-char ip)) + (define ($unread-char c) + (set! $pos (- $pos 1)) + (unread-char c ip)) + (define ($ws!) (set! $prev-pos $pos)) + (define ($make-token type value) + (let ([tok (make-token type value $prev-pos $pos)]) + (set! $prev-pos $pos) + tok)) + (define ($lex-error c) + (errorf #f "unexpected ~a at character ~s of ~a" + (if (eof-object? c) + "eof" + (format "character '~c'" c)) + $pos fn)) + (define-syntax lex-error + (syntax-rules () + [(_ ?c) + (let ([c ?c]) + ($lex-error c) + (void))])) + (let-values ([(sp get-buf) (open-string-output-port)]) + (define (return-token type value) + (stream-cons ($make-token type value) lex)) + (module (identifier-initial? identifier-subsequent?) + (define identifier-initial? + (lambda (c) + (char-alphabetic? c))) + (define identifier-subsequent? + (lambda (c) + (or (char-alphabetic? c) + (char-numeric? c))))) + (define-syntax define-state-case + (syntax-rules () + [(_ ?def-id ?char-id clause ...) + (define (?def-id) + (let ([?char-id ($get-char)]) + (state-case ?char-id clause ...)))])) + (define-state-case lex c + [eof stream-nil] + [char-whitespace? ($ws!) (lex)] + [char-numeric? (lex-number c)] + [#\/ (seen-slash)] + [identifier-initial? (put-char sp c) (lex-identifier)] + [#\( (return-token 'lparen #\()] + [#\) (return-token 'rparen #\))] + [#\! (return-token 'bang #\!)] + [#\+ (seen-plus)] + [#\- (seen-minus)] + [#\= (seen-equals)] + [#\* (return-token 'binop '*)] + [#\, (return-token 'sep #\,)] + [#\; (return-token 'sep #\;)] + [else (lex-error c)]) + (module (lex-identifier) + (define (id) (return-token 'id (string->symbol (get-buf)))) + (define-state-case next c + [eof (id)] + [identifier-subsequent? (put-char sp c) (next)] + [else ($unread-char c) (id)]) + (define (lex-identifier) (next))) + (define-state-case seen-plus c + [eof (return-token 'binop '+)] + [char-numeric? (lex-signed-number #\+ c)] + [else (return-token 'binop '+)]) + (define-state-case seen-minus c + [eof (return-token 'binop '-)] + [char-numeric? (lex-signed-number #\- c)] + [else (return-token 'binop '-)]) + (define-state-case seen-equals c + [eof (return-token 'binop '=)] + [#\> (return-token 'big-arrow #f)] + [else (return-token 'binop '=)]) + (module (lex-number lex-signed-number) + (define (finish-number) + (let ([str (get-buf)]) + (let ([n (string->number str 10)]) + (unless n (errorf 'lexer "unexpected number literal ~a" str)) + (return-token 'integer n)))) + (define (num) + (let ([c ($get-char)]) + (state-case c + [eof (finish-number)] + [char-numeric? (put-char sp c) (num)] + [else ($unread-char c) (finish-number)]))) + (define (lex-signed-number s c) + (put-char sp s) + (lex-number c)) + (define (lex-number c) + (state-case c + [eof (assert #f)] + [char-numeric? (put-char sp c) (num)] + [else (assert #f)]))) + (define-state-case seen-slash c + [eof (return-token 'binop '/)] + [#\* (lex-block-comment)] + [#\/ (lex-comment)] + [else (return-token 'binop '/)]) + (define-state-case lex-comment c + [eof (lex)] + [#\newline ($ws!) (lex)] + [else (lex-comment)]) + (define (lex-block-comment) + (define-state-case maybe-end-comment c + [eof (lex-error c)] + [#\/ ($ws!) (lex)] + [else (lex-block-comment)]) + (let ([c ($get-char)]) + (state-case c + [eof (lex-error c)] + [#\* (maybe-end-comment)] + [else (lex-block-comment)]))) + (lex)))) + + (record-writer (record-type-descriptor token) + (lambda (x p wr) + (put-char p #\[) + (wr (token-type x) p) + (put-char p #\,) + (put-char p #\space) + (wr (token-value x) p) + (put-char p #\]) + (put-char p #\:) + (wr (token-bfp x) p) + (put-char p #\-) + (wr (token-efp x) p))) +) + +(module parser () + (export parse *sfd*) + (import (chezscheme) (streams) (lexer)) + (define *sfd*) + (module (define-grammar is sat parse-consumed-all? parse-result-value grammar-trace make-src) + (define (sep->parser sep) + (cond + [(char? sep) (sat (lambda (x) (and (eq? (token-type x) 'sep) (eq? (token-value x) sep))))] + [(symbol? sep) (sat (lambda (x) (eq? (token-type x) sep)))] + [else (errorf "don't know how to parse separator: ~s" sep)])) + (meta define (constant? x) (let ([x (syntax->datum x)]) (or (string? x) (char? x)))) + (define constant->parser + (lambda (const) + (define (token-sat type val) + (sat (lambda (x) + (let ([ans (and (token? x) (eqv? (token-type x) type) (eqv? (token-value x) val))]) + (when (grammar-trace) (printf " ~s is [~s, ~a]? => ~s~%" x type val ans)) + ans)))) + (if (string? const) + (case const + [else (token-sat 'id (string->symbol const))]) + (case const + [#\( (token-sat 'lparen const)] + [#\) (token-sat 'rparen const)] + [#\! (token-sat 'bang const)] + [else (errorf 'constant->parser "don't know how to construct a parser for ~a" const)])))) + (meta define (constant->markdown k) + (format "~a" k)) + (define binop->parser + (lambda (binop) + (define (binop-sat type val) + (is val + (where [x <- item] (and (token? x) (eq? (token-type x) type) (eq? (token-value x) val))))) + (define (unexpected) (errorf 'binop->parser "don't know how to construct a parser for ~a" binop)) + (if (string? binop) + (binop-sat 'binop + (case binop + ["=" '=] + ["+" '+] + ["-" '-] + ["*" '*] + ["/" '/] + [else (unexpected)])) + (unexpected)))) + (define make-src + (lambda (bfp efp) + (make-source-object *sfd* bfp efp))) + (include "ez-grammar.ss")) + + (define token + (case-lambda + [(type) + (is (token-value x) + (where + [x <- (sat (lambda (x) + (let ([ans (eq? (token-type x) type)]) + (when (grammar-trace) (printf " ~s is ~s? => ~s~%" x type ans)) + ans)))]))] + [(type val) + (is (token-value x) + (where + [x <- (sat (lambda (x) + (let ([ans (and + (eq? (token-type x) type) + (eqv? (token-value x) val))]) + (when (grammar-trace) (printf " ~s is [~s, ~s]? => ~s~%" x type val ans)) + ans)))]))])) + + (define identifier (token 'id)) + + (define integer (token 'integer)) + + (define-grammar expr (markdown-directory ".") + (TERMINALS + (identifier (x y) (DESCRIPTION ("An identifier is ..."))) + (integer (i) (DESCRIPTION ("An integer literal is ...")))) + (expr (e) + (BINOP src ((RIGHT "=") (LEFT "+" "-") (LEFT "*" "/")) t) => + (lambda (src op x y) + (make-annotation `(,op ,x ,y) src `(,op ,(annotation-stripped x) ,(annotation-stripped y))))) + (term (t) + [test-SEP+ :: src "sepplus" #\( (SEP+ e #\;) #\) => + (lambda (src e+) + (make-annotation `(SEP+ ,@e+) src `(SEP+ ,@(map annotation-stripped e+))))] + [test-SEP* :: src "sepstar" #\( (SEP* e #\,) #\) => + (lambda (src e*) + (make-annotation `(SEP* ,@e*) src `(SEP* ,@(map annotation-stripped e*))))] + [test-OPT :: src "opt" #\( (OPT e #f) #\) => + (lambda (src maybe-e) + (if maybe-e + (make-annotation `(OPT ,maybe-e) src `(OPT ,(annotation-stripped maybe-e))) + (make-annotation `(OPT) src `(OPT))))] + [test-K+ :: src "kplus" #\( (K+ e) #\) => + (lambda (src e+) + (make-annotation `(K+ ,@e+) src `(K+ ,@(map annotation-stripped e+))))] + [test-K* :: src "kstar" #\( (K* e) #\) => + (lambda (src e*) + (make-annotation `(K* ,@e*) src `(K* ,@(map annotation-stripped e*))))] + [varref :: src x => + (lambda (src id) + (make-annotation `(id ,id) src `(id ,id)))] + [intref :: src i => + (lambda (src n) + (make-annotation `(int ,n) src `(int ,n)))] + [group :: src #\( e #\) => + (lambda (src e) + `(group ,src ,e))])) + + (define parse + (lambda (fn ip) + (let ([token-stream (lexer fn ip)]) + (define (oops) + (let ([last-token (stream-last-forced token-stream)]) + (if last-token + (errorf 'parse "parse error at or before character ~s of ~a" (token-bfp last-token) fn) + (errorf 'parse "no expressions found in ~a" fn)))) + ;;; return the first result, if any, for which the input stream was entirely consumed. + (let loop ([res* (expr token-stream)]) + (if (null? res*) + (oops) + (let ([res (car res*)]) + (if (parse-consumed-all? res) + (parse-result-value res) + (loop (cdr res*)))))))))) + +(define run + (lambda (fn) + (import parser) + (let* ([ip (open-file-input-port fn)] + [sfd (make-source-file-descriptor fn ip #t)] + [ip (transcoded-port ip (native-transcoder))]) + (fluid-let ([*sfd* sfd]) + (eval + `(let () + (define-syntax define-ops + (lambda (x) + (syntax-case x () + [(_ op ...) + #`(begin + (define-syntax op + (lambda (x) + (let ([src (annotation-source (syntax->annotation x))]) + (with-syntax ([bfp (source-object-bfp src)] [efp (source-object-efp src)]) + (syntax-case x () + [(_ e (... ...)) #'`(op (bfp . efp) ,e (... ...))]))))) + ...)]))) + (define-ops SEP+ SEP* OPT K+ K* id int group) + (define-ops = + - * /) + (define x 'x) + (define y 'y) + (define z 'z) + ,(dynamic-wind + void + (lambda () (parse fn ip)) + (lambda () (close-input-port ip))))))))) + +(define (ez-grammar-test) + (define n 0) + (define test + (lambda (line* okay?) + (set! n (+ n 1)) + (let ([fn (format "testfile~s" n)]) + (with-output-to-file fn + (lambda () (for-each (lambda (line) (printf "~a\n" line)) line*)) + 'replace) + (let ([result (parameterize ([compile-profile #t] [compile-interpret-simple #f]) + (guard (c [else c]) (run fn)))]) + (guard (c [else #f]) (profile-dump-html)) + (delete-file fn) + (delete-file "profile.html") + (delete-file (format "~a.html" fn)) + (unless (okay? result) + (printf "test ~s failed\n" n) + (printf " test code:") + (for-each (lambda (line) (printf " ~a\n" line)) line*) + (printf " result:\n ") + (if (condition? result) + (begin (display-condition result) (newline)) + (parameterize ([pretty-initial-indent 4]) + (pretty-print result))) + (newline)))))) + + (define-syntax returns + (syntax-rules () + [(_ k) (lambda (x) (equal? x 'k))])) + + (define-syntax oops + (syntax-rules () + [(_ (c) e1 e2 ...) + (lambda (c) (and (condition? c) e1 e2 ...))])) + + (test + '( + "1347" + ) + (returns + (int (0 . 4) 1347))) + + (test + '( + "3 /*" + ) + (oops (c) + (equal? (condition-message c) "unexpected ~a at character ~s of ~a") + (equal? (condition-irritants c) '("eof" 6 "testfile2")))) + + (test + '( + "3 / 4 + 5 opt(6)" + ) + (oops (c) + (equal? (condition-message c) "parse error at or before character ~s of ~a") + (equal? (condition-irritants c) '(10 "testfile3")))) + + (test + '( + "x = y = 5" + ) + (returns + (= + (0 . 9) + (id (0 . 1) x) + (= (4 . 9) (id (4 . 5) y) (int (8 . 9) 5))))) + + (test + '( + "x = y = x + 5 - z * 7 + 8 / z" + ) + (returns + (= + (0 . 29) + (id (0 . 1) x) + (= + (4 . 29) + (id (4 . 5) y) + (+ + (8 . 29) + (- + (8 . 21) + (+ (8 . 13) (id (8 . 9) x) (int (12 . 13) 5)) + (* (16 . 21) (id (16 . 17) z) (int (20 . 21) 7))) + (/ (24 . 29) (int (24 . 25) 8) (id (28 . 29) z))))))) + + (test + '( + "opt(opt(opt()))" + ) + (returns + (OPT (0 . 15) (OPT (4 . 14) (OPT (8 . 13)))))) + + (test + '( + "kstar(3 4 kplus(1 2 3 kstar()))" + ) + (returns + (K* (0 . 31) + (int (6 . 7) 3) + (int (8 . 9) 4) + (K+ (10 . 30) + (int (16 . 17) 1) + (int (18 . 19) 2) + (int (20 . 21) 3) + (K* (22 . 29)))))) + + (test + '( + "sepplus( opt() ; opt(5) ; sepstar(17, 34) ; sepstar())" + ) + (returns + (SEP+ (0 . 54) + (OPT (9 . 14)) + (OPT (17 . 23) (int (21 . 22) 5)) + (SEP* (26 . 41) (int (34 . 36) 17) (int (38 . 40) 34)) + (SEP* (44 . 53))))) + + (delete-file "expr.md") + (printf "~s tests ran\n" n) + ) + +#!eof + +The following should print only " tests ran". + +echo '(ez-grammar-test)' | ../bin/scheme -q ez-grammar-test.ss diff --git a/examples/ez-grammar.ss b/examples/ez-grammar.ss new file mode 100644 index 0000000..1d95dd8 --- /dev/null +++ b/examples/ez-grammar.ss @@ -0,0 +1,759 @@ +;;; Copyright 2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; See http://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf for origins of +;;; some of the monadic combinators. + +;;; Authors: Jon Rossie, Kent Dybvig + +;;; The define-grammar form produces a parser: +;;; +;;; parser : token-stream -> ((Tree token-stream) ...) +;;; +;;; If the return value is the empty list, a parse error occurred. +;;; If the return value has multiple elements, the parse was ambiguous. +;;; The token-stream in each (Tree token-stream) is the tail of the +;;; input stream that begins with the last token consumed by the parse. +;;; This gives the consumer access to both the first and last token, +;;; allowing it to determine cheaply the extent of the parse, including +;;; source locations if source information is attached to the tokens. + +;;; Internally, backtracking occurs whenever a parser return value +;;; has multiple elements. + +;;; This code should be included into a lexical context that supplies: +;;; +;;; token-bfp : token -> token's beginning file position +;;; token-efp : token -> token's ending file position +;;; meta constant? : syntax-object -> boolean +;;; sep->parser : sep -> parser +;;; constant->parser : constant -> parser +;;; make-src : bfp x efp -> src. bfp > efp => no tokens consumed. +;;; +;;; See ez-grammar-test.ss for an example. + +(module (define-grammar + is sat item peek seq ++ +++ many many+ ? + parse-consumed-all? parse-result-value parse-result-unused + grammar-trace + ) + (import (streams)) + + (define grammar-trace (make-parameter #f)) + + (define-record-type parse-result + (nongenerative parse-result) + (sealed #t) + (fields value unused)) + + ;; to enable $trace-is to determine the ending file position (efp) of a parse + ;; form, the input stream actually points to the preceding token rather than + ;; to the current token. the next few routines establish, maintain, and deal + ;; with that invariant. + (define make-top-level-parser + (lambda (parser) + (lambda (inp) + (parser (stream-cons 'dummy-token inp))))) + + (define preceding-token + (lambda (inp) + (stream-car inp))) + + (define current-token + (lambda (inp) + (stream-car (stream-cdr inp)))) + + (define remaining-tokens + (lambda (inp) + (stream-cdr inp))) + + (define no-more-tokens? + (lambda (inp) + (stream-null? (stream-cdr inp)))) + + (define parse-consumed-all? + (lambda (res) + (no-more-tokens? (parse-result-unused res)))) + + ;; A parser generator + (define result + (lambda (v) + ;; this is a parser that ignores its input and produces v + (lambda (inp) + (stream (make-parse-result v inp))))) + + ;; A parse that always generates a parse error + (define zero + (lambda (inp) + stream-nil)) + + ;; For a non-empty stream, successfully consume the first element + (define item + (lambda (inp) + (cond + [(no-more-tokens? inp) '()] + [else + (stream (make-parse-result (current-token inp) (remaining-tokens inp)))]))) + + (define (peek p) + (lambda (inp) + (stream-map (lambda (pr) + (make-parse-result (parse-result-value pr) inp)) + (p inp)))) + + ;;------------------------------------------ + + (define bind + (lambda (parser receiver) + (lambda (inp) + (let ([res* (parser inp)]) + (stream-append-all + (stream-map (lambda (res) + ((receiver (parse-result-value res)) + (parse-result-unused res))) + res*)))))) + + ;; monad comprehensions + (define-syntax is-where ; used by is and trace-is + (lambda (x) + (syntax-case x (where <-) + [(_ expr (where)) #'expr] + [(_ expr (where [x <- p] clauses ...)) + #'(bind p (lambda (x) (is-where expr (where clauses ...))))] + [(_ expr (where pred clauses ...)) + #'(if pred (is-where expr (where clauses ...)) zero)] + [(_ expr where-clause) (syntax-error #'where-clause)]))) + (indirect-export is-where bind) + + (define-syntax is + (syntax-rules () + [(_ expr where-clause) (is-where (result expr) where-clause)])) + (indirect-export is is-where) + + (module (trace-is) + (define ($trace-is name proc head) + (lambda (unused) + (let ([res (proc (token-bfp (current-token head)) (token-efp (preceding-token unused)))]) + (when (and name (grammar-trace)) (printf "<<~s = ~s~%" name res)) + (stream (make-parse-result res unused))))) + + (define-syntax trace-is + (syntax-rules () + [(_ name proc-expr where-clause) + (lambda (inp) ((is-where ($trace-is 'name proc-expr inp) where-clause) inp))])) + (indirect-export trace-is $trace-is)) + + (define (seq2 p q) (is (cons x y) (where [x <- p] [y <- q]))) + + (define seq + (lambda p* + (let loop ([p* p*]) + (cond + [(null? p*) (result '())] + [else (seq2 (car p*) (loop (cdr p*)))])))) + + (define (sat pred) (is x (where [x <- item] (pred x)))) + + (define ++ ;; introduce ambiguity + (lambda (p q) + (lambda (inp) + (stream-append2 (p inp) + (lambda () + (q inp)))))) + + (define (many+ p) (is (cons x xs) (where [x <- p] [xs <- (many p)]))) + + (define (many p) (++ (many+ p) (result '()))) + + (define (? p) (++ (sat p) (result #f))) + + (define (sepby1 p sep) + (is (cons x xs) + (where + [x <- p] + [xs <- (many (is y (where [_ <- sep] [y <- p])))]))) + + (define (sepby p sep) (++ (sepby1 p sep) (result '()))) + + (define (bracket open p close) (is x (where [_ <- open] [x <- p] [_ <- close]))) + + (define (optional p default) + (lambda (inp) + (let ([res (p inp)]) + (if (stream-null? res) + (stream (make-parse-result default inp)) + res)))) + + (define (first p) + (lambda (inp) + (let ([res (p inp)]) + (if (stream-null? res) + res + (stream (stream-car res)))))) + + (define (+++ p q) (first (++ p q))) ;; choose first match, cut backtracking + + (define-syntax infix-expression-parser + (lambda (x) + (syntax-case x () + [(_ ((L/R ?op-parser) ...) ?term-parser ?receiver) + (with-syntax ([(op-parser ...) (generate-temporaries #'(?op-parser ...))]) + #`(let ([op-parser ?op-parser] ... [term-parser (lambda (inp) (?term-parser inp))] [receiver ?receiver]) + #,(let f ([ls #'((L/R op-parser) ...)]) + (if (null? ls) + #'term-parser + #`(let ([next #,(f (cdr ls))]) + #,(syntax-case (car ls) (LEFT RIGHT) + [(LEFT op-parser) + #'(let () + (define-record-type frob (nongenerative) (sealed #t) (fields op y efp)) + (trace-is binop-left (lambda (bfp ignore-this-efp) + (fold-left + (lambda (x f) (receiver bfp (frob-efp f) (frob-op f) x (frob-y f))) + x f*)) + (where + [x <- next] + [f* <- (rec this + (optional + (is (cons f f*) + (where + [f <- (trace-is binop-left-tail (lambda (bfp efp) (make-frob op y efp)) + (where + [op <- op-parser] + [y <- next]))] + [f* <- this])) + '()))])))] + [(RIGHT op-parser) + #'(rec this + (+++ + (trace-is binop-right (lambda (bfp efp) (receiver bfp efp op x y)) + (where + [x <- next] + [op <- op-parser] + [y <- this])) + next))]))))))]))) + + (define (format-inp inp) + (if (no-more-tokens? inp) + "#" + (format "(~s ...)" (current-token inp)))) + + (define-syntax define-grammar + (lambda (x) + (define-record-type grammar + (nongenerative) + (sealed #t) + (fields title paragraph* section*)) + (define-record-type section + (nongenerative) + (sealed #t) + (fields title paragraph* suppressed? clause*)) + (define-record-type clause + (nongenerative) + (fields id alias* before-paragraph* after-paragraph*)) + (define-record-type regular-clause + (nongenerative) + (sealed #t) + (parent clause) + (fields prod*)) + (define-record-type binop-clause + (nongenerative) + (sealed #t) + (parent clause) + (fields level* term receiver) + (protocol + (lambda (pargs->new) + (lambda (nt alias* before-paragraph* after-paragraph* level* term src? receiver) + ((pargs->new nt alias* before-paragraph* after-paragraph*) level* term + #`(lambda (bfp efp op x y) + #,(if src? + #`(#,receiver (make-src bfp efp) op x y) + #`(#,receiver op x y)))))))) + (define-record-type terminal-clause + (nongenerative) + (sealed #t) + (fields term*)) + (define-record-type terminal + (nongenerative) + (sealed #t) + (fields parser alias* paragraph*)) + (define-record-type production + (nongenerative) + (sealed #t) + (fields name paragraph* elt* receiver) + (protocol + (let () + (define (check-elts elt*) + (for-each (lambda (elt) (unless (elt? elt) (errorf 'make-production "~s is not an elt" elt))) elt*)) + (lambda (new) + (case-lambda + [(name elt* receiver) + (check-elts elt*) + (new name #f elt* receiver)] + [(name paragraph* elt* receiver) + (check-elts elt*) + (new name paragraph* elt* receiver)]))))) + (define-record-type elt + (nongenerative)) + (define-record-type sep-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields +? elt sep)) + (define-record-type opt-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields elt default)) + (define-record-type kleene-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields +? elt)) + (define-record-type constant-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields k)) + (define-record-type id-elt + (nongenerative) + (sealed #t) + (parent elt) + (fields id)) + (define paragraph? + (lambda (x) + (syntax-case x (include) + [(include filename) (string? (datum filename))] + [(str ...) (andmap string? (datum (str ...)))]))) + (define (gentemp) (datum->syntax #'* (gensym))) + (define (elt-temps elt*) + (for-each (lambda (elt) (unless (elt? elt) (errorf 'elt-temps "~s is not an elt" elt))) elt*) + (fold-left + (lambda (t* elt) + (if (constant-elt? elt) t* (cons (gentemp) t*))) + '() + elt*)) + (define (left-factor clause*) + (define syntax-equal? + (lambda (x y) + (equal? (syntax->datum x) (syntax->datum y)))) + (define (elt-equal? x y) + (cond + [(sep-elt? x) + (and (sep-elt? y) + (eq? (sep-elt-+? x) (sep-elt-+? y)) + (elt-equal? (sep-elt-elt x) (sep-elt-elt y)) + (syntax-equal? (sep-elt-sep x) (sep-elt-sep y)))] + [(opt-elt? x) + (and (opt-elt? y) + (elt-equal? (opt-elt-elt x) (opt-elt-elt y)) + (syntax-equal? (opt-elt-default x) (opt-elt-default y)))] + [(kleene-elt? x) + (and (kleene-elt? y) + (eq? (kleene-elt-+? x) (kleene-elt-+? y)) + (elt-equal? (kleene-elt-elt x) (kleene-elt-elt y)))] + [(constant-elt? x) + (and (constant-elt? y) + (syntax-equal? (constant-elt-k x) (constant-elt-k y)))] + [(id-elt? x) + (and (id-elt? y) + (syntax-equal? (id-elt-id x) (id-elt-id y)))] + [else #f])) + (let lp1 ([clause* clause*] [new-clause* '()]) + (if (null? clause*) + (reverse new-clause*) + (let ([clause (car clause*)]) + (let lp2 ([prod* (regular-clause-prod* clause)] [new-prod* '()] [clause* (cdr clause*)]) + (if (null? prod*) + (lp1 clause* (cons (make-regular-clause (clause-id clause) (clause-alias* clause) '() '() (reverse new-prod*)) new-clause*)) + (let ([prod (car prod*)] [prod* (cdr prod*)]) + (let ([elt* (production-elt* prod)]) + (if (null? elt*) + (lp2 prod* (cons prod new-prod*) clause*) + (let ([elt (car elt*)]) + (let-values ([(haves have-nots) (partition + (lambda (prod) + (let ([elt* (production-elt* prod)]) + (and (not (null? elt*)) + (elt-equal? (car elt*) elt)))) + prod*)]) + (if (null? haves) + (lp2 prod* (cons prod new-prod*) clause*) + (let ([haves (cons prod haves)]) + ; "haves" start with the same elt. to cut down on the number of new + ; nonterminals and receiver overhead, find the largest common prefix + (let ([prefix (cons elt + (let f ([elt** (map production-elt* haves)]) + (let ([elt** (map cdr elt**)]) + (if (ormap null? elt**) + '() + (let ([elt (caar elt**)]) + (if (andmap (lambda (elt*) (elt-equal? (car elt*) elt)) (cdr elt**)) + (cons elt (f elt**)) + '()))))))]) + (let ([t (gentemp)] [n (length prefix)] [t* (elt-temps prefix)]) + (lp2 have-nots + (cons (make-production #f (append prefix (list (make-id-elt t))) + #`(lambda (bfp efp #,@t* p) (p bfp #,@t*))) + new-prod*) + (cons (make-regular-clause t '() '() '() + (map (lambda (prod) + (let ([elt* (list-tail (production-elt* prod) n)]) + (make-production (production-name prod) elt* + (let ([u* (elt-temps elt*)]) + #`(lambda (bfp efp #,@u*) + (lambda (bfp #,@t*) + (#,(production-receiver prod) bfp efp #,@t* #,@u*))))))) + haves)) + clause*))))))))))))))))) + (define (make-env tclause* clause*) + (let ([env (make-hashtable (lambda (x) (symbol-hash (syntax->datum x))) free-identifier=?)]) + (define (insert parser) + (lambda (name) + (let ([a (hashtable-cell env name #f)]) + (when (cdr a) (syntax-error name "duplicate terminal/non-terminal name")) + (set-cdr! a parser)))) + (for-each + (lambda (tclause) + (for-each + (lambda (term) + (let ([parser (terminal-parser term)]) + (for-each (insert parser) (cons parser (terminal-alias* term))))) + (terminal-clause-term* tclause))) + tclause*) + (for-each + (lambda (clause) + (let ([id (clause-id clause)]) + (for-each (insert id) (cons id (clause-alias* clause))))) + clause*) + env)) + (define (lookup id env) + (or (hashtable-ref env id #f) + (syntax-error id "unrecognized terminal or nonterminal"))) + (define (render-markdown name grammar mdfn env) + (define (separators sep ls) + (if (null? ls) + "" + (apply string-append + (cons (car ls) + (map (lambda (s) (format "~a~a" sep s)) (cdr ls)))))) + (define (render-paragraph hard-leading-newline?) + (lambda (paragraph) + (define (md-text s) + (list->string + (fold-right + (lambda (c ls) + (case c + [(#\\) (cons* c c ls)] + [else (cons c ls)])) + '() + (string->list s)))) + (syntax-case paragraph (include) + [(include filename) + (string? (datum filename)) + (let ([text (call-with-port (open-input-file (datum filename)) get-string-all)]) + (unless (equal? text "") + (if hard-leading-newline? (printf "\\\n") (newline)) + (display-string text)))] + [(sentence ...) + (andmap string? (datum (sentence ...))) + (let ([sentence* (datum (sentence ...))]) + (unless (null? sentence*) + (if hard-leading-newline? (printf "\\\n") (newline)) + (printf "~a\n" (separators " " (map md-text sentence*)))))]))) + (define (format-elt x) + (cond + [(sep-elt? x) + (let* ([one (format-elt (sep-elt-elt x))] + [sep (constant->markdown (syntax->datum (sep-elt-sep x)))] + [seq (format "~a  ~a  `...`" one sep)]) + (if (sep-elt-+? x) + seq + (format "OPT(~a)" seq)))] + [(opt-elt? x) + (format "~a~~opt~~" (format-elt (opt-elt-elt x)))] + [(kleene-elt? x) + (let ([one (format-elt (kleene-elt-elt x))]) + (if (kleene-elt-+? x) + (format "~a  `...`" one) + (format "OPT(~a)" one)))] + [(constant-elt? x) (constant->markdown (syntax->datum (constant-elt-k x)))] + [(id-elt? x) (format "[*~s*](#~s)" + (syntax->datum (id-elt-id x)) + (syntax->datum (lookup (id-elt-id x) env)))] + [else (errorf 'format-elt "unexpected elt ~s" x)])) + (define (render-elt x) + (printf "  ~a" (format-elt x))) + (define (render-production prod) + (unless (null? (production-elt* prod)) + (printf " : ") + (for-each render-elt (production-elt* prod)) + (printf "\n")) + (when (and (null? (production-elt* prod)) + (not (null? (production-paragraph* prod)))) + (errorf 'render-production "empty production must not have description: ~a" (production-paragraph* prod))) + (for-each (render-paragraph #t) (production-paragraph* prod))) + (define (render-clause clause) + (define (render-aliases alias*) + (unless (null? alias*) + (printf " \naliases: ~{*~a*~^, ~}\n" (map syntax->datum alias*)))) + (if (terminal-clause? clause) + (for-each + (lambda (term) + (printf "\n#### *~a* {#~:*~a}\n" (syntax->datum (terminal-parser term))) + (render-aliases (terminal-alias* term)) + (for-each (render-paragraph #f) (terminal-paragraph* term))) + (terminal-clause-term* clause)) + (let ([id (syntax->datum (clause-id clause))]) + (printf "\n#### *~a* {#~:*~a}\n" id) + (render-aliases (clause-alias* clause)) + (for-each (render-paragraph #f) (clause-before-paragraph* clause)) + (printf "\nsyntax:\n") + (if (binop-clause? clause) + (let ([level* (binop-clause-level* clause)]) + (let loop ([level* level*] [first? #t]) + (unless (null? level*) + (let ([level (syntax->datum (car level*))] [level* (cdr level*)]) + (let ([L/R (car level)] [op* (cdr level)]) + (printf " : _~(~a~)-associative" L/R) + (if first? + (if (null? level*) + (printf ":_\n") + (printf ", highest precedence:_\n")) + (if (null? level*) + (printf ", lowest precedence:_\n") + (printf ":_\n"))) + (for-each + (lambda (op) (printf " : ~s ~a ~s\n" id (constant->markdown op) id)) + op*)) + (loop level* #f)))) + (printf " : _leaves:_\n") + (printf " : ") + (render-elt (binop-clause-term clause)) + (printf "\n")) + (for-each render-production (or (regular-clause-prod* clause) '()))) + (for-each (render-paragraph #f) (clause-after-paragraph* clause))))) + (define (render-section section) + (unless (section-suppressed? section) + (printf "\n## ~a\n" (or (section-title section) "The section")) + (for-each (render-paragraph #f) (section-paragraph* section)) + (for-each render-clause (section-clause* section)))) + (with-output-to-file mdfn + (lambda () + (printf "# ~a\n" (or (grammar-title grammar) "The grammar")) + (for-each (render-paragraph #f) (grammar-paragraph* grammar)) + (for-each render-section (grammar-section* grammar))) + 'replace)) + (module (parse-grammar) + (define parse-elt + (lambda (elt) + (syntax-case elt (SEP+ SEP* OPT K* K+) + [(SEP+ p sep) (make-sep-elt #t (parse-elt #'p) #'sep)] + [(SEP* p sep) (make-sep-elt #f (parse-elt #'p) #'sep)] + [(OPT p default) (make-opt-elt (parse-elt #'p) #'default)] + [(K+ p) (make-kleene-elt #t (parse-elt #'p))] + [(K* p) (make-kleene-elt #f (parse-elt #'p))] + [k (constant? #'k) (make-constant-elt #'k)] + [id (identifier? #'id) (make-id-elt #'id)] + [_ (syntax-error elt "invalid production element")]))) + (define parse-production + (lambda (prod) + (define (finish name src? paragraph* elt* receiver) + (let ([elt* (map parse-elt elt*)]) + (make-production name paragraph* elt* + (with-syntax ([(t ...) (elt-temps elt*)]) + #`(lambda (bfp efp t ...) + #,(if src? + #`(#,receiver (make-src bfp efp) t ...) + #`(#,receiver t ...))))))) + (syntax-case prod (:: src =>) + [[name :: src elt ... => receiver] + (finish #'name #t '() #'(elt ...) #'receiver)] + [[name :: elt ... => receiver] + (finish #'name #f '() #'(elt ...) #'receiver)]))) + (define (parse-terminal term) + (syntax-case term (DESCRIPTION) + [(parser (alias ...) (DESCRIPTION paragraph ...)) + (and (identifier? #'parser) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...))) + (make-terminal #'parser #'(alias ...) #'(paragraph ...))] + [(parser (alias ...)) + (and (identifier? #'parser) (andmap identifier? #'(alias ...))) + (make-terminal #'parser #'(alias ...) '())])) + (define (parse-clause clause nt alias* before-paragraph* after-paragraph* stuff*) + (syntax-case stuff* (BINOP :: src =>) + [((BINOP src (level ...) term) => receiver) + (make-binop-clause nt alias* before-paragraph* after-paragraph* #'(level ...) (parse-elt #'term) #t #'receiver)] + [((BINOP (level ...) term) => receiver) + (make-binop-clause nt alias* before-paragraph* after-paragraph* #'(level ...) (parse-elt #'term) #f #'receiver)] + [(prod prods ...) + (make-regular-clause nt alias* before-paragraph* after-paragraph* (map parse-production #'(prod prods ...)))] + [else (syntax-error clause)])) + (define (parse-top top* knull kgrammar ksection kclause) + (if (null? top*) + (knull) + (let ([top (car top*)] [top* (cdr top*)]) + (syntax-case top (GRAMMAR SECTION SUPPRESSED DESCRIPTION BINOP TERMINALS src =>) + [(GRAMMAR title paragraph ...) + (andmap paragraph? #'(paragraph ...)) + (kgrammar top* (datum title) #'(paragraph ...))] + [(SECTION SUPPRESSED title paragraph ...) + (andmap paragraph? #'(paragraph ...)) + (ksection top* (datum title) #'(paragraph ...) #t)] + [(SECTION title paragraph ...) + (andmap paragraph? #'(paragraph ...)) + (ksection top* (datum title) #'(paragraph ...) #f)] + [(TERMINALS term ...) + (kclause top* (make-terminal-clause (map parse-terminal #'(term ...))))] + [(TERMINALS term ...) + (kclause top* (make-terminal-clause (map parse-terminal #'(term ...))))] + [(nt (alias ...) (DESCRIPTION paragraph1 ...) stuff ... (DESCRIPTION paragraph2 ...)) + (and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph1 ...)) (andmap paragraph? #'(paragraph2 ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) #'(paragraph1 ...) #'(paragraph2 ...) #'(stuff ...)))] + [(nt (alias ...) (DESCRIPTION paragraph ...) stuff ...) + (and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) #'(paragraph ...) '() #'(stuff ...)))] + [(nt (alias ...) stuff ... (DESCRIPTION paragraph ...)) + (and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) '() #'(paragraph ...) #'(stuff ...)))] + [(nt (alias ...) stuff ...) + (and (identifier? #'nt) (andmap identifier? #'(alias ...))) + (kclause top* (parse-clause top #'nt #'(alias ...) '() '() #'(stuff ...)))])))) + (define (parse-grammar top*) + (define (misplaced-grammar-error top) + (syntax-error top "unexpected GRAMMAR element after other elements")) + (define (s1 top*) ; looking for GRAMMAR form, first SECTION form, or clause + (parse-top top* + (lambda () (make-grammar #f '() '())) + (lambda (top* title paragraph*) + (make-grammar title paragraph* (s2 top*))) + (lambda (top* title paragraph* suppressed?) + (make-grammar #f '() + (s3 top* title paragraph* suppressed? '() '()))) + (lambda (top* clause) + (make-grammar #f '() + (s3 top* #f '() #f (list clause) '()))))) + (define (s2 top*) ; looking for first SECTION form or clause + (parse-top top* + (lambda () '()) + (lambda (title paragraph*) (misplaced-grammar-error (car top*))) + (lambda (top* title paragraph* suppressed?) + (s3 top* title paragraph* suppressed? '() '())) + (lambda (top* clause) + (s3 top* #f '() #f (list clause) '())))) + (define (s3 top* title paragraph* suppressed? rclause* rsection*) ; steady state: looking for remaining SECTION forms and clauses + (define (finish-section) + (cons (make-section title paragraph* suppressed? (reverse rclause*)) rsection*)) + (parse-top top* + (lambda () (reverse (finish-section))) + (lambda (title paragraph*) (misplaced-grammar-error (car top*))) + (lambda (top* title paragraph* suppressed?) + (s3 top* title paragraph* suppressed? '() (finish-section))) + (lambda (top* clause) + (s3 top* title paragraph* suppressed? (cons clause rclause*) rsection*)))) + (s1 top*))) + (define (go init-nts top* mddir) + (let ([grammar (parse-grammar top*)]) + (let* ([clause* (apply append (map section-clause* (grammar-section* grammar)))] + [terminal-clause* (filter terminal-clause? clause*)] + [binop-clause* (filter binop-clause? clause*)] + [regular-clause* (left-factor (filter regular-clause? clause*))] + [env (make-env terminal-clause* (append binop-clause* regular-clause*))]) + (define (elt-helper x) + (cond + [(sep-elt? x) #`(#,(if (sep-elt-+? x) #'sepby1 #'sepby) #,(elt-helper (sep-elt-elt x)) (sep->parser #,(sep-elt-sep x)))] + [(opt-elt? x) #`(optional #,(elt-helper (opt-elt-elt x)) #,(opt-elt-default x))] + [(kleene-elt? x) #`(#,(if (kleene-elt-+? x) #'many+ #'many) #,(elt-helper (kleene-elt-elt x)))] + [(constant-elt? x) #`(constant->parser '#,(constant-elt-k x))] + [(id-elt? x) (lookup (id-elt-id x) env)] + [else (errorf 'elt-helper "unhandled elt ~s\n" x)])) + (define (binop-helper clause) + #`[#,(clause-id clause) + (infix-expression-parser + #,(map (lambda (level) + (syntax-case level () + [(L/R op1 ... op2) + (or (free-identifier=? #'L/R #'LEFT) (free-identifier=? #'L/R #'RIGHT)) + #`(L/R #,(fold-right (lambda (op next) #`(++ (binop->parser '#,op) #,next)) #'(binop->parser 'op2) #'(op1 ...)))])) + (binop-clause-level* clause)) + #,(elt-helper (binop-clause-term clause)) + #,(binop-clause-receiver clause))]) + (define (nt-helper clause) + #`[#,(clause-id clause) + #,(let f ([prod* (regular-clause-prod* clause)]) + (if (null? prod*) + #'zero + (let ([elt* (production-elt* (car prod*))]) + (with-syntax ([name (production-name (car prod*))] + [(elt ...) elt*] + [receiver (production-receiver (car prod*))]) + (with-syntax ([(x ...) (generate-temporaries elt*)]) + (with-syntax ([([y _] ...) (filter (lambda (pr) (not (constant-elt? (cadr pr)))) #'([x elt] ...))]) + (with-syntax ([(where-nt ...) (map elt-helper elt*)]) + #`(+++ ;; use +++ if you don't ever need to backtrack to a previous production for the same non-terminal + (lambda (inp) + (when (and 'name (grammar-trace)) (printf ">>~s(~a)~%" 'name (format-inp inp))) + (let ([res ((trace-is name (lambda (bfp efp) (receiver bfp efp y ...)) (where [x <- where-nt] ...)) inp)]) + (when (and 'name (grammar-trace)) + (if (stream-null? res) + (printf "<<~s(~a) failed~%" 'name (format-inp inp)) + (printf "<<~s(~a) succeeded~%" 'name (format-inp inp)))) + res)) + #,(f (cdr prod*))))))))))]) + (with-syntax ([(init-nt ...) + (syntax-case init-nts () + [(id1 id2 ...) (andmap identifier? #'(id1 id2 ...)) #'(id1 id2 ...)] + [id (identifier? #'id) (list #'id)])]) + (when mddir + (for-each + (lambda (init-nt) + (let ([mdfn (format "~a/~a.md" mddir (syntax->datum init-nt))]) + (render-markdown init-nt grammar mdfn env))) + #'(init-nt ...))) + (with-syntax ([((lhs rhs) ...) + (append + (map binop-helper binop-clause*) + (map nt-helper regular-clause*))]) + #'(module (init-nt ...) + (module M (init-nt ...) (define lhs rhs) ...) + (define init-nt + (let () + (import M) + (make-top-level-parser init-nt))) + ...)))))) + (syntax-case x (markdown-directory) + [(_ init-nts (markdown-directory mddir) top ...) + (string? (datum mddir)) + (go #'init-nts #'(top ...) (datum mddir))] + [(_ init-nts top ...) (go #'init-nts #'(top ...) #f)]))) + + (indirect-export define-grammar + result + zero + is + trace-is + sepby1 + sepby + optional + many + many+ + +++ + infix-expression-parser + + grammar-trace + format-inp + trace-is + + make-top-level-parser + ) +) diff --git a/examples/fact.ss b/examples/fact.ss new file mode 100644 index 0000000..037cd2c --- /dev/null +++ b/examples/fact.ss @@ -0,0 +1,11 @@ +;;; simple factorial function + +;;; it is interesting to change the 'lambda' into 'trace-lambda' +;;; or simply type (trace fact) before running fact to observe +;;; the nesting of recursive calls. + +(define fact + (lambda (x) + (if (zero? x) + 1 + (* x (fact (1- x)))))) diff --git a/examples/fatfib.ss b/examples/fatfib.ss new file mode 100644 index 0000000..6f150e2 --- /dev/null +++ b/examples/fatfib.ss @@ -0,0 +1,19 @@ +;;; fat fibonacci function + +;;; this is "fat" because it uses only increments and decrements +;;; for addition and subtraction (i.e., peano arithmetic). + +;;; note that fat+ is tail-recursive; this is how all looping is +;;; performed in Scheme. + +(define fat+ + (lambda (x y) + (if (zero? y) + x + (fat+ (1+ x) (1- y))))) + +(define fatfib + (lambda (x) + (if (< x 2) + 1 + (fat+ (fatfib (1- x)) (fatfib (1- (1- x))))))) diff --git a/examples/fft.ss b/examples/fft.ss new file mode 100644 index 0000000..edcb407 --- /dev/null +++ b/examples/fft.ss @@ -0,0 +1,63 @@ +;;; fft.ss +;;; Copyright (C) 1996 R. Kent Dybvig +;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(define (dft x) + (define (w-powers n) + (let ((pi (* (acos 0.0) 2))) + (let ((delta (/ (* -2.0i pi) n))) + (let f ((n n) (x 0.0)) + (if (= n 0) + '() + (cons (exp x) (f (- n 2) (+ x delta)))))))) + (define (evens w) + (if (null? w) + '() + (cons (car w) (evens (cddr w))))) + (define (interlace x y) + (if (null? x) + '() + (cons (car x) (cons (car y) (interlace (cdr x) (cdr y)))))) + (define (split ls) + (let split ((fast ls) (slow ls)) + (if (null? fast) + (values '() slow) + (call-with-values + (lambda () (split (cddr fast) (cdr slow))) + (lambda (front back) + (values (cons (car slow) front) back)))))) + (define (butterfly x w) + (call-with-values + (lambda () (split x)) + (lambda (front back) + (values + (map + front back) + (map * (map - front back) w))))) + (define (rfft x w) + (if (null? (cddr x)) + (let ((x0 (car x)) (x1 (cadr x))) + (list (+ x0 x1) (- x0 x1))) + (call-with-values + (lambda () (butterfly x w)) + (lambda (front back) + (let ((w (evens w))) + (interlace (rfft front w) (rfft back w))))))) + (rfft x (w-powers (length x)))) diff --git a/examples/fib.ss b/examples/fib.ss new file mode 100644 index 0000000..12e3155 --- /dev/null +++ b/examples/fib.ss @@ -0,0 +1,9 @@ +;;; simple fibonacci function + +;;; uses trace-lambda to show the nesting + +(define fib + (trace-lambda fib (x) + (if (<= x 1) + 1 + (+ (fib (- x 1)) (fib (- x 2)))))) diff --git a/examples/foreign.ss b/examples/foreign.ss new file mode 100644 index 0000000..dd68f56 --- /dev/null +++ b/examples/foreign.ss @@ -0,0 +1,179 @@ +;;; foreign.ss +;;; Copyright (c) 1997 R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; Prototype code for converting ``foreign-callable'' declarations into +;;; C interface routines to support C calls to Scheme procedures with +;;; automatic datatype conversion analogous to that provided for Scheme +;;; calls to C procedures via foreign-procedure. + +;;; Todo +;;; - support for foreign-pointer and foreign-object +;;; - similar support for foreign-procedure declarations + +(define spec->decl + (lambda (spec) + (case spec + [(integer-32 boolean) "int"] + [(unsigned-32) "unsigned int"] + [(char) "char"] + [(string) "char *"] + [(fixnum) "int"] + [(double-float) "double"] + [(single-float) "float"] + [(void) "void"] + [(scheme-object) "ptr"] + [else + (record-case spec + [(foreign-pointer foreign-object) () + (error 'spec->decl "unsupported specifier ~s" spec)] + [else (error 'spec->decl "unexpected specifier ~s" spec)])]))) + +(define C->Scheme + (lambda (spec id) + (case spec + [(boolean) (format "Sboolean(~a)" id)] + [(char) (format "Schar(~a)" id)] + [(fixnum) (format "Sfixnum(~a)" id)] + [(integer-32) (format "Sinteger(~a)" id)] + [(unsigned-32) (format "Sunsigned(~a)" id)] + [(single-float) (format "Sflonum((double)~a)" id)] + [(double-float) (format "Sflonum(~a)" id)] + [(scheme-object) id] + [(string) (format "Sstring(~a)" id)] + [else + (record-case spec + [(foreign-pointer foreign-object) () + (error 'C->Scheme "unsupported specifier ~s" spec)] + [else (error 'C->Scheme "unexpected specifier ~s" spec)])]))) + +(define Scheme->C + (lambda (op spec src) + (case spec + [(boolean) (fprintf op "Sboolean_value(~a)" src)] + [(char) (fprintf op "Schar_value(~a)" src)] + [(fixnum) (fprintf op "Sfixnum_value(~a)" src)] + [(integer-32) (fprintf op "Sinteger_value(~a)" src)] + [(unsigned-32) (fprintf op "Sunsigned_value(~a)" src)] + [(single-float) (fprintf op "(float)Sflonum_value(~a)" src)] + [(double-float) (fprintf op "Sflonum_value(~a)" src)] + [(scheme-object) (display src op)] + [(string) (fprintf op "Sstring_value(~a)" src)] + [else + (record-case spec + [(foreign-pointer foreign-object) () + (error 'Scheme->C "unsupported specifier ~s" spec)] + [else (error 'Scheme->C "unexpected specifier ~s" spec)])]))) + +(define gen-fcallable + (case-lambda + [(cname arg-specs res-spec) + (gen-fcallable (current-output-port) cname arg-specs res-spec)] + [(op cname arg-specs res-spec) + (let ((names (let loop ((ls arg-specs) (i 1)) + (if (null? ls) + '() + (cons (format "x~d" i) (loop (cdr ls) (+ i 1)))))) + (count (length arg-specs))) + (newline op) + (fprintf op "~a ~a(ptr proc" (spec->decl res-spec) cname) ;) + (let loop ((arg-specs arg-specs) (names names)) + (unless (null? arg-specs) + (fprintf op ", ~a ~a" (spec->decl (car arg-specs)) (car names)) + (loop (cdr arg-specs) (cdr names)))) ;( + (fprintf op ") {~%") + (if (<= 0 count 3) + (begin + (display " return " op) + (Scheme->C op res-spec + (let ((op (open-output-string))) + (fprintf op "Scall~d(proc" count) ;) + (let loop ((arg-specs arg-specs) (names names)) + (unless (null? arg-specs) + (display ", " op) + (display (C->Scheme (car arg-specs) (car names)) op) + (loop (cdr arg-specs) (cdr names)))) ;( + (fprintf op ")") + (get-output-string op)))) + (begin + (fprintf op " Sinitframe(~d);~%" count) + (let loop ([arg-specs arg-specs] [names names] [num 1]) + (unless (null? arg-specs) + (fprintf op " Sput_arg(~d, ~a);~%" + num (C->Scheme (car arg-specs) (car names))) + (loop (cdr arg-specs) (cdr names) (+ num 1)))) + (fprintf op " return ") + (Scheme->C op res-spec + (format "Scall(proc, ~d)" count)))) + (fprintf op ";~%}~%"))])) + +(define-syntax foreign-callable + (syntax-rules () + ((_ n args res) + (gen-fcallable n 'args 'res)))) + +(define gen-file + (lambda (fnroot) + (let ((ifn (format "~a.ss" fnroot)) + (ofn (format "~a.xx" fnroot))) + (with-output-to-file ofn + (lambda () (load ifn)) + 'replace)))) + +#!eof ; cut off the input here so we can give examples w/o comment chars + +Example input file: + +------------------------------------------------------------------------ +(foreign-callable "foo" + (boolean single-float double-float) + scheme-object) + +(foreign-callable "bar" + (boolean char integer-32 unsigned-32 single-float + double-float scheme-object) + string) + +(foreign-callable "baz" () fixnum) +------------------------------------------------------------------------ + +Generated output file: + +------------------------------------------------------------------------ +ptr foo(ptr proc, int x1, float x2, double x3) { + return Scall3(proc, Sboolean(x1), Sflonum((double)x2), Sflonum(x3)); +} + +char * bar(ptr proc, int x1, char x2, int x3, unsigned int x4, float x5, double x6, ptr x7) { + Sinitframe(7); + Sput_arg(1, Sboolean(x1)); + Sput_arg(2, Schar(x2)); + Sput_arg(3, Sinteger(x3)); + Sput_arg(4, Sunsigned(x4)); + Sput_arg(5, Sflonum((double)x5)); + Sput_arg(6, Sflonum(x6)); + Sput_arg(7, x7); + return Sstring_value(Scall(proc, 7)); +} + +int baz(ptr proc) { + return Sfixnum_value(Scall0(proc)); +} +------------------------------------------------------------------------ diff --git a/examples/freq.ss b/examples/freq.ss new file mode 100644 index 0000000..a036676 --- /dev/null +++ b/examples/freq.ss @@ -0,0 +1,123 @@ +;;; freq.ss +;;; Copyright (C) 1996 R. Kent Dybvig +;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; If the next character on p is a letter, get-word reads a word +;;; from p and returns it in a string. If the character is not a +;;; letter, get-word returns the character (on eof, the eof-object). +(define get-word + (lambda (p) + (let ((c (read-char p))) + (if (eq? (char-type c) 'letter) + (list->string + (let loop ((c c)) + (cons c + (if (memq (char-type (peek-char p)) '(letter digit)) + (loop (read-char p)) + '())))) + c)))) + +;;; char-type tests for the eof-object first, since the eof-object +;;; may not be a valid argument to char-alphabetic? or char-numeric? +;;; It returns the eof-object, the symbol letter, the symbol digit, +;;; or the argument itself if it is not a letter or digit. +(define char-type + (lambda (c) + (cond + ((eof-object? c) c) + ((char-alphabetic? c) 'letter) + ((char-numeric? c) 'digit) + (else c)))) + +;;; Trees are represented as vectors with four fields: word, left, +;;; right, and count. Only one field, word, is initialized by an +;;; argument to the constructor procedure make-tree. The remaining +;;; fields are explicitly initialized and changed by subsequent +;;; operations. Most Scheme systems provide structure definition +;;; facilities that automate creation of structure manipulation +;;; procedures, but we simply define the procedures by hand here. +(define make-tree + (lambda (word) + (vector word '() '() 1))) + +(define tree-word (lambda (tree) (vector-ref tree 0))) + +(define tree-left (lambda (tree) (vector-ref tree 1))) +(define set-tree-left! + (lambda (tree new-left) + (vector-set! tree 1 new-left))) + +(define tree-right (lambda (tree) (vector-ref tree 2))) +(define set-tree-right! + (lambda (tree new-right) + (vector-set! tree 2 new-right))) + +(define tree-count (lambda (tree) (vector-ref tree 3))) +(define set-tree-count! + (lambda (tree new-count) + (vector-set! tree 3 new-count))) + +;;; If the word already exists in the tree, tree increments its +;;; count. Otherwise, a new tree node is created and put into the +;;; tree. In any case, the new or modified tree is returned. +(define tree + (lambda (node word) + (cond + ((null? node) (make-tree word)) + ((string=? word (tree-word node)) + (set-tree-count! node (+ (tree-count node) 1)) + node) + ((stringlist s) (ibuf-pb ib))))) + +(define int->str + (lambda (num) + (format "~s" num))) + +(define char->digit + (let ([zero (char->integer #\0)]) + (lambda (c) + (- (char->integer c) zero)))) + +(define str->int + (let ([ustr->int + (lambda (s i n) + (let f ([a 0] [i i]) + (if (= i n) + a + (f (+ (* a 10) (char->digit (string-ref s i))) + (+ i 1)))))]) + (lambda (s) + (let ([n (string-length s)]) + (if (= n 0) + 0 + (if (char=? (string-ref s 0) #\-) + (- (ustr->int s 1 n)) + (ustr->int s 0 n))))))) + +(define eval-string + (let ([str #f] [port #f] [token #f] [value #f]) + (define eval-error + (lambda () + (error 'm4 "invalid arithmetic expression ~s" str))) + (define next-token! + (lambda () + (let ([c (read-char port)]) + (cond + [(eof-object? c) (set! token 'eof)] + [(char-whitespace? c) (next-token!)] + [(char-numeric? c) + (let loop ([a (char->digit c)]) + (let ([c (read-char port)]) + (cond + [(eof-object? c) + (set! token 'integer) + (set! value a)] + [(char-numeric? c) + (loop (+ (* a 10) (char->digit c)))] + [else + (unread-char c port) + (set! token 'integer) + (set! value a)])))] + [(char=? c oparen) (set! token 'oparen)] + [(char=? c cparen) (set! token 'cparen)] + [(char=? c #\-) (set! token '-)] + [(char=? c #\*) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (set! token '*)] + [(char=? c #\*) (set! token '**)] + [else (unread-char c port) (set! token '*)]))] + [(char=? c #\+) (set! token '+)] + [(char=? c #\-) (set! token '+)] + [(char=? c #\/) (set! token '/)] + [(char=? c #\%) (set! token '%)] + [(char=? c #\!) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (set! token '!)] + [(char=? c #\=) (set! token '!=)] + [else (unread-char c port) (set! token '!)]))] + [(char=? c #\|) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (eval-error)] + [(char=? c #\|) (set! token 'or)] + [else (unread-char c port) (eval-error)]))] + [(char=? c #\&) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (eval-error)] + [(char=? c #\&) (set! token 'and)] + [else (unread-char c port) (eval-error)]))] + [(char=? c #\=) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (eval-error)] + [(char=? c #\=) (set! token '==)] + [else (unread-char c port) (eval-error)]))] + [(char=? c #\<) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (set! token '<)] + [(char=? c #\=) (set! token '<=)] + [else (unread-char c port) (set! token '<)]))] + [(char=? c #\>) + (let ([c (read-char port)]) + (cond + [(eof-object? c) (set! token '>)] + [(char=? c #\=) (set! token '>=)] + [else (unread-char c port) (set! token '>)]))])))) + (define E0 ; or + (lambda () + (E0* (E1)))) + (define E0* + (lambda (v) + (case token + [or (next-token!) (E0* (if (= (+ v (E1)) 0) 0 1))] + [else v]))) + (define E1 ; and + (lambda () + (E1* (E2)))) + (define E1* + (lambda (v) + (case token + [and (next-token!) (E1* (if (= (* v (E2)) 0) 0 1))] + [else v]))) + (define E2 ; ==, != + (lambda () + (E2* (E3)))) + (define E2* + (lambda (v) + (case token + [== (next-token!) (E2* (if (= v (E3)) 1 0))] + [!= (next-token!) (E2* (if (= v (E3)) 0 1))] + [else v]))) + (define E3 ; <, <=, >, >= + (lambda () + (E3* (E4)))) + (define E3* + (lambda (v) + (case token + [< (next-token!) (E3* (if (< v (E4)) 1 0))] + [<= (next-token!) (E3* (if (<= v (E4)) 1 0))] + [> (next-token!) (E3* (if (> v (E4)) 1 0))] + [>= (next-token!) (E3* (if (>= v (E4)) 1 0))] + [else v]))) + (define E4 ; +, - + (lambda () + (E4* (E5)))) + (define E4* + (lambda (v) + (case token + [+ (next-token!) (E4* (+ v (E5)))] + [- (next-token!) (E4* (- v (E5)))] + [else v]))) + (define E5 ; *, /, % + (lambda () + (E5* (E6)))) + (define E5* + (lambda (v) + (case token + [* (next-token!) (E5* (* v (E6)))] + [/ (next-token!) (E5* (quotient v (E6)))] + [% (next-token!) (E5* (modulo v (E6)))] + [else v]))) + (define E6 ; ** + (lambda () + (E6* (E7)))) + (define E6* + (lambda (v) + (case token + [** (next-token!) (E6* (expt v (E7)))] + [else v]))) + (define E7 ; -, integer, paren + (lambda () + (case token + [- (next-token!) (- (E7))] + [! (next-token!) (if (= (E7) 0) 1 0)] + [oparen + (next-token!) + (let ([v (E0)]) + (unless (eq? token 'cparen) (eval-error)) + (next-token!) + v)] + [integer (next-token!) value] + [else (eval-error)]))) + (lambda (s) + (fluid-let ([str s] [port (open-input-string s)] [token #f] [value #f]) + (next-token!) + (let ([v (E0)]) + (unless (eq? token 'eof) (eval-error)) + v))))) + +(define *divnum* #f) +(define *diversions* #f) + +(define m4-put-string + (lambda (s) + (unless (= *divnum* -1) + (display s (vector-ref *diversions* *divnum*))))) + +(define *open-quote* #f) +(define *close-quote* #f) + +(define *macros* #f) +(define builtin-macros '()) + +(define *translit-table* #f) + +(define define-builtin-macro + (lambda (name proc) + (set! builtin-macros (cons (cons name proc) builtin-macros)))) + +(define m4 + (lambda (ofn ifn . rest) + (let ([op (open-output-file ofn 'replace)]) + (fluid-let ([*macros* builtin-macros] + [*open-quote* #\`] + [*close-quote* #\'] + [*translit-table* #f] + [*divnum* 0] + [*diversions* (vector op #f #f #f #f #f #f #f #f #f)]) + (let loop ([ip (open-input-file ifn)] [rest rest]) + (m4-process (make-ibuf ip) op) + (close-input-port ip) + (unless (null? rest) + (loop (open-input-file (car rest)) (cdr rest)))) + (for-each undivert '(1 2 3 4 5 6 7 8 9))) + (close-output-port op)))) + +(define m4-process + (lambda (ib op) + (let ([lexeme (read-lexeme ib)]) + (case (lexeme-type lexeme) + [(comment literal) + (m4-put-string (lexeme-value lexeme)) + (m4-process ib op)] + [macro + ((cdr (lexeme-value lexeme)) (read-args ib) ib) + (m4-process ib op)] + [eof #t] + [else (error 'm4-internal "unexpected lexeme ~s" lexeme)])))) + +(define name-start-char? + (lambda (c) + (or (char-alphabetic? c) + (char=? c #\_)))) + +(define name-char? + (lambda (c) + (or (name-start-char? c) + (char-numeric? c)))) + +(define read-lexeme + (lambda (ib) + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) (cons 'eof c)] + [(char=? c #\#) (cons 'comment (read-comment ib))] + [(char=? c *open-quote*) (cons 'literal (read-quoted ib))] + [(name-start-char? c) (lookup-macro (cons c (read-alpha ib)))] + [else (cons 'literal (string c))])))) + +(define read-comment + (lambda (ib) + (let loop ([ls '(#\#)]) + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) (list->string (reverse ls))] + [(char=? c #\newline) (list->string (reverse (cons c ls)))] + [else (loop (cons c ls))]))))) + +(define read-quoted + (lambda (ib) + (let loop ([ls '()] [n 0]) + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) + (error 'm4 "end-of-file detected at quote level ~s" n)] + [(char=? c *close-quote*) + (if (= n 0) + (list->string (reverse ls)) + (loop (cons c ls) (- n 1)))] + [(char=? c *open-quote*) (loop (cons c ls) (+ n 1))] + [else (loop (cons c ls) n)]))))) + +(define read-alpha + (lambda (ib) + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) '()] + [(name-char? c) (cons c (read-alpha ib))] + [else (m4-unget-char c ib) '()])))) + +(define lookup-macro + (lambda (ls) + (let ([s (list->string ls)]) + (let ([a (assoc s *macros*)]) + (if a + (cons 'macro a) + (cons 'literal s)))))) + +(define read-args + (lambda (ib) + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) '()] + [(char=? c oparen) + (let next-arg () + (let skip-white () + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) '()] + [(char-whitespace? c) (skip-white)] + [else (m4-unget-char c ib)]))) + (let this-arg ([strings '()]) + (let ([c (m4-get-char ib)]) + (cond + [(or (eof-object? c) (char=? c cparen)) + (if (null? strings) + '() + (cons (apply string-append (reverse strings)) + '()))] + [(char=? c oparen) + (let nest ([strings (cons (string oparen) + strings)] + [k this-arg]) + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) (this-arg strings)] + [(char=? c cparen) + (k (cons (string cparen) strings))] + [(char=? c oparen) + (nest (cons (string oparen) strings) + (lambda (strings) + (nest strings k)))] + [else + (m4-unget-char c ib) + (let ([lexeme (read-lexeme ib)]) + (case (lexeme-type lexeme) + [comment (nest strings k)] + [literal + (nest (cons (lexeme-value lexeme) + strings) + k)] + [macro + ((cdr (lexeme-value lexeme)) + (read-args ib) + ib) + (nest strings k)] + [else + (error 'm4-internal + "unexpected lexeme ~s" + lexeme)]))])))] + [(char=? c #\,) + (cons (apply string-append (reverse strings)) + (next-arg))] + + [else + (m4-unget-char c ib) + (let ([lexeme (read-lexeme ib)]) + (case (lexeme-type lexeme) + [comment (this-arg strings)] + [literal + (this-arg + (cons (lexeme-value lexeme) strings))] + [macro + ((cdr (lexeme-value lexeme)) (read-args ib) ib) + (this-arg strings)] + [else + (error 'm4-internal + "unexpected lexeme ~s" + lexeme)]))]))))] + [else (m4-unget-char c ib) '()])))) + +;;; builtin macros + +(define $$ (lambda (ls) (if (null? ls) ls (cdr ls)))) +(define $1 (lambda (ls) (if (null? ls) "" (car ls)))) +(define $2 (lambda (ls) ($1 ($$ ls)))) +(define $3 (lambda (ls) ($2 ($$ ls)))) +(define $4 (lambda (ls) ($3 ($$ ls)))) +(define $5 (lambda (ls) ($4 ($$ ls)))) +(define $6 (lambda (ls) ($5 ($$ ls)))) +(define $7 (lambda (ls) ($6 ($$ ls)))) +(define $8 (lambda (ls) ($7 ($$ ls)))) +(define $9 (lambda (ls) ($8 ($$ ls)))) + +(define-builtin-macro "changequote" + (lambda (args ib) + (set! *open-quote* + (if (string=? ($1 args) "") #\` (string-ref ($1 args) 0))) + (set! *close-quote* + (if (string=? ($2 args) "") #\' (string-ref ($2 args) 0))))) + +(define-builtin-macro "define" + (lambda (args ib) + (let ([name ($1 args)]) + (unless (let ([n (string-length name)]) + (and (fx> n 0) + (name-start-char? (string-ref name 0)) + (let ok? ([i 1]) + (or (fx= i n) + (and (name-char? (string-ref name i)) + (ok? (fx+ i 1))))))) + (error 'm4-define "invalid macro name ~s" name)) + (let ([proc (make-macro ($2 args))]) + (let ([a (assoc name *macros*)]) + (if a + (set-cdr! a proc) + (set! *macros* (cons (cons name proc) *macros*)))))))) + +(define make-macro + (lambda (s) + (let ([ls (string->list s)]) + (lambda (args ib) + (let loop ([ls ls]) + (unless (null? ls) + (case (and (char=? (car ls) #\$) + (not (null? (cdr ls))) + (cadr ls)) + [#\1 (loop (cddr ls)) (unget-string ($1 args) ib)] + [#\2 (loop (cddr ls)) (unget-string ($2 args) ib)] + [#\3 (loop (cddr ls)) (unget-string ($3 args) ib)] + [#\4 (loop (cddr ls)) (unget-string ($4 args) ib)] + [#\5 (loop (cddr ls)) (unget-string ($5 args) ib)] + [#\6 (loop (cddr ls)) (unget-string ($6 args) ib)] + [#\7 (loop (cddr ls)) (unget-string ($7 args) ib)] + [#\8 (loop (cddr ls)) (unget-string ($8 args) ib)] + [#\9 (loop (cddr ls)) (unget-string ($9 args) ib)] + [else (loop (cdr ls)) (m4-unget-char (car ls) ib)]))))))) + +(define-builtin-macro "divert" + (lambda (args ib) + (set! *divnum* + (if (string=? ($1 args) "") + 0 + (case (string-ref ($1 args) 0) + [#\0 0] + [#\1 1] + [#\2 2] + [#\3 3] + [#\4 4] + [#\5 5] + [#\6 6] + [#\7 7] + [#\8 8] + [#\9 9] + [else -1]))) + (when (and (<= 1 *divnum* 9) (not (vector-ref *diversions* *divnum*))) + (vector-set! *diversions* *divnum* (open-output-string))))) + +(define-builtin-macro "divnum" + (lambda (args ib) + (unget-string (format "~a" *divnum*) ib))) + +(define-builtin-macro "dnl" + (lambda (args ib) + (let loop () + (let ([c (m4-get-char ib)]) + (cond + [(eof-object? c) '()] + [(char=? c #\newline) '()] + [else (loop)]))))) + +(define-builtin-macro "dumpdef" + (lambda (args ib) + (printf "m4 warning: no dumpdef yet~%"))) + +(define-builtin-macro "errprint" + (lambda (args ib) + (display ($1 args) *error-output*) + (newline *error-output*))) + +(define-builtin-macro "eval" + (lambda (args ib) + (unget-string (int->str (eval-string ($1 args))) ib))) + +(define-builtin-macro "ifdef" + (lambda (args ib) + (unget-string ((if (assoc ($1 args) *macros*) $2 $3) args) ib))) + +(define-builtin-macro "ifelse" + (rec ifelse + (lambda (args ib) + (if (string=? ($1 args) ($2 args)) + (unget-string ($3 args) ib) + (if (> (length args) 4) + (ifelse ($$ ($$ ($$ args))) ib) + (unget-string ($4 args) ib)))))) + +(define-builtin-macro "include" + (lambda (args ib) + (printf "m4 warning: no include yet~%"))) + +(define-builtin-macro "incr" + (lambda (args ib) + (unget-string (int->str (+ (str->int ($1 args)) 1)) ib))) + +(define-builtin-macro "index" + (lambda (args ib) + (let ([s1 ($1 args)] [s2 ($2 args)]) + (let ([n1 (string-length s1)] [n2 (string-length s2)]) + (let find ([i 0]) + (if (fx> n2 (fx- n1 i)) + (unget-string "-1" ib) + (let try ([i1 i] [i2 0]) + (if (fx= i2 n2) + (unget-string (int->str i) ib) + (if (char=? (string-ref s1 i1) (string-ref s2 i2)) + (try (fx+ i1 1) (fx+ i2 1)) + (find (fx+ i 1))))))))))) + +(define-builtin-macro "len" + (lambda (args ib) + (unget-string (int->str (string-length ($1 args))) ib))) + +(define-builtin-macro "maketemp" + (lambda (args ib) + (printf "m4 warning: no maketemp yet~%"))) + +(define-builtin-macro "shift" + (lambda (args ib) + (printf "m4 warning: no shift yet~%"))) + +(define-builtin-macro "sinclude" + (lambda (args ib) + (printf "m4 warning: no sinclude yet~%"))) + +(define-builtin-macro "substr" + (lambda (args ib) + (let ([s ($1 args)] [start ($2 args)] [count ($3 args)]) + (let ([n (string-length s)]) + (let ([start (min (max (str->int start) 0) n)]) + (let ([end (if (string=? count "") + n + (min (max (+ (str->int count) start) start) n))]) + (unget-string (substring s start end) ib))))))) + +(define-builtin-macro "syscmd" + ;;; cannot be written in Scheme---needs something more powerful than + ;;; "system" or "process" + (lambda (args ib) + (printf "m4 warning: no syscmd yet~%"))) + +(define-builtin-macro "translit" + (lambda (args ib) + (let ([s1 ($1 args)] [s2 ($2 args)] [s3 ($3 args)]) + (let ([n1 (string-length s1)] [n2 (string-length s2)]) + (unless (= n2 (string-length s3)) + (error 'm4 "translit arguments ~s and ~s are not of same length" + s2 s3)) + (when (null? *translit-table*) + (set! *translit-table* (make-string 256))) + (do ([i 0 (fx+ i 1)]) + ((fx= i 256)) + (string-set! *translit-table* i (integer->char i))) + (do ([i 0 (fx+ i 1)]) + ((fx= i n2)) + (string-set! *translit-table* + (char->integer (string-ref s2 i)) + (string-ref s3 i))) + (let ([s4 (make-string n1)]) + (do ([i 0 (fx+ i 1)]) + ((fx= i n1)) + (string-set! s4 i + (string-ref *translit-table* + (char->integer (string-ref s1 i))))) + (unget-string s4 ib)))))) + +(define-builtin-macro "undefine" + (lambda (args ib) + (let ([a (assoc ($1 args) *macros*)]) + (unless a (error 'm4 "cannot undefine ~s (not defined)" ($1 args))) + (set-car! a #f)))) + +(define-builtin-macro "undivert" + (rec myself + (lambda (args ib) + (if (null? args) + (myself '("1" "2" "3" "4" "5" "6" "7" "8" "9") ib) + (for-each + (lambda (x) + (case (and (not (string=? x "")) (string-ref x 0)) + [#\1 (undivert 1)] + [#\2 (undivert 2)] + [#\3 (undivert 3)] + [#\4 (undivert 4)] + [#\5 (undivert 5)] + [#\6 (undivert 6)] + [#\7 (undivert 7)] + [#\8 (undivert 8)] + [#\9 (undivert 9)])) + args))))) + +(define undivert + (lambda (n) + (let ([op (vector-ref *diversions* n)]) + (when op + (display (get-output-string op) (vector-ref *diversions* 0)))))) diff --git a/examples/macro.ss b/examples/macro.ss new file mode 100644 index 0000000..4b03a48 --- /dev/null +++ b/examples/macro.ss @@ -0,0 +1,89 @@ +;;; Copyright (C) 1989 R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; PCScheme/MacScheme "macro" defined in terms of "syntax-case": + +(define-syntax macro + (lambda (x) + (syntax-case x () + ((_ name fcn) + #'(define-syntax name + (lambda (x) + (syntax-case x () + ((k . stuff) + (datum->syntax-object #'k + (fcn (syntax-object->datum x))))))))))) + + +;;; PCScheme/MacScheme "macro" defined in terms of "extend-syntax": +;;; requires (current-expand eps-expand) + +;(extend-syntax (macro) +; [(macro name fcn) +; (eval-when (compile load eval) +; (let ([f fcn]) +; (extend-syntax (name) +; [anything +; ((with ([w 'with]) w) +; ([v (f 'anything)]) v)])))]) + +;;; The strange expression "(with ([w 'with]) w)" is used to insert the +;;; keyword "with" into the expansion. The "eval-when" in the expansion is +;;; necessary to allow macros defined in a file to be used later in the +;;; file, even if the file is compiled with "compile-file". If it were +;;; left out, the implicit "eval-when" wrapped around the "extend-syntax" +;;; would cause it to be evaluated, but without the enclosing "let" +;;; expression. The enclosing "let" expression is necessary to cause the +;;; function to be evaluated once, which may be important if the function +;;; something other than a simple lambda expression. + + +;;; PCScheme/MacScheme "macro" defined in terms of "define-syntax-expander": +;;; requires (current-expand eps-expand) + +;(extend-syntax (macro) +; [(macro name fcn) +; (define-syntax-expander name +; (let ([f fcn]) +; (lambda (x e) (e (f x) e))))]) + +;;; The "eval-when" is not necessary because "define-syntax-expander" +;;; expands into an "eval-when" expression, and the "let" expression is +;;; tucked inside the "define-syntax-expander" expression. + +;;; If you want to see the expander generated by either of the above +;;; "extend-syntax" definitions looks like, use "extend-syntax/code" in +;;; place of "extend-syntax": + +;;; > (extend-syntax/code (macro) +;;; [(macro name fcn) +;;; (define-syntax-expander name +;;; (let ([f fcn]) +;;; (lambda (x e) (e (f x) e))))]) +;;; +;;; (lambda (x e) +;;; (unless (procedure? e) +;;; (error 'macro "~s is not a procedure" e)) +;;; (e (cond +;;; [(syntax-match? '(macro * *) x) +;;; `(define-syntax-expander ,(cadr x) +;;; (let ([f ,@(cddr x)]) (lambda (x e) (e (f x) e))))] +;;; [else (error 'macro "invalid syntax ~s" x)]) +;;; e)) diff --git a/examples/matrix.ss b/examples/matrix.ss new file mode 100644 index 0000000..833f7b0 --- /dev/null +++ b/examples/matrix.ss @@ -0,0 +1,127 @@ +;;; matrix.ss +;;; Copyright (C) 1996 R. Kent Dybvig +;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; make-matrix creates a matrix (a vector of vectors). +(define make-matrix + (lambda (rows columns) + (do ((m (make-vector rows)) + (i 0 (+ i 1))) + ((= i rows) m) + (vector-set! m i (make-vector columns))))) + +;;; matrix? checks to see if its argument is a matrix. +;;; It isn't foolproof, but it's generally good enough. +(define matrix? + (lambda (x) + (and (vector? x) + (> (vector-length x) 0) + (vector? (vector-ref x 0))))) + +;;; matrix-ref returns the jth element of the ith row. +(define matrix-ref + (lambda (m i j) + (vector-ref (vector-ref m i) j))) + +;;; matrix-set! changes the jth element of the ith row. +(define matrix-set! + (lambda (m i j x) + (vector-set! (vector-ref m i) j x))) + +;;; mul is the generic matrix/scalar multiplication procedure +(define mul + (lambda (x y) + ;; type-error is called to complain when mul receives an invalid + ;; type of argument. + (define type-error + (lambda (what) + (error 'mul + "~s is not a number or matrix" + what))) + + ;; match-error is called to complain when mul receives a pair of + ;; incompatible arguments. + (define match-error + (lambda (what1 what2) + (error 'mul + "~s and ~s are incompatible operands" + what1 + what2))) + + ;; matrix-rows returns the number of rows in a matrix. + (define matrix-rows + (lambda (x) + (vector-length x))) + + ;; matrix-columns returns the number of columns in a matrix. + (define matrix-columns + (lambda (x) + (vector-length (vector-ref x 0)))) + + ;; mat-sca-mul multiplies a matrix by a scalar. + (define mat-sca-mul + (lambda (m x) + (let* ((nr (matrix-rows m)) + (nc (matrix-columns m)) + (r (make-matrix nr nc))) + (do ((i 0 (+ i 1))) + ((= i nr) r) + (do ((j 0 (+ j 1))) + ((= j nc)) + (matrix-set! r i j + (* x (matrix-ref m i j)))))))) + + ;; mat-mat-mul multiplies one matrix by another, after verifying + ;; that the first matrix has as many columns as the second + ;; matrix has rows. + (define mat-mat-mul + (lambda (m1 m2) + (let* ((nr1 (matrix-rows m1)) + (nr2 (matrix-rows m2)) + (nc2 (matrix-columns m2)) + (r (make-matrix nr1 nc2))) + (if (not (= (matrix-columns m1) nr2)) + (match-error m1 m2)) + (do ((i 0 (+ i 1))) + ((= i nr1) r) + (do ((j 0 (+ j 1))) + ((= j nc2)) + (do ((k 0 (+ k 1)) + (a 0 + (+ a + (* (matrix-ref m1 i k) + (matrix-ref m2 k j))))) + ((= k nr2) + (matrix-set! r i j a)))))))) + + ;; body of mul; dispatch based on input types + (cond + ((number? x) + (cond + ((number? y) (* x y)) + ((matrix? y) (mat-sca-mul y x)) + (else (type-error y)))) + ((matrix? x) + (cond + ((number? y) (mat-sca-mul x y)) + ((matrix? y) (mat-mat-mul x y)) + (else (type-error y)))) + (else (type-error x))))) diff --git a/examples/object.ss b/examples/object.ss new file mode 100644 index 0000000..e4e7be0 --- /dev/null +++ b/examples/object.ss @@ -0,0 +1,54 @@ +;;; object.ss +;;; Copyright (C) 1996 R. Kent Dybvig +;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; define-object creates an object constructor that uses let* to bind +;;; local fields and letrec to define the exported procedures. An +;;; object is itself a procedure that accepts messages corresponding +;;; to the names of the exported procedures. The second pattern is +;;; used to allow the set of local fields to be omitted. +(define-syntax define-object + (syntax-rules () + ((_ (name . varlist) + ((var1 val1) ...) + ((var2 val2) ...)) + (define name + (lambda varlist + (let* ((var1 val1) ...) + (letrec ((var2 val2) ...) + (lambda (msg . args) + (case msg + ((var2) (apply var2 args)) ... + (else + (error 'name "invalid message ~s" + (cons msg args)))))))))) + ((_ (name . varlist) + ((var2 val2) ...)) + (define-object (name . varlist) + () + ((var2 val2) ...))))) + +;;; send-message abstracts the act of sending a message from the act +;;; of applying a procedure and allows the message to be unquoted. +(define-syntax send-message + (syntax-rules () + ((_ obj msg arg ...) + (obj 'msg arg ...)))) diff --git a/examples/power.ss b/examples/power.ss new file mode 100644 index 0000000..7d1a704 --- /dev/null +++ b/examples/power.ss @@ -0,0 +1,12 @@ +;;; doubly recursive power (expt) function + +;;; try using trace-lambda to see the nesting. + +(define power + (lambda (x n) + (cond + [(= n 0) 1] + [(= n 1) x] + [else + (let ([q (quotient n 2)]) + (* (power x q) (power x (- n q))))]))) diff --git a/examples/queue.ss b/examples/queue.ss new file mode 100644 index 0000000..389611a --- /dev/null +++ b/examples/queue.ss @@ -0,0 +1,56 @@ +;;; queue +;;; an abstract datatype + +;;; operations: +;;; (queue) ;create a queue object + +;;; if 'q' is a queue object: + +;;; (q 'type?) ;return the type (queue), useful if there are other +;;; ;abstract datatypes floating around. +;;; (q 'empty?) ;returns true iff q is empty +;;; (q 'put val) ;adds val to end of q; returns val +;;; (q 'get) ;removes first element of q and returns it + +;;; Examples + +;;; (define! q (queue)) +;;; (q 'type?) => queue +;;; (q 'empty?) => #!true +;;; (q 'put 3) +;;; (q 'put 4) +;;; (q 'put 5) +;;; (q 'empty?) => () +;;; (q 'get) => 3 +;;; (q 'get) => 4 +;;; (q 'put 7) +;;; (q 'get) => 5 +;;; (q 'get) => 7 +;;; (q 'empty?) => #!true + +(define queue + (lambda () + (let ([head '()] [tail '()]) + (lambda (request . args) + (case request + [type? 'queue] + [empty? (null? head)] + [put + (let ([v (car args)]) + (if (null? head) + (let ([p (cons v '())]) + (set! tail p) + (set! head p)) + (let ([quebit (cons v '())]) + (set-cdr! tail quebit) + (set! tail quebit))) + v)] + [get + (if (null? head) + (error 'queue "queue is empty") + (let ([v (car head)]) + (set! head (cdr head)) + (when (null? head) (set! tail '())) + v))] + [else + (error 'queue "~s is not a valid request" request)]))))) diff --git a/examples/rabbit.ss b/examples/rabbit.ss new file mode 100644 index 0000000..6e2f29d --- /dev/null +++ b/examples/rabbit.ss @@ -0,0 +1,90 @@ +;;; rabbit + +;;; The rabbit program highlights the use of continuations and +;;; timer interrupts to perform thread scheduling. The scheduler +;;; maintains a thread queue and operating system primitives for +;;; dispatching and thread creation. The queue is only visible +;;; to the operating system kernel and all accesses are performed +;;; with the timer off to prevent corruption. + +;;; (thread exp) will create a thread out of exp and place it in +;;; the thread queue. you may do this for as many threads as +;;; you like. (dispatch) starts the threads going. If the +;;; thread queue ever becomes empty, dispatch exits. Threads +;;; may create other threads. + +;;; The rabbit function creates a thread that spawns two offspring +;;; and dies. Each thread has a generation number associated with +;;; it. The generation number of each rabbit is one lower than that +;;; of it's parent; rabbits in generation 0 are sterile. + +;;; load the queue datatype -- might need a fuller pathname +(load "queue.ss") + +;;; swap-time determines the number of timer ticks in a time slice +(define swap-time + (make-parameter + 100 + (lambda (x) + (unless (and (integer? x) (positive? x)) + (error 'swap-time "~s is not a positive integer" x)) + x))) + +(define dispatch #f) +(define thread #f) + +(let ([pq (queue)]) + (set! dispatch + (lambda () + (unless (pq 'empty?) + ; the thread queue holds continuations---grab one and invoke it + (let ([next (pq 'get)]) + (set-timer (swap-time)) + (next #f))))) + (set! thread + (lambda (thunk) + (call/cc + (lambda (return) + (call/cc + (lambda (k) + ; turn off the timer while accessing the queue + (let ([time-left (set-timer 0)]) + ; put the thread on the queue + (pq 'put k) + (set-timer time-left) + ; get out of here + (return #f)))) + ; the first time through we will return before getting + ; here. the second time is when a thread is first + ; dispatched from the thread queue. + (thunk) + (set-timer 0) + (dispatch))))) + (timer-interrupt-handler + (lambda () + (printf "swapping~%") + (call/cc + (lambda (l) + ; place the continuation of the interrupt on the queue + (pq 'put l) + (dispatch)))))) + + +;;; *delay-max* gives the maximum random delay before a rabbit +;;; reaches child-bearing age. +(define *delay-max* 10000) + +(define rabbit + (lambda (n) + (thread + (lambda () + (printf "~s~%" n) + (unless (zero? n) + (do ([i (random *delay-max*) (1- i)]) ((zero? i))) + (rabbit (1- n)) + (rabbit (1- n))))))) + +;;; try: +;;; (rabbit 3) +;;; (rabbit 5) +;;; (dispatch) diff --git a/examples/rsa.ss b/examples/rsa.ss new file mode 100644 index 0000000..c59d377 --- /dev/null +++ b/examples/rsa.ss @@ -0,0 +1,308 @@ +;;; rsa.ss +;;; Bruce T. Smith, University of North Carolina at Chapel Hill +;;; (circa 1984) + +;;; Updated for Chez Scheme Version 7, May 2005 + +;;; This is a toy example of an RSA public-key encryption system. It +;;; is possible to create users who register their public keys with a +;;; center and hide their private keys. Then, it is possible to have +;;; the users exchange messages. To a limited extent one can look at +;;; the intermediate steps of the process by using encrypt and decrypt. +;;; The encrypted messages are represented by lists of numbers. + +;;; Example session: + +#| +> (make-user bonzo) +Registered with Center +User: bonzo +Base: 152024296883113044375867034718782727467 +Encryption exponent: 7 +> (make-user bobo) +Registered with Center +User: bobo +Base: 244692569127295893294157219042233636899 +Encryption exponent: 5 +> (make-user tiger) +Registered with Center +User: tiger +Base: 138555414233087084786368622588289286073 +Encryption exponent: 7 +> (show-center) + +User: tiger +Base: 138555414233087084786368622588289286073 +Encryption exponent: 7 + +User: bobo +Base: 244692569127295893294157219042233636899 +Encryption exponent: 5 + +User: bonzo +Base: 152024296883113044375867034718782727467 +Encryption exponent: 7 +> (send "hi there" bonzo bobo) +"hi there" +> (send "hi there to you" bobo bonzo) +"hi there to you" +> (decrypt (encrypt "hi there" bonzo bobo) tiger) +" #z R4WN Zbb E8J" +|# + +;;; Implementation: + +(module ((make-user user) show-center encrypt decrypt send) + +;;; (make-user name) creates a user with the chosen name. When it +;;; creates the user, it tells him what his name is. He will use +;;; this when registering with the center. + +(define-syntax make-user + (syntax-rules () + [(_ uid) + (begin (define uid (user 'uid)) (uid 'register))])) + +;;; (encrypt mesg u1 u2) causes user 1 to encrypt mesg using the public +;;; keys for user 2. + +(define-syntax encrypt + (syntax-rules () + [(_ mesg u1 u2) ((u1 'send) mesg 'u2)])) + +;;; (decrypt number-list u) causes the user to decrypt the list of +;;; numbers using his private key. + +(define-syntax decrypt + (syntax-rules () + [(_ numbers u) ((u 'receive) numbers)])) + +;;; (send mesg u1 u2) this combines the functions 'encrypt' and 'decrypt', +;;; calling on user 1 to encrypt the message for user 2 and calling on +;;; user 2 to decrypt the message. + +(define-syntax send + (syntax-rules () + [(_ mesg u1 u2) (decrypt (encrypt mesg u1 u2) u2)])) + +;;; A user is capable of the following: +;;; - choosing public and private keys and registering with the center +;;; - revealing his public and private keys +;;; - retrieving user's private keys from the center and encrypting a +;;; message for that user +;;; - decrypting a message with his private key + +(define user + (lambda (name) + (let* ([low (expt 2 63)] ; low, high = bounds on p and q + [high (* 2 low)] + [p 0] ; p,q = two large, probable primes + [q 0] + [n 0] ; n = p * q, base for modulo arithmetic + [phi 0] ; phi = lcm(p-1,q-1), not quite the Euler phi function, + ; but it will serve for our purposes + [e 0] ; e = exponent for encryption + [d 0]) ; d = exponent for decryption + (lambda (request) + (case request + ;; choose keys and register with the center + [register + (set! p (find-prime low high)) + (set! q + (let loop ([q1 (find-prime low high)]) + (if (= 1 (gcd p q1)) + q1 + (loop (find-prime low high))))) + (set! n (* p q)) + (set! phi + (/ (* (1- p) (1- q)) + (gcd (1- p) (1- q)))) + (set! e + (do ([i 3 (+ 2 i)]) + ((= 1 (gcd i phi)) i))) + (set! d (mod-inverse e phi)) + (register-center (cons name (list n e))) + (printf "Registered with Center~%") + (printf "User: ~s~%" name) + (printf "Base: ~d~%" n) + (printf "Encryption exponent: ~d~%" e)] + + ;; divulge your keys-- you should resist doing this... + [show-all + (printf "p = ~d ; q = ~d~%" p q) + (printf "n = ~d~%" n) + (printf "phi = ~d~%" (* (1- p) (1- q))) + (printf "e = ~d ; d = ~d~%" e d)] + + ;; get u's public key from the center and encode + ;; a message for him + [send + (lambda (mesg u) + (let* ([public (request-center u)] + [base (car public)] + [exponent (cadr public)] + [mesg-list (string->numbers mesg base)]) + (map (lambda (x) (expt-mod x exponent base)) + mesg-list)))] + + ;; decrypt a message with your private key + [receive + (lambda (crypt-mesg) + (let ([mesg-list (map (lambda (x) (expt-mod x d n)) crypt-mesg)]) + (numbers->string mesg-list)))]))))) + +;;; The center maintains the list of public keys. It can register +;;; new users, provide the public keys for any particular user, or +;;; display the whole public file. + +(module (register-center request-center show-center) + (define public-keys '()) + (define register-center + (lambda (entry) + (set! public-keys + (cons entry + (remq (assq (car entry) public-keys) public-keys))))) + (define request-center + (lambda (u) + (let ([a (assoc u public-keys)]) + (when (null? a) + (error 'request-center + "User ~s not registered in center" + u)) + (cdr a)))) + (define show-center + (lambda () + (for-each + (lambda (entry) + (printf "~%User: ~s~%" (car entry)) + (printf "Base: ~s~%" (cadr entry)) + (printf "Encryption exponent: ~s~%" (caddr entry))) + public-keys))) +) + +;;; string->numbers encodes a string as a list of numbers +;;; numbers->string decodes a string from a list of numbers + +;;; string->numbers and numbers->string are defined with respect to +;;; an alphabet. Any characters in the alphabet are translated into +;;; integers---their regular ascii codes. Any characters outside +;;; the alphabet cause an error during encoding. An invalid code +;;; during decoding is translated to a space. + +(module (string->numbers numbers->string) + (define first-code 32) + (define last-code 126) + (define alphabet + ; printed form of the characters, indexed by their ascii codes + (let ([alpha (make-string 128 #\space)]) + (do ([i first-code (1+ i)]) + ((= i last-code) alpha) + (string-set! alpha i (integer->char i))))) + + (define string->integer + (lambda (str) + (let ([ln (string-length str)]) + (let loop ([i 0] [m 0]) + (if (= i ln) + m + (let* ([c (string-ref str i)] [code (char->integer c)]) + (when (or (< code first-code) (>= code last-code)) + (error 'rsa "Illegal character ~s" c)) + (loop (1+ i) (+ code (* m 128))))))))) + + (define integer->string + (lambda (n) + (list->string + (map (lambda (n) (string-ref alphabet n)) + (let loop ([m n] [lst '()]) + (if (zero? m) + lst + (loop (quotient m 128) + (cons (remainder m 128) lst)))))))) + + ; turn a string into a list of numbers, each no larger than base + (define string->numbers + (lambda (str base) + (letrec ([block-size + (do ([i -1 (1+ i)] [m 1 (* m 128)]) ((>= m base) i))] + [substring-list + (lambda (str) + (let ([ln (string-length str)]) + (if (>= block-size ln) + (list str) + (cons (substring str 0 block-size) + (substring-list + (substring str block-size ln))))))]) + (map string->integer (substring-list str))))) + + ; turn a list of numbers into a string + (define numbers->string + (lambda (lst) + (letrec ([reduce + (lambda (f l) + (if (null? (cdr l)) + (car l) + (f (car l) (reduce f (cdr l)))))]) + (reduce + string-append + (map (lambda (x) (integer->string x)) lst))))) +) + +;;; find-prime finds a probable prime between two given arguments. +;;; find-prime uses a cheap but fairly dependable test for primality +;;; for large numbers, by first weeding out multiples of first 200 +;;; primes, then applies Fermat's theorem with base 2. + +(module (find-prime) + (define product-of-primes + ; compute product of first n primes, n > 0 + (lambda (n) + (let loop ([n (1- n)] [p 2] [i 3]) + (cond + [(zero? n) p] + [(= 1 (gcd i p)) (loop (1- n) (* p i) (+ i 2))] + [else (loop n p (+ i 2))])))) + (define prod-first-200-primes (product-of-primes 200)) + (define probable-prime + ; first check is quick, and weeds out most non-primes + ; second check is slower, but weeds out almost all non-primes + (lambda (p) + (and (= 1 (gcd p prod-first-200-primes)) + (= 1 (expt-mod 2 (1- p) p))))) + (define find-prime + ; find probable prime in range low to high (inclusive) + (lambda (low high) + (let ([guess + (lambda (low high) + (let ([g (+ low (random (1+ (- high low))))]) + (if (odd? g) g (1+ g))))]) + (let loop ([g (guess low high)]) + (cond + ; start over if already too high + [(> g high) (loop (guess low high))] + ; if guess is probably prime, return + [(probable-prime g) g] + ; don't bother with even guesses + [else (loop (+ 2 g))]))))) +) + +;;; mod-inverse finds the multiplicative inverse of x mod b, if it exists + +(module (mod-inverse) + (define gcdx + ; extended Euclid's gcd algorithm, x <= y + (lambda (x y) + (let loop ([x x] [y y] [u1 1] [u2 0] [v1 0] [v2 1]) + (if (zero? y) + (list x u1 v1) + (let ([q (quotient x y)] [r (remainder x y)]) + (loop y r u2 (- u1 (* q u2)) v2 (- v1 (* q v2)))))))) + + (define mod-inverse + (lambda (x b) + (let* ([x1 (modulo x b)] [g (gcdx x1 b)]) + (unless (= (car g) 1) + (error 'mod-inverse "~d and ~d not relatively prime" x b)) + (modulo (cadr g) b)))) +) +) diff --git a/examples/scons.ss b/examples/scons.ss new file mode 100644 index 0000000..83dc575 --- /dev/null +++ b/examples/scons.ss @@ -0,0 +1,41 @@ +;;; scons.ss +;;; a stream-construction facility + +;;; The scons special form performs a cons, suspending the cdr field +;;; by enclosing it in a procedure of no arguments. scdr tests to see +;;; if the cdr is a procedure, and if so, invokes it. scar is provided +;;; for symmetry; it is just car. + +;;; The function stream-ref is simply list-ref defined in terms of +;;; scdr and scar. + +;;; factlist and fiblist are two infinite streams. +;;; Try (stream-ref factlist 10) or (stream-ref fiblist 20). + +;;; scons could easily suspend the car field as well. This would +;;; implement the lazy cons of Friedman & Wise. + +(define-syntax scons + (syntax-rules () + ((_ car cdr) (cons car (lambda () cdr))))) + +(define scar car) + +(define scdr + (lambda (x) + (when (procedure? (cdr x)) (set-cdr! x ((cdr x)))) + (cdr x))) + +(define stream-ref + (lambda (x n) + (if (zero? n) + (scar x) + (stream-ref (scdr x) (1- n))))) + +(define factlist + (let fact ([a 1] [n 1]) + (scons a (fact (* a n) (1+ n))))) + +(define fiblist + (let fib ([fib-2 0] [fib-1 1]) + (scons fib-1 (fib fib-1 (+ fib-2 fib-1))))) diff --git a/examples/setof.ss b/examples/setof.ss new file mode 100644 index 0000000..51a5fc8 --- /dev/null +++ b/examples/setof.ss @@ -0,0 +1,52 @@ +;;; setof.ss +;;; Copyright (C) 1996 R. Kent Dybvig +;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; set-of uses helper syntactic extension set-of-help, passing it +;;; an initial base expression of '() +(define-syntax set-of + (syntax-rules () + ((_ e m ...) + (set-of-help e '() m ...)))) + +;;; set-of-help recognizes in, is, and predicate expressions and +;;; changes them into nested named let, let, and if expressions. +(define-syntax set-of-help + (syntax-rules (in is) + ((_ e base) + (set-cons e base)) + ((_ e base (x in s) m ...) + (let loop ((set s)) + (if (null? set) + base + (let ((x (car set))) + (set-of-help e (loop (cdr set)) m ...))))) + ((_ e base (x is y) m ...) + (let ((x y)) (set-of-help e base m ...))) + ((_ e base p m ...) + (if p (set-of-help e base m ...) base)))) + +;;; set-cons returns the original set y if x is already in y. +(define set-cons + (lambda (x y) + (if (memv x y) + y + (cons x y)))) diff --git a/examples/socket.ss b/examples/socket.ss new file mode 100644 index 0000000..6f3e7c0 --- /dev/null +++ b/examples/socket.ss @@ -0,0 +1,248 @@ +;;; socket.ss +;;; R. Kent Dybvig May 1998 +;;; Updated November 2005 +;;; Updated by Jamie Taylor, Sept 2016 +;;; Public Domain +;;; +;;; bindings for socket operations and other items useful for writing +;;; programs that use sockets. + +;;; Requires csocket.so, built from csocket.c. +;;; Example compilation command line from macOS: +;;; cc -c csocket.c -o csocket.o +;;; cc csocket.o -dynamic -dynamiclib -current_version 1.0 -compatibility_version 1.0 -o csocket.so +(load-shared-object "./csocket.so") + +;;; Requires from C library: +;;; close, dup, execl, fork, kill, listen, tmpnam, unlink +(case (machine-type) + [(i3le ti3le a6le ta6le) (load-shared-object "libc.so.6")] + [(i3osx ti3osx a6osx ta6osx) (load-shared-object "libc.dylib")] + [else (load-shared-object "libc.so")]) + +;;; basic C-library stuff + +(define close + (foreign-procedure "close" (int) + int)) + +(define dup + (foreign-procedure "dup" (int) + int)) + +(define execl4 + (let ((execl-help + (foreign-procedure "execl" + (string string string string void*) + int))) + (lambda (s1 s2 s3 s4) + (execl-help s1 s2 s3 s4 0)))) + +(define fork + (foreign-procedure "fork" () + int)) + +(define kill + (foreign-procedure "kill" (int int) + int)) + +(define listen + (foreign-procedure "listen" (int int) + int)) + +(define tmpnam + (foreign-procedure "tmpnam" (void*) + string)) + +(define unlink + (foreign-procedure "unlink" (string) + int)) + +;;; routines defined in csocket.c + +(define accept + (foreign-procedure "do_accept" (int) + int)) + +(define bytes-ready? + (foreign-procedure "bytes_ready" (int) + boolean)) + +(define bind + (foreign-procedure "do_bind" (int string) + int)) + +(define c-error + (foreign-procedure "get_error" () + string)) + +(define c-read + (foreign-procedure "c_read" (int u8* size_t size_t) + ssize_t)) + +(define c-write + (foreign-procedure "c_write" (int u8* size_t ssize_t) + ssize_t)) + +(define connect + (foreign-procedure "do_connect" (int string) + int)) + +(define socket + (foreign-procedure "do_socket" () + int)) + +;;; higher-level routines + +(define dodup + ; (dodup old new) closes old and dups new, then checks to + ; make sure that resulting fd is the same as old + (lambda (old new) + (check 'close (close old)) + (unless (= (dup new) old) + (error 'dodup + "couldn't set up child process io for fd ~s" old)))) + +(define dofork + ; (dofork child parent) forks a child process and invokes child + ; without arguments and parent with the child's pid + (lambda (child parent) + (let ([pid (fork)]) + (cond + [(= pid 0) (child)] + [(> pid 0) (parent pid)] + [else (error 'fork (c-error))])))) + +(define setup-server-socket + ; create a socket, bind it to name, and listen for connections + (lambda (name) + (let ([sock (check 'socket (socket))]) + (unlink name) + (check 'bind (bind sock name)) + (check 'listen (listen sock 1)) + sock))) + +(define setup-client-socket + ; create a socket and attempt to connect to server + (lambda (name) + (let ([sock (check 'socket (socket))]) + (check 'connect (connect sock name)) + sock))) + +(define accept-socket + ; accept a connection + (lambda (sock) + (check 'accept (accept sock)))) + +(define check + ; signal an error if status x is negative, using c-error to + ; obtain the operating-system's error message + (lambda (who x) + (if (< x 0) + (error who (c-error)) + x))) + +(define terminate-process + ; kill the process identified by pid + (lambda (pid) + (define sigterm 15) + (kill pid sigterm) + (void))) + +(define open-process + (lambda (command) + (define (make-r! socket) + (lambda (bv start n) + (check 'r! (c-read socket bv start n)))) + (define (make-w! socket) + (lambda (bv start n) + (check 'w! (c-write socket bv start n)))) + (define (make-close pid socket) + (lambda () + (check 'close (close socket)) + (terminate-process pid))) + (let* ([server-socket-name (tmpnam 0)] + [server-socket (setup-server-socket server-socket-name)]) + (dofork + (lambda () ; child + (check 'close (close server-socket)) + (let ([sock (setup-client-socket server-socket-name)]) + (dodup 0 sock) + (dodup 1 sock)) + (check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" command)) + (error 'open-process "subprocess exec failed")) + (lambda (pid) ; parent + (let ([sock (accept-socket server-socket)]) + (check 'close (close server-socket)) + (make-custom-binary-input/output-port command + (make-r! sock) (make-w! sock) #f #f (make-close pid sock)))))))) + +#!eof + +;;; sample session using base socket functionality + +> (define client-pid) +> (define client-socket) +> (let* ([server-socket-name (tmpnam 0)] + [server-socket (setup-server-socket server-socket-name)]) + ; fork a child, use it to exec a client Scheme process, and set + ; up server-side client-pid and client-socket variables. + (dofork ; child + (lambda () + ; the child establishes the socket input/output fds as + ; stdin and stdout, then starts a new Scheme session + (check 'close (close server-socket)) + (let ([sock (setup-client-socket server-socket-name)]) + (dodup 0 sock) + (dodup 1 sock)) + (check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" "exec scheme")) + (error 'client "returned!")) + (lambda (pid) ; parent + ; the parent waits for a connection from the client + (set! client-pid pid) + (set! client-socket (accept-socket server-socket)) + (check 'close (close server-socket))))) +> (define put ; procedure to send data to client + (lambda (x) + (let* ([s (format "~s~%" x)] + [bv (string->utf8 s)]) + (c-write client-socket bv 0 (bytevector-length bv))) + (void))) +> (define get ; procedure to read data from client + (let ([buff (make-bytevector 1024)]) + (lambda () + (let* ([n (c-read client-socket buff 0 (bytevector-length buff))] + [bv (make-bytevector n)]) + (bytevector-copy! buff 0 bv 0 n) + (printf "client:~%~a~%server:~%" (utf8->string bv)))))) +> (get) +client: +Chez Scheme Version 9.5.1 +Copyright 1984-2017 Cisco Systems, Inc. + +> +server: +> (put '(let ((x 3)) x)) +> (get) +client: +3 +> +server: +> (terminate-process client-pid) +> (exit) + + +;;; sample session using process port + +> (define p (transcoded-port (open-process "exec scheme -q") (native-transcoder))) +> (pretty-print '(+ 3 4) p) +> (read p) +7 +> (pretty-print '(define (f x) (if (= x 0) 1 (* x (f (- x 1))))) p) +> (pretty-print '(f 10) p) +> (read p) +3628800 +> (pretty-print '(exit) p) +> (read p) +#!eof +> (close-port p) diff --git a/examples/template.ss b/examples/template.ss new file mode 100644 index 0000000..5aa6161 --- /dev/null +++ b/examples/template.ss @@ -0,0 +1,858 @@ +#!chezscheme +;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. +;;; include-template: a simple yet powerful extensible templating mechanism +;;; +;;; Authors: Andrew W. Keep and R. Kent Dybvig +;;; +;;; The syntax (include-template ) expands into an expression whose +;;; value is a string containing the contents of the file named by , +;;; except each occurrence of @@ within the file is replaced by @, and each +;;; occurrence of @() is replaced with the value of +;;; . must be a string literal, and the value +;;; of each must be a string. The file named by +;;; must be present at expand time and need not be present at run time. +;;; +;;; The template system can also be extended using the syntax: +;;; +;;; (define-template-extension ) +;;; +;;; where: +;;; +;;; -> ( *) +;;; | +;;; -> (*) +;;; | +;;; -> +;;; | ( (*) ) ... +;;; | ( ) ... +;;; | (optional (*) +;;; ) +;;; | (optional ) +;;; -> (*) +;;; -> +;;; -> a - z | A - Z | ! | $ | % | & | * | / | : | < +;;; | = | > | ? | ^ | _ | ~ +;;; -> | 0 - 9 | - | + | . +;;; +;;; is treated as a quasisyntax template, +;;; is a syntax-rules pattern and, +;;; is any valid scheme identifier. +;;; +;;; For using a a new @ +;;; form is created and when the @(*) is encountered +;;; in a template, it is immediately replaced with the . +;;; +;;; For instance an extension that converts numbers to strings can be +;;; implemented as: +;;; +;;; (define-template-extension (num (e)) (number->string e)) +;;; +;;; When @num(10) is encountered in a template, the string "10" is generated. +;;; +;;; For with an each in the +;;; the define-template-extension will create a new syntax +;;; form @ along with an @end for the from the +;;; . When include-template encounters an +;;; @ ... @end pattern it will match the +;;; * (when supplied) against the following scheme expression +;;; and match the template expressions found between the @ to the +;;; matching bindings. +;;; +;;; For example, we can add a "for" loop extension as: +;;; +;;; (define-template-extension (for ([x e] [xs es] ...) tmpl) +;;; (let ([t e]) +;;; (apply string-append (map (lambda (x xs ...) tmpl) t es ...)))) +;;; +;;; (for (exprs ...) tmpl) +;;; => +;;; @for (lambda (...) +;;; (let ([t (read-scheme k...)]) +;;; (cons (incomplete-node @for t) ...))) +;;; @endfor (lambda (...) +;;; --- +;;; (let loop ([t '()] [tmpl '()] ...) +;;; (cond +;;; [(and (incomplete-node? (car stack)) (eq? (incomplete-node-kw (car stack)) '@for)) +;;; (with-syntax (['([x e] [xs es] ...) (incomplete-node-stx (car stack))]) +;;; '(let ([t e]) +;;; (apply string-append (map (lambda (x xs ...) tmpl) t es ..)))) +;;; +;;; In a template if: @for([x '("a" "b" "c")]) got @(t). @endfor +;;; is encountered, it will print the string " got a. got b. got c. " for +;;; this expression (which will be produced by the code: +;;; (apply string-append +;;; (map (lambda (x) (string-append " got " x ". ") '("a" "b" "c")))) +;;; +;;; For a more complex example see the @if/@elif/@else/@endif example at +;;; the end of the library. +;;; +;;; Additional examples are embedded within the tests below #!eof. + +;;; The (template-helpers) library supplies scheme procedures that are used at +;;; macro-expansion time by both the include-template and +;;; define-template-extension macros. +(library (template-helpers) + (export + incomplete-node? make-incomplete-node + incomplete-node-type incomplete-node-e* incomplete-node-bfp + source-string source-error + read-scheme initial-id-char? id-char? + make-string-buffer extend-string-buffer! extract-string-and-reset! + open-positional-string-output-port + strip-blanks) + (import (chezscheme)) + + (define (source-string sfd bfp) + (call-with-values + (lambda () (locate-source sfd bfp)) + (case-lambda + [() (format "at char position ~s of ~a" bfp + (source-file-descriptor-path sfd))] + [(path lp cp) (format "at line ~s, char ~s of ~a" lp cp + (source-file-descriptor-path sfd))]))) + + (define (source-error sfd bfp msg . args) + (errorf 'include-template "~? ~a" msg args (source-string sfd bfp))) + + (define (read-scheme k ip sfd bfp) + (let-values ([(x new-bfp) (get-datum/annotations ip sfd bfp)]) + (let ([x (if (annotation? x) (annotation-expression x) x)]) + (values (datum->syntax k x) new-bfp)))) + + (define-record-type incomplete-node (nongenerative) (fields type e* bfp)) + + (define (initial-id-char? c) + (or (char<=? #\a c #\z) (char<=? #\A c #\Z) + (char=? c #\!) (char<=? #\$ c #\&) + (char=? c #\*) (char=? c #\/) + (char=? c #\:) (char<=? #\< c #\?) + (char=? c #\^) (char=? c #\_) (char=? c #\~))) + + (define (id-char? c) + (or (initial-id-char? c) (char<=? #\0 c #\9) + (char=? c #\-) (char=? c #\+) (char=? c #\.))) + + (define-record-type string-buffer (nongenerative) + (fields (mutable n) (mutable str)) + (protocol (lambda (new) (lambda () (new 0 (make-string 16)))))) + (define (get-buffer tb n required-capacity) + (let* ([str (string-buffer-str tb)] [len (string-length str)]) + (if (fx< (fx- len n) required-capacity) + (let ([new-str (make-string (fx* 2 (fx+ len required-capacity)))]) + (string-copy! str 0 new-str 0 n) + (string-buffer-str-set! tb new-str) + new-str) + str))) + (define (extend-string-buffer! tb c) + (let ([n (string-buffer-n tb)]) + (string-set! (get-buffer tb n 1) n c) + (string-buffer-n-set! tb (fx+ n 1)))) + (define (append-to-string-buffer! tb str) + (let ([n (string-buffer-n tb)] [len (string-length str)]) + (string-copy! (get-buffer tb n len) n str 0 len) + (string-buffer-n-set! tb (fx+ n len)))) + (define (extract-string-and-reset! tb) + (let ([str (substring (string-buffer-str tb) 0 (string-buffer-n tb))]) + (string-buffer-n-set! tb 0) + str)) + (define (open-positional-string-output-port) + (define-record-type position (nongenerative) + (fields (mutable line) (mutable column)) + (protocol (lambda (new) (lambda () (new 1 1))))) + (let ([tb (make-string-buffer)] [pos (make-position)]) + (define (w! str start cnt) + (let* ([n (string-buffer-n tb)] + [buf (get-buffer tb n cnt)] + [end (fx+ start cnt)]) + (let loop! ([i start] [n n] [line (position-line pos)] [column (position-column pos)]) + (if (fx= i end) + (begin + (position-line-set! pos line) + (position-column-set! pos column) + (string-buffer-n-set! tb n)) + (let ([c (string-ref str i)]) + (string-set! buf n c) + (if (char=? c #\newline) + (loop! (fx+ i 1) (fx+ n 1) (fx+ line 1) 1) + (loop! (fx+ i 1) (fx+ n 1) line (fx+ column 1))))))) + cnt) + (define (gp) (string-buffer-n tb)) + (let ([op (make-custom-textual-output-port "positional-string-output-port" w! gp #f #f)]) + (define (line) (flush-output-port op) (position-line pos)) + (define (column) (flush-output-port op) (position-column pos)) + (define (p) (flush-output-port op) (extract-string-and-reset! tb)) + (values op p line column)))) + + ;; scan forward for blanks, and if it leads you to a new-line, strip + ;; the previous blanks back to the new line. + (define (finish-strip ip stack bfp start-bfp) + (let ([node-to-strip (car stack)]) + (if (string? node-to-strip) + (let loop ([i (string-length node-to-strip)]) + (if (fx= i 0) + (values (cdr stack) bfp) + (let ([i (fx- i 1)]) + (let ([c (string-ref node-to-strip i)]) + (cond + [(char=? c #\newline) + (values (cons (substring node-to-strip 0 (fx+ i 1)) (cdr stack)) bfp)] + [(char-whitespace? c) (loop i)] + [else (set-port-position! ip start-bfp) (values stack start-bfp)]))))) + (begin (set-port-position! ip start-bfp) (values stack start-bfp))))) + (define (strip-blanks ip stack start-bfp) + (let gather-blanks ([bfp start-bfp]) + (let ([c (read-char ip)]) + (cond + [(eof-object? c) (finish-strip ip stack bfp start-bfp)] + [(char=? c #\newline) (finish-strip ip stack (fx+ bfp 1) start-bfp)] + [(char-whitespace? c) (gather-blanks (fx+ bfp 1))] + [else (set-port-position! ip start-bfp) (values stack start-bfp)]))))) + +(library (template) + (export include-template define-template-extension optional @if @elif @else @endif @for @endfor @num) + (import (chezscheme) (template-helpers)) + + (define-syntax optional (lambda (x) (syntax-violation #f "misplaced aux keyword" x))) + + (define check-string-and-indent + (lambda (s at indent) + (unless (string? s) + (errorf 'include-template "unexpected non-string value ~s of expression ~s" s at)) + (if (= indent 0) + s + (let ([ip (open-string-input-port s)]) + (let ([first-line (get-line ip)]) + (if (eof-object? first-line) + s + (let-values ([(op p) (open-string-output-port)]) + (display first-line op) + (let ([indent (make-string indent #\space)]) + (let loop () + (let ([line (get-line ip)]) + (if (eof-object? line) + (begin + (when (char=? (string-ref s (fx- (string-length s) 1)) #\newline) (newline op)) + (p)) + (begin + (newline op) + (display indent op) + (display line op) + (loop))))))))))))) + + (define-syntax include-template + (lambda (x) + (define (process-template-file r fn k) + (let* ([bip (open-file-input-port fn)] + [sfd (make-source-file-descriptor fn bip #t)] + [ip (transcoded-port bip (native-transcoder))] + [tb (make-string-buffer)]) + (define (s0 a bfp) + (let ([c (read-char ip)]) + (cond + [(eof-object? c) + (close-input-port ip) + (reverse (cons (extract-string-and-reset! tb) a))] + [(char=? c #\@) (s1 a (+ bfp 1))] + [else (extend-string-buffer! tb c) (s0 a (+ bfp 1))]))) + (define (s1 a bfp) + (let ([c (read-char ip)]) + (cond + [(eof-object? c) (source-error sfd bfp "expected open paren or @ following @")] + [(eqv? c #\@) (extend-string-buffer! tb c) (s0 a (+ bfp 1))] + [(eqv? c #\() + (unread-char c ip) + (let-values ([(e* new-bfp) (read-scheme k ip sfd bfp)]) + (syntax-case e* () + [(e) + (s0 + (cons* + #`(check-string-and-indent e #,(source-string sfd bfp) (fx- (column) 1)) + (extract-string-and-reset! tb) + a) + new-bfp)] + [else (source-error sfd bfp "found more than one expression within @(---)")]))] + [(initial-id-char? c) + (let ([str (extract-string-and-reset! tb)]) + (extend-string-buffer! tb #\@) + (extend-string-buffer! tb c) + (s2 (cons str a) (+ bfp 1) bfp))] + [else (source-error sfd bfp "expected open paren or @ following @")]))) + (define (s2 a bfp token-start-bfp) + (let ([c (read-char ip)]) + (cond + [(eof-object? c) (close-input-port ip) (finish-identifier a bfp token-start-bfp)] + [(id-char? c) (extend-string-buffer! tb c) (s2 a (+ bfp 1) token-start-bfp)] + [else (unread-char c ip) (finish-identifier a bfp token-start-bfp)]))) + (define (finish-identifier a bfp token-bfp) + (let* ([token (extract-string-and-reset! tb)] + [@kw (datum->syntax k (string->symbol token))] + [p (r @kw)]) + (unless p (source-error sfd token-bfp "unrecognized token ~a" token)) + (call-with-values (lambda () (p k ip sfd a bfp token-bfp)) s0))) + (s0 '() 0))) + (syntax-case x () + [(k fn) + (string? (datum fn)) + (lambda (r) + (with-syntax ([(e ...) (process-template-file r (datum fn) #'k)]) + #'(let ([filename fn]) + (let-values ([(op p line column) (open-positional-string-output-port)]) + (display e op) ... + (p)))))]))) + + (define-syntax define-template-extension + (lambda (x) + (define who 'define-template-extension) + (define (make-prefix-id prefix kw) + (datum->syntax kw + (string->symbol + (string-append prefix (symbol->string (syntax->datum kw)))))) + (define build-matcher + (case-lambda + [(kw) + (with-syntax ([kw kw] [@kw (make-prefix-id "@" kw)]) + #'[@kw (lambda (k ip sfd stack bfp token-bfp) + (let-values ([(stack bfp) (strip-blanks ip stack bfp)]) + (values (cons (make-incomplete-node 'kw #f token-bfp) stack) bfp)))])] + [(kw expr) + (with-syntax ([kw kw] [@kw (make-prefix-id "@" kw)] [(expr ...) expr]) + #'[@kw (lambda (k ip sfd stack bfp token-bfp) + (let-values ([(e* new-bfp) (read-scheme k ip sfd bfp)]) + (syntax-case e* () + [(expr ...) + (let-values ([(stack new-bfp) (strip-blanks ip stack new-bfp)]) + (values (cons (make-incomplete-node 'kw e* token-bfp) stack) new-bfp))] + [_ (source-error sfd token-bfp "expected @~s~s syntax, but got @~s~s" + 'kw '(expr ...) 'kw (syntax->datum e*))])))])])) + (define (check-id id) + (let* ([str (symbol->string (syntax->datum id))] + [len (string-length str)]) + (unless (and (> len 0) (initial-id-char? (string-ref str 0)) + (let loop ([len len]) + (or (= len 0) + (let ([len (- len 1)]) + (and (id-char? (string-ref str len)) (loop len)))))) + (syntax-violation who "invalid template keyword" id)))) + (define (check-unique! type ids) + (let loop ([ids ids]) + (syntax-case ids () + [(id rest ...) + (if (memq (datum id) (datum (rest ...))) + (syntax-violation who (format "one or more ~a used more than once" type) #'id #'(rest ...)) + (loop #'(rest ...)))] + [() (void)]))) + (define (check-syntax-unique! type maybe-expr*) + (check-unique! type + (let f ([stx maybe-expr*] [ids '()]) + (syntax-case stx () + [id (and (identifier? #'id) (not (memq (datum id) '(... unquote quote)))) (cons #'id ids)] + [(a . d) (f #'a (f #'d ids))] + [_ ids])))) + (define (build-check kw tmpl x) + #`(unless #,(if x #`(and #,x #,tmpl) tmpl) + (source-error sfd token-bfp "found ~s without required ~s" token '#,kw))) + (define (build-initial-values bindings list?*) + (fold-right (lambda (binding list? init-val**) + (cons + (if list? + (make-list (length binding) #''()) + (make-list (length binding) #'#f)) + init-val**)) + '() bindings list?*)) + (define (build-bodies list?* tmpls updates bindings) + (let f ([list?* list?*] [tmpls tmpls] [updates updates] [bindings bindings] [rbindings '()]) + (if (null? list?*) + '() + (with-syntax ([(checks ...) + (if (car list?*) + '() + #`((when #,(car tmpls) + (source-error token-bfp "found more @~s than expected" type))))] + [((args ...) ...) (fold-left (lambda (args binding) (cons binding args)) + (cons (car updates) (cdr bindings)) rbindings)]) + (cons #'(begin checks ... (loop (cdr stack) '() args ... ...)) + (f (cdr list?*) (cdr tmpls) (cdr updates) (cdr bindings) (cons (car bindings) rbindings))))))) + (define (process-template output pat) + (define (squawk type) + (syntax-violation who (format "extension cannot start with ~s keyword" type) pat)) + (syntax-case pat (optional) + [((optional kw (expr ...) tmpl) . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (squawk 'optional)] + [((optional kw tmpl) . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (squawk 'optional)] + [((kw (expr ...) tmpl) dots . rest) + (and (eq? (datum dots) '...) (identifier? #'kw) (identifier? #'tmpl)) + (squawk 'list)] + [((kw tmpl) dots . rest) + (and (eq? (datum dots) '...) (identifier? #'kw) (identifier? #'tmpl)) + (squawk 'optional)] + [(kw (expr ...) tmpl . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (process-rest output #'kw #'rest + (list (build-matcher #'kw #'(expr ...))) + #'([tmpl #`(string-append #,@rstack)] + [(expr ...) (incomplete-node-e* item)]))] + [(kw tmpl . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (process-rest output #'kw #'rest (list (build-matcher #'kw)) + #'([tmpl #`(string-append #,@rstack)]))] + [(kw (expr ...)) + (with-syntax ([@kw (make-prefix-id "@" #'kw)] [output output]) + #'([@kw (lambda (k ip sfd stack bfp token-bfp) + (let-values ([(e* new-bfp) (read-scheme k ip sfd bfp)]) + (syntax-case e* () + [(expr ...) (values (cons #`output stack) new-bfp)] + [_ (source-error sfd token-bfp "expected @~s~s syntax, but got @~s~s" + 'kw '(expr ...) 'kw (syntax->datum e*))])))]))] + [(kw) + (with-syntax ([@kw (make-prefix-id "@" #'kw)] [output output]) + #'([@kw (lambda (k ip sfd stack bfp indent token-bfp) + (values (cons #`output stack) bfp indent))]))])) + (define (process-rest output first-kw rest as* matches) + (let f ([pat rest] + [as* as*] + [checks '()] + [kws '()] + [tmpls '()] + [list?* '()] + [bindings '()] + [updates '()] + [exprs '()] + [matches matches]) + (syntax-case pat (optional) + [((optional kw (expr ...) tmpl) . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (with-syntax ([(t) (generate-temporaries '(t))]) + (f #'rest + (cons (build-matcher #'kw #'(expr ...)) as*) checks + (cons #'kw kws) (cons #'tmpl tmpls) (cons #f list?*) + (cons (list #'tmpl #'t) bindings) + (cons (list #'#`(string-append #,@rstack) #'(incomplete-node-e* item)) updates) + (cons #'(expr ...) exprs) (cons* #'[tmpl tmpl] #'[(expr ...) #'t] matches)))] + [((optional kw tmpl) . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (f #'rest + (cons (build-matcher #'kw) as*) checks + (cons #'kw kws) (cons #'tmpl tmpls) (cons #f list?*) (cons (list #'tmpl) bindings) + (cons (list #'#`(string-append #,@rstack)) updates) + (cons #f exprs) (cons #'[tmpl tmpl] matches))] + [((kw (expr ...) tmpl) dots . rest) + (and (eq? (datum dots) '...) (identifier? #'kw) (identifier? #'tmpl)) + (with-syntax ([(t*) (generate-temporaries '(t*))]) + (f #'rest + (cons (build-matcher #'kw #'(expr ...)) as*) checks + (cons #'kw kws) (cons #'tmpl tmpls) (cons #t list?*) (cons (list #'tmpl #'t*) bindings) + (cons (list #'(cons #`(string-append #,@rstack) tmpl) #'(cons (incomplete-node-e* item) t*)) updates) + (cons #'(expr ...) exprs) (cons* #'[(tmpl (... ...)) tmpl] #'[((expr ...) (... ...)) t*] matches)))] + [((kw tmpl) dots . rest) + (and (eq? (datum dots) '...) (identifier? #'kw) (identifier? #'tmpl)) + (f #'rest + (cons (build-matcher #'kw) as*) checks + (cons #'kw kws) (cons #'tmpl tmpls) (cons #t list?*) (cons (list #'tmpl) bindings) + (cons (list #'(cons #`(string-append #,@rstack) tmpl)) updates) + (cons #f exprs) (cons* #'[(tmpl (... ...)) tmpl] matches))] + [(kw (expr ...) tmpl . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (with-syntax ([(t) (generate-temporaries '(t))]) + (f #'rest + (cons (build-matcher #'kw #'(expr ...)) as*) + (cons (build-check #'kw #'tmpl #'t) checks) + (cons #'kw kws) (cons #'tmpl tmpls) (cons #f list?*) (cons (list #'tmpl #'t) bindings) + (cons (list #'#`(string-append #,@rstack) #'(incomplete-node-e* item)) updates) + (cons #'(expr ...) exprs) (cons* #'[tmpl tmpl] #'[(expr ...) #'t] matches)))] + [(kw tmpl . rest) + (and (identifier? #'kw) (identifier? #'tmpl)) + (f #'rest + (cons (build-matcher #'kw) as*) + (cons (build-check #'kw #'tmpl #f) checks) + (cons #'kw kws) (cons #'tmpl tmpls) (cons #f list?*) (cons (list #'tmpl) bindings) + (cons (list #'#`(string-append #,@rstack)) updates) + (cons #f exprs) (cons #'[tmpl tmpl] matches))] + [() + (begin + (for-each check-id kws) + (check-unique! "keyword" kws) + (check-unique! "template bindings" tmpls) + (check-syntax-unique! "scheme syntax matching expressions" exprs) + (cons + (with-syntax ([startkw first-kw] + [endkw (make-prefix-id "end" first-kw)] + [@endkw (make-prefix-id "@end" first-kw)] + [output output] + [(matches ...) matches] + [(checks ...) checks] + [((x ...) ...) bindings] + [((init-val ...) ...) (build-initial-values bindings list?*)] + [(kw ...) kws] + [(body ...) (build-bodies list?* tmpls updates bindings)]) + #'[@endkw (lambda (k ip sfd stack bfp token-bfp) + (let-values ([(stack bfp) (strip-blanks ip stack bfp)]) + (let loop ([stack stack] [rstack '()] [x init-val] ... ...) + (if (null? stack) + (source-error sfd token-bfp "found @~s with no initial @~s" 'endkw 'startkw) + (let ([item (car stack)]) + (if (incomplete-node? item) + (let ([type (incomplete-node-type item)]) + (case type + [(startkw) checks ... + (with-syntax (matches ...) + (values (cons #`output (cdr stack)) bfp))] + [(kw) body] ... + [else (source-error sfd token-bfp + "found unexpected @~s (~a) instead of expected @~s before @~s" + type (source-string sfd (incomplete-node-bfp item)) 'startkw 'endkw)])) + (loop (cdr stack) (cons item rstack) x ... ...)))))))]) + as*))] + [_ (syntax-violation who "unrecognized pattern" pat)]))) + (syntax-case x () + [(_ pat output) + (with-syntax ([([@kw proc] ...) (process-template #'output #'pat)]) + #'(begin (define-syntax @kw (make-compile-time-value proc)) ...))]))) + + (define-template-extension (num (e)) (number->string e)) + + (define-template-extension (for ([binding e] [bindings es] ...) tmpl) + (with-output-to-string + (lambda () + (for-each (lambda (binding bindings ...) (display tmpl)) e es ...)))) + + (define-template-extension (if (expr) tmpl (elif (exprs) tmpls) ... (optional else else-tmpl)) + (if expr + tmpl + #,(let f ([exprs #'(exprs ...)] [tmpls #'(tmpls ...)]) + (if (null? exprs) + (or #'else-tmpl #'"") + (with-syntax ([expr (car exprs)] [tmpl (car tmpls)] [else (f (cdr exprs) (cdr tmpls))]) + #'(if expr + tmpl + else))))))) +#!eof +-------- saving remainder of file to /tmp/t and running /tmp/t should produce only "end of tests" -------- +#!/bin/tcsh + +cat >! /tmp/spam.h << END +extern void @(name)(void); +END + +cat >! /tmp/spam.c << END +#include + +@((include-template "/tmp/spam.h")) + +void @(name)() { + @(name)(); +} +END +scheme -q << END +(import (template)) +(unless (equal? + (let ([name "bob"]) (include-template "/tmp/spam.c")) + "#include \n\nextern void bob(void);\n\n\nvoid bob() {\n bob();\n}\n") + (error #f "test 1 failed")) +END + +cat >! /tmp/spam.c << END +(import (template)) +(unless (equal? + (guard (c [else (with-output-to-string (lambda () (display-condition c)))]) + (expand '(let ([name "bob"]) (include-template "/tmp/spam.c")))) + "Exception in get-datum/annotations: unexpected end-of-file reading list at line 6, char 4 of /tmp/spam.c") + (error #f "test 2 failed")) +END + +cat >! /tmp/spam.c << END +#include + +@((include-template "/tmp/spam.h")) + +void @(name)() { + @(name)(); + @ +} +END +scheme -q << END +(import (template)) +(unless (equal? + (guard (c [else (with-output-to-string (lambda () (display-condition c)))]) + (expand '(let ([name "bob"]) (include-template "/tmp/spam.c")))) + "Exception in include-template: expected open paren or @ following @ at line 7, char 4 of /tmp/spam.c") + (error #f "test 3 failed")) +END + +cat >! /tmp/spam.c << END +#include + +@((include-template "/tmp/spam.h")) + +void @(name)() { + @(name)(); +} +END +echo -n "@" >> /tmp/spam.c +scheme -q << END +(import (template)) +(unless (equal? + (guard (c [else (with-output-to-string (lambda () (display-condition c)))]) + (expand '(let ([name "bob"]) (include-template "/tmp/spam.c")))) + "Exception in include-template: expected open paren or @ following @ at line 8, char 2 of /tmp/spam.c") + (error #f "test 4 failed")) +END + +cat >! /tmp/spam.c << END +#include + +@((include-template #xGO! "/tmp/spam.h")) + +void @(name)() { + @(name)(); +} +END +echo -n "@" >> /tmp/spam.c +scheme -q << END +(import (template)) +(unless (equal? + (guard (c [else (with-output-to-string (lambda () (display-condition c)))]) + (expand '(let ([name "bob"]) (include-template "/tmp/spam.c")))) + "Exception in get-datum/annotations: invalid number syntax #xGO! at line 3, char 21 of /tmp/spam.c") + (error #f "test 5 failed")) +END + +cat >! /tmp/spam.c << END +#include + +@((include-template)) + +void @(name)() { + @(name)(); +} +END +scheme -q << END +(import (template)) +(unless (equal? + (guard (c [else (with-output-to-string (lambda () (display-condition c)))]) + (expand '(let ([name "bob"]) (include-template "/tmp/spam.c")))) + "Exception: invalid syntax (include-template) at line 3, char 3 of /tmp/spam.c") + (error #f "test 6 failed")) +END + +cat >! /tmp/spam.c < + +/* function: @(name) + * + * @@param: @(name) + */ +@((include-template "/tmp/spam.h")) + +void @(name)() { + @(name)(); +} +END +scheme -q << END +(import (template)) +(unless (equal? (let ([name "bob"]) (include-template "/tmp/spam.c")) + "#include \n\n/* function: bob\n *\n * @param: bob\n */\nextern void bob(void);\n\n\nvoid bob() {\n bob();\n}\n") + (error #f "test 7 failed")) +END + +cat >! /tmp/rockets <> /tmp/rockets <> /tmp/rockets <! /tmp/indent-test.c << END +#include + +int main(int argc, char *argv[]) { + @(body) +} +END +scheme -q << END +(import (template)) +(unless (equal? (let ([body "printf(\"Hello, world!\\\\n\");\nprintf(\"So... uh, what's going on?\\\\n\");\nprintf(\"Well, goodbye then.\\\\n\");"]) + (include-template "/tmp/indent-test.c")) + "#include \n\nint main(int argc, char *argv[]) {\n printf(\"Hello, world!\\\\n\");\n printf(\"So... uh, what's going on?\\\\n\");\n printf(\"Well, goodbye then.\\\\n\");\n}\n") + (error #f "test 17 failed")) +END +cat >! /tmp/hygeine << END +Hygiene test: + +@for([t i*]) + got @(t) . +@endfor + +@for([x j*]) + got @(x) and t is @(t). +@endfor + +@let([outer-t t]) + @for([x i*] [t j*]) + got @(x) and @(t) and @(outer-t). + @endfor +@endlet +END +scheme -q << END +(import (template)) +(let () + (define-template-extension (for ([x e] [xs es] ...) tmpl) + (let ([t e]) + (apply string-append (map (lambda (x xs ...) tmpl) t es ...)))) + (define-template-extension (let ([x e] [xs es] ...) tmpl) + (let ([x e] [xs es] ...) tmpl)) + (unless (equal? (let ([t "10"] [i* '("1" "2" "3")] [j* '("a" "b" "c")]) + (include-template "/tmp/hygeine")) + "Hygiene test:\n\n got 1 .\n got 2 .\n got 3 .\n\n got a and t is 10.\n got b and t is 10.\n got c and t is 10.\n\n got 1 and a and 10.\n got 2 and b and 10.\n got 3 and c and 10.\n") + (error #f "test 18 failed"))) +END +cat >! /tmp/indent << END +This is to test indents: + simple indent: @(x) + + nested indents: @(y) @(x) +END +scheme -q << END +(import (template)) +(unless (equal? (let ([x "a\nb\nc\n"] [y "x\ny\nz"]) + (include-template "/tmp/indent")) + "This is to test indents:\n simple indent: a\n b\n c\n\n\n nested indents: x\n y\n z a\n b\n c\n\n") + (error #f "test 19 failed")) +END +echo "end of tests" + diff --git a/examples/unify.ss b/examples/unify.ss new file mode 100644 index 0000000..756c27f --- /dev/null +++ b/examples/unify.ss @@ -0,0 +1,91 @@ +;;; unify.ss +;;; Copyright (C) 1996 R. Kent Dybvig +;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig + +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(define unify #f) +(let () + ;; occurs? returns true if and only if u occurs in v + (define occurs? + (lambda (u v) + (and (pair? v) + (let f ((l (cdr v))) + (and (pair? l) + (or (eq? u (car l)) + (occurs? u (car l)) + (f (cdr l)))))))) + + ;; sigma returns a new substitution procedure extending s by + ;; the substitution of u with v + (define sigma + (lambda (u v s) + (lambda (x) + (let f ((x (s x))) + (if (symbol? x) + (if (eq? x u) v x) + (cons (car x) (map f (cdr x)))))))) + + ;; try-subst tries to substitute u for v but may require a + ;; full unification if (s u) is not a variable, and it may + ;; fail if it sees that u occurs in v. + (define try-subst + (lambda (u v s ks kf) + (let ((u (s u))) + (if (not (symbol? u)) + (uni u v s ks kf) + (let ((v (s v))) + (cond + ((eq? u v) (ks s)) + ((occurs? u v) (kf "cycle")) + (else (ks (sigma u v s))))))))) + + ;; uni attempts to unify u and v with a continuation-passing + ;; style that returns a substitution to the success argument + ;; ks or an error message to the failure argument kf. The + ;; substitution itself is represented by a procedure from + ;; variables to terms. + (define uni + (lambda (u v s ks kf) + (cond + ((symbol? u) (try-subst u v s ks kf)) + ((symbol? v) (try-subst v u s ks kf)) + ((and (eq? (car u) (car v)) + (= (length u) (length v))) + (let f ((u (cdr u)) (v (cdr v)) (s s)) + (if (null? u) + (ks s) + (uni (car u) + (car v) + s + (lambda (s) (f (cdr u) (cdr v) s)) + kf)))) + (else (kf "clash"))))) + + ;; unify shows one possible interface to uni, where the initial + ;; substitution is the identity procedure, the initial success + ;; continuation returns the unified term, and the initial failure + ;; continuation returns the error message. + (set! unify + (lambda (u v) + (uni u + v + (lambda (x) x) + (lambda (s) (s u)) + (lambda (msg) msg))))) diff --git a/lz4/.circleci/config.yml b/lz4/.circleci/config.yml new file mode 100644 index 0000000..7f03d1a --- /dev/null +++ b/lz4/.circleci/config.yml @@ -0,0 +1,75 @@ +# This configuration was automatically generated from a CircleCI 1.0 config. +# It should include any build commands you had along with commands that CircleCI +# inferred from your project structure. We strongly recommend you read all the +# comments in this file to understand the structure of CircleCI 2.0, as the idiom +# for configuration has changed substantially in 2.0 to allow arbitrary jobs rather +# than the prescribed lifecycle of 1.0. In general, we recommend using this generated +# configuration as a reference rather than using it in production, though in most +# cases it should duplicate the execution of your original 1.0 config. +version: 2 +jobs: + build: + working_directory: ~/lz4/lz4 + # Parallelism is broken in this file : it just plays the same tests twice. + # The script will have to be modified to support parallelism properly + # In the meantime, set it to 1. + parallelism: 1 + shell: /bin/bash --login + # CircleCI 2.0 does not support environment variables that refer to each other the same way as 1.0 did. + # If any of these refer to each other, rewrite them so that they don't or see https://circleci.com/docs/2.0/env-vars/#interpolating-environment-variables-to-set-other-environment-variables . + environment: + CIRCLE_ARTIFACTS: /tmp/circleci-artifacts + CIRCLE_TEST_REPORTS: /tmp/circleci-test-results + # In CircleCI 1.0 we used a pre-configured image with a large number of languages and other packages. + # In CircleCI 2.0 you can now specify your own image, or use one of our pre-configured images. + # The following configuration line tells CircleCI to use the specified docker image as the runtime environment for you job. + # We have selected a pre-built image that mirrors the build environment we use on + # the 1.0 platform, but we recommend you choose an image more tailored to the needs + # of each job. For more information on choosing an image (or alternatively using a + # VM instead of a container) see https://circleci.com/docs/2.0/executor-types/ + # To see the list of pre-built images that CircleCI provides for most common languages see + # https://circleci.com/docs/2.0/circleci-images/ + docker: + - image: fbopensource/lz4-circleci-primary:0.0.4 + steps: + # Machine Setup + # If you break your build into multiple jobs with workflows, you will probably want to do the parts of this that are relevant in each + # The following `checkout` command checks out your code to your working directory. In 1.0 we did this implicitly. In 2.0 you can choose where in the course of a job your code should be checked out. + - checkout + # Prepare for artifact and test results collection equivalent to how it was done on 1.0. + # In many cases you can simplify this from what is generated here. + # 'See docs on artifact collection here https://circleci.com/docs/2.0/artifacts/' + - run: mkdir -p $CIRCLE_ARTIFACTS $CIRCLE_TEST_REPORTS + # Test + # This would typically be a build job when using workflows, possibly combined with build + # This is based on your 1.0 configuration file or project settings + - run: CFLAGS= make clangtest && make clean + - run: g++ -v; make gpptest && make clean + - run: gcc -v; g++ -v; make ctocpptest && make clean + - run: gcc-5 -v; CC=gcc-5 CFLAGS="-O2 -Werror" make check && make clean + - run: gcc-5 -v; CC=gcc-5 CFLAGS="-O2 -m32 -Werror" CPPFLAGS=-I/usr/include/x86_64-linux-gnu make check && make clean + - run: gcc-6 -v; CC=gcc-6 MOREFLAGS="-O2 -Werror" make check && make clean + - run: make cmake && make clean + - run: make -C tests test-lz4 + - run: make -C tests test-lz4c + - run: make -C tests test-frametest + - run: make -C tests test-fuzzer && make clean + - run: make -C lib all && make clean + - run: pyenv global 3.4.4; make versionsTest MOREFLAGS=-I/usr/include/x86_64-linux-gnu && make clean + - run: make travis-install && make clean + - run: gcc -v; CFLAGS="-O2 -m32 -Werror" CPPFLAGS=-I/usr/include/x86_64-linux-gnu make check && make clean + - run: clang -v; make staticAnalyze && make clean + - run: make platformTest CC=powerpc-linux-gnu-gcc QEMU_SYS=qemu-ppc-static && make clean + - run: make platformTest CC=powerpc-linux-gnu-gcc QEMU_SYS=qemu-ppc64-static MOREFLAGS=-m64 && make clean + - run: make platformTest CC=arm-linux-gnueabi-gcc QEMU_SYS=qemu-arm-static && make clean + - run: make platformTest CC=aarch64-linux-gnu-gcc QEMU_SYS=qemu-aarch64-static && make clean + # Teardown + # If you break your build into multiple jobs with workflows, you will probably want to do the parts of this that are relevant in each + # Save test results + - store_test_results: + path: /tmp/circleci-test-results + # Save artifacts + - store_artifacts: + path: /tmp/circleci-artifacts + - store_artifacts: + path: /tmp/circleci-test-results diff --git a/lz4/.circleci/images/primary/Dockerfile b/lz4/.circleci/images/primary/Dockerfile new file mode 100644 index 0000000..7767014 --- /dev/null +++ b/lz4/.circleci/images/primary/Dockerfile @@ -0,0 +1,12 @@ +FROM circleci/buildpack-deps:bionic + +RUN sudo apt-get -y -qq update +RUN sudo apt-get -y install software-properties-common +RUN sudo add-apt-repository -y ppa:ubuntu-toolchain-r/test +RUN sudo apt-get -y install cmake +RUN sudo apt-get -y install qemu-system-ppc qemu-user-static qemu-system-arm +RUN sudo apt-get -y install libc6-dev-armel-cross libc6-dev-arm64-cross libc6-dev-i386 +RUN sudo apt-get -y install clang clang-tools +RUN sudo apt-get -y install gcc-5 gcc-5-multilib gcc-6 +RUN sudo apt-get -y install valgrind +RUN sudo apt-get -y install gcc-multilib-powerpc-linux-gnu gcc-powerpc-linux-gnu gcc-arm-linux-gnueabi gcc-aarch64-linux-gnu diff --git a/lz4/.cirrus.yml b/lz4/.cirrus.yml new file mode 100644 index 0000000..0c0e7a7 --- /dev/null +++ b/lz4/.cirrus.yml @@ -0,0 +1,5 @@ +freebsd_instance: + image_family: freebsd-12-1 + +task: + script: pkg install -y gmake && gmake test diff --git a/lz4/.gitattributes b/lz4/.gitattributes new file mode 100644 index 0000000..6212bd4 --- /dev/null +++ b/lz4/.gitattributes @@ -0,0 +1,21 @@ +# Set the default behavior +* text eol=lf + +# Explicitly declare source files +*.c text eol=lf +*.h text eol=lf + +# Denote files that should not be modified. +*.odt binary +*.png binary + +# Visual Studio +*.sln text eol=crlf +*.vcxproj* text eol=crlf +*.vcproj* text eol=crlf +*.suo binary +*.rc text eol=crlf + +# Windows +*.bat text eol=crlf +*.cmd text eol=crlf diff --git a/lz4/.github/ISSUE_TEMPLATE/bug_report.md b/lz4/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 0000000..86b7696 --- /dev/null +++ b/lz4/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,32 @@ +--- +name: Bug report +about: Create a report to help us improve +title: '' +labels: '' +assignees: '' + +--- + +**Describe the bug** +A clear and concise description of what the bug is. + +**Expected behavior** +Please describe what you expected to happen. + +**To Reproduce** +Steps to reproduce the behavior: +1. Go to '...' +2. Click on '....' +3. Scroll down to '....' +4. See error '...' +If applicable, add screenshots to help explain your problem. + +**System (please complete the following information):** + - OS: [e.g. Mac] + - Version [e.g. 22] + - Compiler [e.g. gcc] + - Build System [e.g. Makefile] + - Other hardware specs [e.g Core 2 duo...] + +**Additional context** +Add any other context about the problem here. diff --git a/lz4/.github/ISSUE_TEMPLATE/feature_request.md b/lz4/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 0000000..bbcbbe7 --- /dev/null +++ b/lz4/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,20 @@ +--- +name: Feature request +about: Suggest an idea for this project +title: '' +labels: '' +assignees: '' + +--- + +**Is your feature request related to a problem? Please describe.** +A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] + +**Describe the solution you'd like** +A clear and concise description of what you want to happen. + +**Describe alternatives you've considered** +A clear and concise description of any alternative solutions or features you've considered. + +**Additional context** +Add any other context or screenshots about the feature request here. diff --git a/lz4/.gitignore b/lz4/.gitignore new file mode 100644 index 0000000..d7ba96e --- /dev/null +++ b/lz4/.gitignore @@ -0,0 +1,41 @@ +# Object files +*.o +*.ko + +# Libraries +*.lib +*.a + +# Shared objects (inc. Windows DLLs) +*.dll +*.so +*.so.* +*.dylib +*.dSYM # apple + +# Executables +*.exe +*.out +*.app +lz4 + +# IDE / editors files +.clang_complete +_codelite/ +_codelite_lz4/ +bin/ +*.zip + +# analyzers +infer-out + +# Mac +.DS_Store +*.dSYM + +# Windows / Msys +nul +ld.exe* + +# test files +*.lz4 diff --git a/lz4/.travis.yml b/lz4/.travis.yml new file mode 100644 index 0000000..f201d52 --- /dev/null +++ b/lz4/.travis.yml @@ -0,0 +1,236 @@ +language: c + +matrix: + fast_finish: true + include: + # OS X Mavericks + - name: (macOS) General Test + os: osx + compiler: clang + script: + - make # test library build + - make clean + - make test MOREFLAGS='-Werror -Wconversion -Wno-sign-conversion' | tee # test scenario where `stdout` is not the console + + # Container-based 12.04 LTS Server Edition 64 bit (doesn't support 32-bit includes) + - name: (Precise) benchmark test + dist: precise + script: + - make -C tests test-lz4 test-lz4c test-fullbench + + - name: (Precise) frame and fuzzer test + dist: precise + install: + - sudo sysctl -w vm.mmap_min_addr=4096 + script: + - make -C tests test-frametest test-fuzzer + + - name: ASAN tests with fuzzer and frametest + install: + - sudo sysctl -w vm.mmap_min_addr=4096 + script: + - CC=clang MOREFLAGS=-fsanitize=address make -C tests test-frametest test-fuzzer + + - name: Custom LZ4_DISTANCE_MAX ; lz4-wlib (CLI linked to dynamic library); LZ4_USER_MEMORY_FUNCTIONS + script: + - MOREFLAGS=-DLZ4_DISTANCE_MAX=8000 make check + - make clean + - make -C programs lz4-wlib + - make clean + - make -C tests fullbench-wmalloc # test LZ4_USER_MEMORY_FUNCTIONS + - make clean + - CC="c++ -Wno-deprecated" make -C tests fullbench-wmalloc # stricter function signature check + + - name: (Precise) g++ and clang CMake test + dist: precise + script: + - make gpptest + - make clean + - make examples + - make clean cmake + - make clean travis-install + - make clean clangtest + + - name: x32 compatibility test + addons: + apt: + packages: + - gcc-multilib + script: + - make -C tests test MOREFLAGS=-mx32 + + # 14.04 LTS Server Edition 64 bit + # presume clang >= v3.9.0 + - name: (Trusty) USan test + dist: trusty + compiler: clang + script: + - make usan MOREFLAGS=-Wcomma -Werror + + - name: (Trusty) valgrind test + dist: trusty + install: + - sudo apt-get install -qq valgrind + script: + - make c_standards + - make -C tests test-lz4 test-mem + + - name: (Trusty) c-to-c++ test + dist: trusty + script: + - make ctocpptest + + - name: (Trusty) i386 benchmark + version test + dist: trusty + install: + - sudo apt-get install -qq python3 libc6-dev-i386 gcc-multilib + script: + - make -C tests test-lz4c32 test-fullbench32 versionsTest + + - name: (Trusty) i386 frame + fuzzer test + dist: trusty + install: + - sudo apt-get install -qq libc6-dev-i386 gcc-multilib + - sudo sysctl -w vm.mmap_min_addr=4096 + script: + - make -C tests test-frametest32 test-fuzzer32 + + - name: (Trusty) gcc-6 standard C compilation + dist: trusty + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - gcc-6 + env: + - CC=gcc-6 + script: + - make c_standards + - make -C tests test-lz4 MOREFLAGS=-Werror + + - name: (Trusty) arm + aarch64 compilation + dist: trusty + install: + - sudo apt-get install -qq + qemu-system-arm + qemu-user-static + gcc-arm-linux-gnueabi + libc6-dev-armel-cross + gcc-aarch64-linux-gnu + libc6-dev-arm64-cross + script: + - make platformTest CC=arm-linux-gnueabi-gcc QEMU_SYS=qemu-arm-static + - make platformTest CC=aarch64-linux-gnu-gcc QEMU_SYS=qemu-aarch64-static + + - name: aarch64 real-hw tests + arch: arm64 + script: + - make test + + - name: PPC64LE real-hw tests + arch: ppc64le + script: + - make test + + - name: IBM s390x real-hw tests + arch: s390x + script: + - make test + + - name: (Xenial) gcc-5 compilation + dist: xenial + install: + - sudo apt-get install -qq libc6-dev-i386 gcc-multilib + script: + - make -C tests test-lz4 clean test-lz4c32 MOREFLAGS=-Werror + + - name: (Trusty) clang-3.8 compilation + dist: trusty + addons: + apt: + sources: + - ubuntu-toolchain-r-test + - llvm-toolchain-precise-3.8 + packages: + - clang-3.8 + script: + - make -C tests test-lz4 CC=clang-3.8 + + - name: (Trusty) PowerPC + PPC64 compilation + dist: trusty + install: + - sudo apt-get install -qq qemu-system-ppc qemu-user-static gcc-powerpc-linux-gnu + script: + - make platformTest CC=powerpc-linux-gnu-gcc QEMU_SYS=qemu-ppc-static + - make platformTest CC=powerpc-linux-gnu-gcc QEMU_SYS=qemu-ppc64-static MOREFLAGS=-m64 + + - name: (Trusty) scan-build + cppcheck + dist: trusty + compiler: clang + install: + - sudo apt-get install -qq cppcheck + script: + - make staticAnalyze + - make cppcheck + + - name: (Trusty) gcc-4.4 compilation + dist: trusty + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - libc6-dev-i386 + - gcc-multilib + - gcc-4.4 + script: + - make clean all CC=gcc-4.4 MOREFLAGS=-Werror + - make clean + - CFLAGS=-fPIC LDFLAGS='-pie -fPIE -D_FORTIFY_SOURCE=2' make -C programs + + # tag-specific test + - name: tag build + if: tag =~ ^v[0-9]\.[0-9] + os: linux + script: + - make -C tests checkTag + - tests/checkTag "$TRAVIS_BRANCH" + + - name: (Xenial) Meson + clang build + #env: ALLOW_FAILURES=true + dist: xenial + language: cpp + compiler: clang + install: + - sudo apt-get install -qq python3 tree + - | + travis_retry curl -o ~/ninja.zip -L 'https://github.com/ninja-build/ninja/releases/download/v1.9.0/ninja-linux.zip' && + unzip ~/ninja.zip -d ~/.local/bin + - | + travis_retry curl -o ~/get-pip.py 'https://bootstrap.pypa.io/get-pip.py' && + python3 ~/get-pip.py --user && + pip3 install --user meson + script: + - | + meson setup \ + --buildtype=debug \ + -Db_lundef=false \ + -Dauto_features=enabled \ + -Ddefault_library=both \ + -Dbin_programs=true \ + -Dbin_contrib=true \ + -Dbin_tests=true \ + -Dbin_examples=true \ + contrib/meson build + - pushd build + - DESTDIR=./staging ninja install + - tree ./staging + + # oss-fuzz compilation test + - name: Compile OSS-Fuzz targets + script: + - ./ossfuzz/travisoss.sh + + allow_failures: + - env: ALLOW_FAILURES=true diff --git a/lz4/INSTALL b/lz4/INSTALL new file mode 100644 index 0000000..6aab067 --- /dev/null +++ b/lz4/INSTALL @@ -0,0 +1,16 @@ +Installation +============= + +``` +make +make install # this command may require root access +``` + +LZ4's `Makefile` supports standard [Makefile conventions], +including [staged installs], [redirection], or [command redefinition]. +It is compatible with parallel builds (`-j#`). + +[Makefile conventions]: https://www.gnu.org/prep/standards/html_node/Makefile-Conventions.html +[staged installs]: https://www.gnu.org/prep/standards/html_node/DESTDIR.html +[redirection]: https://www.gnu.org/prep/standards/html_node/Directory-Variables.html +[command redefinition]: https://www.gnu.org/prep/standards/html_node/Utilities-in-Makefiles.html diff --git a/lz4/LICENSE b/lz4/LICENSE new file mode 100644 index 0000000..c221aeb --- /dev/null +++ b/lz4/LICENSE @@ -0,0 +1,11 @@ +This repository uses 2 different licenses : +- all files in the `lib` directory use a BSD 2-Clause license +- all other files use a GPLv2 license, unless explicitly stated otherwise + +Relevant license is reminded at the top of each source file, +and with presence of COPYING or LICENSE file in associated directories. + +This model is selected to emphasize that +files in the `lib` directory are designed to be included into 3rd party applications, +while all other files, in `programs`, `tests` or `examples`, +receive more limited attention and support for such scenario. diff --git a/lz4/Makefile b/lz4/Makefile new file mode 100644 index 0000000..744005f --- /dev/null +++ b/lz4/Makefile @@ -0,0 +1,208 @@ +# ################################################################ +# LZ4 - Makefile +# Copyright (C) Yann Collet 2011-present +# All rights reserved. +# +# BSD license +# 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. +# +# 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 HOLDER 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. +# +# You can contact the author at : +# - LZ4 source repository : https://github.com/lz4/lz4 +# - LZ4 forum froup : https://groups.google.com/forum/#!forum/lz4c +# ################################################################ + +LZ4DIR = lib +PRGDIR = programs +TESTDIR = tests +EXDIR = examples +FUZZDIR = ossfuzz + +include Makefile.inc + +.PHONY: default +default: lib-release lz4-release + +.PHONY: all +all: allmost examples manuals build_tests + +.PHONY: allmost +allmost: lib lz4 + +.PHONY: lib lib-release liblz4.a +lib: liblz4.a +lib lib-release liblz4.a: + @$(MAKE) -C $(LZ4DIR) $@ + +.PHONY: lz4 lz4-release +lz4 : liblz4.a +lz4-release : lib-release +lz4 lz4-release : + @$(MAKE) -C $(PRGDIR) $@ + @cp $(PRGDIR)/lz4$(EXT) . + +.PHONY: examples +examples: liblz4.a + $(MAKE) -C $(EXDIR) all + +.PHONY: manuals +manuals: + @$(MAKE) -C contrib/gen_manual $@ + +.PHONY: build_tests +build_tests: + @$(MAKE) -C $(TESTDIR) all + +.PHONY: clean +clean: + @$(MAKE) -C $(LZ4DIR) $@ > $(VOID) + @$(MAKE) -C $(PRGDIR) $@ > $(VOID) + @$(MAKE) -C $(TESTDIR) $@ > $(VOID) + @$(MAKE) -C $(EXDIR) $@ > $(VOID) + @$(MAKE) -C $(FUZZDIR) $@ > $(VOID) + @$(MAKE) -C contrib/gen_manual $@ > $(VOID) + @$(RM) lz4$(EXT) + @echo Cleaning completed + + +#----------------------------------------------------------------------------- +# make install is validated only for Linux, OSX, BSD, Hurd and Solaris targets +#----------------------------------------------------------------------------- +ifeq ($(POSIX_ENV),Yes) +HOST_OS = POSIX + +.PHONY: install uninstall +install uninstall: + @$(MAKE) -C $(LZ4DIR) $@ + @$(MAKE) -C $(PRGDIR) $@ + +travis-install: + $(MAKE) -j1 install DESTDIR=~/install_test_dir + +cmake: + @cd build/cmake; cmake $(CMAKE_PARAMS) CMakeLists.txt; $(MAKE) + +endif + + +ifneq (,$(filter MSYS%,$(shell uname))) +HOST_OS = MSYS +CMAKE_PARAMS = -G"MSYS Makefiles" +endif + + +#------------------------------------------------------------------------ +#make tests validated only for MSYS, Linux, OSX, kFreeBSD and Hurd targets +#------------------------------------------------------------------------ +ifneq (,$(filter $(HOST_OS),MSYS POSIX)) + +.PHONY: list +list: + @$(MAKE) -pRrq -f $(lastword $(MAKEFILE_LIST)) : 2>/dev/null | awk -v RS= -F: '/^# File/,/^# Finished Make data base/ {if ($$1 !~ "^[#.]") {print $$1}}' | sort | egrep -v -e '^[^[:alnum:]]' -e '^$@$$' | xargs + +.PHONY: check +check: + $(MAKE) -C $(TESTDIR) test-lz4-essentials + +.PHONY: test +test: + CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" $(MAKE) -C $(TESTDIR) $@ + CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" $(MAKE) -C $(EXDIR) $@ + +clangtest: CFLAGS ?= -O3 +clangtest: CFLAGS += -Werror -Wconversion -Wno-sign-conversion +clangtest: CC = clang +clangtest: clean + $(CC) -v + @CFLAGS="$(CFLAGS)" $(MAKE) -C $(LZ4DIR) all CC=$(CC) + @CFLAGS="$(CFLAGS)" $(MAKE) -C $(PRGDIR) all CC=$(CC) + @CFLAGS="$(CFLAGS)" $(MAKE) -C $(TESTDIR) all CC=$(CC) + +clangtest-native: clean + clang -v + @CFLAGS="-O3 -Werror -Wconversion -Wno-sign-conversion" $(MAKE) -C $(LZ4DIR) all CC=clang + @CFLAGS="-O3 -Werror -Wconversion -Wno-sign-conversion" $(MAKE) -C $(PRGDIR) native CC=clang + @CFLAGS="-O3 -Werror -Wconversion -Wno-sign-conversion" $(MAKE) -C $(TESTDIR) native CC=clang + +usan: CC = clang +usan: CFLAGS = -O3 -g -fsanitize=undefined -fno-sanitize-recover=undefined -fsanitize-recover=pointer-overflow +usan: LDFLAGS = $(CFLAGS) +usan: clean + CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" $(MAKE) test FUZZER_TIME="-T30s" NB_LOOPS=-i1 + +usan32: clean + CFLAGS="-m32 -O3 -g -fsanitize=undefined" $(MAKE) test FUZZER_TIME="-T30s" NB_LOOPS=-i1 + +SCANBUILD ?= scan-build +SCANBUILD_FLAGS += --status-bugs -v --force-analyze-debug-code +.PHONY: staticAnalyze +staticAnalyze: clean + CPPFLAGS=-DLZ4_DEBUG=1 CFLAGS=-g $(SCANBUILD) $(SCANBUILD_FLAGS) $(MAKE) all V=1 DEBUGLEVEL=1 + +.PHONY: cppcheck +cppcheck: + cppcheck . --force --enable=warning,portability,performance,style --error-exitcode=1 > /dev/null + +platformTest: clean + @echo "\n ---- test lz4 with $(CC) compiler ----" + @$(CC) -v + CFLAGS="-O3 -Werror" $(MAKE) -C $(LZ4DIR) all + CFLAGS="-O3 -Werror -static" $(MAKE) -C $(PRGDIR) all + CFLAGS="-O3 -Werror -static" $(MAKE) -C $(TESTDIR) all + $(MAKE) -C $(TESTDIR) test-platform + +.PHONY: versionsTest +versionsTest: clean + $(MAKE) -C $(TESTDIR) $@ + +gpptest gpptest32: CC = "$(CXX) -Wno-deprecated" +gpptest gpptest32: CFLAGS = -O3 -Wall -Wextra -Wundef -Wshadow -Wcast-align -Werror +gpptest32: CFLAGS += -m32 +gpptest gpptest32: clean + $(CXX) -v + CC=$(CC) $(MAKE) -C $(LZ4DIR) all CFLAGS="$(CFLAGS)" + CC=$(CC) $(MAKE) -C $(PRGDIR) all CFLAGS="$(CFLAGS)" + CC=$(CC) $(MAKE) -C $(TESTDIR) all CFLAGS="$(CFLAGS)" + +cxx17build : CC = "$(CXX) -Wno-deprecated" +cxx17build : CFLAGS = -std=c++17 -Wall -Wextra -Wundef -Wshadow -Wcast-align -Werror -pedantic +cxx17build : clean + $(CXX) -v + CC=$(CC) $(MAKE) -C $(LZ4DIR) all CFLAGS="$(CFLAGS)" + CC=$(CC) $(MAKE) -C $(PRGDIR) all CFLAGS="$(CFLAGS)" + CC=$(CC) $(MAKE) -C $(TESTDIR) all CFLAGS="$(CFLAGS)" + +ctocpptest: LIBCC="$(CC)" +ctocpptest: TESTCC="$(CXX)" +ctocpptest: CFLAGS="" +ctocpptest: clean + CC=$(LIBCC) $(MAKE) -C $(LZ4DIR) CFLAGS="$(CFLAGS)" all + CC=$(LIBCC) $(MAKE) -C $(TESTDIR) CFLAGS="$(CFLAGS)" lz4.o lz4hc.o lz4frame.o + CC=$(TESTCC) $(MAKE) -C $(TESTDIR) CFLAGS="$(CFLAGS)" all + +c_standards: clean + $(MAKE) clean; CFLAGS="-std=c90 -Werror -pedantic -Wno-long-long -Wno-variadic-macros" $(MAKE) allmost + $(MAKE) clean; CFLAGS="-std=gnu90 -Werror -pedantic -Wno-long-long -Wno-variadic-macros" $(MAKE) allmost + $(MAKE) clean; CFLAGS="-std=c99 -Werror -pedantic" $(MAKE) all + $(MAKE) clean; CFLAGS="-std=gnu99 -Werror -pedantic" $(MAKE) all + $(MAKE) clean; CFLAGS="-std=c11 -Werror" $(MAKE) all + +endif diff --git a/lz4/Makefile.inc b/lz4/Makefile.inc new file mode 100644 index 0000000..2d64405 --- /dev/null +++ b/lz4/Makefile.inc @@ -0,0 +1,87 @@ +ifeq ($(V), 1) +Q = +else +Q = @ +endif + +TARGET_OS ?= $(shell uname) +ifeq ($(TARGET_OS),) + TARGET_OS ?= $(OS) +endif + +ifneq (,$(filter Windows%,$(TARGET_OS))) +LIBLZ4 = liblz4-$(LIBVER_MAJOR) +LIBLZ4_EXP = liblz4.lib +WINBASED = yes +else +LIBLZ4_EXP = liblz4.dll.a + ifneq (,$(filter MINGW%,$(TARGET_OS))) +LIBLZ4 = liblz4 +WINBASED = yes + else + ifneq (,$(filter MSYS%,$(TARGET_OS))) +LIBLZ4 = msys-lz4-$(LIBVER_MAJOR) +WINBASED = yes + else + ifneq (,$(filter CYGWIN%,$(TARGET_OS))) +LIBLZ4 = cyglz4-$(LIBVER_MAJOR) +WINBASED = yes + else +LIBLZ4 = liblz4.$(SHARED_EXT_VER) +WINBASED = no +EXT = + endif + endif + endif +endif + +ifeq ($(WINBASED),yes) +EXT = .exe +WINDRES = windres +endif + +#determine if dev/nul based on host environment +ifneq (,$(filter MINGW% MSYS% CYGWIN%,$(shell uname))) +VOID := /dev/null +else + ifneq (,$(filter Windows%,$(OS))) +VOID := nul + else +VOID := /dev/null + endif +endif + +ifneq (,$(filter Linux Darwin GNU/kFreeBSD GNU OpenBSD FreeBSD NetBSD DragonFly SunOS Haiku MidnightBSD MINGW% CYGWIN% MSYS%,$(shell uname))) +POSIX_ENV = Yes +else +POSIX_ENV = No +endif + +# Avoid symlinks when targetting Windows or building on a Windows host +ifeq ($(WINBASED),yes) +LN_S = cp -p +LN_SF = cp -p +else + ifneq (,$(filter MINGW% MSYS% CYGWIN%,$(shell uname))) +LN_S = cp -p +LN_SF = cp -p + else + ifneq (,$(filter Windows%,$(OS))) +LN_S = cp -p +LN_SF = cp -p + else +LN_S = ln -s +LN_SF = ln -sf + endif + endif +endif + +ifneq (,$(filter $(shell uname),SunOS)) +INSTALL ?= ginstall +else +INSTALL ?= install +endif + +INSTALL_PROGRAM ?= $(INSTALL) -m 755 +INSTALL_DATA ?= $(INSTALL) -m 644 +INSTALL_DIR ?= $(INSTALL) -d -m 755 diff --git a/lz4/NEWS b/lz4/NEWS new file mode 100644 index 0000000..401931e --- /dev/null +++ b/lz4/NEWS @@ -0,0 +1,320 @@ +v1.9.3 +perf: highly improved speed in kernel space, by @terrelln +perf: faster speed with Visual Studio, thanks to @wolfpld and @remittor +perf: improved dictionary compression speed, by @felixhandte +perf: fixed LZ4_compress_HC_destSize() ratio, detected by @hsiangkao +perf: reduced stack usage in high compression mode, by @Yanpas +api : LZ4_decompress_safe_partial() supports unknown compressed size, requested by @jfkthame +api : improved LZ4F_compressBound() with automatic flushing, by Christopher Harvie +api : can (de)compress to/from NULL without UBs +api : fix alignment test on 32-bit systems (state initialization) +api : fix LZ4_saveDictHC() in corner case scenario, detected by @IgorKorkin +cli : `-l` legacy format is now compatible with `-m` multiple files, by Filipe Calasans +cli : benchmark mode supports dictionary, by @rkoradi +cli : fix --fast with large argument, detected by @picoHz +build: link to user-defined memory functions with LZ4_USER_MEMORY_FUNCTIONS, suggested by Yuriy Levchenko +build: contrib/cmake_unofficial/ moved to build/cmake/ +build: visual/* moved to build/ +build: updated meson script, by @neheb +build: tinycc support, by Anton Kochkov +install: Haiku support, by Jerome Duval +doc : updated LZ4 frame format, clarify EndMark + +v1.9.2 +fix : out-of-bound read in exceptional circumstances when using decompress_partial(), by @terrelln +fix : slim opportunity for out-of-bound write with compress_fast() with a large enough input and when providing an output smaller than recommended (< LZ4_compressBound(inputSize)), by @terrelln +fix : rare data corruption bug with LZ4_compress_destSize(), by @terrelln +fix : data corruption bug when Streaming with an Attached Dict in HC Mode, by @felixhandte +perf: enable LZ4_FAST_DEC_LOOP on aarch64/GCC by default, by @prekageo +perf: improved lz4frame streaming API speed, by @dreambottle +perf: speed up lz4hc on slow patterns when using external dictionary, by @terrelln +api: better in-place decompression and compression support +cli : --list supports multi-frames files, by @gstedman +cli: --version outputs to stdout +cli : add option --best as an alias of -12 , by @Low-power +misc: Integration into oss-fuzz by @cmeister2, expanded list of scenarios by @terrelln + +v1.9.1 +fix : decompression functions were reading a few bytes beyond input size (introduced in v1.9.0, reported by @ppodolsky and @danlark1) +api : fix : lz4frame initializers compatibility with c++, reported by @degski +cli : added command --list, based on a patch by @gabrielstedman +build: improved Windows build, by @JPeterMugaas +build: AIX, by Norman Green + +v1.9.0 +perf: large decompression speed improvement on x86/x64 (up to +20%) by @djwatson +api : changed : _destSize() compression variants are promoted to stable API +api : new : LZ4_initStream(HC), replacing LZ4_resetStream(HC) +api : changed : LZ4_resetStream(HC) as recommended reset function, for better performance on small data +cli : support custom block sizes, by @blezsan +build: source code can be amalgamated, by Bing Xu +build: added meson build, by @lzutao +build: new build macros : LZ4_DISTANCE_MAX, LZ4_FAST_DEC_LOOP +install: MidnightBSD, by @laffer1 +install: msys2 on Windows 10, by @vtorri + +v1.8.3 +perf: minor decompression speed improvement (~+2%) with gcc +fix : corruption in v1.8.2 at level 9 for files > 64KB under rare conditions (#560) +cli : new command --fast, by @jennifermliu +cli : fixed elapsed time, and added cpu load indicator (on -vv) (#555) +api : LZ4_decompress_safe_partial() now decodes exactly the nb of bytes requested (feature request #566) +build : added Haiku target, by @fbrosson, and MidnightBSD, by @laffer1 +doc : updated documentation regarding dictionary compression + +v1.8.2 +perf: *much* faster dictionary compression on small files, by @felixhandte +perf: improved decompression speed and binary size, by Alexey Tourbin (@svpv) +perf: slightly faster HC compression and decompression speed +perf: very small compression ratio improvement +fix : compression compatible with low memory addresses (< 0xFFFF) +fix : decompression segfault when provided with NULL input, by @terrelln +cli : new command --favor-decSpeed +cli : benchmark mode more accurate for small inputs +fullbench : can bench _destSize() variants, by @felixhandte +doc : clarified block format parsing restrictions, by Alexey Tourbin (@svpv) + +v1.8.1 +perf : faster and stronger ultra modes (levels 10+) +perf : slightly faster compression and decompression speed +perf : fix bad degenerative case, reported by @c-morgenstern +fix : decompression failed when using a combination of extDict + low memory address (#397), reported and fixed by Julian Scheid (@jscheid) +cli : support for dictionary compression (`-D`), by Felix Handte @felixhandte +cli : fix : `lz4 -d --rm` preserves timestamp (#441) +cli : fix : do not modify /dev/null permission as root, by @aliceatlas +api : `_destSize()` variant supported for all compression levels +build : `make` and `make test` compatible with `-jX`, reported by @mwgamera +build : can control LZ4LIB_VISIBILITY macro, by @mikir +install: fix man page directory (#387), reported by Stuart Cardall (@itoffshore) + +v1.8.0 +cli : fix : do not modify /dev/null permissions, reported by @Maokaman1 +cli : added GNU separator -- specifying that all following arguments are files +API : added LZ4_compress_HC_destSize(), by Oleg (@remittor) +API : added LZ4F_resetDecompressionContext() +API : lz4frame : negative compression levels trigger fast acceleration, request by Lawrence Chan +API : lz4frame : can control block checksum and dictionary ID +API : fix : expose obsolete decoding functions, reported by Chen Yufei +API : experimental : lz4frame_static : new dictionary compression API +build : fix : static lib installation, by Ido Rosen +build : dragonFlyBSD, OpenBSD, NetBSD supported +build : LZ4_MEMORY_USAGE can be modified at compile time, through external define +doc : Updated LZ4 Frame format to v1.6.0, restoring Dictionary-ID field +doc : lz4 api manual, by Przemyslaw Skibinski + +v1.7.5 +lz4hc : new high compression mode : levels 10-12 compress more and slower, by Przemyslaw Skibinski +lz4cat : fix : works with relative path (#284) and stdin (#285) (reported by @beiDei8z) +cli : fix minor notification when using -r recursive mode +API : lz4frame : LZ4F_frameBound(0) gives upper bound of *flush() and *End() operations (#290, #280) +doc : markdown version of man page, by Takayuki Matsuoka (#279) +build : Makefile : fix make -jX lib+exe concurrency (#277) +build : cmake : improvements by Michał Górny (#296) + +v1.7.4.2 +fix : Makefile : release build compatible with PIE and customized compilation directives provided through environment variables (#274, reported by Antoine Martin) + +v1.7.4 +Improved : much better speed in -mx32 mode +cli : fix : Large file support in 32-bits mode on Mac OS-X +fix : compilation on gcc 4.4 (#272), reported by Antoine Martin + +v1.7.3 +Changed : moved to versioning; package, cli and library have same version number +Improved: Small decompression speed boost +Improved: Small compression speed improvement on 64-bits systems +Improved: Small compression ratio and speed improvement on small files +Improved: Significant speed boost on ARMv6 and ARMv7 +Fix : better ratio on 64-bits big-endian targets +Improved cmake build script, by Evan Nemerson +New liblz4-dll project, by Przemyslaw Skibinki +Makefile: Generates object files (*.o) for faster (re)compilation on low power systems +cli : new : --rm and --help commands +cli : new : preserved file attributes, by Przemyslaw Skibinki +cli : fix : crash on some invalid inputs +cli : fix : -t correctly validates lz4-compressed files, by Nick Terrell +cli : fix : detects and reports fread() errors, thanks to Hiroshi Fujishima report #243 +cli : bench : new : -r recursive mode +lz4cat : can cat multiple files in a single command line (#184) +Added : doc/lz4_manual.html, by Przemyslaw Skibinski +Added : dictionary compression and frame decompression examples, by Nick Terrell +Added : Debianization, by Evgeniy Polyakov + +r131 +New : Dos/DJGPP target, thanks to Louis Santillan (#114) +Added : Example using lz4frame library, by Zbigniew Jędrzejewski-Szmek (#118) +Changed: xxhash symbols are modified (namespace emulation) within liblz4 + +r130: +Fixed : incompatibility sparse mode vs console, reported by Yongwoon Cho (#105) +Fixed : LZ4IO exits too early when frame crc not present, reported by Yongwoon Cho (#106) +Fixed : incompatibility sparse mode vs append mode, reported by Takayuki Matsuoka (#110) +Performance fix : big compression speed boost for clang (+30%) +New : cross-version test, by Takayuki Matsuoka + +r129: +Added : LZ4_compress_fast(), LZ4_compress_fast_continue() +Added : LZ4_compress_destSize() +Changed: New lz4 and lz4hc compression API. Previous function prototypes still supported. +Changed: Sparse file support enabled by default +New : LZ4 CLI improved performance compressing/decompressing multiple files (#86, kind contribution from Kyle J. Harper & Takayuki Matsuoka) +Fixed : GCC 4.9+ optimization bug - Reported by Markus Trippelsdorf, Greg Slazinski & Evan Nemerson +Changed: Enums converted to LZ4F_ namespace convention - by Takayuki Matsuoka +Added : AppVeyor CI environment, for Visual tests - Suggested by Takayuki Matsuoka +Modified:Obsolete functions generate warnings - Suggested by Evan Nemerson, contributed by Takayuki Matsuoka +Fixed : Bug #75 (unfinished stream), reported by Yongwoon Cho +Updated: Documentation converted to MarkDown format + +r128: +New : lz4cli sparse file support (Requested by Neil Wilson, and contributed by Takayuki Matsuoka) +New : command -m, to compress multiple files in a single command (suggested by Kyle J. Harper) +Fixed : Restored lz4hc compression ratio (slightly lower since r124) +New : lz4 cli supports long commands (suggested by Takayuki Matsuoka) +New : lz4frame & lz4cli frame content size support +New : lz4frame supports skippable frames, as requested by Sergey Cherepanov +Changed: Default "make install" directory is /usr/local, as notified by Ron Johnson +New : lz4 cli supports "pass-through" mode, requested by Neil Wilson +New : datagen can generate sparse files +New : scan-build tests, thanks to kind help by Takayuki Matsuoka +New : g++ compatibility tests +New : arm cross-compilation test, thanks to kind help by Takayuki Matsuoka +Fixed : Fuzzer + frametest compatibility with NetBSD (issue #48, reported by Thomas Klausner) +Added : Visual project directory +Updated: Man page & Specification + +r127: +N/A : added a file on SVN + +r126: +New : lz4frame API is now integrated into liblz4 +Fixed : GCC 4.9 bug on highest performance settings, reported by Greg Slazinski +Fixed : bug within LZ4 HC streaming mode, reported by James Boyle +Fixed : older compiler don't like nameless unions, reported by Cheyi Lin +Changed : lz4 is C90 compatible +Changed : added -pedantic option, fixed a few mminor warnings + +r125: +Changed : endian and alignment code +Changed : directory structure : new "lib" directory +Updated : lz4io, now uses lz4frame +Improved: slightly improved decoding speed +Fixed : LZ4_compress_limitedOutput(); Special thanks to Christopher Speller ! +Fixed : some alignment warnings under clang +Fixed : deprecated function LZ4_slideInputBufferHC() + +r124: +New : LZ4 HC streaming mode +Fixed : LZ4F_compressBound() using null preferencesPtr +Updated : xxHash to r38 +Updated library number, to 1.4.0 + +r123: +Added : experimental lz4frame API, thanks to Takayuki Matsuoka and Christopher Jackson for testings +Fix : s390x support, thanks to Nobuhiro Iwamatsu +Fix : test mode (-t) no longer requires confirmation, thanks to Thary Nguyen + +r122: +Fix : AIX & AIX64 support (SamG) +Fix : mips 64-bits support (lew van) +Added : Examples directory, using code examples from Takayuki Matsuoka +Updated : Framing specification, to v1.4.1 +Updated : xxHash, to r36 + +r121: +Added : Makefile : install for kFreeBSD and Hurd (Nobuhiro Iwamatsu) +Fix : Makefile : install for OS-X and BSD, thanks to Takayuki Matsuoka + +r120: +Modified : Streaming API, using strong types +Added : LZ4_versionNumber(), thanks to Takayuki Matsuoka +Fix : OS-X : library install name, thanks to Clemens Lang +Updated : Makefile : synchronize library version number with lz4.h, thanks to Takayuki Matsuoka +Updated : Makefile : stricter compilation flags +Added : pkg-config, thanks to Zbigniew Jędrzejewski-Szmek (issue 135) +Makefile : lz4-test only test native binaries, as suggested by Michał Górny (issue 136) +Updated : xxHash to r35 + +r119: +Fix : Issue 134 : extended malicious address space overflow in 32-bits mode for some specific configurations + +r118: +New : LZ4 Streaming API (Fast version), special thanks to Takayuki Matsuoka +New : datagen : parametrable synthetic data generator for tests +Improved : fuzzer, support more test cases, more parameters, ability to jump to specific test +fix : support ppc64le platform (issue 131) +fix : Issue 52 (malicious address space overflow in 32-bits mode when using large custom format) +fix : Makefile : minor issue 130 : header files permissions + +r117: +Added : man pages for lz4c and lz4cat +Added : automated tests on Travis, thanks to Takayuki Matsuoka ! +fix : block-dependency command line (issue 127) +fix : lz4fullbench (issue 128) + +r116: +hotfix (issue 124 & 125) + +r115: +Added : lz4cat utility, installed on POSX systems (issue 118) +OS-X compatible compilation of dynamic library (issue 115) + +r114: +Makefile : library correctly compiled with -O3 switch (issue 114) +Makefile : library compilation compatible with clang +Makefile : library is versioned and linked (issue 119) +lz4.h : no more static inline prototypes (issue 116) +man : improved header/footer (issue 111) +Makefile : Use system default $(CC) & $(MAKE) variables (issue 112) +xxhash : updated to r34 + +r113: +Large decompression speed improvement for GCC 32-bits. Thanks to Valery Croizier ! +LZ4HC : Compression Level is now a programmable parameter (CLI from 4 to 9) +Separated IO routines from command line (lz4io.c) +Version number into lz4.h (suggested by Francesc Alted) + +r112: +quickfix + +r111 : +Makefile : added capability to install libraries +Modified Directory tree, to better separate libraries from programs. + +r110 : +lz4 & lz4hc : added capability to allocate state & stream state with custom allocator (issue 99) +fuzzer & fullbench : updated to test new functions +man : documented -l command (Legacy format, for Linux kernel compression) (issue 102) +cmake : improved version by Mika Attila, building programs and libraries (issue 100) +xxHash : updated to r33 +Makefile : clean also delete local package .tar.gz + +r109 : +lz4.c : corrected issue 98 (LZ4_compress_limitedOutput()) +Makefile : can specify version number from makefile + +r108 : +lz4.c : corrected compression efficiency issue 97 in 64-bits chained mode (-BD) for streams > 4 GB (thanks Roman Strashkin for reporting) + +r107 : +Makefile : support DESTDIR for staged installs. Thanks Jorge Aparicio. +Makefile : make install installs both lz4 and lz4c (Jorge Aparicio) +Makefile : removed -Wno-implicit-declaration compilation switch +lz4cli.c : include for isatty() (Luca Barbato) +lz4.h : introduced LZ4_MAX_INPUT_SIZE constant (Shay Green) +lz4.h : LZ4_compressBound() : unified macro and inline definitions (Shay Green) +lz4.h : LZ4_decompressSafe_partial() : clarify comments (Shay Green) +lz4.c : LZ4_compress() verify input size condition (Shay Green) +bench.c : corrected a bug in free memory size evaluation +cmake : install into bin/ directory (Richard Yao) +cmake : check for just C compiler (Elan Ruusamae) + +r106 : +Makefile : make dist modify text files in the package to respect Unix EoL convention +lz4cli.c : corrected small display bug in HC mode + +r105 : +Makefile : New install script and man page, contributed by Prasad Pandit +lz4cli.c : Minor modifications, for easier extensibility +COPYING : added license file +LZ4_Streaming_Format.odt : modified file name to remove white space characters +Makefile : .exe suffix now properly added only for Windows target diff --git a/lz4/README.md b/lz4/README.md new file mode 100644 index 0000000..bdb028c --- /dev/null +++ b/lz4/README.md @@ -0,0 +1,120 @@ +LZ4 - Extremely fast compression +================================ + +LZ4 is lossless compression algorithm, +providing compression speed > 500 MB/s per core, +scalable with multi-cores CPU. +It features an extremely fast decoder, +with speed in multiple GB/s per core, +typically reaching RAM speed limits on multi-core systems. + +Speed can be tuned dynamically, selecting an "acceleration" factor +which trades compression ratio for faster speed. +On the other end, a high compression derivative, LZ4_HC, is also provided, +trading CPU time for improved compression ratio. +All versions feature the same decompression speed. + +LZ4 is also compatible with [dictionary compression](https://github.com/facebook/zstd#the-case-for-small-data-compression), +both at [API](https://github.com/lz4/lz4/blob/v1.8.3/lib/lz4frame.h#L481) and [CLI](https://github.com/lz4/lz4/blob/v1.8.3/programs/lz4.1.md#operation-modifiers) levels. +It can ingest any input file as dictionary, though only the final 64KB are used. +This capability can be combined with the [Zstandard Dictionary Builder](https://github.com/facebook/zstd/blob/v1.3.5/programs/zstd.1.md#dictionary-builder), +in order to drastically improve compression performance on small files. + + +LZ4 library is provided as open-source software using BSD 2-Clause license. + + +|Branch |Status | +|------------|---------| +|dev | [![Build Status][travisDevBadge]][travisLink] [![Build status][AppveyorDevBadge]][AppveyorLink] | + +[travisDevBadge]: https://travis-ci.org/lz4/lz4.svg?branch=dev "Continuous Integration test suite" +[travisLink]: https://travis-ci.org/lz4/lz4 +[AppveyorDevBadge]: https://ci.appveyor.com/api/projects/status/github/lz4/lz4?branch=dev&svg=true "Windows test suite" +[AppveyorLink]: https://ci.appveyor.com/project/YannCollet/lz4-1lndh + + +Benchmarks +------------------------- + +The benchmark uses [lzbench], from @inikep +compiled with GCC v8.2.0 on Linux 64-bits (Ubuntu 4.18.0-17). +The reference system uses a Core i7-9700K CPU @ 4.9GHz (w/ turbo boost). +Benchmark evaluates the compression of reference [Silesia Corpus] +in single-thread mode. + +[lzbench]: https://github.com/inikep/lzbench +[Silesia Corpus]: http://sun.aei.polsl.pl/~sdeor/index.php?page=silesia + +| Compressor | Ratio | Compression | Decompression | +| ---------- | ----- | ----------- | ------------- | +| memcpy | 1.000 | 13700 MB/s | 13700 MB/s | +|**LZ4 default (v1.9.0)** |**2.101**| **780 MB/s**| **4970 MB/s** | +| LZO 2.09 | 2.108 | 670 MB/s | 860 MB/s | +| QuickLZ 1.5.0 | 2.238 | 575 MB/s | 780 MB/s | +| Snappy 1.1.4 | 2.091 | 565 MB/s | 1950 MB/s | +| [Zstandard] 1.4.0 -1 | 2.883 | 515 MB/s | 1380 MB/s | +| LZF v3.6 | 2.073 | 415 MB/s | 910 MB/s | +| [zlib] deflate 1.2.11 -1| 2.730 | 100 MB/s | 415 MB/s | +|**LZ4 HC -9 (v1.9.0)** |**2.721**| 41 MB/s | **4900 MB/s** | +| [zlib] deflate 1.2.11 -6| 3.099 | 36 MB/s | 445 MB/s | + +[zlib]: http://www.zlib.net/ +[Zstandard]: http://www.zstd.net/ + +LZ4 is also compatible and optimized for x32 mode, +for which it provides additional speed performance. + + +Installation +------------------------- + +``` +make +make install # this command may require root permissions +``` + +LZ4's `Makefile` supports standard [Makefile conventions], +including [staged installs], [redirection], or [command redefinition]. +It is compatible with parallel builds (`-j#`). + +[Makefile conventions]: https://www.gnu.org/prep/standards/html_node/Makefile-Conventions.html +[staged installs]: https://www.gnu.org/prep/standards/html_node/DESTDIR.html +[redirection]: https://www.gnu.org/prep/standards/html_node/Directory-Variables.html +[command redefinition]: https://www.gnu.org/prep/standards/html_node/Utilities-in-Makefiles.html + +Building LZ4 - Using vcpkg + +You can download and install LZ4 using the [vcpkg](https://github.com/Microsoft/vcpkg) dependency manager: + + git clone https://github.com/Microsoft/vcpkg.git + cd vcpkg + ./bootstrap-vcpkg.sh + ./vcpkg integrate install + vcpkg install lz4 + +The LZ4 port in vcpkg is kept up to date by Microsoft team members and community contributors. If the version is out of date, please [create an issue or pull request](https://github.com/Microsoft/vcpkg) on the vcpkg repository. + +Documentation +------------------------- + +The raw LZ4 block compression format is detailed within [lz4_Block_format]. + +Arbitrarily long files or data streams are compressed using multiple blocks, +for streaming requirements. These blocks are organized into a frame, +defined into [lz4_Frame_format]. +Interoperable versions of LZ4 must also respect the frame format. + +[lz4_Block_format]: doc/lz4_Block_format.md +[lz4_Frame_format]: doc/lz4_Frame_format.md + + +Other source versions +------------------------- + +Beyond the C reference source, +many contributors have created versions of lz4 in multiple languages +(Java, C#, Python, Perl, Ruby, etc.). +A list of known source ports is maintained on the [LZ4 Homepage]. + +[LZ4 Homepage]: http://www.lz4.org diff --git a/lz4/appveyor.yml b/lz4/appveyor.yml new file mode 100644 index 0000000..b4c27ef --- /dev/null +++ b/lz4/appveyor.yml @@ -0,0 +1,147 @@ +version: 1.0.{build} +environment: + matrix: + - COMPILER: "gcc" + PLATFORM: "mingw64" + - COMPILER: "gcc" + PLATFORM: "mingw32" + - COMPILER: "visual" + CONFIGURATION: "Debug" + PLATFORM: "x64" + - COMPILER: "visual" + CONFIGURATION: "Debug" + PLATFORM: "Win32" + - COMPILER: "visual" + CONFIGURATION: "Release" + PLATFORM: "x64" + - COMPILER: "visual" + CONFIGURATION: "Release" + PLATFORM: "Win32" + - COMPILER: "gcc" + PLATFORM: "clang" + +install: + - ECHO Installing %COMPILER% %PLATFORM% %CONFIGURATION% + - MKDIR bin + - if [%COMPILER%]==[gcc] SET PATH_ORIGINAL=%PATH% + - if [%COMPILER%]==[gcc] ( + SET "PATH_MINGW32=c:\MinGW\bin;c:\MinGW\usr\bin" && + SET "PATH_MINGW64=c:\msys64\mingw64\bin;c:\msys64\usr\bin" && + COPY C:\MinGW\bin\mingw32-make.exe C:\MinGW\bin\make.exe && + COPY C:\MinGW\bin\gcc.exe C:\MinGW\bin\cc.exe + ) else ( + IF [%PLATFORM%]==[x64] (SET ADDITIONALPARAM=/p:LibraryPath="C:\Program Files\Microsoft SDKs\Windows\v7.1\lib\x64;c:\Program Files (x86)\Microsoft Visual Studio 10.0\VC\lib\amd64;C:\Program Files (x86)\Microsoft Visual Studio 10.0\;C:\Program Files (x86)\Microsoft Visual Studio 10.0\lib\amd64;") + ) + +build_script: + - if [%PLATFORM%]==[mingw32] SET PATH=%PATH_MINGW32%;%PATH_ORIGINAL% + - if [%PLATFORM%]==[mingw64] SET PATH=%PATH_MINGW64%;%PATH_ORIGINAL% + - if [%PLATFORM%]==[clang] SET PATH=%PATH_MINGW64%;%PATH_ORIGINAL% + - ECHO *** && + ECHO Building %COMPILER% %PLATFORM% %CONFIGURATION% && + ECHO *** + - if [%PLATFORM%]==[clang] (clang -v) + - if [%COMPILER%]==[gcc] (gcc -v) + - if [%COMPILER%]==[gcc] ( + echo ----- && + make -v && + echo ----- && + if not [%PLATFORM%]==[clang] ( + make -C programs lz4 && + make -C tests fullbench && + make -C tests fuzzer && + make -C lib lib V=1 + ) ELSE ( + make -C programs lz4 CC=clang MOREFLAGS="--target=x86_64-w64-mingw32 -Werror -Wconversion -Wno-sign-conversion" && + make -C tests fullbench CC=clang MOREFLAGS="--target=x86_64-w64-mingw32 -Werror -Wconversion -Wno-sign-conversion" && + make -C tests fuzzer CC=clang MOREFLAGS="--target=x86_64-w64-mingw32 -Werror -Wconversion -Wno-sign-conversion" && + make -C lib lib CC=clang MOREFLAGS="--target=x86_64-w64-mingw32 -Werror -Wconversion -Wno-sign-conversion" + ) + ) + - if [%COMPILER%]==[gcc] if not [%PLATFORM%]==[clang] ( + MKDIR bin\dll bin\static bin\example bin\include && + COPY tests\fullbench.c bin\example\ && + COPY lib\xxhash.c bin\example\ && + COPY lib\xxhash.h bin\example\ && + COPY lib\lz4.h bin\include\ && + COPY lib\lz4hc.h bin\include\ && + COPY lib\lz4frame.h bin\include\ && + COPY lib\liblz4.a bin\static\liblz4_static.lib && + COPY lib\dll\* bin\dll\ && + COPY lib\dll\example\Makefile bin\example\ && + COPY lib\dll\example\fullbench-dll.* bin\example\ && + COPY lib\dll\example\README.md bin\ && + COPY programs\lz4.exe bin\lz4.exe + ) + - if [%COMPILER%]==[gcc] if [%PLATFORM%]==[mingw64] ( + 7z.exe a -bb1 bin\lz4_x64.zip NEWS .\bin\lz4.exe .\bin\README.md .\bin\example .\bin\dll .\bin\static .\bin\include && + appveyor PushArtifact bin\lz4_x64.zip + ) + - if [%COMPILER%]==[gcc] if [%PLATFORM%]==[mingw32] ( + 7z.exe a -bb1 bin\lz4_x86.zip NEWS .\bin\lz4.exe .\bin\README.md .\bin\example .\bin\dll .\bin\static .\bin\include && + appveyor PushArtifact bin\lz4_x86.zip + ) + - if [%COMPILER%]==[gcc] (COPY tests\*.exe programs\) + - if [%COMPILER%]==[visual] ( + ECHO *** && + ECHO *** Building Visual Studio 2010 %PLATFORM%\%CONFIGURATION% && + ECHO *** && + msbuild "build\VS2010\lz4.sln" %ADDITIONALPARAM% /m /verbosity:minimal /property:PlatformToolset=v100 /t:Clean,Build /p:Platform=%PLATFORM% /p:Configuration=%CONFIGURATION% /p:EnableWholeProgramOptimization=true /logger:"C:\Program Files\AppVeyor\BuildAgent\Appveyor.MSBuildLogger.dll" && + ECHO *** && + ECHO *** Building Visual Studio 2012 %PLATFORM%\%CONFIGURATION% && + ECHO *** && + msbuild "build\VS2010\lz4.sln" /m /verbosity:minimal /property:PlatformToolset=v110 /t:Clean,Build /p:Platform=%PLATFORM% /p:Configuration=%CONFIGURATION% /logger:"C:\Program Files\AppVeyor\BuildAgent\Appveyor.MSBuildLogger.dll" && + ECHO *** && + ECHO *** Building Visual Studio 2013 %PLATFORM%\%CONFIGURATION% && + ECHO *** && + msbuild "build\VS2010\lz4.sln" /m /verbosity:minimal /property:PlatformToolset=v120 /t:Clean,Build /p:Platform=%PLATFORM% /p:Configuration=%CONFIGURATION% /logger:"C:\Program Files\AppVeyor\BuildAgent\Appveyor.MSBuildLogger.dll" && + ECHO *** && + ECHO *** Building Visual Studio 2015 %PLATFORM%\%CONFIGURATION% && + ECHO *** && + msbuild "build\VS2010\lz4.sln" /m /verbosity:minimal /property:PlatformToolset=v140 /t:Clean,Build /p:Platform=%PLATFORM% /p:Configuration=%CONFIGURATION% /logger:"C:\Program Files\AppVeyor\BuildAgent\Appveyor.MSBuildLogger.dll" && + COPY build\VS2010\bin\%PLATFORM%_%CONFIGURATION%\*.exe programs\ + ) + +test_script: + - ECHO *** && + ECHO Testing %COMPILER% %PLATFORM% %CONFIGURATION% && + ECHO *** + - if not [%COMPILER%]==[unknown] ( + CD programs && + lz4 -h && + lz4 -i1b lz4.exe && + lz4 -i1b5 lz4.exe && + lz4 -i1b10 lz4.exe && + lz4 -i1b15 lz4.exe && + echo ------- lz4 tested ------- && + fullbench.exe -i1 fullbench.exe && + echo trying to launch fuzzer.exe && + fuzzer.exe -v -T30s + ) + +artifacts: + - path: bin\lz4_x64.zip + - path: bin\lz4_x86.zip + +deploy: +- provider: GitHub + artifact: bin\lz4_x64.zip + auth_token: + secure: w6UJaGie0qbZvffr/fqyhO/Vj8rMiQWnv9a8qm3gxfngdHDTMT42wYupqJpIExId + force_update: true + prerelease: true + on: + COMPILER: gcc + PLATFORM: "mingw64" + appveyor_repo_tag: true + +- provider: GitHub + artifact: bin\lz4_x86.zip + auth_token: + secure: w6UJaGie0qbZvffr/fqyhO/Vj8rMiQWnv9a8qm3gxfngdHDTMT42wYupqJpIExId + force_update: true + prerelease: true + on: + COMPILER: gcc + PLATFORM: "mingw32" + appveyor_repo_tag: true diff --git a/lz4/build/.gitignore b/lz4/build/.gitignore new file mode 100644 index 0000000..69e1111 --- /dev/null +++ b/lz4/build/.gitignore @@ -0,0 +1,16 @@ +# Visual C++ +.vs/ +*Copy +*.db +*.opensdf +*.sdf +*.suo +*.user +ver*/ +VS2010/bin/ +VS2017/bin/ +ipch + +# Fixup for lz4 project directories +!VS2010/lz4 +!VS2017/lz4 diff --git a/lz4/build/README.md b/lz4/build/README.md new file mode 100644 index 0000000..d416aeb --- /dev/null +++ b/lz4/build/README.md @@ -0,0 +1,55 @@ +Projects for various integrated development environments (IDE) +============================================================== + +#### Included projects + +The following projects are included with the lz4 distribution: +- `cmake` - CMake project +- `VS2010` - Visual Studio 2010 project (which also works well with Visual Studio 2012, 2013, 2015) +- `VS2017` - Visual Studio 2017 project + + +#### How to compile lz4 with Visual Studio + +1. Install Visual Studio e.g. VS 2015 Community Edition (it's free). +2. Download the latest version of lz4 from https://github.com/lz4/lz4/releases +3. Decompress ZIP archive. +4. Go to decompressed directory then to `build` then `VS2010` and open `lz4.sln` +5. Visual Studio will ask about converting VS2010 project to VS2015 and you should agree. +6. Change `Debug` to `Release` and if you have 64-bit Windows change also `Win32` to `x64`. +7. Press F7 on keyboard or select `BUILD` from the menu bar and choose `Build Solution`. +8. If compilation will be fine a compiled executable will be in `build\VS2010\bin\x64_Release\lz4.exe` + + +#### Projects available within lz4.sln + +The Visual Studio solution file `lz4.sln` contains many projects that will be compiled to the +`build\VS2010\bin\$(Platform)_$(Configuration)` directory. For example `lz4` set to `x64` and +`Release` will be compiled to `build\VS2010\bin\x64_Release\lz4.exe`. The solution file contains the +following projects: + +- `lz4` : Command Line Utility, supporting gzip-like arguments +- `datagen` : Synthetic and parametrable data generator, for tests +- `frametest` : Test tool that checks lz4frame integrity on target platform +- `fullbench` : Precisely measure speed for each lz4 inner functions +- `fuzzer` : Test tool, to check lz4 integrity on target platform +- `liblz4` : A static LZ4 library compiled to `liblz4_static.lib` +- `liblz4-dll` : A dynamic LZ4 library (DLL) compiled to `liblz4.dll` with the import library `liblz4.lib` +- `fullbench-dll` : The fullbench program compiled with the import library; the executable requires LZ4 DLL + + +#### Using LZ4 DLL with Microsoft Visual C++ project + +The header files `lib\lz4.h`, `lib\lz4hc.h`, `lib\lz4frame.h` and the import library +`build\VS2010\bin\$(Platform)_$(Configuration)\liblz4.lib` are required to +compile a project using Visual C++. + +1. The path to header files should be added to `Additional Include Directories` that can + be found in Project Properties of Visual Studio IDE in the `C/C++` Property Pages on the `General` page. +2. The import library has to be added to `Additional Dependencies` that can + be found in Project Properties in the `Linker` Property Pages on the `Input` page. + If one will provide only the name `liblz4.lib` without a full path to the library + then the directory has to be added to `Linker\General\Additional Library Directories`. + +The compiled executable will require LZ4 DLL which is available at +`build\VS2010\bin\$(Platform)_$(Configuration)\liblz4.dll`. diff --git a/lz4/build/VS2010/datagen/datagen.vcxproj b/lz4/build/VS2010/datagen/datagen.vcxproj new file mode 100644 index 0000000..e24f961 --- /dev/null +++ b/lz4/build/VS2010/datagen/datagen.vcxproj @@ -0,0 +1,169 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {D745AE2F-596A-403A-9B91-81A8C6779243} + Win32Proj + datagen + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + + + Application + true + Unicode + + + Application + false + Unicode + true + + + Application + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + diff --git a/lz4/build/VS2010/frametest/frametest.vcxproj b/lz4/build/VS2010/frametest/frametest.vcxproj new file mode 100644 index 0000000..3196768 --- /dev/null +++ b/lz4/build/VS2010/frametest/frametest.vcxproj @@ -0,0 +1,176 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7} + Win32Proj + frametest + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + + + Application + true + Unicode + + + Application + false + Unicode + true + + + Application + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + + + + + + + + diff --git a/lz4/build/VS2010/fullbench-dll/fullbench-dll.vcxproj b/lz4/build/VS2010/fullbench-dll/fullbench-dll.vcxproj new file mode 100644 index 0000000..8f503f5 --- /dev/null +++ b/lz4/build/VS2010/fullbench-dll/fullbench-dll.vcxproj @@ -0,0 +1,180 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {13992FD2-077E-4954-B065-A428198201A9} + Win32Proj + fullbench-dll + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + + + Application + true + Unicode + + + Application + false + Unicode + true + + + Application + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2010/fullbench/fullbench.vcxproj b/lz4/build/VS2010/fullbench/fullbench.vcxproj new file mode 100644 index 0000000..aa67431 --- /dev/null +++ b/lz4/build/VS2010/fullbench/fullbench.vcxproj @@ -0,0 +1,176 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E} + Win32Proj + fullbench + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + + + Application + true + Unicode + + + Application + false + Unicode + true + + + Application + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + + + + + + + + diff --git a/lz4/build/VS2010/fuzzer/fuzzer.vcxproj b/lz4/build/VS2010/fuzzer/fuzzer.vcxproj new file mode 100644 index 0000000..21cbf56 --- /dev/null +++ b/lz4/build/VS2010/fuzzer/fuzzer.vcxproj @@ -0,0 +1,173 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {18B9F1A7-9C66-4352-898B-30804DADE0FD} + Win32Proj + fuzzer + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + + + Application + true + Unicode + + + Application + false + Unicode + true + + + Application + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + + + + + diff --git a/lz4/build/VS2010/liblz4-dll/liblz4-dll.rc b/lz4/build/VS2010/liblz4-dll/liblz4-dll.rc new file mode 100644 index 0000000..b1871fe --- /dev/null +++ b/lz4/build/VS2010/liblz4-dll/liblz4-dll.rc @@ -0,0 +1,51 @@ +// Microsoft Visual C++ generated resource script. +// + +#include "lz4.h" /* LZ4_VERSION_STRING */ +#define APSTUDIO_READONLY_SYMBOLS +#include "verrsrc.h" +#undef APSTUDIO_READONLY_SYMBOLS + + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU) +LANGUAGE 9, 1 + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + PRODUCTVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS_NT_WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904B0" + BEGIN + VALUE "CompanyName", "Yann Collet" + VALUE "FileDescription", "Extremely fast compression" + VALUE "FileVersion", LZ4_VERSION_STRING + VALUE "InternalName", "lz4.dll" + VALUE "LegalCopyright", "Copyright (C) 2013-2016, Yann Collet" + VALUE "OriginalFilename", "lz4.dll" + VALUE "ProductName", "LZ4" + VALUE "ProductVersion", LZ4_VERSION_STRING + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x0409, 1200 + END +END + +#endif diff --git a/lz4/build/VS2010/liblz4-dll/liblz4-dll.vcxproj b/lz4/build/VS2010/liblz4-dll/liblz4-dll.vcxproj new file mode 100644 index 0000000..56ec3b9 --- /dev/null +++ b/lz4/build/VS2010/liblz4-dll/liblz4-dll.vcxproj @@ -0,0 +1,179 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {9800039D-4AAA-43A4-BB78-FEF6F4836927} + Win32Proj + liblz4-dll + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + liblz4-dll + + + + DynamicLibrary + true + Unicode + + + DynamicLibrary + true + Unicode + + + DynamicLibrary + false + Unicode + true + + + DynamicLibrary + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + true + true + true + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2010/liblz4/liblz4.vcxproj b/lz4/build/VS2010/liblz4/liblz4.vcxproj new file mode 100644 index 0000000..61ea159 --- /dev/null +++ b/lz4/build/VS2010/liblz4/liblz4.vcxproj @@ -0,0 +1,175 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476} + Win32Proj + liblz4 + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + StaticLibrary + true + Unicode + + + StaticLibrary + true + Unicode + + + StaticLibrary + false + Unicode + true + + + StaticLibrary + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + true + true + true + + + + + + + + + + + + + + + + + + + diff --git a/lz4/build/VS2010/lz4.sln b/lz4/build/VS2010/lz4.sln new file mode 100644 index 0000000..78f223b --- /dev/null +++ b/lz4/build/VS2010/lz4.sln @@ -0,0 +1,98 @@ +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio Express 2012 for Windows Desktop +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "lz4", "lz4\lz4.vcxproj", "{E30329AC-0057-4FE0-8FDA-7F650D398C4C}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "liblz4-dll", "liblz4-dll\liblz4-dll.vcxproj", "{9800039D-4AAA-43A4-BB78-FEF6F4836927}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "liblz4", "liblz4\liblz4.vcxproj", "{9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fuzzer", "fuzzer\fuzzer.vcxproj", "{18B9F1A7-9C66-4352-898B-30804DADE0FD}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fullbench", "fullbench\fullbench.vcxproj", "{6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "frametest", "frametest\frametest.vcxproj", "{39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "datagen", "datagen\datagen.vcxproj", "{D745AE2F-596A-403A-9B91-81A8C6779243}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fullbench-dll", "fullbench-dll\fullbench-dll.vcxproj", "{13992FD2-077E-4954-B065-A428198201A9}" + ProjectSection(ProjectDependencies) = postProject + {9800039D-4AAA-43A4-BB78-FEF6F4836927} = {9800039D-4AAA-43A4-BB78-FEF6F4836927} + EndProjectSection +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Debug|Win32.ActiveCfg = Debug|Win32 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Debug|Win32.Build.0 = Debug|Win32 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Debug|x64.ActiveCfg = Debug|x64 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Debug|x64.Build.0 = Debug|x64 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Release|Win32.ActiveCfg = Release|Win32 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Release|Win32.Build.0 = Release|Win32 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Release|x64.ActiveCfg = Release|x64 + {E30329AC-0057-4FE0-8FDA-7F650D398C4C}.Release|x64.Build.0 = Release|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|Win32.ActiveCfg = Debug|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|Win32.Build.0 = Debug|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|x64.ActiveCfg = Debug|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|x64.Build.0 = Debug|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|Win32.ActiveCfg = Release|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|Win32.Build.0 = Release|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|x64.ActiveCfg = Release|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|x64.Build.0 = Release|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|Win32.ActiveCfg = Debug|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|Win32.Build.0 = Debug|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|x64.ActiveCfg = Debug|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|x64.Build.0 = Debug|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|Win32.ActiveCfg = Release|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|Win32.Build.0 = Release|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|x64.ActiveCfg = Release|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|x64.Build.0 = Release|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|Win32.ActiveCfg = Debug|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|Win32.Build.0 = Debug|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|x64.ActiveCfg = Debug|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|x64.Build.0 = Debug|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|Win32.ActiveCfg = Release|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|Win32.Build.0 = Release|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|x64.ActiveCfg = Release|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|x64.Build.0 = Release|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|Win32.ActiveCfg = Debug|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|Win32.Build.0 = Debug|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|x64.ActiveCfg = Debug|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|x64.Build.0 = Debug|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|Win32.ActiveCfg = Release|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|Win32.Build.0 = Release|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|x64.ActiveCfg = Release|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|x64.Build.0 = Release|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|Win32.ActiveCfg = Debug|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|Win32.Build.0 = Debug|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|x64.ActiveCfg = Debug|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|x64.Build.0 = Debug|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|Win32.ActiveCfg = Release|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|Win32.Build.0 = Release|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|x64.ActiveCfg = Release|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|x64.Build.0 = Release|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|Win32.ActiveCfg = Debug|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|Win32.Build.0 = Debug|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|x64.ActiveCfg = Debug|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|x64.Build.0 = Debug|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|Win32.ActiveCfg = Release|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|Win32.Build.0 = Release|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|x64.ActiveCfg = Release|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|x64.Build.0 = Release|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|Win32.ActiveCfg = Debug|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|Win32.Build.0 = Debug|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|x64.ActiveCfg = Debug|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|x64.Build.0 = Debug|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Release|Win32.ActiveCfg = Release|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Release|Win32.Build.0 = Release|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Release|x64.ActiveCfg = Release|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Release|x64.Build.0 = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/lz4/build/VS2010/lz4/lz4.rc b/lz4/build/VS2010/lz4/lz4.rc new file mode 100644 index 0000000..c593edf --- /dev/null +++ b/lz4/build/VS2010/lz4/lz4.rc @@ -0,0 +1,51 @@ +// Microsoft Visual C++ generated resource script. +// + +#include "lz4.h" /* LZ4_VERSION_STRING */ +#define APSTUDIO_READONLY_SYMBOLS +#include "verrsrc.h" +#undef APSTUDIO_READONLY_SYMBOLS + + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU) +LANGUAGE 9, 1 + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + PRODUCTVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS_NT_WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904B0" + BEGIN + VALUE "CompanyName", "Yann Collet" + VALUE "FileDescription", "Extremely fast compression" + VALUE "FileVersion", LZ4_VERSION_STRING + VALUE "InternalName", "lz4.exe" + VALUE "LegalCopyright", "Copyright (C) 2013-2016, Yann Collet" + VALUE "OriginalFilename", "lz4.exe" + VALUE "ProductName", "LZ4" + VALUE "ProductVersion", LZ4_VERSION_STRING + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x0409, 1200 + END +END + +#endif diff --git a/lz4/build/VS2010/lz4/lz4.vcxproj b/lz4/build/VS2010/lz4/lz4.vcxproj new file mode 100644 index 0000000..de7a714 --- /dev/null +++ b/lz4/build/VS2010/lz4/lz4.vcxproj @@ -0,0 +1,189 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {E30329AC-0057-4FE0-8FDA-7F650D398C4C} + Win32Proj + lz4 + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + + + Application + true + Unicode + + + Application + false + Unicode + true + + + Application + false + Unicode + true + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + setargv.obj;%(AdditionalDependencies) + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + setargv.obj;%(AdditionalDependencies) + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + setargv.obj;%(AdditionalDependencies) + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + setargv.obj;%(AdditionalDependencies) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/datagen/datagen.vcxproj b/lz4/build/VS2017/datagen/datagen.vcxproj new file mode 100644 index 0000000..30e159e --- /dev/null +++ b/lz4/build/VS2017/datagen/datagen.vcxproj @@ -0,0 +1,173 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {D745AE2F-596A-403A-9B91-81A8C6779243} + Win32Proj + datagen + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + v141 + + + Application + true + Unicode + v141 + + + Application + false + Unicode + true + v141 + + + Application + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\programs;$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/frametest/frametest.vcxproj b/lz4/build/VS2017/frametest/frametest.vcxproj new file mode 100644 index 0000000..a3a403d --- /dev/null +++ b/lz4/build/VS2017/frametest/frametest.vcxproj @@ -0,0 +1,180 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7} + Win32Proj + frametest + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + v141 + + + Application + true + Unicode + v141 + + + Application + false + Unicode + true + v141 + + + Application + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/fullbench-dll/fullbench-dll.vcxproj b/lz4/build/VS2017/fullbench-dll/fullbench-dll.vcxproj new file mode 100644 index 0000000..d54a8d7 --- /dev/null +++ b/lz4/build/VS2017/fullbench-dll/fullbench-dll.vcxproj @@ -0,0 +1,184 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {13992FD2-077E-4954-B065-A428198201A9} + Win32Proj + fullbench-dll + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + v141 + + + Application + true + Unicode + v141 + + + Application + false + Unicode + true + v141 + + + Application + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + $(SolutionDir)bin\$(Platform)_$(Configuration);%(AdditionalLibraryDirectories) + liblz4.lib;%(AdditionalDependencies) + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/fullbench/fullbench.vcxproj b/lz4/build/VS2017/fullbench/fullbench.vcxproj new file mode 100644 index 0000000..54c9743 --- /dev/null +++ b/lz4/build/VS2017/fullbench/fullbench.vcxproj @@ -0,0 +1,180 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E} + Win32Proj + fullbench + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + v141 + + + Application + true + Unicode + v141 + + + Application + false + Unicode + true + v141 + + + Application + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/fuzzer/fuzzer.vcxproj b/lz4/build/VS2017/fuzzer/fuzzer.vcxproj new file mode 100644 index 0000000..aa6fe42 --- /dev/null +++ b/lz4/build/VS2017/fuzzer/fuzzer.vcxproj @@ -0,0 +1,177 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {18B9F1A7-9C66-4352-898B-30804DADE0FD} + Win32Proj + fuzzer + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + Application + true + Unicode + v141 + + + Application + true + Unicode + v141 + + + Application + false + Unicode + true + v141 + + + Application + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + Console + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + Console + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + Console + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + Console + true + true + true + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/liblz4-dll/liblz4-dll.rc b/lz4/build/VS2017/liblz4-dll/liblz4-dll.rc new file mode 100644 index 0000000..b1871fe --- /dev/null +++ b/lz4/build/VS2017/liblz4-dll/liblz4-dll.rc @@ -0,0 +1,51 @@ +// Microsoft Visual C++ generated resource script. +// + +#include "lz4.h" /* LZ4_VERSION_STRING */ +#define APSTUDIO_READONLY_SYMBOLS +#include "verrsrc.h" +#undef APSTUDIO_READONLY_SYMBOLS + + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU) +LANGUAGE 9, 1 + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + PRODUCTVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS_NT_WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904B0" + BEGIN + VALUE "CompanyName", "Yann Collet" + VALUE "FileDescription", "Extremely fast compression" + VALUE "FileVersion", LZ4_VERSION_STRING + VALUE "InternalName", "lz4.dll" + VALUE "LegalCopyright", "Copyright (C) 2013-2016, Yann Collet" + VALUE "OriginalFilename", "lz4.dll" + VALUE "ProductName", "LZ4" + VALUE "ProductVersion", LZ4_VERSION_STRING + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x0409, 1200 + END +END + +#endif diff --git a/lz4/build/VS2017/liblz4-dll/liblz4-dll.vcxproj b/lz4/build/VS2017/liblz4-dll/liblz4-dll.vcxproj new file mode 100644 index 0000000..8e7ee3b --- /dev/null +++ b/lz4/build/VS2017/liblz4-dll/liblz4-dll.vcxproj @@ -0,0 +1,183 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {9800039D-4AAA-43A4-BB78-FEF6F4836927} + Win32Proj + liblz4-dll + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + liblz4-dll + + + + DynamicLibrary + true + Unicode + v141 + + + DynamicLibrary + true + Unicode + v141 + + + DynamicLibrary + false + Unicode + true + v141 + + + DynamicLibrary + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + liblz4 + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + true + true + true + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/liblz4/liblz4.vcxproj b/lz4/build/VS2017/liblz4/liblz4.vcxproj new file mode 100644 index 0000000..948f7db --- /dev/null +++ b/lz4/build/VS2017/liblz4/liblz4.vcxproj @@ -0,0 +1,179 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476} + Win32Proj + liblz4 + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + + + + StaticLibrary + true + Unicode + v141 + + + StaticLibrary + true + Unicode + v141 + + + StaticLibrary + false + Unicode + true + v141 + + + StaticLibrary + false + Unicode + true + v141 + + + + + + + + + + + + + + + + + + + true + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + true + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + false + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + false + liblz4_static + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + true + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + false + MultiThreadedDebug + + + true + + + + + + + Level4 + Disabled + WIN32;_DEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + true + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreadedDebug + + + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + false + MultiThreaded + + + true + true + true + + + + + Level4 + + + MaxSpeed + true + true + WIN32;NDEBUG;LZ4_DLL_EXPORT=1;%(PreprocessorDefinitions) + false + true + /analyze:stacksize295252 %(AdditionalOptions) + MultiThreaded + + + true + true + true + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/VS2017/lz4.sln b/lz4/build/VS2017/lz4.sln new file mode 100644 index 0000000..6a2779f --- /dev/null +++ b/lz4/build/VS2017/lz4.sln @@ -0,0 +1,103 @@ +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 15 +VisualStudioVersion = 15.0.28307.271 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "liblz4-dll", "liblz4-dll\liblz4-dll.vcxproj", "{9800039D-4AAA-43A4-BB78-FEF6F4836927}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "liblz4", "liblz4\liblz4.vcxproj", "{9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fuzzer", "fuzzer\fuzzer.vcxproj", "{18B9F1A7-9C66-4352-898B-30804DADE0FD}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fullbench", "fullbench\fullbench.vcxproj", "{6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "frametest", "frametest\frametest.vcxproj", "{39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "datagen", "datagen\datagen.vcxproj", "{D745AE2F-596A-403A-9B91-81A8C6779243}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fullbench-dll", "fullbench-dll\fullbench-dll.vcxproj", "{13992FD2-077E-4954-B065-A428198201A9}" + ProjectSection(ProjectDependencies) = postProject + {9800039D-4AAA-43A4-BB78-FEF6F4836927} = {9800039D-4AAA-43A4-BB78-FEF6F4836927} + EndProjectSection +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "lz4", "lz4\lz4.vcxproj", "{60A3115E-B988-41EE-8815-F4D4F253D866}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|Win32.ActiveCfg = Debug|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|Win32.Build.0 = Debug|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|x64.ActiveCfg = Debug|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Debug|x64.Build.0 = Debug|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|Win32.ActiveCfg = Release|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|Win32.Build.0 = Release|Win32 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|x64.ActiveCfg = Release|x64 + {9800039D-4AAA-43A4-BB78-FEF6F4836927}.Release|x64.Build.0 = Release|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|Win32.ActiveCfg = Debug|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|Win32.Build.0 = Debug|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|x64.ActiveCfg = Debug|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Debug|x64.Build.0 = Debug|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|Win32.ActiveCfg = Release|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|Win32.Build.0 = Release|Win32 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|x64.ActiveCfg = Release|x64 + {9092C5CC-3E71-41B3-BF68-4A7BDD8A5476}.Release|x64.Build.0 = Release|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|Win32.ActiveCfg = Debug|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|Win32.Build.0 = Debug|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|x64.ActiveCfg = Debug|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Debug|x64.Build.0 = Debug|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|Win32.ActiveCfg = Release|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|Win32.Build.0 = Release|Win32 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|x64.ActiveCfg = Release|x64 + {18B9F1A7-9C66-4352-898B-30804DADE0FD}.Release|x64.Build.0 = Release|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|Win32.ActiveCfg = Debug|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|Win32.Build.0 = Debug|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|x64.ActiveCfg = Debug|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Debug|x64.Build.0 = Debug|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|Win32.ActiveCfg = Release|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|Win32.Build.0 = Release|Win32 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|x64.ActiveCfg = Release|x64 + {6A4DF4EF-C77F-43C6-8901-DDCD20879E4E}.Release|x64.Build.0 = Release|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|Win32.ActiveCfg = Debug|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|Win32.Build.0 = Debug|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|x64.ActiveCfg = Debug|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Debug|x64.Build.0 = Debug|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|Win32.ActiveCfg = Release|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|Win32.Build.0 = Release|Win32 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|x64.ActiveCfg = Release|x64 + {39AD6ECC-8BAD-4368-95E4-A1AA2F077BB7}.Release|x64.Build.0 = Release|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|Win32.ActiveCfg = Debug|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|Win32.Build.0 = Debug|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|x64.ActiveCfg = Debug|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Debug|x64.Build.0 = Debug|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|Win32.ActiveCfg = Release|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|Win32.Build.0 = Release|Win32 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|x64.ActiveCfg = Release|x64 + {D745AE2F-596A-403A-9B91-81A8C6779243}.Release|x64.Build.0 = Release|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|Win32.ActiveCfg = Debug|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|Win32.Build.0 = Debug|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|x64.ActiveCfg = Debug|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Debug|x64.Build.0 = Debug|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Release|Win32.ActiveCfg = Release|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Release|Win32.Build.0 = Release|Win32 + {13992FD2-077E-4954-B065-A428198201A9}.Release|x64.ActiveCfg = Release|x64 + {13992FD2-077E-4954-B065-A428198201A9}.Release|x64.Build.0 = Release|x64 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Debug|Win32.ActiveCfg = Debug|Win32 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Debug|Win32.Build.0 = Debug|Win32 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Debug|x64.ActiveCfg = Debug|x64 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Debug|x64.Build.0 = Debug|x64 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Release|Win32.ActiveCfg = Release|Win32 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Release|Win32.Build.0 = Release|Win32 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Release|x64.ActiveCfg = Release|x64 + {60A3115E-B988-41EE-8815-F4D4F253D866}.Release|x64.Build.0 = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {BBC259B2-BABF-47CD-8A6A-7B8318A803AC} + EndGlobalSection +EndGlobal diff --git a/lz4/build/VS2017/lz4/lz4.rc b/lz4/build/VS2017/lz4/lz4.rc new file mode 100644 index 0000000..c593edf --- /dev/null +++ b/lz4/build/VS2017/lz4/lz4.rc @@ -0,0 +1,51 @@ +// Microsoft Visual C++ generated resource script. +// + +#include "lz4.h" /* LZ4_VERSION_STRING */ +#define APSTUDIO_READONLY_SYMBOLS +#include "verrsrc.h" +#undef APSTUDIO_READONLY_SYMBOLS + + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU) +LANGUAGE 9, 1 + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + PRODUCTVERSION LZ4_VERSION_MAJOR,LZ4_VERSION_MINOR,LZ4_VERSION_RELEASE,0 + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS_NT_WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904B0" + BEGIN + VALUE "CompanyName", "Yann Collet" + VALUE "FileDescription", "Extremely fast compression" + VALUE "FileVersion", LZ4_VERSION_STRING + VALUE "InternalName", "lz4.exe" + VALUE "LegalCopyright", "Copyright (C) 2013-2016, Yann Collet" + VALUE "OriginalFilename", "lz4.exe" + VALUE "ProductName", "LZ4" + VALUE "ProductVersion", LZ4_VERSION_STRING + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x0409, 1200 + END +END + +#endif diff --git a/lz4/build/VS2017/lz4/lz4.vcxproj b/lz4/build/VS2017/lz4/lz4.vcxproj new file mode 100644 index 0000000..b4fed24 --- /dev/null +++ b/lz4/build/VS2017/lz4/lz4.vcxproj @@ -0,0 +1,164 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {60A3115E-B988-41EE-8815-F4D4F253D866} + lz4 + 8.1 + + + + Application + true + v141 + Unicode + + + Application + false + v141 + false + Unicode + + + Application + true + v141 + MultiByte + + + Application + false + v141 + true + MultiByte + + + + + + + + + + + + + + + + + + + + + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + + + $(SolutionDir)bin\$(Platform)_$(Configuration)\ + $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\ + $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(SolutionDir)..\..\programs;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath); + false + + + + Level4 + Disabled + true + true + true + WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) + + + true + Console + false + false + + + + + Level3 + Disabled + true + true + + + + + Level3 + MaxSpeed + true + true + true + true + WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) + + + true + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + + + true + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/lz4/build/cmake/.gitignore b/lz4/build/cmake/.gitignore new file mode 100644 index 0000000..d39505d --- /dev/null +++ b/lz4/build/cmake/.gitignore @@ -0,0 +1,9 @@ +# cmake artefact + +CMakeCache.txt +CMakeFiles +*.cmake +Makefile +liblz4.pc +lz4c +install_manifest.txt diff --git a/lz4/build/cmake/CMakeLists.txt b/lz4/build/cmake/CMakeLists.txt new file mode 100644 index 0000000..57501ee --- /dev/null +++ b/lz4/build/cmake/CMakeLists.txt @@ -0,0 +1,235 @@ +# CMake support for LZ4 +# +# To the extent possible under law, the author(s) have dedicated all +# copyright and related and neighboring rights to this software to +# the public domain worldwide. This software is distributed without +# any warranty. +# +# For details, see . +# +# LZ4's CMake support is maintained by Evan Nemerson; when filing +# bugs please mention @nemequ to make sure I see it. + +set(LZ4_TOP_SOURCE_DIR "${CMAKE_CURRENT_SOURCE_DIR}/../..") + +option(LZ4_BUILD_CLI "Build lz4 program" ON) +option(LZ4_BUILD_LEGACY_LZ4C "Build lz4c progam with legacy argument support" ON) + +# Parse version information +file(STRINGS "${LZ4_TOP_SOURCE_DIR}/lib/lz4.h" LZ4_VERSION_MAJOR REGEX "^#define LZ4_VERSION_MAJOR +([0-9]+) +.*$") +string(REGEX REPLACE "^#define LZ4_VERSION_MAJOR +([0-9]+) +.*$" "\\1" LZ4_VERSION_MAJOR "${LZ4_VERSION_MAJOR}") +file(STRINGS "${LZ4_TOP_SOURCE_DIR}/lib/lz4.h" LZ4_VERSION_MINOR REGEX "^#define LZ4_VERSION_MINOR +([0-9]+) +.*$") +string(REGEX REPLACE "^#define LZ4_VERSION_MINOR +([0-9]+) +.*$" "\\1" LZ4_VERSION_MINOR "${LZ4_VERSION_MINOR}") +file(STRINGS "${LZ4_TOP_SOURCE_DIR}/lib/lz4.h" LZ4_VERSION_RELEASE REGEX "^#define LZ4_VERSION_RELEASE +([0-9]+) +.*$") +string(REGEX REPLACE "^#define LZ4_VERSION_RELEASE +([0-9]+) +.*$" "\\1" LZ4_VERSION_RELEASE "${LZ4_VERSION_RELEASE}") +set(LZ4_VERSION_STRING "${LZ4_VERSION_MAJOR}.${LZ4_VERSION_MINOR}.${LZ4_VERSION_RELEASE}") +mark_as_advanced(LZ4_VERSION_STRING LZ4_VERSION_MAJOR LZ4_VERSION_MINOR LZ4_VERSION_RELEASE) + +if("${CMAKE_VERSION}" VERSION_LESS "3.0") + project(LZ4 C) +else() + cmake_policy (SET CMP0048 NEW) + project(LZ4 + VERSION ${LZ4_VERSION_STRING} + LANGUAGES C) +endif() + +cmake_minimum_required (VERSION 2.8.6) + +# If LZ4 is being bundled in another project, we don't want to +# install anything. However, we want to let people override this, so +# we'll use the LZ4_BUNDLED_MODE variable to let them do that; just +# set it to OFF in your project before you add_subdirectory(lz4/contrib/cmake_unofficial). +get_directory_property(LZ4_PARENT_DIRECTORY PARENT_DIRECTORY) +if("${LZ4_BUNDLED_MODE}" STREQUAL "") + # Bundled mode hasn't been set one way or the other, set the default + # depending on whether or not we are the top-level project. + if("${LZ4_PARENT_DIRECTORY}" STREQUAL "") + set(LZ4_BUNDLED_MODE OFF) + else() + set(LZ4_BUNDLED_MODE ON) + endif() +endif() +mark_as_advanced(LZ4_BUNDLED_MODE) + +# CPack +if(NOT LZ4_BUNDLED_MODE AND NOT CPack_CMake_INCLUDED) + set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LZ4 compression library") + set(CPACK_PACKAGE_DESCRIPTION_FILE "${LZ4_TOP_SOURCE_DIR}/README.md") + set(CPACK_RESOURCE_FILE_LICENSE "${LZ4_TOP_SOURCE_DIR}/LICENSE") + set(CPACK_PACKAGE_VERSION_MAJOR ${LZ4_VERSION_MAJOR}) + set(CPACK_PACKAGE_VERSION_MINOR ${LZ4_VERSION_MINOR}) + set(CPACK_PACKAGE_VERSION_PATCH ${LZ4_VERSION_RELEASE}) + include(CPack) +endif(NOT LZ4_BUNDLED_MODE AND NOT CPack_CMake_INCLUDED) + +# Allow people to choose whether to build shared or static libraries +# via the BUILD_SHARED_LIBS option unless we are in bundled mode, in +# which case we always use static libraries. +include(CMakeDependentOption) +CMAKE_DEPENDENT_OPTION(BUILD_SHARED_LIBS "Build shared libraries" ON "NOT LZ4_BUNDLED_MODE" OFF) +CMAKE_DEPENDENT_OPTION(BUILD_STATIC_LIBS "Build static libraries" OFF "BUILD_SHARED_LIBS" ON) + +if(NOT BUILD_SHARED_LIBS AND NOT BUILD_STATIC_LIBS) + message(FATAL_ERROR "Both BUILD_SHARED_LIBS and BUILD_STATIC_LIBS have been disabled") +endif() + +set(LZ4_LIB_SOURCE_DIR "${LZ4_TOP_SOURCE_DIR}/lib") +set(LZ4_PROG_SOURCE_DIR "${LZ4_TOP_SOURCE_DIR}/programs") + +include_directories("${LZ4_LIB_SOURCE_DIR}") + +# CLI sources +set(LZ4_SOURCES + "${LZ4_LIB_SOURCE_DIR}/lz4.c" + "${LZ4_LIB_SOURCE_DIR}/lz4hc.c" + "${LZ4_LIB_SOURCE_DIR}/lz4.h" + "${LZ4_LIB_SOURCE_DIR}/lz4hc.h" + "${LZ4_LIB_SOURCE_DIR}/lz4frame.c" + "${LZ4_LIB_SOURCE_DIR}/lz4frame.h" + "${LZ4_LIB_SOURCE_DIR}/xxhash.c") +set(LZ4_CLI_SOURCES + "${LZ4_PROG_SOURCE_DIR}/bench.c" + "${LZ4_PROG_SOURCE_DIR}/lz4cli.c" + "${LZ4_PROG_SOURCE_DIR}/lz4io.c" + "${LZ4_PROG_SOURCE_DIR}/datagen.c") + +# Whether to use position independent code for the static library. If +# we're building a shared library this is ignored and PIC is always +# used. +option(LZ4_POSITION_INDEPENDENT_LIB "Use position independent code for static library (if applicable)" ON) + +# liblz4 +set(LZ4_LIBRARIES_BUILT) +if(BUILD_SHARED_LIBS) + add_library(lz4_shared SHARED ${LZ4_SOURCES}) + set_target_properties(lz4_shared PROPERTIES + OUTPUT_NAME lz4 + SOVERSION "${LZ4_VERSION_MAJOR}" + VERSION "${LZ4_VERSION_STRING}") + if(MSVC) + target_compile_definitions(lz4_shared PRIVATE + LZ4_DLL_EXPORT=1) + endif() + list(APPEND LZ4_LIBRARIES_BUILT lz4_shared) +endif() +if(BUILD_STATIC_LIBS) + add_library(lz4_static STATIC ${LZ4_SOURCES}) + set_target_properties(lz4_static PROPERTIES + OUTPUT_NAME lz4 + POSITION_INDEPENDENT_CODE ${LZ4_POSITION_INDEPENDENT_LIB}) + list(APPEND LZ4_LIBRARIES_BUILT lz4_static) +endif() + +# link to shared whenever possible, to static otherwise +if(BUILD_SHARED_LIBS) + set(LZ4_LINK_LIBRARY lz4_shared) +else() + set(LZ4_LINK_LIBRARY lz4_static) +endif() + +# lz4 +if (LZ4_BUILD_CLI) + set(LZ4_PROGRAMS_BUILT lz4cli) + add_executable(lz4cli ${LZ4_CLI_SOURCES}) + set_target_properties(lz4cli PROPERTIES OUTPUT_NAME lz4) + target_link_libraries(lz4cli ${LZ4_LINK_LIBRARY}) +endif() + +# lz4c +if (LZ4_BUILD_LEGACY_LZ4C) + list(APPEND LZ4_PROGRAMS_BUILT lz4c) + add_executable(lz4c ${LZ4_CLI_SOURCES}) + set_target_properties(lz4c PROPERTIES COMPILE_DEFINITIONS "ENABLE_LZ4C_LEGACY_OPTIONS") + target_link_libraries(lz4c ${LZ4_LINK_LIBRARY}) +endif() + +# Extra warning flags +include (CheckCCompilerFlag) +foreach (flag + # GCC-style + -Wall + -Wextra + -Wundef + -Wcast-qual + -Wcast-align + -Wshadow + -Wswitch-enum + -Wdeclaration-after-statement + -Wstrict-prototypes + -Wpointer-arith + + # MSVC-style + /W4) + # Because https://gcc.gnu.org/wiki/FAQ#wnowarning + string(REGEX REPLACE "\\-Wno\\-(.+)" "-W\\1" flag_to_test "${flag}") + string(REGEX REPLACE "[^a-zA-Z0-9]+" "_" test_name "CFLAG_${flag_to_test}") + + check_c_compiler_flag("${ADD_COMPILER_FLAGS_PREPEND} ${flag_to_test}" ${test_name}) + + if(${test_name}) + set(CMAKE_C_FLAGS "${flag} ${CMAKE_C_FLAGS}") + endif() + + unset(test_name) + unset(flag_to_test) +endforeach (flag) + +if(NOT LZ4_BUNDLED_MODE) + include(GNUInstallDirs) + + install(TARGETS ${LZ4_PROGRAMS_BUILT} + BUNDLE DESTINATION "${CMAKE_INSTALL_BINDIR}" + RUNTIME DESTINATION "${CMAKE_INSTALL_BINDIR}") + install(TARGETS ${LZ4_LIBRARIES_BUILT} + LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" + ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" + RUNTIME DESTINATION "${CMAKE_INSTALL_BINDIR}") + install(FILES + "${LZ4_LIB_SOURCE_DIR}/lz4.h" + "${LZ4_LIB_SOURCE_DIR}/lz4frame.h" + "${LZ4_LIB_SOURCE_DIR}/lz4hc.h" + DESTINATION "${CMAKE_INSTALL_INCLUDEDIR}") + install(FILES "${LZ4_PROG_SOURCE_DIR}/lz4.1" + DESTINATION "${CMAKE_INSTALL_MANDIR}/man1") + install(FILES "${CMAKE_CURRENT_BINARY_DIR}/liblz4.pc" + DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig") + + # install lz4cat and unlz4 symlinks on *nix + if(UNIX AND LZ4_BUILD_CLI) + install(CODE " + foreach(f lz4cat unlz4) + set(dest \"\$ENV{DESTDIR}${CMAKE_INSTALL_FULL_BINDIR}/\${f}\") + message(STATUS \"Symlinking: \${dest} -> lz4\") + execute_process( + COMMAND \"${CMAKE_COMMAND}\" -E create_symlink lz4 \"\${dest}\") + endforeach() + ") + + # create manpage aliases + foreach(f lz4cat unlz4) + file(WRITE "${CMAKE_CURRENT_BINARY_DIR}/${f}.1" ".so man1/lz4.1\n") + install(FILES "${CMAKE_CURRENT_BINARY_DIR}/${f}.1" + DESTINATION "${CMAKE_INSTALL_MANDIR}/man1") + endforeach() + endif(UNIX AND LZ4_BUILD_CLI) +endif(NOT LZ4_BUNDLED_MODE) + +# pkg-config +set(PREFIX "${CMAKE_INSTALL_PREFIX}") + +if("${CMAKE_INSTALL_FULL_LIBDIR}" STREQUAL "${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_LIBDIR}") + set(LIBDIR "\${prefix}/${CMAKE_INSTALL_LIBDIR}") +else() + set(LIBDIR "${CMAKE_INSTALL_FULL_LIBDIR}") +endif() + +if("${CMAKE_INSTALL_FULL_INCLUDEDIR}" STREQUAL "${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_INCLUDEDIR}") + set(INCLUDEDIR "\${prefix}/${CMAKE_INSTALL_INCLUDEDIR}") +else() + set(INCLUDEDIR "${CMAKE_INSTALL_FULL_INCLUDEDIR}") +endif() + +# for liblz4.pc substitution +set(VERSION ${LZ4_VERSION_STRING}) +configure_file(${LZ4_LIB_SOURCE_DIR}/liblz4.pc.in liblz4.pc @ONLY) diff --git a/lz4/contrib/debian/changelog b/lz4/contrib/debian/changelog new file mode 100644 index 0000000..87ac016 --- /dev/null +++ b/lz4/contrib/debian/changelog @@ -0,0 +1,10 @@ +liblz4 (1.7.2) unstable; urgency=low + + * Changed : moved to versioning; package, cli and library have same version number + * Improved: Small decompression speed boost (+4%) + * Improved: Performance on ARMv6 and ARMv7 + * Added : Debianization, by Evgeniy Polyakov + * Makefile: Generates object files (*.o) for faster (re)compilation on low power systems + * Fix : cli : crash on some invalid inputs + + -- Yann Collet Sun, 28 Jun 2015 01:00:00 +0000 diff --git a/lz4/contrib/debian/compat b/lz4/contrib/debian/compat new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/lz4/contrib/debian/compat @@ -0,0 +1 @@ +7 diff --git a/lz4/contrib/debian/control b/lz4/contrib/debian/control new file mode 100644 index 0000000..ac3b460 --- /dev/null +++ b/lz4/contrib/debian/control @@ -0,0 +1,23 @@ +Source: liblz4 +Section: devel +Priority: optional +Maintainer: Evgeniy Polyakov +Build-Depends: + cmake (>= 2.6), + debhelper (>= 7.0.50~), + cdbs +Standards-Version: 3.8.0 +Homepage: http://www.lz4.org/ +Vcs-Git: git://github.com/lz4/lz4.git +Vcs-Browser: https://github.com/lz4/lz4 + +Package: liblz4 +Architecture: any +Depends: ${shlibs:Depends}, ${misc:Depends} +Description: Extremely Fast Compression algorithm http://www.lz4.org + +Package: liblz4-dev +Architecture: any +Depends: ${shlibs:Depends}, ${misc:Depends} +Description: Extremely Fast Compression algorithm http://www.lz4.org + Development files. diff --git a/lz4/contrib/debian/copyright b/lz4/contrib/debian/copyright new file mode 100644 index 0000000..0914768 --- /dev/null +++ b/lz4/contrib/debian/copyright @@ -0,0 +1,9 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Upstream-Name: liblz4 +Upstream-Contact: Yann Collet +Source: https://github.com/lz4/lz4 + +Files: * +Copyright: (C) 2011-2020 Yann Collet +License: GPL-2+ + The full text of license: https://github.com/lz4/lz4/blob/dev/lib/LICENSE diff --git a/lz4/contrib/debian/dirs b/lz4/contrib/debian/dirs new file mode 100644 index 0000000..e772481 --- /dev/null +++ b/lz4/contrib/debian/dirs @@ -0,0 +1 @@ +usr/bin diff --git a/lz4/contrib/debian/docs b/lz4/contrib/debian/docs new file mode 100644 index 0000000..e69de29 diff --git a/lz4/contrib/debian/liblz4-dev.install b/lz4/contrib/debian/liblz4-dev.install new file mode 100644 index 0000000..3a02909 --- /dev/null +++ b/lz4/contrib/debian/liblz4-dev.install @@ -0,0 +1,2 @@ +usr/include/lz4* +usr/lib/liblz4.so diff --git a/lz4/contrib/debian/liblz4.install b/lz4/contrib/debian/liblz4.install new file mode 100644 index 0000000..e444956 --- /dev/null +++ b/lz4/contrib/debian/liblz4.install @@ -0,0 +1,2 @@ +usr/lib/liblz4.so.* +usr/bin/* diff --git a/lz4/contrib/debian/rules b/lz4/contrib/debian/rules new file mode 100755 index 0000000..c897bc5 --- /dev/null +++ b/lz4/contrib/debian/rules @@ -0,0 +1,7 @@ +#!/usr/bin/make -f + +include /usr/share/cdbs/1/rules/debhelper.mk +include /usr/share/cdbs/1/class/cmake.mk + + +DEB_CMAKE_EXTRA_FLAGS := -DCMAKE_BUILD_TYPE=RelWithDebInfo ../../build/cmake diff --git a/lz4/contrib/djgpp/LICENSE b/lz4/contrib/djgpp/LICENSE new file mode 100644 index 0000000..fee0d3b --- /dev/null +++ b/lz4/contrib/djgpp/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2014, lpsantil +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. + +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 HOLDER 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. + diff --git a/lz4/contrib/djgpp/Makefile b/lz4/contrib/djgpp/Makefile new file mode 100644 index 0000000..8cd3580 --- /dev/null +++ b/lz4/contrib/djgpp/Makefile @@ -0,0 +1,130 @@ +# Copyright (c) 2015, Louis P. Santillan +# All rights reserved. +# See LICENSE for licensing details. +DESTDIR ?= /opt/local + +# Pulled the code below from lib/Makefile. Might be nicer to derive this somehow without sed +# Version numbers +VERSION ?= 129 +RELEASE ?= r$(VERSION) +LIBVER_MAJOR=$(shell sed -n '/define LZ4_VERSION_MAJOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < lib/lz4.h) +LIBVER_MINOR=$(shell sed -n '/define LZ4_VERSION_MINOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < lib/lz4.h) +LIBVER_PATCH=$(shell sed -n '/define LZ4_VERSION_RELEASE/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < lib/lz4.h) +LIBVER=$(LIBVER_MAJOR).$(LIBVER_MINOR).$(LIBVER_PATCH) + +###################################################################### + +CROSS ?= i586-pc-msdosdjgpp +CC = $(CROSS)-gcc +AR = $(CROSS)-ar +LD = $(CROSS)-gcc + +CFLAGS ?= -O3 -std=gnu99 -Wall -Wextra -Wundef -Wshadow -Wcast-qual -Wcast-align -Wstrict-prototypes -pedantic -DLZ4_VERSION=\"$(RELEASE)\" +LDFLAGS ?= -s +SRC = programs/bench.c programs/lz4io.c programs/lz4cli.c +OBJ = $(SRC:.c=.o) +SDEPS = $(SRC:.c=.d) +IDIR = lib +EDIR = . +EXE = lz4.exe +LNK = lz4 +LDIR = lib +LSRC = lib/lz4.c lib/lz4hc.c lib/lz4frame.c lib/xxhash.c +INC = $(LSRC:.c=.h) +LOBJ = $(LSRC:.c=.o) +LSDEPS = $(LSRC:.c=.d) +LIB = $(LDIR)/lib$(LNK).a + +# Since LDFLAGS defaults to "-s", probably better to override unless +# you have a default you would like to maintain +ifeq ($(WITH_DEBUG), 1) + CFLAGS += -g + LDFLAGS += -g +endif + +# Since LDFLAGS defaults to "-s", probably better to override unless +# you have a default you would like to maintain +ifeq ($(WITH_PROFILING), 1) + CFLAGS += -pg + LDFLAGS += -pg +endif + +%.o: %.c $(INC) Makefile + $(CC) $(CFLAGS) -MMD -MP -I$(IDIR) -c $< -o $@ + +%.exe: %.o $(LIB) Makefile + $(LD) $< -L$(LDIR) -l$(LNK) $(LDFLAGS) $(LIBDEP) -o $@ + +###################################################################### +######################## DO NOT MODIFY BELOW ######################### +###################################################################### + +.PHONY: all install uninstall showconfig gstat gpush + +all: $(LIB) $(EXE) + +$(LIB): $(LOBJ) + $(AR) -rcs $@ $^ + +$(EXE): $(LOBJ) $(OBJ) + $(LD) $(LDFLAGS) $(LOBJ) $(OBJ) -o $(EDIR)/$@ + +clean: + rm -f $(OBJ) $(EXE) $(LOBJ) $(LIB) *.tmp $(SDEPS) $(LSDEPS) $(TSDEPS) + +install: $(INC) $(LIB) $(EXE) + mkdir -p $(DESTDIR)/bin $(DESTDIR)/include $(DESTDIR)/lib + rm -f .footprint + echo $(DESTDIR)/bin/$(EXE) >> .footprint + cp -v $(EXE) $(DESTDIR)/bin/ + @for T in $(LIB); \ + do ( \ + echo $(DESTDIR)/$$T >> .footprint; \ + cp -v --parents $$T $(DESTDIR) \ + ); done + @for T in $(INC); \ + do ( \ + echo $(DESTDIR)/include/`basename -a $$T` >> .footprint; \ + cp -v $$T $(DESTDIR)/include/ \ + ); done + +uninstall: .footprint + @for T in $(shell cat .footprint); do rm -v $$T; done + +-include $(SDEPS) $(LSDEPS) + +showconfig: + @echo "PWD="$(PWD) + @echo "VERSION="$(VERSION) + @echo "RELEASE="$(RELEASE) + @echo "LIBVER_MAJOR="$(LIBVER_MAJOR) + @echo "LIBVER_MINOR="$(LIBVER_MINOR) + @echo "LIBVER_PATCH="$(LIBVER_PATCH) + @echo "LIBVER="$(LIBVER) + @echo "CROSS="$(CROSS) + @echo "CC="$(CC) + @echo "AR="$(AR) + @echo "LD="$(LD) + @echo "DESTDIR="$(DESTDIR) + @echo "CFLAGS="$(CFLAGS) + @echo "LDFLAGS="$(LDFLAGS) + @echo "SRC="$(SRC) + @echo "OBJ="$(OBJ) + @echo "IDIR="$(IDIR) + @echo "INC="$(INC) + @echo "EDIR="$(EDIR) + @echo "EXE="$(EXE) + @echo "LDIR="$(LDIR) + @echo "LSRC="$(LSRC) + @echo "LOBJ="$(LOBJ) + @echo "LNK="$(LNK) + @echo "LIB="$(LIB) + @echo "SDEPS="$(SDEPS) + @echo "LSDEPS="$(LSDEPS) + +gstat: + git status + +gpush: + git commit + git push diff --git a/lz4/contrib/djgpp/README.MD b/lz4/contrib/djgpp/README.MD new file mode 100644 index 0000000..0f4cae6 --- /dev/null +++ b/lz4/contrib/djgpp/README.MD @@ -0,0 +1,21 @@ +# lz4 for DOS/djgpp +This file details on how to compile lz4.exe, and liblz4.a for use on DOS/djgpp using +Andrew Wu's build-djgpp cross compilers ([GH][0], [Binaries][1]) on OSX, Linux. + +## Setup +* Download a djgpp tarball [binaries][1] for your platform. +* Extract and install it (`tar jxvf djgpp-linux64-gcc492.tar.bz2`). Note the path. We'll assume `/home/user/djgpp`. +* Add the `bin` folder to your `PATH`. In bash, do `export PATH=/home/user/djgpp/bin:$PATH`. +* The `Makefile` in `contrib/djgpp/` sets up `CC`, `AR`, `LD` for you. So, `CC=i586-pc-msdosdjgpp-gcc`, `AR=i586-pc-msdosdjgpp-ar`, `LD=i586-pc-msdosdjgpp-gcc`. + +## Building LZ4 for DOS +In the base dir of lz4 and with `contrib/djgpp/Makefile`, try: +Try: +* `make -f contrib/djgpp/Makefile` +* `make -f contrib/djgpp/Makefile liblz4.a` +* `make -f contrib/djgpp/Makefile lz4.exe` +* `make -f contrib/djgpp/Makefile DESTDIR=/home/user/dos install`, however it doesn't make much sense on a \*nix. +* You can also do `make -f contrib/djgpp/Makefile uninstall` + +[0]: https://github.com/andrewwutw/build-djgpp +[1]: https://github.com/andrewwutw/build-djgpp/releases diff --git a/lz4/contrib/gen_manual/.gitignore b/lz4/contrib/gen_manual/.gitignore new file mode 100644 index 0000000..6ea967f --- /dev/null +++ b/lz4/contrib/gen_manual/.gitignore @@ -0,0 +1,2 @@ +# build artefact +gen_manual diff --git a/lz4/contrib/gen_manual/Makefile b/lz4/contrib/gen_manual/Makefile new file mode 100644 index 0000000..95abe2e --- /dev/null +++ b/lz4/contrib/gen_manual/Makefile @@ -0,0 +1,76 @@ +# ################################################################ +# Copyright (C) Przemyslaw Skibinski 2016-present +# All rights reserved. +# +# BSD license +# 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. +# +# 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 HOLDER 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. +# +# You can contact the author at : +# - LZ4 source repository : https://github.com/Cyan4973/lz4 +# - LZ4 forum froup : https://groups.google.com/forum/#!forum/lz4c +# ################################################################ + + +CXXFLAGS ?= -O3 +CXXFLAGS += -Wall -Wextra -Wcast-qual -Wcast-align -Wshadow -Wstrict-aliasing=1 -Wswitch-enum -Wno-comment +CXXFLAGS += $(MOREFLAGS) +FLAGS = $(CPPFLAGS) $(CXXFLAGS) $(LDFLAGS) + +LZ4API = ../../lib/lz4.h +LZ4MANUAL = ../../doc/lz4_manual.html +LZ4FAPI = ../../lib/lz4frame.h +LZ4FMANUAL = ../../doc/lz4frame_manual.html +LIBVER_MAJOR_SCRIPT:=`sed -n '/define LZ4_VERSION_MAJOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < $(LZ4API)` +LIBVER_MINOR_SCRIPT:=`sed -n '/define LZ4_VERSION_MINOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < $(LZ4API)` +LIBVER_PATCH_SCRIPT:=`sed -n '/define LZ4_VERSION_RELEASE/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < $(LZ4API)` +LIBVER_SCRIPT:= $(LIBVER_MAJOR_SCRIPT).$(LIBVER_MINOR_SCRIPT).$(LIBVER_PATCH_SCRIPT) +LZ4VER := $(shell echo $(LIBVER_SCRIPT)) + +# Define *.exe as extension for Windows systems +ifneq (,$(filter Windows%,$(OS))) +EXT =.exe +else +EXT = +endif + + +.PHONY: default +default: gen_manual + +gen_manual: gen_manual.cpp + $(CXX) $(FLAGS) $^ -o $@$(EXT) + +$(LZ4MANUAL) : gen_manual $(LZ4API) + echo "Update lz4 manual in /doc" + ./gen_manual $(LZ4VER) $(LZ4API) $@ + +$(LZ4FMANUAL) : gen_manual $(LZ4FAPI) + echo "Update lz4frame manual in /doc" + ./gen_manual $(LZ4VER) $(LZ4FAPI) $@ + +.PHONY: manuals +manuals: gen_manual $(LZ4MANUAL) $(LZ4FMANUAL) + +.PHONY: clean +clean: + @$(RM) gen_manual$(EXT) + @echo Cleaning completed diff --git a/lz4/contrib/gen_manual/README.md b/lz4/contrib/gen_manual/README.md new file mode 100644 index 0000000..7664ac6 --- /dev/null +++ b/lz4/contrib/gen_manual/README.md @@ -0,0 +1,31 @@ +gen_manual - a program for automatic generation of manual from source code +========================================================================== + +#### Introduction + +This simple C++ program generates a single-page HTML manual from `lz4.h`. + +The format of recognized comment blocks is following: +- comments of type `/*!` mean: this is a function declaration; switch comments with declarations +- comments of type `/**` and `/*-` mean: this is a comment; use a `

    ` header for the first line +- comments of type `/*=` and `/**=` mean: use a `

    ` header and show also all functions until first empty line +- comments of type `/*X` where `X` is different from above-mentioned are ignored + +Moreover: +- `LZ4LIB_API` is removed to improve readability +- `typedef` are detected and included even if uncommented +- comments of type `/**<` and `/*!<` are detected and only function declaration is highlighted (bold) + + +#### Usage + +The program requires 3 parameters: +``` +gen_manual [lz4_version] [input_file] [output_html] +``` + +To compile program and generate lz4 manual we have used: +``` +make +./gen_manual.exe 1.7.3 ../../lib/lz4.h lz4_manual.html +``` diff --git a/lz4/contrib/gen_manual/gen-lz4-manual.sh b/lz4/contrib/gen_manual/gen-lz4-manual.sh new file mode 100644 index 0000000..73a7214 --- /dev/null +++ b/lz4/contrib/gen_manual/gen-lz4-manual.sh @@ -0,0 +1,10 @@ +#!/bin/sh + +LIBVER_MAJOR_SCRIPT=`sed -n '/define LZ4_VERSION_MAJOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < ../../lib/lz4.h` +LIBVER_MINOR_SCRIPT=`sed -n '/define LZ4_VERSION_MINOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < ../../lib/lz4.h` +LIBVER_PATCH_SCRIPT=`sed -n '/define LZ4_VERSION_RELEASE/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < ../../lib/lz4.h` +LIBVER_SCRIPT=$LIBVER_MAJOR_SCRIPT.$LIBVER_MINOR_SCRIPT.$LIBVER_PATCH_SCRIPT + +echo LZ4_VERSION=$LIBVER_SCRIPT +./gen_manual "lz4 $LIBVER_SCRIPT" ../../lib/lz4.h ./lz4_manual.html +./gen_manual "lz4frame $LIBVER_SCRIPT" ../../lib/lz4frame.h ./lz4frame_manual.html diff --git a/lz4/contrib/gen_manual/gen_manual.cpp b/lz4/contrib/gen_manual/gen_manual.cpp new file mode 100644 index 0000000..d5fe702 --- /dev/null +++ b/lz4/contrib/gen_manual/gen_manual.cpp @@ -0,0 +1,248 @@ +/* +Copyright (c) 2016-present, Przemyslaw Skibinski +All rights reserved. + +BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php) + +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. + +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. + +You can contact the author at : +- LZ4 homepage : http://www.lz4.org +- LZ4 source repository : https://github.com/lz4/lz4 +*/ + +#include +#include +#include +#include +using namespace std; + + +/* trim string at the beginning and at the end */ +void trim(string& s, string characters) +{ + size_t p = s.find_first_not_of(characters); + s.erase(0, p); + + p = s.find_last_not_of(characters); + if (string::npos != p) + s.erase(p+1); +} + + +/* trim C++ style comments */ +void trim_comments(string &s) +{ + size_t spos, epos; + + spos = s.find("/*"); + epos = s.find("*/"); + s = s.substr(spos+3, epos-(spos+3)); +} + + +/* get lines until a given terminator */ +vector get_lines(vector& input, int& linenum, string terminator) +{ + vector out; + string line; + + while ((size_t)linenum < input.size()) { + line = input[linenum]; + + if (terminator.empty() && line.empty()) { linenum--; break; } + + size_t const epos = line.find(terminator); + if (!terminator.empty() && epos!=string::npos) { + out.push_back(line); + break; + } + out.push_back(line); + linenum++; + } + return out; +} + + +/* print line with LZ4LIB_API removed and C++ comments not bold */ +void print_line(stringstream &sout, string line) +{ + size_t spos, epos; + + if (line.substr(0,11) == "LZ4LIB_API ") line = line.substr(11); + if (line.substr(0,12) == "LZ4FLIB_API ") line = line.substr(12); + spos = line.find("/*"); + epos = line.find("*/"); + if (spos!=string::npos && epos!=string::npos) { + sout << line.substr(0, spos); + sout << "" << line.substr(spos) << "" << '\n'; + } else { + sout << line << '\n'; + } +} + + +int main(int argc, char *argv[]) { + char exclam; + int linenum, chapter = 1; + vector input, lines, comments, chapters; + string line, version; + size_t spos, l; + stringstream sout; + ifstream istream; + ofstream ostream; + + if (argc < 4) { + cout << "usage: " << argv[0] << " [lz4_version] [input_file] [output_html]" << endl; + return 1; + } + + version = string(argv[1]) + " Manual"; + + istream.open(argv[2], ifstream::in); + if (!istream.is_open()) { + cout << "Error opening file " << argv[2] << endl; + return 1; + } + + ostream.open(argv[3], ifstream::out); + if (!ostream.is_open()) { + cout << "Error opening file " << argv[3] << endl; + return 1; + } + + while (getline(istream, line)) { + input.push_back(line); + } + + for (linenum=0; (size_t)linenum < input.size(); linenum++) { + line = input[linenum]; + + /* typedefs are detected and included even if uncommented */ + if (line.substr(0,7) == "typedef" && line.find("{")!=string::npos) { + lines = get_lines(input, linenum, "}"); + sout << "
    ";
+            for (l=0; l

    " << endl; + continue; + } + + /* comments of type / * * < and / * ! < are detected, and only function declaration is highlighted (bold) */ + if ((line.find("/**<")!=string::npos || line.find("/*!<")!=string::npos) + && line.find("*/")!=string::npos) { + sout << "
    ";
+            print_line(sout, line);
+            sout << "

    " << endl; + continue; + } + + spos = line.find("/**="); + if (spos==string::npos) { + spos = line.find("/*!"); + if (spos==string::npos) + spos = line.find("/**"); + if (spos==string::npos) + spos = line.find("/*-"); + if (spos==string::npos) + spos = line.find("/*="); + if (spos==string::npos) + continue; + exclam = line[spos+2]; + } + else exclam = '='; + + comments = get_lines(input, linenum, "*/"); + if (!comments.empty()) comments[0] = line.substr(spos+3); + if (!comments.empty()) + comments[comments.size()-1] = comments[comments.size()-1].substr(0, comments[comments.size()-1].find("*/")); + for (l=0; l"; + for (l=0; l

    "; + for (l=0; l
    " << endl << endl; + } else if (exclam == '=') { /* comments of type / * = and / * * = mean: use a

    header and show also all functions until first empty line */ + trim(comments[0], " "); + sout << "

    " << comments[0] << "

    ";
+            for (l=1; l
    ";
+            lines = get_lines(input, ++linenum, "");
+            for (l=0; l
    " << endl;
+        } else { /* comments of type  / * *  and  / * -  mean: this is a comment; use a 
     header for the first line */
+            if (comments.empty()) continue;
+
+            trim(comments[0], " ");
+            sout << "
    " << comments[0] << "
    ";
+            chapters.push_back(comments[0]);
+            chapter++;
+
+            for (l=1; l 1)
+                sout << "
    " << endl << endl;
+            else
+                sout << "
    " << endl << endl;
+        }
+    }
+
+    ostream << "\n\n\n" << version << "\n\n" << endl;
+    ostream << "
    " << version << "
    \n";
+
+    ostream << "
    \n
    Contents
    \n
      \n";
+    for (size_t i=0; i" << chapters[i].c_str() << "\n";
+    ostream << "
    \n
    \n";
+
+    ostream << sout.str();
+    ostream << "" << endl << "" << endl;
+
+    return 0;
+}
diff --git a/lz4/contrib/meson/README.md b/lz4/contrib/meson/README.md
new file mode 100644
index 0000000..a44850a
--- /dev/null
+++ b/lz4/contrib/meson/README.md
@@ -0,0 +1,34 @@
+Meson build system for lz4
+==========================
+
+Meson is a build system designed to optimize programmer productivity.
+It aims to do this by providing simple, out-of-the-box support for
+modern software development tools and practices, such as unit tests,
+coverage reports, Valgrind, CCache and the like.
+
+This Meson build system is provided with no guarantee.
+
+## How to build
+
+`cd` to this meson directory (`contrib/meson`)
+
+```sh
+meson setup --buildtype=release -Ddefault_library=shared -Dbin_programs=true builddir
+cd builddir
+ninja             # to build
+ninja install     # to install
+```
+
+You might want to install it in staging directory:
+
+```sh
+DESTDIR=./staging ninja install
+```
+
+To configure build options, use:
+
+```sh
+meson configure
+```
+
+See [man meson(1)](https://manpages.debian.org/testing/meson/meson.1.en.html).
diff --git a/lz4/contrib/meson/meson.build b/lz4/contrib/meson/meson.build
new file mode 100644
index 0000000..d1e97d9
--- /dev/null
+++ b/lz4/contrib/meson/meson.build
@@ -0,0 +1,21 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+# This is a dummy meson file.
+# The intention is that it can be easily moved to the root of the project
+# (together with meson_options.txt) and packaged for wrapdb.
+
+project('lz4', ['c'],
+  license: ['BSD', 'GPLv2'],
+  default_options : ['c_std=c99',
+    'buildtype=release'],
+  version: 'DUMMY',
+  meson_version: '>=0.47.0')
+
+subdir('meson')
diff --git a/lz4/contrib/meson/meson/GetLz4LibraryVersion.py b/lz4/contrib/meson/meson/GetLz4LibraryVersion.py
new file mode 100644
index 0000000..d8abfcb
--- /dev/null
+++ b/lz4/contrib/meson/meson/GetLz4LibraryVersion.py
@@ -0,0 +1,39 @@
+#!/usr/bin/env python3
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+import re
+
+
+def find_version_tuple(filepath):
+  version_file_data = None
+  with open(filepath) as fd:
+    version_file_data = fd.read()
+
+  patterns = r"""#\s*define\s+LZ4_VERSION_MAJOR\s+([0-9]+).*$
+#\s*define\s+LZ4_VERSION_MINOR\s+([0-9]+).*$
+#\s*define\s+LZ4_VERSION_RELEASE\s+([0-9]+).*$
+"""
+  regex = re.compile(patterns, re.MULTILINE)
+  version_match = regex.search(version_file_data)
+  if version_match:
+    return version_match.groups()
+  raise Exception("Unable to find version string.")
+
+
+def main():
+  import argparse
+  parser = argparse.ArgumentParser(description='Print lz4 version from lib/lz4.h')
+  parser.add_argument('file', help='path to lib/lz4.h')
+  args = parser.parse_args()
+  version_tuple = find_version_tuple(args.file)
+  print('.'.join(version_tuple))
+
+
+if __name__ == '__main__':
+  main()
diff --git a/lz4/contrib/meson/meson/InstallSymlink.py b/lz4/contrib/meson/meson/InstallSymlink.py
new file mode 100644
index 0000000..3f2998c
--- /dev/null
+++ b/lz4/contrib/meson/meson/InstallSymlink.py
@@ -0,0 +1,55 @@
+#!/usr/bin/env python3
+# #############################################################################
+# Copyright (c) 2018-present  lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+# This file should be synced with https://github.com/lzutao/meson-symlink
+
+import os
+import pathlib  # since Python 3.4
+
+
+def install_symlink(src, dst, install_dir, dst_is_dir=False, dir_mode=0o777):
+  if not install_dir.exists():
+    install_dir.mkdir(mode=dir_mode, parents=True, exist_ok=True)
+  if not install_dir.is_dir():
+    raise NotADirectoryError(install_dir)
+
+  new_dst = install_dir.joinpath(dst)
+  if new_dst.is_symlink() and os.readlink(new_dst) == src:
+    print('File exists: {!r} -> {!r}'.format(new_dst, src))
+    return
+  print('Installing symlink {!r} -> {!r}'.format(new_dst, src))
+  new_dst.symlink_to(src, target_is_directory=dst_is_dir)
+
+
+def main():
+  import argparse
+  parser = argparse.ArgumentParser(description='Install a symlink',
+      usage='{0} [-h] [-d] [-m MODE] source dest install_dir\n\n'
+            'example:\n'
+            '        {0} dash sh /bin'.format(pathlib.Path(__file__).name))
+  parser.add_argument('source', help='target to link')
+  parser.add_argument('dest', help='link name')
+  parser.add_argument('install_dir', help='installation directory')
+  parser.add_argument('-d', '--isdir',
+      action='store_true',
+      help='dest is a directory')
+  parser.add_argument('-m', '--mode',
+      help='directory mode on creating if not exist',
+      default='0o755')
+  args = parser.parse_args()
+
+  dir_mode = int(args.mode, 8)
+
+  meson_destdir = os.environ.get('MESON_INSTALL_DESTDIR_PREFIX', default='')
+  install_dir = pathlib.Path(meson_destdir, args.install_dir)
+  install_symlink(args.source, args.dest, install_dir, args.isdir, dir_mode)
+
+
+if __name__ == '__main__':
+  main()
diff --git a/lz4/contrib/meson/meson/contrib/gen_manual/meson.build b/lz4/contrib/meson/meson/contrib/gen_manual/meson.build
new file mode 100644
index 0000000..a872bd6
--- /dev/null
+++ b/lz4/contrib/meson/meson/contrib/gen_manual/meson.build
@@ -0,0 +1,43 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+lz4_root_dir = '../../../../..'
+
+add_languages('cpp')
+cxx = meson.get_compiler('cpp')
+
+gen_manual_includes = include_directories(join_paths(lz4_root_dir, 'contrib/gen_manual'))
+
+gen_manual_cppflags = cxx.get_supported_arguments(['-Wextra', '-Wcast-qual',
+  '-Wcast-align', '-Wshadow', '-Wstrict-aliasing=1', '-Wswitch-enum',
+  '-Wno-comment'])
+
+gen_manual = executable('gen_manual',
+  join_paths(lz4_root_dir, 'contrib/gen_manual/gen_manual.cpp'),
+  cpp_args: gen_manual_cppflags,
+  include_directories: gen_manual_includes,
+  native: true,
+  install: false)
+
+# Update lz4 manual
+lz4_manual_html = custom_target('lz4_manual.html',
+  output : 'lz4_manual.html',
+  command : [gen_manual,
+    lz4_version,
+    join_paths(meson.current_source_dir(), lz4_root_dir, 'lib/lz4.h'),
+    '@OUTPUT@'],
+  install : false)
+# Update lz4frame manual
+lz4_manual_html = custom_target('lz4frame_manual.html',
+  output : 'lz4frame_manual.html',
+  command : [gen_manual,
+    lz4_version,
+    join_paths(meson.current_source_dir(), lz4_root_dir, 'lib/lz4frame.h'),
+    '@OUTPUT@'],
+  install : false)
diff --git a/lz4/contrib/meson/meson/contrib/meson.build b/lz4/contrib/meson/meson/contrib/meson.build
new file mode 100644
index 0000000..5249a4c
--- /dev/null
+++ b/lz4/contrib/meson/meson/contrib/meson.build
@@ -0,0 +1,10 @@
+# #############################################################################
+# Copyright (c) 2018-present        lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+subdir('gen_manual')
diff --git a/lz4/contrib/meson/meson/examples/meson.build b/lz4/contrib/meson/meson/examples/meson.build
new file mode 100644
index 0000000..493049d
--- /dev/null
+++ b/lz4/contrib/meson/meson/examples/meson.build
@@ -0,0 +1,49 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+lz4_root_dir = '../../../..'
+
+#examples_c_args = ['-Wextra', '-Wundef', '-Wshadow', '-Wcast-align', '-Wstrict-prototypes']
+
+printVersion = executable('printVersion',
+  join_paths(lz4_root_dir, 'examples/printVersion.c'),
+  dependencies: liblz4_dep,
+  install: false)
+doubleBuffer = executable('doubleBuffer',
+  join_paths(lz4_root_dir, 'examples/blockStreaming_doubleBuffer.c'),
+  dependencies: liblz4_dep,
+  install: false)
+dictionaryRandomAccess = executable('dictionaryRandomAccess',
+  join_paths(lz4_root_dir, 'examples/dictionaryRandomAccess.c'),
+  dependencies: liblz4_dep,
+  install: false)
+ringBuffer = executable('ringBuffer',
+  join_paths(lz4_root_dir, 'examples/blockStreaming_ringBuffer.c'),
+  dependencies: liblz4_dep,
+  install: false)
+ringBufferHC = executable('ringBufferHC',
+  join_paths(lz4_root_dir, 'examples/HCStreaming_ringBuffer.c'),
+  dependencies: liblz4_dep,
+  install: false)
+lineCompress = executable('lineCompress',
+  join_paths(lz4_root_dir, 'examples/blockStreaming_lineByLine.c'),
+  dependencies: liblz4_dep,
+  install: false)
+frameCompress = executable('frameCompress',
+  join_paths(lz4_root_dir, 'examples/frameCompress.c'),
+  dependencies: liblz4_dep,
+  install: false)
+compressFunctions = executable('compressFunctions',
+  join_paths(lz4_root_dir, 'examples/compress_functions.c'),
+  dependencies: liblz4_dep,
+  install: false)
+simpleBuffer = executable('simpleBuffer',
+  join_paths(lz4_root_dir, 'examples/simple_buffer.c'),
+  dependencies: liblz4_dep,
+  install: false)
diff --git a/lz4/contrib/meson/meson/lib/meson.build b/lz4/contrib/meson/meson/lib/meson.build
new file mode 100644
index 0000000..131edcb
--- /dev/null
+++ b/lz4/contrib/meson/meson/lib/meson.build
@@ -0,0 +1,57 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+lz4_root_dir = '../../../..'
+
+liblz4_includes = [include_directories(join_paths(lz4_root_dir, 'lib'))]
+liblz4_sources = [join_paths(lz4_root_dir, 'lib/lz4.c'),
+  join_paths(lz4_root_dir, 'lib/lz4frame.c'),
+  join_paths(lz4_root_dir, 'lib/lz4hc.c'),
+  join_paths(lz4_root_dir, 'lib/xxhash.c')]
+liblz4_c_args = []
+
+liblz4_debug_cflags = []
+if use_debug
+  liblz4_c_args += '-DLZ4_DEBUG=@0@'.format(debug_level)
+  if [compiler_gcc, compiler_clang].contains(cc_id)
+    liblz4_debug_cflags = ['-Wextra', '-Wcast-qual', '-Wcast-align', '-Wshadow',
+      '-Wswitch-enum', '-Wdeclaration-after-statement', '-Wstrict-prototypes',
+      '-Wundef', '-Wpointer-arith', '-Wstrict-aliasing=1']
+  endif
+endif
+liblz4_c_args += cc.get_supported_arguments(liblz4_debug_cflags)
+
+if host_machine_os == os_windows and default_library != 'static'
+  liblz4_c_args += '-DLZ4_DLL_EXPORT=1'
+endif
+
+liblz4 = library('lz4',
+  liblz4_sources,
+  include_directories: liblz4_includes,
+  c_args: liblz4_c_args,
+  install: true,
+  version: lz4_libversion)
+
+liblz4_dep = declare_dependency(link_with: liblz4,
+  include_directories: liblz4_includes)
+
+pkgconfig.generate(liblz4,
+  name: 'lz4',
+  filebase: 'liblz4',
+  description: 'extremely fast lossless compression algorithm library',
+  version: lz4_libversion,
+  url: 'http://www.lz4.org/')
+
+install_headers(join_paths(lz4_root_dir, 'lib/lz4.h'),
+  join_paths(lz4_root_dir, 'lib/lz4hc.h'),
+  join_paths(lz4_root_dir, 'lib/lz4frame.h'))
+
+if default_library != 'shared'
+  install_headers(join_paths(lz4_root_dir, 'lib/lz4frame_static.h'))
+endif
diff --git a/lz4/contrib/meson/meson/meson.build b/lz4/contrib/meson/meson/meson.build
new file mode 100644
index 0000000..b278b7c
--- /dev/null
+++ b/lz4/contrib/meson/meson/meson.build
@@ -0,0 +1,117 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+cc = meson.get_compiler('c')
+pkgconfig = import('pkgconfig')
+c_std = get_option('c_std')
+default_library = get_option('default_library')
+
+host_machine_os = host_machine.system()
+os_windows = 'windows'
+os_linux = 'linux'
+os_darwin = 'darwin'
+os_freebsd = 'freebsd'
+os_sun = 'sunos'
+
+cc_id = cc.get_id()
+compiler_gcc = 'gcc'
+compiler_clang = 'clang'
+compiler_msvc = 'msvc'
+
+lz4_version = meson.project_version()
+
+lz4_h_file = join_paths(meson.current_source_dir(), '../../../lib/lz4.h')
+GetLz4LibraryVersion_py = find_program('GetLz4LibraryVersion.py', native : true)
+r = run_command(GetLz4LibraryVersion_py, lz4_h_file)
+if r.returncode() == 0
+  lz4_version = r.stdout().strip()
+  message('Project version is now: @0@'.format(lz4_version))
+else
+  error('Cannot find project version in @0@'.format(lz4_h_file))
+endif
+
+lz4_libversion = lz4_version
+
+# =============================================================================
+# Installation directories
+# =============================================================================
+
+lz4_prefix = get_option('prefix')
+lz4_bindir = get_option('bindir')
+lz4_datadir = get_option('datadir')
+lz4_mandir = get_option('mandir')
+lz4_docdir = join_paths(lz4_datadir, 'doc', meson.project_name())
+
+# =============================================================================
+# Project options
+# =============================================================================
+
+buildtype = get_option('buildtype')
+
+# Built-in options
+use_debug = get_option('debug')
+
+# Custom options
+debug_level = get_option('debug_level')
+use_backtrace = get_option('backtrace')
+
+bin_programs = get_option('bin_programs')
+bin_contrib = get_option('bin_contrib')
+bin_tests = get_option('bin_tests')
+bin_examples = get_option('bin_examples')
+#feature_multi_thread = get_option('multi_thread')
+
+# =============================================================================
+# Dependencies
+# =============================================================================
+
+#libm_dep = cc.find_library('m', required: bin_tests)
+#thread_dep = dependency('threads', required: feature_multi_thread)
+#use_multi_thread = thread_dep.found()
+
+# =============================================================================
+# Compiler flags
+# =============================================================================
+
+add_project_arguments(['-DXXH_NAMESPACE=LZ4_'], language: 'c')
+
+if [compiler_gcc, compiler_clang].contains(cc_id)
+  common_warning_flags = []
+  # Should use Meson's own --werror build option
+  #common_warning_flags += ['-Werror']
+  if c_std == 'c89' or c_std == 'gnu89'
+    common_warning_flags += ['-pedantic', '-Wno-long-long', '-Wno-variadic-macros']
+  elif c_std == 'c99' or c_std == 'gnu99'
+    common_warning_flags += ['-pedantic']
+  endif
+  cc_compile_flags = cc.get_supported_arguments(common_warning_flags)
+  add_project_arguments(cc_compile_flags, language: 'c')
+endif
+
+# =============================================================================
+# Subdirs
+# =============================================================================
+
+subdir('lib')
+
+if bin_programs
+  subdir('programs')
+endif
+
+if bin_tests
+  subdir('tests')
+endif
+
+if bin_contrib
+  subdir('contrib')
+endif
+
+if bin_examples
+  subdir('examples')
+endif
diff --git a/lz4/contrib/meson/meson/programs/meson.build b/lz4/contrib/meson/meson/programs/meson.build
new file mode 100644
index 0000000..705dbf5
--- /dev/null
+++ b/lz4/contrib/meson/meson/programs/meson.build
@@ -0,0 +1,52 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+lz4_root_dir = '../../../..'
+
+lz4_includes = include_directories(join_paths(lz4_root_dir, 'programs'))
+lz4_sources = [join_paths(lz4_root_dir, 'programs/bench.c'),
+  join_paths(lz4_root_dir, 'programs/datagen.c'),
+  join_paths(lz4_root_dir, 'programs/lz4cli.c'),
+  join_paths(lz4_root_dir, 'programs/lz4io.c')]
+lz4_c_args = []
+
+export_dynamic_on_windows = false
+# explicit backtrace enable/disable for Linux & Darwin
+if not use_backtrace
+  lz4_c_args += '-DBACKTRACE_ENABLE=0'
+elif use_debug and host_machine_os == os_windows  # MinGW target
+  lz4_c_args += '-DBACKTRACE_ENABLE=1'
+  export_dynamic_on_windows = true
+endif
+
+lz4_deps = [ liblz4_dep ]
+
+lz4 = executable('lz4',
+  lz4_sources,
+  include_directories: lz4_includes,
+  c_args: lz4_c_args,
+  dependencies: lz4_deps,
+  export_dynamic: export_dynamic_on_windows, # Since Meson 0.45.0
+  install: true)
+
+# =============================================================================
+# Programs and manpages installing
+# =============================================================================
+
+install_man(join_paths(lz4_root_dir, 'programs/lz4.1'))
+
+InstallSymlink_py = '../InstallSymlink.py'
+lz4_man1_dir = join_paths(lz4_mandir, 'man1')
+bin_EXT = host_machine_os == os_windows ? '.exe' : ''
+man1_EXT = meson.version().version_compare('>=0.49.0') ? '.1' : '.1.gz'
+
+foreach f : ['lz4c', 'lz4cat', 'unlz4']
+  meson.add_install_script(InstallSymlink_py, 'lz4' + bin_EXT, f + bin_EXT, lz4_bindir)
+  meson.add_install_script(InstallSymlink_py, 'lz4' + man1_EXT, f + man1_EXT, lz4_man1_dir)
+endforeach
diff --git a/lz4/contrib/meson/meson/tests/meson.build b/lz4/contrib/meson/meson/tests/meson.build
new file mode 100644
index 0000000..7800475
--- /dev/null
+++ b/lz4/contrib/meson/meson/tests/meson.build
@@ -0,0 +1,93 @@
+# #############################################################################
+# Copyright (c) 2018-present    lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+lz4_root_dir = '../../../..'
+programs_dir_inc = include_directories(join_paths(lz4_root_dir, 'programs'))
+lib_dir_inc = include_directories(join_paths(lz4_root_dir, 'lib'))
+
+# =============================================================================
+# Test flags
+# =============================================================================
+
+TEST_FILES   = join_paths(meson.current_source_dir(), lz4_root_dir, 'tests/COPYING')
+FUZZER_TIME  = '-T90s'
+NB_LOOPS     = '-i1'
+
+# =============================================================================
+# Executables
+# =============================================================================
+
+fullbench_sources = [join_paths(lz4_root_dir, 'tests/fullbench.c')]
+fullbench = executable('fullbench',
+  fullbench_sources,
+  include_directories: programs_dir_inc,
+  dependencies: liblz4_dep,
+  install: false)
+
+fuzzer_sources = [join_paths(lz4_root_dir, 'tests/fuzzer.c')]
+fuzzer = executable('fuzzer',
+  fuzzer_sources,
+  c_args: ['-D_DEFAULT_SOURCE', '-D_BSD_SOURCE'], # since glibc 2.19
+  include_directories: programs_dir_inc,
+  dependencies: liblz4_dep,
+  install: false)
+
+frametest_sources = [join_paths(lz4_root_dir, 'tests/frametest.c')]
+frametest = executable('frametest',
+  frametest_sources,
+  include_directories: programs_dir_inc,
+  dependencies: liblz4_dep,
+  install: false)
+
+roundTripTest_sources = [join_paths(lz4_root_dir, 'tests/roundTripTest.c')]
+roundTripTest = executable('roundTripTest',
+  roundTripTest_sources,
+  dependencies: [ liblz4_dep ],
+  install: false)
+
+datagen_sources = [join_paths(lz4_root_dir, 'tests/datagencli.c')]
+datagen = executable('datagen',
+  datagen_sources,
+  objects: lz4.extract_objects(join_paths(lz4_root_dir, 'programs/datagen.c')),
+  include_directories: lz4_includes,
+  dependencies: [ liblz4_dep ],
+  install: false)
+
+checkFrame_sources = [join_paths(lz4_root_dir, 'tests/checkFrame.c')]
+checkFrame = executable('checkFrame',
+  checkFrame_sources,
+  include_directories: programs_dir_inc,
+  dependencies: [ liblz4_dep ],
+  install: false)
+
+checkTag_sources = [join_paths(lz4_root_dir, 'tests/checkTag.c')]
+checkTag = executable('checkTag',
+  checkTag_sources,
+  include_directories: lib_dir_inc,
+  install: false)
+
+# =============================================================================
+# Tests (Use "meson test --list" to list all tests)
+# =============================================================================
+
+# XXX: (Need TEST) These timeouts (in seconds) when running on a HDD should be
+# at least six times bigger than on a SSD
+
+test('test-fullbench',
+  fullbench,
+  args: ['--no-prompt', NB_LOOPS, TEST_FILES],
+  timeout: 420) # Should enough when running on HDD
+test('test-fuzzer',
+  fuzzer,
+  args: [FUZZER_TIME],
+  timeout: 100)
+test('test-frametest',
+  frametest,
+  args: [FUZZER_TIME],
+  timeout: 100)
diff --git a/lz4/contrib/meson/meson_options.txt b/lz4/contrib/meson/meson_options.txt
new file mode 100644
index 0000000..a409c2d
--- /dev/null
+++ b/lz4/contrib/meson/meson_options.txt
@@ -0,0 +1,24 @@
+# #############################################################################
+# Copyright (c) 2018-present        lzutao 
+# All rights reserved.
+#
+# This source code is licensed under both the BSD-style license (found in the
+# LICENSE file in the root directory of this source tree) and the GPLv2 (found
+# in the COPYING file in the root directory of this source tree).
+# #############################################################################
+
+# Read guidelines from https://wiki.gnome.org/Initiatives/GnomeGoals/MesonPorting
+
+option('debug_level', type: 'integer', min: 0, max: 7, value: 1,
+  description: 'Enable run-time debug. See lib/lz4hc.c')
+option('backtrace', type: 'boolean', value: false,
+  description: 'Display a stack backtrace when execution generates a runtime exception')
+
+option('bin_programs', type: 'boolean', value: false,
+  description: 'Enable programs build')
+option('bin_tests', type: 'boolean', value: false,
+  description: 'Enable tests build')
+option('bin_contrib', type: 'boolean', value: false,
+  description: 'Enable contrib build')
+option('bin_examples', type: 'boolean', value: false,
+  description: 'Enable examples build')
diff --git a/lz4/contrib/snap/README.md b/lz4/contrib/snap/README.md
new file mode 100644
index 0000000..612d6d7
--- /dev/null
+++ b/lz4/contrib/snap/README.md
@@ -0,0 +1,29 @@
+Snap Packaging
+--------------
+
+This directory contains the config required to generate a snap package
+of lz4. Snaps are universal Linux packages that allow you to easily
+build your application from any source and ship it to any Linux
+distribution by publishing it to https://snapcraft.io/. A key attribute
+of a snap package is that it is (ideally) confined such that it
+executes within a controlled environmenti with all its dependencies
+bundled with it and does not share dependencies with of from any other
+package on the system (with a couple of minor exceptions).
+
+The basic anatomy and workflow is:
+
+  * ensure snap.snapcraft.yaml is up-to-date e.g. with version info
+
+  * build the snap by installing the snapcraft package and running it
+
+  * push snap/* changes to the repo (excluding any crud generated by a build of course)
+
+  * register yourself as owner of lz4 name in snapstore
+
+  * publish new snap to the snap store
+
+  * install snap by doing 'snap install lz4' on any Linux distro
+
+  * all installed copies of lz4 will be automatically updated to your new version
+
+For more information on Snaps see https://docs.snapcraft.io and https://forum.snapcraft.io/
diff --git a/lz4/contrib/snap/snapcraft.yaml b/lz4/contrib/snap/snapcraft.yaml
new file mode 100644
index 0000000..2793c0e
--- /dev/null
+++ b/lz4/contrib/snap/snapcraft.yaml
@@ -0,0 +1,31 @@
+name: lz4
+version: 1.8.4
+summary: Extremely Fast Compression algorithm 
+description: >
+    LZ4 is lossless compression algorithm, providing compression
+    speed > 500 MB/s per core, scalable with multi-cores CPU. It features an
+    extremely fast decoder, with speed in multiple GB/s per core, typically
+    reaching RAM speed limits on multi-core systems.
+    .
+    Speed can be tuned dynamically, selecting an "acceleration" factor which
+    trades compression ratio for faster speed. On the other end, a high
+    compression derivative, LZ4_HC, is also provided, trading CPU time for
+    improved compression ratio. All versions feature the same decompression
+    speed.
+    .
+    LZ4 is also compatible with dictionary compression, and can ingest any
+    input file as dictionary, including those created by Zstandard Dictionary
+    Builder. (note: only the final 64KB are used).
+    .
+    LZ4 library is provided as open-source software using BSD 2-Clause license.
+confinement: strict
+grade: stable
+
+apps:
+  lz4:
+    command: usr/local/bin/lz4
+    plugs: [home]
+parts:
+  lz4:
+    source: ../
+    plugin: make
diff --git a/lz4/doc/lz4_Block_format.md b/lz4/doc/lz4_Block_format.md
new file mode 100644
index 0000000..4344e9b
--- /dev/null
+++ b/lz4/doc/lz4_Block_format.md
@@ -0,0 +1,156 @@
+LZ4 Block Format Description
+============================
+Last revised: 2019-03-30.
+Author : Yann Collet
+
+
+This specification is intended for developers
+willing to produce LZ4-compatible compressed data blocks
+using any programming language.
+
+LZ4 is an LZ77-type compressor with a fixed, byte-oriented encoding.
+There is no entropy encoder back-end nor framing layer.
+The latter is assumed to be handled by other parts of the system
+(see [LZ4 Frame format]).
+This design is assumed to favor simplicity and speed.
+It helps later on for optimizations, compactness, and features.
+
+This document describes only the block format,
+not how the compressor nor decompressor actually work.
+The correctness of the decompressor should not depend
+on implementation details of the compressor, and vice versa.
+
+[LZ4 Frame format]: lz4_Frame_format.md
+
+
+
+Compressed block format
+-----------------------
+An LZ4 compressed block is composed of sequences.
+A sequence is a suite of literals (not-compressed bytes),
+followed by a match copy.
+
+Each sequence starts with a `token`.
+The `token` is a one byte value, separated into two 4-bits fields.
+Therefore each field ranges from 0 to 15.
+
+
+The first field uses the 4 high-bits of the token.
+It provides the length of literals to follow.
+
+If the field value is 0, then there is no literal.
+If it is 15, then we need to add some more bytes to indicate the full length.
+Each additional byte then represent a value from 0 to 255,
+which is added to the previous value to produce a total length.
+When the byte value is 255, another byte is output.
+There can be any number of bytes following `token`. There is no "size limit".
+(Side note : this is why a not-compressible input block is expanded by 0.4%).
+
+Example 1 : A literal length of 48 will be represented as :
+
+  - 15 : value for the 4-bits High field
+  - 33 : (=48-15) remaining length to reach 48
+
+Example 2 : A literal length of 280 will be represented as :
+
+  - 15  : value for the 4-bits High field
+  - 255 : following byte is maxed, since 280-15 >= 255
+  - 10  : (=280 - 15 - 255) ) remaining length to reach 280
+
+Example 3 : A literal length of 15 will be represented as :
+
+  - 15 : value for the 4-bits High field
+  - 0  : (=15-15) yes, the zero must be output
+
+Following `token` and optional length bytes, are the literals themselves.
+They are exactly as numerous as previously decoded (length of literals).
+It's possible that there are zero literal.
+
+
+Following the literals is the match copy operation.
+
+It starts by the `offset`.
+This is a 2 bytes value, in little endian format
+(the 1st byte is the "low" byte, the 2nd one is the "high" byte).
+
+The `offset` represents the position of the match to be copied from.
+1 means "current position - 1 byte".
+The maximum `offset` value is 65535, 65536 cannot be coded.
+Note that 0 is an invalid value, not used.
+
+Then we need to extract the `matchlength`.
+For this, we use the second token field, the low 4-bits.
+Value, obviously, ranges from 0 to 15.
+However here, 0 means that the copy operation will be minimal.
+The minimum length of a match, called `minmatch`, is 4.
+As a consequence, a 0 value means 4 bytes, and a value of 15 means 19+ bytes.
+Similar to literal length, on reaching the highest possible value (15),
+we output additional bytes, one at a time, with values ranging from 0 to 255.
+They are added to total to provide the final match length.
+A 255 value means there is another byte to read and add.
+There is no limit to the number of optional bytes that can be output this way.
+(This points towards a maximum achievable compression ratio of about 250).
+
+Decoding the `matchlength` reaches the end of current sequence.
+Next byte will be the start of another sequence.
+But before moving to next sequence,
+it's time to use the decoded match position and length.
+The decoder copies `matchlength` bytes from match position to current position.
+
+In some cases, `matchlength` is larger than `offset`.
+Therefore, `match_pos + matchlength > current_pos`,
+which means that later bytes to copy are not yet decoded.
+This is called an "overlap match", and must be handled with special care.
+A common case is an offset of 1,
+meaning the last byte is repeated `matchlength` times.
+
+
+End of block restrictions
+-----------------------
+There are specific rules required to terminate a block.
+
+1. The last sequence contains only literals.
+   The block ends right after them.
+2. The last 5 bytes of input are always literals.
+   Therefore, the last sequence contains at least 5 bytes.
+   - Special : if input is smaller than 5 bytes,
+     there is only one sequence, it contains the whole input as literals.
+     Empty input can be represented with a zero byte,
+     interpreted as a final token without literal and without a match.
+3. The last match must start at least 12 bytes before the end of block.
+   The last match is part of the penultimate sequence.
+   It is followed by the last sequence, which contains only literals.
+   - Note that, as a consequence,
+     an independent block < 13 bytes cannot be compressed,
+     because the match must copy "something",
+     so it needs at least one prior byte.
+   - When a block can reference data from another block,
+     it can start immediately with a match and no literal,
+     so a block of 12 bytes can be compressed.
+
+When a block does not respect these end conditions,
+a conformant decoder is allowed to reject the block as incorrect.
+
+These rules are in place to ensure that a conformant decoder
+can be designed for speed, issuing speculatively instructions,
+while never reading nor writing beyond provided I/O buffers.
+
+
+Additional notes
+-----------------------
+If the decoder will decompress data from an external source,
+it is recommended to ensure that the decoder will not be vulnerable to
+buffer overflow manipulations.
+Always ensure that read and write operations
+remain within the limits of provided buffers.
+Test the decoder with fuzzers
+to ensure it's resilient to improbable combinations.
+
+The format makes no assumption nor limits to the way the compressor
+searches and selects matches within the source data block.
+Multiple techniques can be considered,
+featuring distinct time / performance trade offs.
+As long as the format is respected,
+the result will be compatible and decodable by any compliant decoder.
+An upper compression limit can be reached,
+using a technique called "full optimal parsing", at high cpu cost.
diff --git a/lz4/doc/lz4_Frame_format.md b/lz4/doc/lz4_Frame_format.md
new file mode 100644
index 0000000..7e08841
--- /dev/null
+++ b/lz4/doc/lz4_Frame_format.md
@@ -0,0 +1,433 @@
+LZ4 Frame Format Description
+============================
+
+### Notices
+
+Copyright (c) 2013-2015 Yann Collet
+
+Permission is granted to copy and distribute this document
+for any  purpose and without charge,
+including translations into other  languages
+and incorporation into compilations,
+provided that the copyright notice and this notice are preserved,
+and that any substantive changes or deletions from the original
+are clearly marked.
+Distribution of this document is unlimited.
+
+### Version
+
+1.6.2 (12/08/2020)
+
+
+Introduction
+------------
+
+The purpose of this document is to define a lossless compressed data format,
+that is independent of CPU type, operating system,
+file system and character set, suitable for
+File compression, Pipe and streaming compression
+using the [LZ4 algorithm](http://www.lz4.org).
+
+The data can be produced or consumed,
+even for an arbitrarily long sequentially presented input data stream,
+using only an a priori bounded amount of intermediate storage,
+and hence can be used in data communications.
+The format uses the LZ4 compression method,
+and optional [xxHash-32 checksum method](https://github.com/Cyan4973/xxHash),
+for detection of data corruption.
+
+The data format defined by this specification
+does not attempt to allow random access to compressed data.
+
+This specification is intended for use by implementers of software
+to compress data into LZ4 format and/or decompress data from LZ4 format.
+The text of the specification assumes a basic background in programming
+at the level of bits and other primitive data representations.
+
+Unless otherwise indicated below,
+a compliant compressor must produce data sets
+that conform to the specifications presented here.
+It doesn’t need to support all options though.
+
+A compliant decompressor must be able to decompress
+at least one working set of parameters
+that conforms to the specifications presented here.
+It may also ignore checksums.
+Whenever it does not support a specific parameter within the compressed stream,
+it must produce a non-ambiguous error code
+and associated error message explaining which parameter is unsupported.
+
+
+General Structure of LZ4 Frame format
+-------------------------------------
+
+| MagicNb | F. Descriptor | Block | (...) | EndMark | C. Checksum |
+|:-------:|:-------------:| ----- | ----- | ------- | ----------- |
+| 4 bytes |  3-15 bytes   |       |       | 4 bytes | 0-4 bytes   |
+
+__Magic Number__
+
+4 Bytes, Little endian format.
+Value : 0x184D2204
+
+__Frame Descriptor__
+
+3 to 15 Bytes, to be detailed in its own paragraph,
+as it is the most important part of the spec.
+
+The combined _Magic_Number_ and _Frame_Descriptor_ fields are sometimes
+called ___LZ4 Frame Header___. Its size varies between 7 and 19 bytes.
+
+__Data Blocks__
+
+To be detailed in its own paragraph.
+That’s where compressed data is stored.
+
+__EndMark__
+
+The flow of blocks ends when the last data block is followed by
+the 32-bit value `0x00000000`.
+
+__Content Checksum__
+
+_Content_Checksum_ verify that the full content has been decoded correctly.
+The content checksum is the result of [xxHash-32 algorithm]
+digesting the original (decoded) data as input, and a seed of zero.
+Content checksum is only present when its associated flag
+is set in the frame descriptor.
+Content Checksum validates the result,
+that all blocks were fully transmitted in the correct order and without error,
+and also that the encoding/decoding process itself generated no distortion.
+Its usage is recommended.
+
+The combined _EndMark_ and _Content_Checksum_ fields might sometimes be
+referred to as ___LZ4 Frame Footer___. Its size varies between 4 and 8 bytes.
+
+__Frame Concatenation__
+
+In some circumstances, it may be preferable to append multiple frames,
+for example in order to add new data to an existing compressed file
+without re-framing it.
+
+In such case, each frame has its own set of descriptor flags.
+Each frame is considered independent.
+The only relation between frames is their sequential order.
+
+The ability to decode multiple concatenated frames
+within a single stream or file
+is left outside of this specification.
+As an example, the reference lz4 command line utility behavior is
+to decode all concatenated frames in their sequential order.
+
+
+Frame Descriptor
+----------------
+
+| FLG     | BD      | (Content Size) | (Dictionary ID) | HC      |
+| ------- | ------- |:--------------:|:---------------:| ------- |
+| 1 byte  | 1 byte  |  0 - 8 bytes   |   0 - 4 bytes   | 1 byte  |
+
+The descriptor uses a minimum of 3 bytes,
+and up to 15 bytes depending on optional parameters.
+
+__FLG byte__
+
+|  BitNb  |  7-6  |   5   |    4     |  3   |    2     |    1     |   0  |
+| ------- |-------|-------|----------|------|----------|----------|------|
+|FieldName|Version|B.Indep|B.Checksum|C.Size|C.Checksum|*Reserved*|DictID|
+
+
+__BD byte__
+
+|  BitNb  |     7    |     6-5-4     |  3-2-1-0 |
+| ------- | -------- | ------------- | -------- |
+|FieldName|*Reserved*| Block MaxSize |*Reserved*|
+
+In the tables, bit 7 is highest bit, while bit 0 is lowest.
+
+__Version Number__
+
+2-bits field, must be set to `01`.
+Any other value cannot be decoded by this version of the specification.
+Other version numbers will use different flag layouts.
+
+__Block Independence flag__
+
+If this flag is set to “1”, blocks are independent.
+If this flag is set to “0”, each block depends on previous ones
+(up to LZ4 window size, which is 64 KB).
+In such case, it’s necessary to decode all blocks in sequence.
+
+Block dependency improves compression ratio, especially for small blocks.
+On the other hand, it makes random access or multi-threaded decoding impossible.
+
+__Block checksum flag__
+
+If this flag is set, each data block will be followed by a 4-bytes checksum,
+calculated by using the xxHash-32 algorithm on the raw (compressed) data block.
+The intention is to detect data corruption (storage or transmission errors)
+immediately, before decoding.
+Block checksum usage is optional.
+
+__Content Size flag__
+
+If this flag is set, the uncompressed size of data included within the frame
+will be present as an 8 bytes unsigned little endian value, after the flags.
+Content Size usage is optional.
+
+__Content checksum flag__
+
+If this flag is set, a 32-bits content checksum will be appended
+after the EndMark.
+
+__Dictionary ID flag__
+
+If this flag is set, a 4-bytes Dict-ID field will be present,
+after the descriptor flags and the Content Size.
+
+__Block Maximum Size__
+
+This information is useful to help the decoder allocate memory.
+Size here refers to the original (uncompressed) data size.
+Block Maximum Size is one value among the following table :
+
+|  0  |  1  |  2  |  3  |   4   |   5    |  6   |  7   |
+| --- | --- | --- | --- | ----- | ------ | ---- | ---- |
+| N/A | N/A | N/A | N/A | 64 KB | 256 KB | 1 MB | 4 MB |
+
+The decoder may refuse to allocate block sizes above any system-specific size.
+Unused values may be used in a future revision of the spec.
+A decoder conformant with the current version of the spec
+is only able to decode block sizes defined in this spec.
+
+__Reserved bits__
+
+Value of reserved bits **must** be 0 (zero).
+Reserved bit might be used in a future version of the specification,
+typically enabling new optional features.
+When this happens, a decoder respecting the current specification version
+shall not be able to decode such a frame.
+
+__Content Size__
+
+This is the original (uncompressed) size.
+This information is optional, and only present if the associated flag is set.
+Content size is provided using unsigned 8 Bytes, for a maximum of 16 Exabytes.
+Format is Little endian.
+This value is informational, typically for display or memory allocation.
+It can be skipped by a decoder, or used to validate content correctness.
+
+__Dictionary ID__
+
+Dict-ID is only present if the associated flag is set.
+It's an unsigned 32-bits value, stored using little-endian convention.
+A dictionary is useful to compress short input sequences.
+The compressor can take advantage of the dictionary context
+to encode the input in a more compact manner.
+It works as a kind of “known prefix” which is used by
+both the compressor and the decompressor to “warm-up” reference tables.
+
+The decompressor can use Dict-ID identifier to determine
+which dictionary must be used to correctly decode data.
+The compressor and the decompressor must use exactly the same dictionary.
+It's presumed that the 32-bits dictID uniquely identifies a dictionary.
+
+Within a single frame, a single dictionary can be defined.
+When the frame descriptor defines independent blocks,
+each block will be initialized with the same dictionary.
+If the frame descriptor defines linked blocks,
+the dictionary will only be used once, at the beginning of the frame.
+
+__Header Checksum__
+
+One-byte checksum of combined descriptor fields, including optional ones.
+The value is the second byte of `xxh32()` : ` (xxh32()>>8) & 0xFF `
+using zero as a seed, and the full Frame Descriptor as an input
+(including optional fields when they are present).
+A wrong checksum indicates an error in the descriptor.
+Header checksum is informational and can be skipped.
+
+
+Data Blocks
+-----------
+
+| Block Size |  data  | (Block Checksum) |
+|:----------:| ------ |:----------------:|
+|  4 bytes   |        |   0 - 4 bytes    |
+
+
+__Block Size__
+
+This field uses 4-bytes, format is little-endian.
+
+If the highest bit is set (`1`), the block is uncompressed.
+
+If the highest bit is not set (`0`), the block is LZ4-compressed,
+using the [LZ4 block format specification](https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md).
+
+All other bits give the size, in bytes, of the data section.
+The size does not include the block checksum if present.
+
+_Block_Size_ shall never be larger than _Block_Maximum_Size_.
+Such an outcome could potentially happen for non-compressible sources.
+In such a case, such data block must be passed using uncompressed format.
+
+A value of `0x00000000` is invalid, and signifies an _EndMark_ instead.
+Note that this is different from a value of `0x80000000` (highest bit set),
+which is an uncompressed block of size 0 (empty),
+which is valid, and therefore doesn't end a frame.
+Note that, if _Block_checksum_ is enabled,
+even an empty block must be followed by a 32-bit block checksum.
+
+__Data__
+
+Where the actual data to decode stands.
+It might be compressed or not, depending on previous field indications.
+
+When compressed, the data must respect the [LZ4 block format specification](https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md).
+
+Note that a block is not necessarily full.
+Uncompressed size of data can be any size __up to__ _Block_Maximum_Size_,
+so it may contain less data than the maximum block size.
+
+__Block checksum__
+
+Only present if the associated flag is set.
+This is a 4-bytes checksum value, in little endian format,
+calculated by using the [xxHash-32 algorithm] on the __raw__ (undecoded) data block,
+and a seed of zero.
+The intention is to detect data corruption (storage or transmission errors)
+before decoding.
+
+_Block_checksum_ can be cumulative with _Content_checksum_.
+
+[xxHash-32 algorithm]: https://github.com/Cyan4973/xxHash/blob/release/doc/xxhash_spec.md
+
+
+Skippable Frames
+----------------
+
+| Magic Number | Frame Size | User Data |
+|:------------:|:----------:| --------- |
+|   4 bytes    |  4 bytes   |           |
+
+Skippable frames allow the integration of user-defined data
+into a flow of concatenated frames.
+Its design is pretty straightforward,
+with the sole objective to allow the decoder to quickly skip
+over user-defined data and continue decoding.
+
+For the purpose of facilitating identification,
+it is discouraged to start a flow of concatenated frames with a skippable frame.
+If there is a need to start such a flow with some user data
+encapsulated into a skippable frame,
+it’s recommended to start with a zero-byte LZ4 frame
+followed by a skippable frame.
+This will make it easier for file type identifiers.
+
+
+__Magic Number__
+
+4 Bytes, Little endian format.
+Value : 0x184D2A5X, which means any value from 0x184D2A50 to 0x184D2A5F.
+All 16 values are valid to identify a skippable frame.
+
+__Frame Size__
+
+This is the size, in bytes, of the following User Data
+(without including the magic number nor the size field itself).
+4 Bytes, Little endian format, unsigned 32-bits.
+This means User Data can’t be bigger than (2^32-1) Bytes.
+
+__User Data__
+
+User Data can be anything. Data will just be skipped by the decoder.
+
+
+Legacy frame
+------------
+
+The Legacy frame format was defined into the initial versions of “LZ4Demo”.
+Newer compressors should not use this format anymore, as it is too restrictive.
+
+Main characteristics of the legacy format :
+
+- Fixed block size : 8 MB.
+- All blocks must be completely filled, except the last one.
+- All blocks are always compressed, even when compression is detrimental.
+- The last block is detected either because
+  it is followed by the “EOF” (End of File) mark,
+  or because it is followed by a known Frame Magic Number.
+- No checksum
+- Convention is Little endian
+
+| MagicNb | B.CSize | CData | B.CSize | CData |  (...)  | EndMark |
+| ------- | ------- | ----- | ------- | ----- | ------- | ------- |
+| 4 bytes | 4 bytes | CSize | 4 bytes | CSize | x times |   EOF   |
+
+
+__Magic Number__
+
+4 Bytes, Little endian format.
+Value : 0x184C2102
+
+__Block Compressed Size__
+
+This is the size, in bytes, of the following compressed data block.
+4 Bytes, Little endian format.
+
+__Data__
+
+Where the actual compressed data stands.
+Data is always compressed, even when compression is detrimental.
+
+__EndMark__
+
+End of legacy frame is implicit only.
+It must be followed by a standard EOF (End Of File) signal,
+wether it is a file or a stream.
+
+Alternatively, if the frame is followed by a valid Frame Magic Number,
+it is considered completed.
+This policy makes it possible to concatenate legacy frames.
+
+Any other value will be interpreted as a block size,
+and trigger an error if it does not fit within acceptable range.
+
+
+Version changes
+---------------
+
+1.6.2 : clarifies specification of _EndMark_
+
+1.6.1 : introduced terms "LZ4 Frame Header" and "LZ4 Frame Footer"
+
+1.6.0 : restored Dictionary ID field in Frame header
+
+1.5.1 : changed document format to MarkDown
+
+1.5 : removed Dictionary ID from specification
+
+1.4.1 : changed wording from “stream” to “frame”
+
+1.4 : added skippable streams, re-added stream checksum
+
+1.3 : modified header checksum
+
+1.2 : reduced choice of “block size”, to postpone decision on “dynamic size of BlockSize Field”.
+
+1.1 : optional fields are now part of the descriptor
+
+1.0 : changed “block size” specification, adding a compressed/uncompressed flag
+
+0.9 : reduced scale of “block maximum size” table
+
+0.8 : removed : high compression flag
+
+0.7 : removed : stream checksum
+
+0.6 : settled : stream size uses 8 bytes, endian convention is little endian
+
+0.5: added copyright notice
+
+0.4 : changed format to Google Doc compatible OpenDocument
diff --git a/lz4/doc/lz4_manual.html b/lz4/doc/lz4_manual.html
new file mode 100644
index 0000000..47fe18d
--- /dev/null
+++ b/lz4/doc/lz4_manual.html
@@ -0,0 +1,597 @@
+
+
+
+1.9.3 Manual
+
+
+
    1.9.3 Manual
    
+
    
+
    Contents
    
+
      
+
    1. Introduction
      2. 
+
    2. Version
      3. 
+
    3. Tuning parameter
      4. 
+
    4. Simple Functions
      5. 
+
    5. Advanced Functions
      6. 
+
    6. Streaming Compression Functions
      7. 
+
    7. Streaming Decompression Functions
      8. 
+
    8. Experimental section
      9. 
+
    9. Private Definitions
      10. 
+
    10. Obsolete Functions
      11. 
+
    
+
    
+
    Introduction
    +  LZ4 is lossless compression algorithm, providing compression speed >500 MB/s per core,
+  scalable with multi-cores CPU. It features an extremely fast decoder, with speed in
+  multiple GB/s per core, typically reaching RAM speed limits on multi-core systems.
+
+  The LZ4 compression library provides in-memory compression and decompression functions.
+  It gives full buffer control to user.
+  Compression can be done in:
+    - a single step (described as Simple Functions)
+    - a single step, reusing a context (described in Advanced Functions)
+    - unbounded multiple steps (described as Streaming compression)
+
+  lz4.h generates and decodes LZ4-compressed blocks (doc/lz4_Block_format.md).
+  Decompressing such a compressed block requires additional metadata.
+  Exact metadata depends on exact decompression function.
+  For the typical case of LZ4_decompress_safe(),
+  metadata includes block's compressed size, and maximum bound of decompressed size.
+  Each application is free to encode and pass such metadata in whichever way it wants.
+
+  lz4.h only handle blocks, it can not generate Frames.
+
+  Blocks are different from Frames (doc/lz4_Frame_format.md).
+  Frames bundle both blocks and metadata in a specified manner.
+  Embedding metadata is required for compressed data to be self-contained and portable.
+  Frame format is delivered through a companion API, declared in lz4frame.h.
+  The `lz4` CLI can only manage frames.
+
    
+
+
    Version
    
+
+
    int LZ4_versionNumber (void);  /**< library version number; useful to check dll version */
+

    
+
    const char* LZ4_versionString (void);   /**< library version string; useful to check dll version */
+

    
+
    Tuning parameter
    
+
+
    #ifndef LZ4_MEMORY_USAGE
+# define LZ4_MEMORY_USAGE 14
+#endif
+
     Memory usage formula : N->2^N Bytes (examples : 10 -> 1KB; 12 -> 4KB ; 16 -> 64KB; 20 -> 1MB; etc.)
+ Increasing memory usage improves compression ratio.
+ Reduced memory usage may improve speed, thanks to better cache locality.
+ Default value is 14, for 16KB, which nicely fits into Intel x86 L1 cache
+ 
+

    
+
+
    Simple Functions
    
+
+
    int LZ4_compress_default(const char* src, char* dst, int srcSize, int dstCapacity);
+
      Compresses 'srcSize' bytes from buffer 'src'
+  into already allocated 'dst' buffer of size 'dstCapacity'.
+  Compression is guaranteed to succeed if 'dstCapacity' >= LZ4_compressBound(srcSize).
+  It also runs faster, so it's a recommended setting.
+  If the function cannot compress 'src' into a more limited 'dst' budget,
+  compression stops *immediately*, and the function result is zero.
+  In which case, 'dst' content is undefined (invalid).
+      srcSize : max supported value is LZ4_MAX_INPUT_SIZE.
+      dstCapacity : size of buffer 'dst' (which must be already allocated)
+     @return  : the number of bytes written into buffer 'dst' (necessarily <= dstCapacity)
+                or 0 if compression fails
+ Note : This function is protected against buffer overflow scenarios (never writes outside 'dst' buffer, nor read outside 'source' buffer).
+ 
+

    
+
+
    int LZ4_decompress_safe (const char* src, char* dst, int compressedSize, int dstCapacity);
+
      compressedSize : is the exact complete size of the compressed block.
+  dstCapacity : is the size of destination buffer (which must be already allocated), presumed an upper bound of decompressed size.
+ @return : the number of bytes decompressed into destination buffer (necessarily <= dstCapacity)
+           If destination buffer is not large enough, decoding will stop and output an error code (negative value).
+           If the source stream is detected malformed, the function will stop decoding and return a negative result.
+ Note 1 : This function is protected against malicious data packets :
+          it will never writes outside 'dst' buffer, nor read outside 'source' buffer,
+          even if the compressed block is maliciously modified to order the decoder to do these actions.
+          In such case, the decoder stops immediately, and considers the compressed block malformed.
+ Note 2 : compressedSize and dstCapacity must be provided to the function, the compressed block does not contain them.
+          The implementation is free to send / store / derive this information in whichever way is most beneficial.
+          If there is a need for a different format which bundles together both compressed data and its metadata, consider looking at lz4frame.h instead.
+ 
+

    
+
+
    Advanced Functions
    
+
+
    int LZ4_compressBound(int inputSize);
+
        Provides the maximum size that LZ4 compression may output in a "worst case" scenario (input data not compressible)
+    This function is primarily useful for memory allocation purposes (destination buffer size).
+    Macro LZ4_COMPRESSBOUND() is also provided for compilation-time evaluation (stack memory allocation for example).
+    Note that LZ4_compress_default() compresses faster when dstCapacity is >= LZ4_compressBound(srcSize)
+        inputSize  : max supported value is LZ4_MAX_INPUT_SIZE
+        return : maximum output size in a "worst case" scenario
+              or 0, if input size is incorrect (too large or negative)
+

    
+
+
    int LZ4_compress_fast (const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
        Same as LZ4_compress_default(), but allows selection of "acceleration" factor.
+    The larger the acceleration value, the faster the algorithm, but also the lesser the compression.
+    It's a trade-off. It can be fine tuned, with each successive value providing roughly +~3% to speed.
+    An acceleration value of "1" is the same as regular LZ4_compress_default()
+    Values <= 0 will be replaced by LZ4_ACCELERATION_DEFAULT (currently == 1, see lz4.c).
+    Values > LZ4_ACCELERATION_MAX will be replaced by LZ4_ACCELERATION_MAX (currently == 65537, see lz4.c).
+

    
+
+
    int LZ4_sizeofState(void);
+int LZ4_compress_fast_extState (void* state, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
      Same as LZ4_compress_fast(), using an externally allocated memory space for its state.
+  Use LZ4_sizeofState() to know how much memory must be allocated,
+  and allocate it on 8-bytes boundaries (using `malloc()` typically).
+  Then, provide this buffer as `void* state` to compression function.
+ 
+

    
+
+
    int LZ4_compress_destSize (const char* src, char* dst, int* srcSizePtr, int targetDstSize);
+
      Reverse the logic : compresses as much data as possible from 'src' buffer
+  into already allocated buffer 'dst', of size >= 'targetDestSize'.
+  This function either compresses the entire 'src' content into 'dst' if it's large enough,
+  or fill 'dst' buffer completely with as much data as possible from 'src'.
+  note: acceleration parameter is fixed to "default".
+
+ *srcSizePtr : will be modified to indicate how many bytes where read from 'src' to fill 'dst'.
+               New value is necessarily <= input value.
+ @return : Nb bytes written into 'dst' (necessarily <= targetDestSize)
+           or 0 if compression fails.
+
+ Note : from v1.8.2 to v1.9.1, this function had a bug (fixed un v1.9.2+):
+        the produced compressed content could, in specific circumstances,
+        require to be decompressed into a destination buffer larger
+        by at least 1 byte than the content to decompress.
+        If an application uses `LZ4_compress_destSize()`,
+        it's highly recommended to update liblz4 to v1.9.2 or better.
+        If this can't be done or ensured,
+        the receiving decompression function should provide
+        a dstCapacity which is > decompressedSize, by at least 1 byte.
+        See https://github.com/lz4/lz4/issues/859 for details
+ 
+

    
+
+
    int LZ4_decompress_safe_partial (const char* src, char* dst, int srcSize, int targetOutputSize, int dstCapacity);
+
      Decompress an LZ4 compressed block, of size 'srcSize' at position 'src',
+  into destination buffer 'dst' of size 'dstCapacity'.
+  Up to 'targetOutputSize' bytes will be decoded.
+  The function stops decoding on reaching this objective.
+  This can be useful to boost performance
+  whenever only the beginning of a block is required.
+
+ @return : the number of bytes decoded in `dst` (necessarily <= targetOutputSize)
+           If source stream is detected malformed, function returns a negative result.
+
+  Note 1 : @return can be < targetOutputSize, if compressed block contains less data.
+
+  Note 2 : targetOutputSize must be <= dstCapacity
+
+  Note 3 : this function effectively stops decoding on reaching targetOutputSize,
+           so dstCapacity is kind of redundant.
+           This is because in older versions of this function,
+           decoding operation would still write complete sequences.
+           Therefore, there was no guarantee that it would stop writing at exactly targetOutputSize,
+           it could write more bytes, though only up to dstCapacity.
+           Some "margin" used to be required for this operation to work properly.
+           Thankfully, this is no longer necessary.
+           The function nonetheless keeps the same signature, in an effort to preserve API compatibility.
+
+  Note 4 : If srcSize is the exact size of the block,
+           then targetOutputSize can be any value,
+           including larger than the block's decompressed size.
+           The function will, at most, generate block's decompressed size.
+
+  Note 5 : If srcSize is _larger_ than block's compressed size,
+           then targetOutputSize **MUST** be <= block's decompressed size.
+           Otherwise, *silent corruption will occur*.
+ 
+

    
+
+
    Streaming Compression Functions
    
+
+
    void LZ4_resetStream_fast (LZ4_stream_t* streamPtr);
+
      Use this to prepare an LZ4_stream_t for a new chain of dependent blocks
+  (e.g., LZ4_compress_fast_continue()).
+
+  An LZ4_stream_t must be initialized once before usage.
+  This is automatically done when created by LZ4_createStream().
+  However, should the LZ4_stream_t be simply declared on stack (for example),
+  it's necessary to initialize it first, using LZ4_initStream().
+
+  After init, start any new stream with LZ4_resetStream_fast().
+  A same LZ4_stream_t can be re-used multiple times consecutively
+  and compress multiple streams,
+  provided that it starts each new stream with LZ4_resetStream_fast().
+
+  LZ4_resetStream_fast() is much faster than LZ4_initStream(),
+  but is not compatible with memory regions containing garbage data.
+
+  Note: it's only useful to call LZ4_resetStream_fast()
+        in the context of streaming compression.
+        The *extState* functions perform their own resets.
+        Invoking LZ4_resetStream_fast() before is redundant, and even counterproductive.
+ 
+

    
+
+
    int LZ4_loadDict (LZ4_stream_t* streamPtr, const char* dictionary, int dictSize);
+
      Use this function to reference a static dictionary into LZ4_stream_t.
+  The dictionary must remain available during compression.
+  LZ4_loadDict() triggers a reset, so any previous data will be forgotten.
+  The same dictionary will have to be loaded on decompression side for successful decoding.
+  Dictionary are useful for better compression of small data (KB range).
+  While LZ4 accept any input as dictionary,
+  results are generally better when using Zstandard's Dictionary Builder.
+  Loading a size of 0 is allowed, and is the same as reset.
+ @return : loaded dictionary size, in bytes (necessarily <= 64 KB)
+ 
+

    
+
+
    int LZ4_compress_fast_continue (LZ4_stream_t* streamPtr, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
      Compress 'src' content using data from previously compressed blocks, for better compression ratio.
+ 'dst' buffer must be already allocated.
+  If dstCapacity >= LZ4_compressBound(srcSize), compression is guaranteed to succeed, and runs faster.
+
+ @return : size of compressed block
+           or 0 if there is an error (typically, cannot fit into 'dst').
+
+  Note 1 : Each invocation to LZ4_compress_fast_continue() generates a new block.
+           Each block has precise boundaries.
+           Each block must be decompressed separately, calling LZ4_decompress_*() with relevant metadata.
+           It's not possible to append blocks together and expect a single invocation of LZ4_decompress_*() to decompress them together.
+
+  Note 2 : The previous 64KB of source data is __assumed__ to remain present, unmodified, at same address in memory !
+
+  Note 3 : When input is structured as a double-buffer, each buffer can have any size, including < 64 KB.
+           Make sure that buffers are separated, by at least one byte.
+           This construction ensures that each block only depends on previous block.
+
+  Note 4 : If input buffer is a ring-buffer, it can have any size, including < 64 KB.
+
+  Note 5 : After an error, the stream status is undefined (invalid), it can only be reset or freed.
+ 
+

    
+
+
    int LZ4_saveDict (LZ4_stream_t* streamPtr, char* safeBuffer, int maxDictSize);
+
      If last 64KB data cannot be guaranteed to remain available at its current memory location,
+  save it into a safer place (char* safeBuffer).
+  This is schematically equivalent to a memcpy() followed by LZ4_loadDict(),
+  but is much faster, because LZ4_saveDict() doesn't need to rebuild tables.
+ @return : saved dictionary size in bytes (necessarily <= maxDictSize), or 0 if error.
+ 
+

    
+
+
    Streaming Decompression Functions
      Bufferless synchronous API
+
    
+
+
    LZ4_streamDecode_t* LZ4_createStreamDecode(void);
+int                 LZ4_freeStreamDecode (LZ4_streamDecode_t* LZ4_stream);
+
      creation / destruction of streaming decompression tracking context.
+  A tracking context can be re-used multiple times.
+ 
+

    
+
+
    int LZ4_setStreamDecode (LZ4_streamDecode_t* LZ4_streamDecode, const char* dictionary, int dictSize);
+
      An LZ4_streamDecode_t context can be allocated once and re-used multiple times.
+  Use this function to start decompression of a new stream of blocks.
+  A dictionary can optionally be set. Use NULL or size 0 for a reset order.
+  Dictionary is presumed stable : it must remain accessible and unmodified during next decompression.
+ @return : 1 if OK, 0 if error
+ 
+

    
+
+
    int LZ4_decoderRingBufferSize(int maxBlockSize);
+#define LZ4_DECODER_RING_BUFFER_SIZE(maxBlockSize) (65536 + 14 + (maxBlockSize))  /* for static allocation; maxBlockSize presumed valid */
+
      Note : in a ring buffer scenario (optional),
+  blocks are presumed decompressed next to each other
+  up to the moment there is not enough remaining space for next block (remainingSize < maxBlockSize),
+  at which stage it resumes from beginning of ring buffer.
+  When setting such a ring buffer for streaming decompression,
+  provides the minimum size of this ring buffer
+  to be compatible with any source respecting maxBlockSize condition.
+ @return : minimum ring buffer size,
+           or 0 if there is an error (invalid maxBlockSize).
+ 
+

    
+
+
    int LZ4_decompress_safe_continue (LZ4_streamDecode_t* LZ4_streamDecode, const char* src, char* dst, int srcSize, int dstCapacity);
+
      These decoding functions allow decompression of consecutive blocks in "streaming" mode.
+  A block is an unsplittable entity, it must be presented entirely to a decompression function.
+  Decompression functions only accepts one block at a time.
+  The last 64KB of previously decoded data *must* remain available and unmodified at the memory position where they were decoded.
+  If less than 64KB of data has been decoded, all the data must be present.
+
+  Special : if decompression side sets a ring buffer, it must respect one of the following conditions :
+  - Decompression buffer size is _at least_ LZ4_decoderRingBufferSize(maxBlockSize).
+    maxBlockSize is the maximum size of any single block. It can have any value > 16 bytes.
+    In which case, encoding and decoding buffers do not need to be synchronized.
+    Actually, data can be produced by any source compliant with LZ4 format specification, and respecting maxBlockSize.
+  - Synchronized mode :
+    Decompression buffer size is _exactly_ the same as compression buffer size,
+    and follows exactly same update rule (block boundaries at same positions),
+    and decoding function is provided with exact decompressed size of each block (exception for last block of the stream),
+    _then_ decoding & encoding ring buffer can have any size, including small ones ( < 64 KB).
+  - Decompression buffer is larger than encoding buffer, by a minimum of maxBlockSize more bytes.
+    In which case, encoding and decoding buffers do not need to be synchronized,
+    and encoding ring buffer can have any size, including small ones ( < 64 KB).
+
+  Whenever these conditions are not possible,
+  save the last 64KB of decoded data into a safe buffer where it can't be modified during decompression,
+  then indicate where this data is saved using LZ4_setStreamDecode(), before decompressing next block.
+

    
+
+
    int LZ4_decompress_safe_usingDict (const char* src, char* dst, int srcSize, int dstCapcity, const char* dictStart, int dictSize);
+
      These decoding functions work the same as
+  a combination of LZ4_setStreamDecode() followed by LZ4_decompress_*_continue()
+  They are stand-alone, and don't need an LZ4_streamDecode_t structure.
+  Dictionary is presumed stable : it must remain accessible and unmodified during decompression.
+  Performance tip : Decompression speed can be substantially increased
+                    when dst == dictStart + dictSize.
+ 
+

    
+
+
    Experimental section
    + Symbols declared in this section must be considered unstable. Their
+ signatures or semantics may change, or they may be removed altogether in the
+ future. They are therefore only safe to depend on when the caller is
+ statically linked against the library.
+
+ To protect against unsafe usage, not only are the declarations guarded,
+ the definitions are hidden by default
+ when building LZ4 as a shared/dynamic library.
+
+ In order to access these declarations,
+ define LZ4_STATIC_LINKING_ONLY in your application
+ before including LZ4's headers.
+
+ In order to make their implementations accessible dynamically, you must
+ define LZ4_PUBLISH_STATIC_FUNCTIONS when building the LZ4 library.
+
    
+
+
    LZ4LIB_STATIC_API int LZ4_compress_fast_extState_fastReset (void* state, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
      A variant of LZ4_compress_fast_extState().
+
+  Using this variant avoids an expensive initialization step.
+  It is only safe to call if the state buffer is known to be correctly initialized already
+  (see above comment on LZ4_resetStream_fast() for a definition of "correctly initialized").
+  From a high level, the difference is that
+  this function initializes the provided state with a call to something like LZ4_resetStream_fast()
+  while LZ4_compress_fast_extState() starts with a call to LZ4_resetStream().
+ 
+

    
+
+
    LZ4LIB_STATIC_API void LZ4_attach_dictionary(LZ4_stream_t* workingStream, const LZ4_stream_t* dictionaryStream);
+
      This is an experimental API that allows
+  efficient use of a static dictionary many times.
+
+  Rather than re-loading the dictionary buffer into a working context before
+  each compression, or copying a pre-loaded dictionary's LZ4_stream_t into a
+  working LZ4_stream_t, this function introduces a no-copy setup mechanism,
+  in which the working stream references the dictionary stream in-place.
+
+  Several assumptions are made about the state of the dictionary stream.
+  Currently, only streams which have been prepared by LZ4_loadDict() should
+  be expected to work.
+
+  Alternatively, the provided dictionaryStream may be NULL,
+  in which case any existing dictionary stream is unset.
+
+  If a dictionary is provided, it replaces any pre-existing stream history.
+  The dictionary contents are the only history that can be referenced and
+  logically immediately precede the data compressed in the first subsequent
+  compression call.
+
+  The dictionary will only remain attached to the working stream through the
+  first compression call, at the end of which it is cleared. The dictionary
+  stream (and source buffer) must remain in-place / accessible / unchanged
+  through the completion of the first compression call on the stream.
+ 
+

    
+
+
    
+ It's possible to have input and output sharing the same buffer,
+ for highly contrained memory environments.
+ In both cases, it requires input to lay at the end of the buffer,
+ and decompression to start at beginning of the buffer.
+ Buffer size must feature some margin, hence be larger than final size.
+
+ |<------------------------buffer--------------------------------->|
+                             |<-----------compressed data--------->|
+ |<-----------decompressed size------------------>|
+                                                  |<----margin---->|
+
+ This technique is more useful for decompression,
+ since decompressed size is typically larger,
+ and margin is short.
+
+ In-place decompression will work inside any buffer
+ which size is >= LZ4_DECOMPRESS_INPLACE_BUFFER_SIZE(decompressedSize).
+ This presumes that decompressedSize > compressedSize.
+ Otherwise, it means compression actually expanded data,
+ and it would be more efficient to store such data with a flag indicating it's not compressed.
+ This can happen when data is not compressible (already compressed, or encrypted).
+
+ For in-place compression, margin is larger, as it must be able to cope with both
+ history preservation, requiring input data to remain unmodified up to LZ4_DISTANCE_MAX,
+ and data expansion, which can happen when input is not compressible.
+ As a consequence, buffer size requirements are much higher,
+ and memory savings offered by in-place compression are more limited.
+
+ There are ways to limit this cost for compression :
+ - Reduce history size, by modifying LZ4_DISTANCE_MAX.
+   Note that it is a compile-time constant, so all compressions will apply this limit.
+   Lower values will reduce compression ratio, except when input_size < LZ4_DISTANCE_MAX,
+   so it's a reasonable trick when inputs are known to be small.
+ - Require the compressor to deliver a "maximum compressed size".
+   This is the `dstCapacity` parameter in `LZ4_compress*()`.
+   When this size is < LZ4_COMPRESSBOUND(inputSize), then compression can fail,
+   in which case, the return code will be 0 (zero).
+   The caller must be ready for these cases to happen,
+   and typically design a backup scheme to send data uncompressed.
+ The combination of both techniques can significantly reduce
+ the amount of margin required for in-place compression.
+
+ In-place compression can work in any buffer
+ which size is >= (maxCompressedSize)
+ with maxCompressedSize == LZ4_COMPRESSBOUND(srcSize) for guaranteed compression success.
+ LZ4_COMPRESS_INPLACE_BUFFER_SIZE() depends on both maxCompressedSize and LZ4_DISTANCE_MAX,
+ so it's possible to reduce memory requirements by playing with them.
+ 
+

    
+
+
    #define LZ4_DECOMPRESS_INPLACE_BUFFER_SIZE(decompressedSize)   ((decompressedSize) + LZ4_DECOMPRESS_INPLACE_MARGIN(decompressedSize))  /**< note: presumes that compressedSize < decompressedSize. note2: margin is overestimated a bit, since it could use compressedSize instead */
+

    
+
    #define LZ4_COMPRESS_INPLACE_BUFFER_SIZE(maxCompressedSize)   ((maxCompressedSize) + LZ4_COMPRESS_INPLACE_MARGIN)  /**< maxCompressedSize is generally LZ4_COMPRESSBOUND(inputSize), but can be set to any lower value, with the risk that compression can fail (return code 0(zero)) */
+

    
+
    Private Definitions
    + Do not use these definitions directly.
+ They are only exposed to allow static allocation of `LZ4_stream_t` and `LZ4_streamDecode_t`.
+ Accessing members will expose user code to API and/or ABI break in future versions of the library.
+
    
+
+
    typedef struct {
+    const LZ4_byte* externalDict;
+    size_t extDictSize;
+    const LZ4_byte* prefixEnd;
+    size_t prefixSize;
+} LZ4_streamDecode_t_internal;
+

    
+
    #define LZ4_STREAMSIZE       16416  /* static size, for inter-version compatibility */
+#define LZ4_STREAMSIZE_VOIDP (LZ4_STREAMSIZE / sizeof(void*))
+union LZ4_stream_u {
+    void* table[LZ4_STREAMSIZE_VOIDP];
+    LZ4_stream_t_internal internal_donotuse;
+}; /* previously typedef'd to LZ4_stream_t */
+
      Do not use below internal definitions directly !
+  Declare or allocate an LZ4_stream_t instead.
+  LZ4_stream_t can also be created using LZ4_createStream(), which is recommended.
+  The structure definition can be convenient for static allocation
+  (on stack, or as part of larger structure).
+  Init this structure with LZ4_initStream() before first use.
+  note : only use this definition in association with static linking !
+  this definition is not API/ABI safe, and may change in future versions.
+ 
+

    
+
+
    LZ4_stream_t* LZ4_initStream (void* buffer, size_t size);
+
      An LZ4_stream_t structure must be initialized at least once.
+  This is automatically done when invoking LZ4_createStream(),
+  but it's not when the structure is simply declared on stack (for example).
+
+  Use LZ4_initStream() to properly initialize a newly declared LZ4_stream_t.
+  It can also initialize any arbitrary buffer of sufficient size,
+  and will @return a pointer of proper type upon initialization.
+
+  Note : initialization fails if size and alignment conditions are not respected.
+         In which case, the function will @return NULL.
+  Note2: An LZ4_stream_t structure guarantees correct alignment and size.
+  Note3: Before v1.9.0, use LZ4_resetStream() instead
+ 
+

    
+
+
    #define LZ4_STREAMDECODESIZE_U64 (4 + ((sizeof(void*)==16) ? 2 : 0) /*AS-400*/ )
+#define LZ4_STREAMDECODESIZE     (LZ4_STREAMDECODESIZE_U64 * sizeof(unsigned long long))
+union LZ4_streamDecode_u {
+    unsigned long long table[LZ4_STREAMDECODESIZE_U64];
+    LZ4_streamDecode_t_internal internal_donotuse;
+} ;   /* previously typedef'd to LZ4_streamDecode_t */
+
      information structure to track an LZ4 stream during decompression.
+  init this structure  using LZ4_setStreamDecode() before first use.
+  note : only use in association with static linking !
+         this definition is not API/ABI safe,
+         and may change in a future version !
+ 
+

    
+
+
    Obsolete Functions
    
+
+
    #ifdef LZ4_DISABLE_DEPRECATE_WARNINGS
+#  define LZ4_DEPRECATED(message)   /* disable deprecation warnings */
+#else
+#  if defined (__cplusplus) && (__cplusplus >= 201402) /* C++14 or greater */
+#    define LZ4_DEPRECATED(message) [[deprecated(message)]]
+#  elif defined(_MSC_VER)
+#    define LZ4_DEPRECATED(message) __declspec(deprecated(message))
+#  elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ * 10 + __GNUC_MINOR__ >= 45))
+#    define LZ4_DEPRECATED(message) __attribute__((deprecated(message)))
+#  elif defined(__GNUC__) && (__GNUC__ * 10 + __GNUC_MINOR__ >= 31)
+#    define LZ4_DEPRECATED(message) __attribute__((deprecated))
+#  else
+#    pragma message("WARNING: LZ4_DEPRECATED needs custom implementation for this compiler")
+#    define LZ4_DEPRECATED(message)   /* disabled */
+#  endif
+#endif /* LZ4_DISABLE_DEPRECATE_WARNINGS */
+
    
+  Deprecated functions make the compiler generate a warning when invoked.
+  This is meant to invite users to update their source code.
+  Should deprecation warnings be a problem, it is generally possible to disable them,
+  typically with -Wno-deprecated-declarations for gcc
+  or _CRT_SECURE_NO_WARNINGS in Visual.
+
+  Another method is to define LZ4_DISABLE_DEPRECATE_WARNINGS
+  before including the header file.
+ 
+

    
+
+
    LZ4_DEPRECATED("use LZ4_compress_default() instead")       LZ4LIB_API int LZ4_compress               (const char* src, char* dest, int srcSize);
+LZ4_DEPRECATED("use LZ4_compress_default() instead")       LZ4LIB_API int LZ4_compress_limitedOutput (const char* src, char* dest, int srcSize, int maxOutputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_extState() instead") LZ4LIB_API int LZ4_compress_withState               (void* state, const char* source, char* dest, int inputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_extState() instead") LZ4LIB_API int LZ4_compress_limitedOutput_withState (void* state, const char* source, char* dest, int inputSize, int maxOutputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_continue() instead") LZ4LIB_API int LZ4_compress_continue                (LZ4_stream_t* LZ4_streamPtr, const char* source, char* dest, int inputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_continue() instead") LZ4LIB_API int LZ4_compress_limitedOutput_continue  (LZ4_stream_t* LZ4_streamPtr, const char* source, char* dest, int inputSize, int maxOutputSize);
+

    
+
+
    LZ4_DEPRECATED("use LZ4_decompress_fast() instead") LZ4LIB_API int LZ4_uncompress (const char* source, char* dest, int outputSize);
+LZ4_DEPRECATED("use LZ4_decompress_safe() instead") LZ4LIB_API int LZ4_uncompress_unknownOutputSize (const char* source, char* dest, int isize, int maxOutputSize);
+

    
+
+
    LZ4_DEPRECATED("use LZ4_decompress_safe_usingDict() instead") LZ4LIB_API int LZ4_decompress_safe_withPrefix64k (const char* src, char* dst, int compressedSize, int maxDstSize);
+LZ4_DEPRECATED("use LZ4_decompress_fast_usingDict() instead") LZ4LIB_API int LZ4_decompress_fast_withPrefix64k (const char* src, char* dst, int originalSize);
+

    
+
+
    LZ4_DEPRECATED("This function is deprecated and unsafe. Consider using LZ4_decompress_safe() instead")
+int LZ4_decompress_fast (const char* src, char* dst, int originalSize);
+LZ4_DEPRECATED("This function is deprecated and unsafe. Consider using LZ4_decompress_safe_continue() instead")
+int LZ4_decompress_fast_continue (LZ4_streamDecode_t* LZ4_streamDecode, const char* src, char* dst, int originalSize);
+LZ4_DEPRECATED("This function is deprecated and unsafe. Consider using LZ4_decompress_safe_usingDict() instead")
+int LZ4_decompress_fast_usingDict (const char* src, char* dst, int originalSize, const char* dictStart, int dictSize);
+
      These functions used to be faster than LZ4_decompress_safe(),
+  but this is no longer the case. They are now slower.
+  This is because LZ4_decompress_fast() doesn't know the input size,
+  and therefore must progress more cautiously into the input buffer to not read beyond the end of block.
+  On top of that `LZ4_decompress_fast()` is not protected vs malformed or malicious inputs, making it a security liability.
+  As a consequence, LZ4_decompress_fast() is strongly discouraged, and deprecated.
+
+  The last remaining LZ4_decompress_fast() specificity is that
+  it can decompress a block without knowing its compressed size.
+  Such functionality can be achieved in a more secure manner
+  by employing LZ4_decompress_safe_partial().
+
+  Parameters:
+  originalSize : is the uncompressed size to regenerate.
+                 `dst` must be already allocated, its size must be >= 'originalSize' bytes.
+ @return : number of bytes read from source buffer (== compressed size).
+           The function expects to finish at block's end exactly.
+           If the source stream is detected malformed, the function stops decoding and returns a negative result.
+  note : LZ4_decompress_fast*() requires originalSize. Thanks to this information, it never writes past the output buffer.
+         However, since it doesn't know its 'src' size, it may read an unknown amount of input, past input buffer bounds.
+         Also, since match offsets are not validated, match reads from 'src' may underflow too.
+         These issues never happen if input (compressed) data is correct.
+         But they may happen if input data is invalid (error or intentional tampering).
+         As a consequence, use these functions in trusted environments with trusted data **only**.
+ 
+

    
+
+
    void LZ4_resetStream (LZ4_stream_t* streamPtr);
+
      An LZ4_stream_t structure must be initialized at least once.
+  This is done with LZ4_initStream(), or LZ4_resetStream().
+  Consider switching to LZ4_initStream(),
+  invoking LZ4_resetStream() will trigger deprecation warnings in the future.
+ 
+

    
+
+
+
diff --git a/lz4/doc/lz4frame_manual.html b/lz4/doc/lz4frame_manual.html
new file mode 100644
index 0000000..2758306
--- /dev/null
+++ b/lz4/doc/lz4frame_manual.html
@@ -0,0 +1,396 @@
+
+
+
+1.9.3 Manual
+
+
+
    1.9.3 Manual
    
+
    
+
    Contents
    
+
      
+
    1. Introduction
      2. 
+
    2. Compiler specifics
      3. 
+
    3. Error management
      4. 
+
    4. Frame compression types
      5. 
+
    5. Simple compression function
      6. 
+
    6. Advanced compression functions
      7. 
+
    7. Resource Management
      8. 
+
    8. Compression
      9. 
+
    9. Decompression functions
      10. 
+
    10. Streaming decompression functions
      11. 
+
    11. Bulk processing dictionary API
      12. 
+
    
+
    
+
    Introduction
    +  lz4frame.h implements LZ4 frame specification (doc/lz4_Frame_format.md).
+  lz4frame.h provides frame compression functions that take care
+  of encoding standard metadata alongside LZ4-compressed blocks.
+
    
+
+
    Compiler specifics
    
+
+
    Error management
    
+
+
    unsigned    LZ4F_isError(LZ4F_errorCode_t code);   /**< tells when a function result is an error code */
+

    
+
    const char* LZ4F_getErrorName(LZ4F_errorCode_t code);   /**< return error code string; for debugging */
+

    
+
    Frame compression types
    
+
+
    typedef enum {
+    LZ4F_default=0,
+    LZ4F_max64KB=4,
+    LZ4F_max256KB=5,
+    LZ4F_max1MB=6,
+    LZ4F_max4MB=7
+    LZ4F_OBSOLETE_ENUM(max64KB)
+    LZ4F_OBSOLETE_ENUM(max256KB)
+    LZ4F_OBSOLETE_ENUM(max1MB)
+    LZ4F_OBSOLETE_ENUM(max4MB)
+} LZ4F_blockSizeID_t;
+

    
+
    typedef enum {
+    LZ4F_blockLinked=0,
+    LZ4F_blockIndependent
+    LZ4F_OBSOLETE_ENUM(blockLinked)
+    LZ4F_OBSOLETE_ENUM(blockIndependent)
+} LZ4F_blockMode_t;
+

    
+
    typedef enum {
+    LZ4F_noContentChecksum=0,
+    LZ4F_contentChecksumEnabled
+    LZ4F_OBSOLETE_ENUM(noContentChecksum)
+    LZ4F_OBSOLETE_ENUM(contentChecksumEnabled)
+} LZ4F_contentChecksum_t;
+

    
+
    typedef enum {
+    LZ4F_noBlockChecksum=0,
+    LZ4F_blockChecksumEnabled
+} LZ4F_blockChecksum_t;
+

    
+
    typedef enum {
+    LZ4F_frame=0,
+    LZ4F_skippableFrame
+    LZ4F_OBSOLETE_ENUM(skippableFrame)
+} LZ4F_frameType_t;
+

    
+
    typedef struct {
+  LZ4F_blockSizeID_t     blockSizeID;         /* max64KB, max256KB, max1MB, max4MB; 0 == default */
+  LZ4F_blockMode_t       blockMode;           /* LZ4F_blockLinked, LZ4F_blockIndependent; 0 == default */
+  LZ4F_contentChecksum_t contentChecksumFlag; /* 1: frame terminated with 32-bit checksum of decompressed data; 0: disabled (default) */
+  LZ4F_frameType_t       frameType;           /* read-only field : LZ4F_frame or LZ4F_skippableFrame */
+  unsigned long long     contentSize;         /* Size of uncompressed content ; 0 == unknown */
+  unsigned               dictID;              /* Dictionary ID, sent by compressor to help decoder select correct dictionary; 0 == no dictID provided */
+  LZ4F_blockChecksum_t   blockChecksumFlag;   /* 1: each block followed by a checksum of block's compressed data; 0: disabled (default) */
+} LZ4F_frameInfo_t;
+
      makes it possible to set or read frame parameters.
+  Structure must be first init to 0, using memset() or LZ4F_INIT_FRAMEINFO,
+  setting all parameters to default.
+  It's then possible to update selectively some parameters 
+

    
+
+
    typedef struct {
+  LZ4F_frameInfo_t frameInfo;
+  int      compressionLevel;    /* 0: default (fast mode); values > LZ4HC_CLEVEL_MAX count as LZ4HC_CLEVEL_MAX; values < 0 trigger "fast acceleration" */
+  unsigned autoFlush;           /* 1: always flush; reduces usage of internal buffers */
+  unsigned favorDecSpeed;       /* 1: parser favors decompression speed vs compression ratio. Only works for high compression modes (>= LZ4HC_CLEVEL_OPT_MIN) */  /* v1.8.2+ */
+  unsigned reserved[3];         /* must be zero for forward compatibility */
+} LZ4F_preferences_t;
+
      makes it possible to supply advanced compression instructions to streaming interface.
+  Structure must be first init to 0, using memset() or LZ4F_INIT_PREFERENCES,
+  setting all parameters to default.
+  All reserved fields must be set to zero. 
+

    
+
+
    Simple compression function
    
+
+
    size_t LZ4F_compressFrameBound(size_t srcSize, const LZ4F_preferences_t* preferencesPtr);
+
      Returns the maximum possible compressed size with LZ4F_compressFrame() given srcSize and preferences.
+ `preferencesPtr` is optional. It can be replaced by NULL, in which case, the function will assume default preferences.
+  Note : this result is only usable with LZ4F_compressFrame().
+         It may also be used with LZ4F_compressUpdate() _if no flush() operation_ is performed.
+ 
+

    
+
+
    size_t LZ4F_compressFrame(void* dstBuffer, size_t dstCapacity,
+                                const void* srcBuffer, size_t srcSize,
+                                const LZ4F_preferences_t* preferencesPtr);
+
      Compress an entire srcBuffer into a valid LZ4 frame.
+  dstCapacity MUST be >= LZ4F_compressFrameBound(srcSize, preferencesPtr).
+  The LZ4F_preferences_t structure is optional : you can provide NULL as argument. All preferences will be set to default.
+ @return : number of bytes written into dstBuffer.
+           or an error code if it fails (can be tested using LZ4F_isError())
+ 
+

    
+
+
    Advanced compression functions
    
+
+
    typedef struct {
+  unsigned stableSrc;    /* 1 == src content will remain present on future calls to LZ4F_compress(); skip copying src content within tmp buffer */
+  unsigned reserved[3];
+} LZ4F_compressOptions_t;
+

    
+
    Resource Management
    
+
+
    LZ4F_errorCode_t LZ4F_createCompressionContext(LZ4F_cctx** cctxPtr, unsigned version);
+LZ4F_errorCode_t LZ4F_freeCompressionContext(LZ4F_cctx* cctx);
+
     The first thing to do is to create a compressionContext object, which will be used in all compression operations.
+ This is achieved using LZ4F_createCompressionContext(), which takes as argument a version.
+ The version provided MUST be LZ4F_VERSION. It is intended to track potential version mismatch, notably when using DLL.
+ The function will provide a pointer to a fully allocated LZ4F_cctx object.
+ If @return != zero, there was an error during context creation.
+ Object can release its memory using LZ4F_freeCompressionContext();
+ 
+

    
+
+
    Compression
    
+
+
    size_t LZ4F_compressBegin(LZ4F_cctx* cctx,
+                                      void* dstBuffer, size_t dstCapacity,
+                                      const LZ4F_preferences_t* prefsPtr);
+
      will write the frame header into dstBuffer.
+  dstCapacity must be >= LZ4F_HEADER_SIZE_MAX bytes.
+ `prefsPtr` is optional : you can provide NULL as argument, all preferences will then be set to default.
+ @return : number of bytes written into dstBuffer for the header
+           or an error code (which can be tested using LZ4F_isError())
+ 
+

    
+
+
    size_t LZ4F_compressBound(size_t srcSize, const LZ4F_preferences_t* prefsPtr);
+
      Provides minimum dstCapacity required to guarantee success of
+  LZ4F_compressUpdate(), given a srcSize and preferences, for a worst case scenario.
+  When srcSize==0, LZ4F_compressBound() provides an upper bound for LZ4F_flush() and LZ4F_compressEnd() instead.
+  Note that the result is only valid for a single invocation of LZ4F_compressUpdate().
+  When invoking LZ4F_compressUpdate() multiple times,
+  if the output buffer is gradually filled up instead of emptied and re-used from its start,
+  one must check if there is enough remaining capacity before each invocation, using LZ4F_compressBound().
+ @return is always the same for a srcSize and prefsPtr.
+  prefsPtr is optional : when NULL is provided, preferences will be set to cover worst case scenario.
+  tech details :
+ @return if automatic flushing is not enabled, includes the possibility that internal buffer might already be filled by up to (blockSize-1) bytes.
+  It also includes frame footer (ending + checksum), since it might be generated by LZ4F_compressEnd().
+ @return doesn't include frame header, as it was already generated by LZ4F_compressBegin().
+ 
+

    
+
+
    size_t LZ4F_compressUpdate(LZ4F_cctx* cctx,
+                                       void* dstBuffer, size_t dstCapacity,
+                                 const void* srcBuffer, size_t srcSize,
+                                 const LZ4F_compressOptions_t* cOptPtr);
+
      LZ4F_compressUpdate() can be called repetitively to compress as much data as necessary.
+  Important rule: dstCapacity MUST be large enough to ensure operation success even in worst case situations.
+  This value is provided by LZ4F_compressBound().
+  If this condition is not respected, LZ4F_compress() will fail (result is an errorCode).
+  LZ4F_compressUpdate() doesn't guarantee error recovery.
+  When an error occurs, compression context must be freed or resized.
+ `cOptPtr` is optional : NULL can be provided, in which case all options are set to default.
+ @return : number of bytes written into `dstBuffer` (it can be zero, meaning input data was just buffered).
+           or an error code if it fails (which can be tested using LZ4F_isError())
+ 
+

    
+
+
    size_t LZ4F_flush(LZ4F_cctx* cctx,
+                              void* dstBuffer, size_t dstCapacity,
+                        const LZ4F_compressOptions_t* cOptPtr);
+
      When data must be generated and sent immediately, without waiting for a block to be completely filled,
+  it's possible to call LZ4_flush(). It will immediately compress any data buffered within cctx.
+ `dstCapacity` must be large enough to ensure the operation will be successful.
+ `cOptPtr` is optional : it's possible to provide NULL, all options will be set to default.
+ @return : nb of bytes written into dstBuffer (can be zero, when there is no data stored within cctx)
+           or an error code if it fails (which can be tested using LZ4F_isError())
+  Note : LZ4F_flush() is guaranteed to be successful when dstCapacity >= LZ4F_compressBound(0, prefsPtr).
+ 
+

    
+
+
    size_t LZ4F_compressEnd(LZ4F_cctx* cctx,
+                                    void* dstBuffer, size_t dstCapacity,
+                              const LZ4F_compressOptions_t* cOptPtr);
+
      To properly finish an LZ4 frame, invoke LZ4F_compressEnd().
+  It will flush whatever data remained within `cctx` (like LZ4_flush())
+  and properly finalize the frame, with an endMark and a checksum.
+ `cOptPtr` is optional : NULL can be provided, in which case all options will be set to default.
+ @return : nb of bytes written into dstBuffer, necessarily >= 4 (endMark),
+           or an error code if it fails (which can be tested using LZ4F_isError())
+  Note : LZ4F_compressEnd() is guaranteed to be successful when dstCapacity >= LZ4F_compressBound(0, prefsPtr).
+  A successful call to LZ4F_compressEnd() makes `cctx` available again for another compression task.
+ 
+

    
+
+
    Decompression functions
    
+
+
    typedef struct {
+  unsigned stableDst;    /* pledges that last 64KB decompressed data will remain available unmodified. This optimization skips storage operations in tmp buffers. */
+  unsigned reserved[3];  /* must be set to zero for forward compatibility */
+} LZ4F_decompressOptions_t;
+

    
+
    LZ4F_errorCode_t LZ4F_createDecompressionContext(LZ4F_dctx** dctxPtr, unsigned version);
+LZ4F_errorCode_t LZ4F_freeDecompressionContext(LZ4F_dctx* dctx);
+
      Create an LZ4F_dctx object, to track all decompression operations.
+  The version provided MUST be LZ4F_VERSION.
+  The function provides a pointer to an allocated and initialized LZ4F_dctx object.
+  The result is an errorCode, which can be tested using LZ4F_isError().
+  dctx memory can be released using LZ4F_freeDecompressionContext();
+  Result of LZ4F_freeDecompressionContext() indicates current state of decompressionContext when being released.
+  That is, it should be == 0 if decompression has been completed fully and correctly.
+ 
+

    
+
+
    Streaming decompression functions
    
+
+
    size_t LZ4F_headerSize(const void* src, size_t srcSize);
+
      Provide the header size of a frame starting at `src`.
+ `srcSize` must be >= LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH,
+  which is enough to decode the header length.
+ @return : size of frame header
+           or an error code, which can be tested using LZ4F_isError()
+  note : Frame header size is variable, but is guaranteed to be
+         >= LZ4F_HEADER_SIZE_MIN bytes, and <= LZ4F_HEADER_SIZE_MAX bytes.
+ 
+

    
+
+
    size_t LZ4F_getFrameInfo(LZ4F_dctx* dctx,
+                                     LZ4F_frameInfo_t* frameInfoPtr,
+                                     const void* srcBuffer, size_t* srcSizePtr);
+
      This function extracts frame parameters (max blockSize, dictID, etc.).
+  Its usage is optional: user can call LZ4F_decompress() directly.
+
+  Extracted information will fill an existing LZ4F_frameInfo_t structure.
+  This can be useful for allocation and dictionary identification purposes.
+
+  LZ4F_getFrameInfo() can work in the following situations :
+
+  1) At the beginning of a new frame, before any invocation of LZ4F_decompress().
+     It will decode header from `srcBuffer`,
+     consuming the header and starting the decoding process.
+
+     Input size must be large enough to contain the full frame header.
+     Frame header size can be known beforehand by LZ4F_headerSize().
+     Frame header size is variable, but is guaranteed to be >= LZ4F_HEADER_SIZE_MIN bytes,
+     and not more than <= LZ4F_HEADER_SIZE_MAX bytes.
+     Hence, blindly providing LZ4F_HEADER_SIZE_MAX bytes or more will always work.
+     It's allowed to provide more input data than the header size,
+     LZ4F_getFrameInfo() will only consume the header.
+
+     If input size is not large enough,
+     aka if it's smaller than header size,
+     function will fail and return an error code.
+
+  2) After decoding has been started,
+     it's possible to invoke LZ4F_getFrameInfo() anytime
+     to extract already decoded frame parameters stored within dctx.
+
+     Note that, if decoding has barely started,
+     and not yet read enough information to decode the header,
+     LZ4F_getFrameInfo() will fail.
+
+  The number of bytes consumed from srcBuffer will be updated in *srcSizePtr (necessarily <= original value).
+  LZ4F_getFrameInfo() only consumes bytes when decoding has not yet started,
+  and when decoding the header has been successful.
+  Decompression must then resume from (srcBuffer + *srcSizePtr).
+
+ @return : a hint about how many srcSize bytes LZ4F_decompress() expects for next call,
+           or an error code which can be tested using LZ4F_isError().
+  note 1 : in case of error, dctx is not modified. Decoding operation can resume from beginning safely.
+  note 2 : frame parameters are *copied into* an already allocated LZ4F_frameInfo_t structure.
+ 
+

    
+
+
    size_t LZ4F_decompress(LZ4F_dctx* dctx,
+                                   void* dstBuffer, size_t* dstSizePtr,
+                                   const void* srcBuffer, size_t* srcSizePtr,
+                                   const LZ4F_decompressOptions_t* dOptPtr);
+
      Call this function repetitively to regenerate data compressed in `srcBuffer`.
+
+  The function requires a valid dctx state.
+  It will read up to *srcSizePtr bytes from srcBuffer,
+  and decompress data into dstBuffer, of capacity *dstSizePtr.
+
+  The nb of bytes consumed from srcBuffer will be written into *srcSizePtr (necessarily <= original value).
+  The nb of bytes decompressed into dstBuffer will be written into *dstSizePtr (necessarily <= original value).
+
+  The function does not necessarily read all input bytes, so always check value in *srcSizePtr.
+  Unconsumed source data must be presented again in subsequent invocations.
+
+ `dstBuffer` can freely change between each consecutive function invocation.
+ `dstBuffer` content will be overwritten.
+
+ @return : an hint of how many `srcSize` bytes LZ4F_decompress() expects for next call.
+  Schematically, it's the size of the current (or remaining) compressed block + header of next block.
+  Respecting the hint provides some small speed benefit, because it skips intermediate buffers.
+  This is just a hint though, it's always possible to provide any srcSize.
+
+  When a frame is fully decoded, @return will be 0 (no more data expected).
+  When provided with more bytes than necessary to decode a frame,
+  LZ4F_decompress() will stop reading exactly at end of current frame, and @return 0.
+
+  If decompression failed, @return is an error code, which can be tested using LZ4F_isError().
+  After a decompression error, the `dctx` context is not resumable.
+  Use LZ4F_resetDecompressionContext() to return to clean state.
+
+  After a frame is fully decoded, dctx can be used again to decompress another frame.
+ 
+

    
+
+
    void LZ4F_resetDecompressionContext(LZ4F_dctx* dctx);   /* always successful */
+
      In case of an error, the context is left in "undefined" state.
+  In which case, it's necessary to reset it, before re-using it.
+  This method can also be used to abruptly stop any unfinished decompression,
+  and start a new one using same context resources. 
+

    
+
+
    typedef enum { LZ4F_LIST_ERRORS(LZ4F_GENERATE_ENUM)
+              _LZ4F_dummy_error_enum_for_c89_never_used } LZ4F_errorCodes;
+

    
+
    Bulk processing dictionary API
    
+
+
    LZ4FLIB_STATIC_API LZ4F_CDict* LZ4F_createCDict(const void* dictBuffer, size_t dictSize);
+LZ4FLIB_STATIC_API void        LZ4F_freeCDict(LZ4F_CDict* CDict);
+
      When compressing multiple messages / blocks using the same dictionary, it's recommended to load it just once.
+  LZ4_createCDict() will create a digested dictionary, ready to start future compression operations without startup delay.
+  LZ4_CDict can be created once and shared by multiple threads concurrently, since its usage is read-only.
+ `dictBuffer` can be released after LZ4_CDict creation, since its content is copied within CDict 
+

    
+
+
    LZ4FLIB_STATIC_API size_t LZ4F_compressFrame_usingCDict(
+    LZ4F_cctx* cctx,
+    void* dst, size_t dstCapacity,
+    const void* src, size_t srcSize,
+    const LZ4F_CDict* cdict,
+    const LZ4F_preferences_t* preferencesPtr);
+
      Compress an entire srcBuffer into a valid LZ4 frame using a digested Dictionary.
+  cctx must point to a context created by LZ4F_createCompressionContext().
+  If cdict==NULL, compress without a dictionary.
+  dstBuffer MUST be >= LZ4F_compressFrameBound(srcSize, preferencesPtr).
+  If this condition is not respected, function will fail (@return an errorCode).
+  The LZ4F_preferences_t structure is optional : you may provide NULL as argument,
+  but it's not recommended, as it's the only way to provide dictID in the frame header.
+ @return : number of bytes written into dstBuffer.
+           or an error code if it fails (can be tested using LZ4F_isError()) 
+

    
+
+
    LZ4FLIB_STATIC_API size_t LZ4F_compressBegin_usingCDict(
+    LZ4F_cctx* cctx,
+    void* dstBuffer, size_t dstCapacity,
+    const LZ4F_CDict* cdict,
+    const LZ4F_preferences_t* prefsPtr);
+
      Inits streaming dictionary compression, and writes the frame header into dstBuffer.
+  dstCapacity must be >= LZ4F_HEADER_SIZE_MAX bytes.
+ `prefsPtr` is optional : you may provide NULL as argument,
+  however, it's the only way to provide dictID in the frame header.
+ @return : number of bytes written into dstBuffer for the header,
+           or an error code (which can be tested using LZ4F_isError()) 
+

    
+
+
    LZ4FLIB_STATIC_API size_t LZ4F_decompress_usingDict(
+    LZ4F_dctx* dctxPtr,
+    void* dstBuffer, size_t* dstSizePtr,
+    const void* srcBuffer, size_t* srcSizePtr,
+    const void* dict, size_t dictSize,
+    const LZ4F_decompressOptions_t* decompressOptionsPtr);
+
      Same as LZ4F_decompress(), using a predefined dictionary.
+  Dictionary is used "in place", without any preprocessing.
+  It must remain accessible throughout the entire frame decoding. 
+

    
+
+
+
diff --git a/lz4/examples/.gitignore b/lz4/examples/.gitignore
new file mode 100644
index 0000000..5abeef6
--- /dev/null
+++ b/lz4/examples/.gitignore
@@ -0,0 +1,10 @@
+/Makefile.lz4*
+/printVersion
+/doubleBuffer
+/dictionaryRandomAccess
+/ringBuffer
+/ringBufferHC
+/lineCompress
+/frameCompress
+/simpleBuffer
+/*.exe
diff --git a/lz4/examples/COPYING b/lz4/examples/COPYING
new file mode 100644
index 0000000..d159169
--- /dev/null
+++ b/lz4/examples/COPYING
@@ -0,0 +1,339 @@
+                    GNU GENERAL PUBLIC LICENSE
+                       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+                            NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    
+    Copyright (C)   
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  , 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.
diff --git a/lz4/examples/HCStreaming_ringBuffer.c b/lz4/examples/HCStreaming_ringBuffer.c
new file mode 100644
index 0000000..bc8391e
--- /dev/null
+++ b/lz4/examples/HCStreaming_ringBuffer.c
@@ -0,0 +1,232 @@
+// LZ4 HC streaming API example : ring buffer
+// Based on a previous example by Takayuki Matsuoka
+
+
+/**************************************
+ * Compiler Options
+ **************************************/
+#if defined(_MSC_VER) && (_MSC_VER <= 1800)  /* Visual Studio <= 2013 */
+#  define _CRT_SECURE_NO_WARNINGS
+#  define snprintf sprintf_s
+#endif
+
+#define GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__)
+#ifdef __GNUC__
+#  pragma GCC diagnostic ignored "-Wmissing-braces"   /* GCC bug 53119 : doesn't accept { 0 } as initializer (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=53119) */
+#endif
+
+
+/**************************************
+ * Includes
+ **************************************/
+#include "lz4hc.h"
+#include "lz4.h"
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+enum {
+    MESSAGE_MAX_BYTES   = 1024,
+    RING_BUFFER_BYTES   = 1024 * 8 + MESSAGE_MAX_BYTES,
+    DEC_BUFFER_BYTES    = RING_BUFFER_BYTES + MESSAGE_MAX_BYTES   // Intentionally larger to test unsynchronized ring buffers
+};
+
+
+size_t write_int32(FILE* fp, int32_t i) {
+    return fwrite(&i, sizeof(i), 1, fp);
+}
+
+size_t write_bin(FILE* fp, const void* array, int arrayBytes) {
+    assert(arrayBytes >= 0);
+    return fwrite(array, 1, (size_t)arrayBytes, fp);
+}
+
+size_t read_int32(FILE* fp, int32_t* i) {
+    return fread(i, sizeof(*i), 1, fp);
+}
+
+size_t read_bin(FILE* fp, void* array, int arrayBytes) {
+    assert(arrayBytes >= 0);
+    return fread(array, 1, (size_t)arrayBytes, fp);
+}
+
+
+void test_compress(FILE* outFp, FILE* inpFp)
+{
+    LZ4_streamHC_t lz4Stream_body = { 0 };
+    LZ4_streamHC_t* lz4Stream = &lz4Stream_body;
+
+    static char inpBuf[RING_BUFFER_BYTES];
+    int inpOffset = 0;
+
+    for(;;) {
+        // Read random length ([1,MESSAGE_MAX_BYTES]) data to the ring buffer.
+        char* const inpPtr = &inpBuf[inpOffset];
+        const int randomLength = (rand() % MESSAGE_MAX_BYTES) + 1;
+        const int inpBytes = (int) read_bin(inpFp, inpPtr, randomLength);
+        if (0 == inpBytes) break;
+
+#define CMPBUFSIZE (LZ4_COMPRESSBOUND(MESSAGE_MAX_BYTES))
+        {   char cmpBuf[CMPBUFSIZE];
+            const int cmpBytes = LZ4_compress_HC_continue(lz4Stream, inpPtr, cmpBuf, inpBytes, CMPBUFSIZE);
+
+            if(cmpBytes <= 0) break;
+            write_int32(outFp, cmpBytes);
+            write_bin(outFp, cmpBuf, cmpBytes);
+
+            inpOffset += inpBytes;
+
+            // Wraparound the ringbuffer offset
+            if(inpOffset >= RING_BUFFER_BYTES - MESSAGE_MAX_BYTES)
+                inpOffset = 0;
+        }
+    }
+
+    write_int32(outFp, 0);
+}
+
+
+void test_decompress(FILE* outFp, FILE* inpFp)
+{
+    static char decBuf[DEC_BUFFER_BYTES];
+    int decOffset = 0;
+    LZ4_streamDecode_t lz4StreamDecode_body = { 0 };
+    LZ4_streamDecode_t* lz4StreamDecode = &lz4StreamDecode_body;
+
+    for(;;) {
+        int  cmpBytes = 0;
+        char cmpBuf[CMPBUFSIZE];
+
+        {   const size_t r0 = read_int32(inpFp, &cmpBytes);
+            size_t r1;
+            if(r0 != 1 || cmpBytes <= 0)
+                break;
+
+            r1 = read_bin(inpFp, cmpBuf, cmpBytes);
+            if(r1 != (size_t) cmpBytes)
+                break;
+        }
+
+        {   char* const decPtr = &decBuf[decOffset];
+            const int decBytes = LZ4_decompress_safe_continue(
+                lz4StreamDecode, cmpBuf, decPtr, cmpBytes, MESSAGE_MAX_BYTES);
+            if(decBytes <= 0)
+                break;
+
+            decOffset += decBytes;
+            write_bin(outFp, decPtr, decBytes);
+
+            // Wraparound the ringbuffer offset
+            if(decOffset >= DEC_BUFFER_BYTES - MESSAGE_MAX_BYTES)
+                decOffset = 0;
+        }
+    }
+}
+
+
+// Compare 2 files content
+// return 0 if identical
+// return ByteNb>0 if different
+size_t compare(FILE* f0, FILE* f1)
+{
+    size_t result = 1;
+
+    for (;;) {
+        char b0[65536];
+        char b1[65536];
+        const size_t r0 = fread(b0, 1, sizeof(b0), f0);
+        const size_t r1 = fread(b1, 1, sizeof(b1), f1);
+
+        if ((r0==0) && (r1==0)) return 0;   // success
+
+        if (r0 != r1) {
+            size_t smallest = r0;
+            if (r1
+#include 
+#include 
+#include 
+
+enum {
+    BLOCK_BYTES = 1024 * 8,
+//  BLOCK_BYTES = 1024 * 64,
+};
+
+
+size_t write_int(FILE* fp, int i) {
+    return fwrite(&i, sizeof(i), 1, fp);
+}
+
+size_t write_bin(FILE* fp, const void* array, size_t arrayBytes) {
+    return fwrite(array, 1, arrayBytes, fp);
+}
+
+size_t read_int(FILE* fp, int* i) {
+    return fread(i, sizeof(*i), 1, fp);
+}
+
+size_t read_bin(FILE* fp, void* array, size_t arrayBytes) {
+    return fread(array, 1, arrayBytes, fp);
+}
+
+
+void test_compress(FILE* outFp, FILE* inpFp)
+{
+    LZ4_stream_t lz4Stream_body;
+    LZ4_stream_t* lz4Stream = &lz4Stream_body;
+
+    char inpBuf[2][BLOCK_BYTES];
+    int  inpBufIndex = 0;
+
+    LZ4_initStream(lz4Stream, sizeof (*lz4Stream));
+
+    for(;;) {
+        char* const inpPtr = inpBuf[inpBufIndex];
+        const int inpBytes = (int) read_bin(inpFp, inpPtr, BLOCK_BYTES);
+        if(0 == inpBytes) {
+            break;
+        }
+
+        {
+            char cmpBuf[LZ4_COMPRESSBOUND(BLOCK_BYTES)];
+            const int cmpBytes = LZ4_compress_fast_continue(
+                lz4Stream, inpPtr, cmpBuf, inpBytes, sizeof(cmpBuf), 1);
+            if(cmpBytes <= 0) {
+                break;
+            }
+            write_int(outFp, cmpBytes);
+            write_bin(outFp, cmpBuf, (size_t) cmpBytes);
+        }
+
+        inpBufIndex = (inpBufIndex + 1) % 2;
+    }
+
+    write_int(outFp, 0);
+}
+
+
+void test_decompress(FILE* outFp, FILE* inpFp)
+{
+    LZ4_streamDecode_t lz4StreamDecode_body;
+    LZ4_streamDecode_t* lz4StreamDecode = &lz4StreamDecode_body;
+
+    char decBuf[2][BLOCK_BYTES];
+    int  decBufIndex = 0;
+
+    LZ4_setStreamDecode(lz4StreamDecode, NULL, 0);
+
+    for(;;) {
+        char cmpBuf[LZ4_COMPRESSBOUND(BLOCK_BYTES)];
+        int  cmpBytes = 0;
+
+        {
+            const size_t readCount0 = read_int(inpFp, &cmpBytes);
+            if(readCount0 != 1 || cmpBytes <= 0) {
+                break;
+            }
+
+            const size_t readCount1 = read_bin(inpFp, cmpBuf, (size_t) cmpBytes);
+            if(readCount1 != (size_t) cmpBytes) {
+                break;
+            }
+        }
+
+        {
+            char* const decPtr = decBuf[decBufIndex];
+            const int decBytes = LZ4_decompress_safe_continue(
+                lz4StreamDecode, cmpBuf, decPtr, cmpBytes, BLOCK_BYTES);
+            if(decBytes <= 0) {
+                break;
+            }
+            write_bin(outFp, decPtr, (size_t) decBytes);
+        }
+
+        decBufIndex = (decBufIndex + 1) % 2;
+    }
+}
+
+
+int compare(FILE* fp0, FILE* fp1)
+{
+    int result = 0;
+
+    while(0 == result) {
+        char b0[65536];
+        char b1[65536];
+        const size_t r0 = read_bin(fp0, b0, sizeof(b0));
+        const size_t r1 = read_bin(fp1, b1, sizeof(b1));
+
+        result = (int) r0 - (int) r1;
+
+        if(0 == r0 || 0 == r1) {
+            break;
+        }
+        if(0 == result) {
+            result = memcmp(b0, b1, r0);
+        }
+    }
+
+    return result;
+}
+
+
+int main(int argc, char* argv[])
+{
+    char inpFilename[256] = { 0 };
+    char lz4Filename[256] = { 0 };
+    char decFilename[256] = { 0 };
+
+    if(argc < 2) {
+        printf("Please specify input filename\n");
+        return 0;
+    }
+
+    snprintf(inpFilename, 256, "%s", argv[1]);
+    snprintf(lz4Filename, 256, "%s.lz4s-%d", argv[1], BLOCK_BYTES);
+    snprintf(decFilename, 256, "%s.lz4s-%d.dec", argv[1], BLOCK_BYTES);
+
+    printf("inp = [%s]\n", inpFilename);
+    printf("lz4 = [%s]\n", lz4Filename);
+    printf("dec = [%s]\n", decFilename);
+
+    // compress
+    {
+        FILE* inpFp = fopen(inpFilename, "rb");
+        FILE* outFp = fopen(lz4Filename, "wb");
+
+        printf("compress : %s -> %s\n", inpFilename, lz4Filename);
+        test_compress(outFp, inpFp);
+        printf("compress : done\n");
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    // decompress
+    {
+        FILE* inpFp = fopen(lz4Filename, "rb");
+        FILE* outFp = fopen(decFilename, "wb");
+
+        printf("decompress : %s -> %s\n", lz4Filename, decFilename);
+        test_decompress(outFp, inpFp);
+        printf("decompress : done\n");
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    // verify
+    {
+        FILE* inpFp = fopen(inpFilename, "rb");
+        FILE* decFp = fopen(decFilename, "rb");
+
+        printf("verify : %s <-> %s\n", inpFilename, decFilename);
+        const int cmp = compare(inpFp, decFp);
+        if(0 == cmp) {
+            printf("verify : OK\n");
+        } else {
+            printf("verify : NG\n");
+        }
+
+        fclose(decFp);
+        fclose(inpFp);
+    }
+
+    return 0;
+}
diff --git a/lz4/examples/blockStreaming_doubleBuffer.md b/lz4/examples/blockStreaming_doubleBuffer.md
new file mode 100644
index 0000000..38dc2e8
--- /dev/null
+++ b/lz4/examples/blockStreaming_doubleBuffer.md
@@ -0,0 +1,100 @@
+# LZ4 Streaming API Example : Double Buffer
+by *Takayuki Matsuoka*
+
+`blockStreaming_doubleBuffer.c` is LZ4 Streaming API example which implements double buffer (de)compression.
+
+Please note :
+
+ - Firstly, read "LZ4 Streaming API Basics".
+ - This is relatively advanced application example.
+ - Output file is not compatible with lz4frame and platform dependent.
+
+
+## What's the point of this example ?
+
+ - Handle huge file in small amount of memory
+ - Always better compression ratio than Block API
+ - Uniform block size
+
+
+## How the compression works
+
+First of all, allocate "Double Buffer" for input and LZ4 compressed data buffer for output.
+Double buffer has two pages, "first" page (Page#1) and "second" page (Page#2).
+
+```
+        Double Buffer
+
+      Page#1    Page#2
+    +---------+---------+
+    | Block#1 |         |
+    +----+----+---------+
+         |
+         v
+      {Out#1}
+
+
+      Prefix Dependency
+         +---------+
+         |         |
+         v         |
+    +---------+----+----+
+    | Block#1 | Block#2 |
+    +---------+----+----+
+                   |
+                   v
+                {Out#2}
+
+
+   External Dictionary Mode
+         +---------+
+         |         |
+         |         v
+    +----+----+---------+
+    | Block#3 | Block#2 |
+    +----+----+---------+
+         |
+         v
+      {Out#3}
+
+
+      Prefix Dependency
+         +---------+
+         |         |
+         v         |
+    +---------+----+----+
+    | Block#3 | Block#4 |
+    +---------+----+----+
+                   |
+                   v
+                {Out#4}
+```
+
+Next, read first block to double buffer's first page. And compress it by `LZ4_compress_continue()`.
+For the first time, LZ4 doesn't know any previous dependencies,
+so it just compress the line without dependencies and generates compressed block {Out#1} to LZ4 compressed data buffer.
+After that, write {Out#1} to the file.
+
+Next, read second block to double buffer's second page. And compress it.
+This time, LZ4 can use dependency to Block#1 to improve compression ratio.
+This dependency is called "Prefix mode".
+
+Next, read third block to double buffer's *first* page, and compress it.
+Also this time, LZ4 can use dependency to Block#2.
+This dependency is called "External Dictonaly mode".
+
+Continue these procedure to the end of the file.
+
+
+## How the decompression works
+
+Decompression will do reverse order.
+
+ - Read first compressed block.
+ - Decompress it to the first page and write that page to the file.
+ - Read second compressed block.
+ - Decompress it to the second page and write that page to the file.
+ - Read third compressed block.
+ - Decompress it to the *first* page and write that page to the file.
+
+Continue these procedure to the end of the compressed file.
diff --git a/lz4/examples/blockStreaming_lineByLine.c b/lz4/examples/blockStreaming_lineByLine.c
new file mode 100644
index 0000000..19c3345
--- /dev/null
+++ b/lz4/examples/blockStreaming_lineByLine.c
@@ -0,0 +1,211 @@
+// LZ4 streaming API example : line-by-line logfile compression
+// by Takayuki Matsuoka
+
+
+#if defined(_MSC_VER) && (_MSC_VER <= 1800)  /* Visual Studio <= 2013 */
+#  define _CRT_SECURE_NO_WARNINGS
+#  define snprintf sprintf_s
+#endif
+#include "lz4.h"
+
+#include 
+#include 
+#include 
+#include 
+
+static size_t write_uint16(FILE* fp, uint16_t i)
+{
+    return fwrite(&i, sizeof(i), 1, fp);
+}
+
+static size_t write_bin(FILE* fp, const void* array, int arrayBytes)
+{
+    return fwrite(array, 1, arrayBytes, fp);
+}
+
+static size_t read_uint16(FILE* fp, uint16_t* i)
+{
+    return fread(i, sizeof(*i), 1, fp);
+}
+
+static size_t read_bin(FILE* fp, void* array, int arrayBytes)
+{
+    return fread(array, 1, arrayBytes, fp);
+}
+
+
+static void test_compress(
+    FILE* outFp,
+    FILE* inpFp,
+    size_t messageMaxBytes,
+    size_t ringBufferBytes)
+{
+    LZ4_stream_t* const lz4Stream = LZ4_createStream();
+    const size_t cmpBufBytes = LZ4_COMPRESSBOUND(messageMaxBytes);
+    char* const cmpBuf = (char*) malloc(cmpBufBytes);
+    char* const inpBuf = (char*) malloc(ringBufferBytes);
+    int inpOffset = 0;
+
+    for ( ; ; )
+    {
+        char* const inpPtr = &inpBuf[inpOffset];
+
+#if 0
+        // Read random length data to the ring buffer.
+        const int randomLength = (rand() % messageMaxBytes) + 1;
+        const int inpBytes = (int) read_bin(inpFp, inpPtr, randomLength);
+        if (0 == inpBytes) break;
+#else
+        // Read line to the ring buffer.
+        int inpBytes = 0;
+        if (!fgets(inpPtr, (int) messageMaxBytes, inpFp))
+            break;
+        inpBytes = (int) strlen(inpPtr);
+#endif
+
+        {
+            const int cmpBytes = LZ4_compress_fast_continue(
+                lz4Stream, inpPtr, cmpBuf, inpBytes, cmpBufBytes, 1);
+            if (cmpBytes <= 0) break;
+            write_uint16(outFp, (uint16_t) cmpBytes);
+            write_bin(outFp, cmpBuf, cmpBytes);
+
+            // Add and wraparound the ringbuffer offset
+            inpOffset += inpBytes;
+            if ((size_t)inpOffset >= ringBufferBytes - messageMaxBytes) inpOffset = 0;
+        }
+    }
+    write_uint16(outFp, 0);
+
+    free(inpBuf);
+    free(cmpBuf);
+    LZ4_freeStream(lz4Stream);
+}
+
+
+static void test_decompress(
+    FILE* outFp,
+    FILE* inpFp,
+    size_t messageMaxBytes,
+    size_t ringBufferBytes)
+{
+    LZ4_streamDecode_t* const lz4StreamDecode = LZ4_createStreamDecode();
+    char* const cmpBuf = (char*) malloc(LZ4_COMPRESSBOUND(messageMaxBytes));
+    char* const decBuf = (char*) malloc(ringBufferBytes);
+    int decOffset = 0;
+
+    for ( ; ; )
+    {
+        uint16_t cmpBytes = 0;
+
+        if (read_uint16(inpFp, &cmpBytes) != 1) break;
+        if (cmpBytes == 0) break;
+        if (read_bin(inpFp, cmpBuf, cmpBytes) != cmpBytes) break;
+
+        {
+            char* const decPtr = &decBuf[decOffset];
+            const int decBytes = LZ4_decompress_safe_continue(
+                lz4StreamDecode, cmpBuf, decPtr, cmpBytes, (int) messageMaxBytes);
+            if (decBytes <= 0) break;
+            write_bin(outFp, decPtr, decBytes);
+
+            // Add and wraparound the ringbuffer offset
+            decOffset += decBytes;
+            if ((size_t)decOffset >= ringBufferBytes - messageMaxBytes) decOffset = 0;
+        }
+    }
+
+    free(decBuf);
+    free(cmpBuf);
+    LZ4_freeStreamDecode(lz4StreamDecode);
+}
+
+
+static int compare(FILE* f0, FILE* f1)
+{
+    int result = 0;
+    const size_t tempBufferBytes = 65536;
+    char* const b0 = (char*) malloc(tempBufferBytes);
+    char* const b1 = (char*) malloc(tempBufferBytes);
+
+    while(0 == result)
+    {
+        const size_t r0 = fread(b0, 1, tempBufferBytes, f0);
+        const size_t r1 = fread(b1, 1, tempBufferBytes, f1);
+
+        result = (int) r0 - (int) r1;
+
+        if (0 == r0 || 0 == r1) break;
+        if (0 == result) result = memcmp(b0, b1, r0);
+    }
+
+    free(b1);
+    free(b0);
+    return result;
+}
+
+
+int main(int argc, char* argv[])
+{
+    enum {
+        MESSAGE_MAX_BYTES   = 1024,
+        RING_BUFFER_BYTES   = 1024 * 256 + MESSAGE_MAX_BYTES,
+    };
+
+    char inpFilename[256] = { 0 };
+    char lz4Filename[256] = { 0 };
+    char decFilename[256] = { 0 };
+
+    if (argc < 2)
+    {
+        printf("Please specify input filename\n");
+        return 0;
+    }
+
+    snprintf(inpFilename, 256, "%s", argv[1]);
+    snprintf(lz4Filename, 256, "%s.lz4s", argv[1]);
+    snprintf(decFilename, 256, "%s.lz4s.dec", argv[1]);
+
+    printf("inp = [%s]\n", inpFilename);
+    printf("lz4 = [%s]\n", lz4Filename);
+    printf("dec = [%s]\n", decFilename);
+
+    // compress
+    {
+        FILE* inpFp = fopen(inpFilename, "rb");
+        FILE* outFp = fopen(lz4Filename, "wb");
+
+        test_compress(outFp, inpFp, MESSAGE_MAX_BYTES, RING_BUFFER_BYTES);
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    // decompress
+    {
+        FILE* inpFp = fopen(lz4Filename, "rb");
+        FILE* outFp = fopen(decFilename, "wb");
+
+        test_decompress(outFp, inpFp, MESSAGE_MAX_BYTES, RING_BUFFER_BYTES);
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    // verify
+    {
+        FILE* inpFp = fopen(inpFilename, "rb");
+        FILE* decFp = fopen(decFilename, "rb");
+
+        const int cmp = compare(inpFp, decFp);
+        if (0 == cmp)
+            printf("Verify : OK\n");
+        else
+            printf("Verify : NG\n");
+
+        fclose(decFp);
+        fclose(inpFp);
+    }
+
+    return 0;
+}
diff --git a/lz4/examples/blockStreaming_lineByLine.md b/lz4/examples/blockStreaming_lineByLine.md
new file mode 100644
index 0000000..4735f92
--- /dev/null
+++ b/lz4/examples/blockStreaming_lineByLine.md
@@ -0,0 +1,122 @@
+# LZ4 Streaming API Example : Line by Line Text Compression
+by *Takayuki Matsuoka*
+
+`blockStreaming_lineByLine.c` is LZ4 Straming API example which implements line by line incremental (de)compression.
+
+Please note the following restrictions :
+
+ - Firstly, read "LZ4 Streaming API Basics".
+ - This is relatively advanced application example.
+ - Output file is not compatible with lz4frame and platform dependent.
+
+
+## What's the point of this example ?
+
+ - Line by line incremental (de)compression.
+ - Handle huge file in small amount of memory
+ - Generally better compression ratio than Block API
+ - Non-uniform block size
+
+
+## How the compression works
+
+First of all, allocate "Ring Buffer" for input and LZ4 compressed data buffer for output.
+
+```
+(1)
+    Ring Buffer
+
+    +--------+
+    | Line#1 |
+    +---+----+
+        |
+        v
+     {Out#1}
+
+
+(2)
+    Prefix Mode Dependency
+          +----+
+          |    |
+          v    |
+    +--------+-+------+
+    | Line#1 | Line#2 |
+    +--------+---+----+
+                 |
+                 v
+              {Out#2}
+
+
+(3)
+          Prefix   Prefix
+          +----+   +----+
+          |    |   |    |
+          v    |   v    |
+    +--------+-+------+-+------+
+    | Line#1 | Line#2 | Line#3 |
+    +--------+--------+---+----+
+                          |
+                          v
+                       {Out#3}
+
+
+(4)
+                        External Dictionary Mode
+                +----+   +----+
+                |    |   |    |
+                v    |   v    |
+    ------+--------+-+------+-+--------+
+          |  ....  | Line#X | Line#X+1 |
+    ------+--------+--------+-----+----+
+                            ^     |
+                            |     v
+                            |  {Out#X+1}
+                            |
+                          Reset
+
+
+(5)
+                                    Prefix
+                                    +-----+
+                                    |     |
+                                    v     |
+    ------+--------+--------+----------+--+-------+
+          |  ....  | Line#X | Line#X+1 | Line#X+2 |
+    ------+--------+--------+----------+-----+----+
+                            ^                |
+                            |                v
+                            |            {Out#X+2}
+                            |
+                          Reset
+```
+
+Next (see (1)), read first line to ringbuffer and compress it by `LZ4_compress_continue()`.
+For the first time, LZ4 doesn't know any previous dependencies,
+so it just compress the line without dependencies and generates compressed line {Out#1} to LZ4 compressed data buffer.
+After that, write {Out#1} to the file and forward ringbuffer offset.
+
+Do the same things to second line (see (2)).
+But in this time, LZ4 can use dependency to Line#1 to improve compression ratio.
+This dependency is called "Prefix mode".
+
+Eventually, we'll reach end of ringbuffer at Line#X (see (4)).
+This time, we should reset ringbuffer offset.
+After resetting, at Line#X+1 pointer is not adjacent, but LZ4 still maintain its memory.
+This is called "External Dictionary Mode".
+
+In Line#X+2 (see (5)), finally LZ4 forget almost all memories but still remains Line#X+1.
+This is the same situation as Line#2.
+
+Continue these procedure to the end of text file.
+
+
+## How the decompression works
+
+Decompression will do reverse order.
+
+ - Read compressed line from the file to buffer.
+ - Decompress it to the ringbuffer.
+ - Output decompressed plain text line to the file.
+ - Forward ringbuffer offset. If offset exceedes end of the ringbuffer, reset it.
+
+Continue these procedure to the end of the compressed file.
diff --git a/lz4/examples/blockStreaming_ringBuffer.c b/lz4/examples/blockStreaming_ringBuffer.c
new file mode 100644
index 0000000..0b6a3ce
--- /dev/null
+++ b/lz4/examples/blockStreaming_ringBuffer.c
@@ -0,0 +1,190 @@
+/* LZ4 streaming API example : ring buffer
+ * Based on sample code from Takayuki Matsuoka */
+
+
+/**************************************
+ * Compiler Options
+ **************************************/
+#if defined(_MSC_VER) && (_MSC_VER <= 1800)  /* Visual Studio <= 2013 */
+#  define _CRT_SECURE_NO_WARNINGS
+#  define snprintf sprintf_s
+#endif
+
+
+/**************************************
+ * Includes
+ **************************************/
+#include 
+#include 
+#include 
+#include 
+#include "lz4.h"
+
+
+enum {
+    MESSAGE_MAX_BYTES   = 1024,
+    RING_BUFFER_BYTES   = 1024 * 8 + MESSAGE_MAX_BYTES,
+    DECODE_RING_BUFFER  = RING_BUFFER_BYTES + MESSAGE_MAX_BYTES   /* Intentionally larger, to test unsynchronized ring buffers */
+};
+
+
+size_t write_int32(FILE* fp, int32_t i) {
+    return fwrite(&i, sizeof(i), 1, fp);
+}
+
+size_t write_bin(FILE* fp, const void* array, int arrayBytes) {
+    return fwrite(array, 1, arrayBytes, fp);
+}
+
+size_t read_int32(FILE* fp, int32_t* i) {
+    return fread(i, sizeof(*i), 1, fp);
+}
+
+size_t read_bin(FILE* fp, void* array, int arrayBytes) {
+    return fread(array, 1, arrayBytes, fp);
+}
+
+
+void test_compress(FILE* outFp, FILE* inpFp)
+{
+    LZ4_stream_t lz4Stream_body = { { 0 } };
+    LZ4_stream_t* lz4Stream = &lz4Stream_body;
+
+    static char inpBuf[RING_BUFFER_BYTES];
+    int inpOffset = 0;
+
+    for(;;) {
+        // Read random length ([1,MESSAGE_MAX_BYTES]) data to the ring buffer.
+        char* const inpPtr = &inpBuf[inpOffset];
+        const int randomLength = (rand() % MESSAGE_MAX_BYTES) + 1;
+        const int inpBytes = (int) read_bin(inpFp, inpPtr, randomLength);
+        if (0 == inpBytes) break;
+
+        {
+#define CMPBUFSIZE (LZ4_COMPRESSBOUND(MESSAGE_MAX_BYTES))
+            char cmpBuf[CMPBUFSIZE];
+            const int cmpBytes = LZ4_compress_fast_continue(lz4Stream, inpPtr, cmpBuf, inpBytes, CMPBUFSIZE, 0);
+            if(cmpBytes <= 0) break;
+            write_int32(outFp, cmpBytes);
+            write_bin(outFp, cmpBuf, cmpBytes);
+
+            inpOffset += inpBytes;
+
+            // Wraparound the ringbuffer offset
+            if(inpOffset >= RING_BUFFER_BYTES - MESSAGE_MAX_BYTES) inpOffset = 0;
+        }
+    }
+
+    write_int32(outFp, 0);
+}
+
+
+void test_decompress(FILE* outFp, FILE* inpFp)
+{
+    static char decBuf[DECODE_RING_BUFFER];
+    int decOffset = 0;
+    LZ4_streamDecode_t lz4StreamDecode_body = { { 0 } };
+    LZ4_streamDecode_t* lz4StreamDecode = &lz4StreamDecode_body;
+
+    for(;;) {
+        int cmpBytes = 0;
+        char cmpBuf[CMPBUFSIZE];
+
+        {   const size_t r0 = read_int32(inpFp, &cmpBytes);
+            if(r0 != 1 || cmpBytes <= 0) break;
+
+            const size_t r1 = read_bin(inpFp, cmpBuf, cmpBytes);
+            if(r1 != (size_t) cmpBytes) break;
+        }
+
+        {   char* const decPtr = &decBuf[decOffset];
+            const int decBytes = LZ4_decompress_safe_continue(
+                lz4StreamDecode, cmpBuf, decPtr, cmpBytes, MESSAGE_MAX_BYTES);
+            if(decBytes <= 0) break;
+            decOffset += decBytes;
+            write_bin(outFp, decPtr, decBytes);
+
+            // Wraparound the ringbuffer offset
+            if(decOffset >= DECODE_RING_BUFFER - MESSAGE_MAX_BYTES) decOffset = 0;
+        }
+    }
+}
+
+
+int compare(FILE* f0, FILE* f1)
+{
+    int result = 0;
+
+    while (0 == result) {
+        char b0[65536];
+        char b1[65536];
+        const size_t r0 = fread(b0, 1, sizeof(b0), f0);
+        const size_t r1 = fread(b1, 1, sizeof(b1), f1);
+
+        result = (int) r0 - (int) r1;
+
+        if (0 == r0 || 0 == r1) break;
+
+        if (0 == result) result = memcmp(b0, b1, r0);
+    }
+
+    return result;
+}
+
+
+int main(int argc, char** argv)
+{
+    char inpFilename[256] = { 0 };
+    char lz4Filename[256] = { 0 };
+    char decFilename[256] = { 0 };
+
+    if (argc < 2) {
+        printf("Please specify input filename\n");
+        return 0;
+    }
+
+    snprintf(inpFilename, 256, "%s", argv[1]);
+    snprintf(lz4Filename, 256, "%s.lz4s-%d", argv[1], 0);
+    snprintf(decFilename, 256, "%s.lz4s-%d.dec", argv[1], 0);
+
+    printf("inp = [%s]\n", inpFilename);
+    printf("lz4 = [%s]\n", lz4Filename);
+    printf("dec = [%s]\n", decFilename);
+
+    // compress
+    {   FILE* const inpFp = fopen(inpFilename, "rb");
+        FILE* const outFp = fopen(lz4Filename, "wb");
+
+        test_compress(outFp, inpFp);
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    // decompress
+    {   FILE* const inpFp = fopen(lz4Filename, "rb");
+        FILE* const outFp = fopen(decFilename, "wb");
+
+        test_decompress(outFp, inpFp);
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    // verify
+    {   FILE* const inpFp = fopen(inpFilename, "rb");
+        FILE* const decFp = fopen(decFilename, "rb");
+
+        const int cmp = compare(inpFp, decFp);
+        if (0 == cmp) {
+            printf("Verify : OK\n");
+        } else {
+            printf("Verify : NG\n");
+        }
+
+        fclose(decFp);
+        fclose(inpFp);
+    }
+
+    return 0;
+}
diff --git a/lz4/examples/compress_functions.c b/lz4/examples/compress_functions.c
new file mode 100644
index 0000000..7fd6775
--- /dev/null
+++ b/lz4/examples/compress_functions.c
@@ -0,0 +1,363 @@
+/*
+ * compress_functions.c
+ * Copyright  : Kyle Harper
+ * License    : Follows same licensing as the lz4.c/lz4.h program at any given time.  Currently, BSD 2.
+ * Description: A program to demonstrate the various compression functions involved in when using LZ4_compress_default().  The idea
+ *              is to show how each step in the call stack can be used directly, if desired.  There is also some benchmarking for
+ *              each function to demonstrate the (probably lack of) performance difference when jumping the stack.
+ *              (If you're new to lz4, please read simple_buffer.c to understand the fundamentals)
+ *
+ *              The call stack (before theoretical compiler optimizations) for LZ4_compress_default is as follows:
+ *                LZ4_compress_default
+ *                  LZ4_compress_fast
+ *                    LZ4_compress_fast_extState
+ *                      LZ4_compress_generic
+ *
+ *              LZ4_compress_default()
+ *                This is the recommended function for compressing data.  It will serve as the baseline for comparison.
+ *              LZ4_compress_fast()
+ *                Despite its name, it's not a "fast" version of compression.  It simply decides if HEAPMODE is set and either
+ *                allocates memory on the heap for a struct or creates the struct directly on the stack.  Stack access is generally
+ *                faster but this function itself isn't giving that advantage, it's just some logic for compile time.
+ *              LZ4_compress_fast_extState()
+ *                This simply accepts all the pointers and values collected thus far and adds logic to determine how
+ *                LZ4_compress_generic should be invoked; specifically: can the source fit into a single pass as determined by
+ *                LZ4_64Klimit.
+ *              LZ4_compress_generic()
+ *                As the name suggests, this is the generic function that ultimately does most of the heavy lifting.  Calling this
+ *                directly can help avoid some test cases and branching which might be useful in some implementation-specific
+ *                situations, but you really need to know what you're doing AND what you're asking lz4 to do!  You also need a
+ *                wrapper function because this function isn't exposed with lz4.h.
+ *
+ *              The call stack for decompression functions is shallow.  There are 2 options:
+ *                LZ4_decompress_safe  ||  LZ4_decompress_fast
+ *                  LZ4_decompress_generic
+ *
+ *               LZ4_decompress_safe
+ *                 This is the recommended function for decompressing data.  It is considered safe because the caller specifies
+ *                 both the size of the compresssed buffer to read as well as the maximum size of the output (decompressed) buffer
+ *                 instead of just the latter.
+ *               LZ4_decompress_fast
+ *                 Again, despite its name it's not a "fast" version of decompression.  It simply frees the caller of sending the
+ *                 size of the compressed buffer (it will simply be read-to-end, hence it's non-safety).
+ *               LZ4_decompress_generic
+ *                 This is the generic function that both of the LZ4_decompress_* functions above end up calling.  Calling this
+ *                 directly is not advised, period.  Furthermore, it is a static inline function in lz4.c, so there isn't a symbol
+ *                 exposed for anyone using lz4.h to utilize.
+ *
+ *               Special Note About Decompression:
+ *               Using the LZ4_decompress_safe() function protects against malicious (user) input.  If you are using data from a
+ *               trusted source, or if your program is the producer (P) as well as its consumer (C) in a PC or MPMC setup, you can
+ *               safely use the LZ4_decompress_fast function
+ */
+
+/* Since lz4 compiles with c99 and not gnu/std99 we need to enable POSIX linking for time.h structs and functions. */
+#if __STDC_VERSION__ >= 199901L
+#define _XOPEN_SOURCE 600
+#else
+#define _XOPEN_SOURCE 500
+#endif
+#define _POSIX_C_SOURCE 199309L
+
+/* Includes, for Power! */
+#define LZ4_DISABLE_DEPRECATE_WARNINGS   /* LZ4_decompress_fast */
+#include "lz4.h"
+#include     /* for printf() */
+#include    /* for exit() */
+#include    /* for atoi() memcmp() */
+#include    /* for uint_types */
+#include  /* for PRIu64 */
+#include      /* for clock_gettime() */
+#include    /* for setlocale() */
+
+/* We need to know what one billion is for clock timing. */
+#define BILLION 1000000000L
+
+/* Create a crude set of test IDs so we can switch on them later  (Can't switch() on a char[] or char*). */
+#define ID__LZ4_COMPRESS_DEFAULT        1
+#define ID__LZ4_COMPRESS_FAST           2
+#define ID__LZ4_COMPRESS_FAST_EXTSTATE  3
+#define ID__LZ4_COMPRESS_GENERIC        4
+#define ID__LZ4_DECOMPRESS_SAFE         5
+#define ID__LZ4_DECOMPRESS_FAST         6
+
+
+
+/*
+ * Easy show-error-and-bail function.
+ */
+void run_screaming(const char *message, const int code) {
+  printf("%s\n", message);
+  exit(code);
+}
+
+
+/*
+ * Centralize the usage function to keep main cleaner.
+ */
+void usage(const char *message) {
+  printf("Usage: ./argPerformanceTesting \n");
+  run_screaming(message, 1);
+  return;
+}
+
+
+
+/*
+ * Runs the benchmark for LZ4_compress_* based on function_id.
+ */
+uint64_t bench(
+    const char *known_good_dst,
+    const int function_id,
+    const int iterations,
+    const char *src,
+    char *dst,
+    const size_t src_size,
+    const size_t max_dst_size,
+    const size_t comp_size
+  ) {
+  uint64_t time_taken = 0;
+  int rv = 0;
+  const int warm_up = 5000;
+  struct timespec start, end;
+  const int acceleration = 1;
+  LZ4_stream_t state;
+
+  // Select the right function to perform the benchmark on.  We perform 5000 initial loops to warm the cache and ensure that dst
+  // remains matching to known_good_dst between successive calls.
+  switch(function_id) {
+    case ID__LZ4_COMPRESS_DEFAULT:
+      printf("Starting benchmark for function: LZ4_compress_default()\n");
+      for(int junk=0; junk 1)
+    iterations = atoi(argv[1]);
+  if (iterations < 1)
+    usage("Argument 1 (iterations) must be > 0.");
+
+  // First we will create 2 sources (char *) of 2000 bytes each.  One normal text, the other highly-compressible text.
+  const char *src    = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed luctus purus et risus vulputate, et mollis orci ullamcorper. Nulla facilisi. Fusce in ligula sed purus varius aliquet interdum vitae justo. Proin quis diam velit. Nulla varius iaculis auctor. Cras volutpat, justo eu dictum pulvinar, elit sem porttitor metus, et imperdiet metus sapien et ante. Nullam nisi nulla, ornare eu tristique eu, dignissim vitae diam. Nulla sagittis porta libero, a accumsan felis sagittis scelerisque.  Integer laoreet eleifend congue. Etiam rhoncus leo vel dolor fermentum, quis luctus nisl iaculis. Praesent a erat sapien. Aliquam semper mi in lorem ultrices ultricies. Lorem ipsum dolor sit amet, consectetur adipiscing elit. In feugiat risus sed enim ultrices, at sodales nulla tristique. Maecenas eget pellentesque justo, sed pellentesque lectus. Fusce sagittis sit amet elit vel varius. Donec sed ligula nec ligula vulputate rutrum sed ut lectus. Etiam congue pharetra leo vitae cursus. Morbi enim ante, porttitor ut varius vel, tincidunt quis justo. Nunc iaculis, risus id ultrices semper, metus est efficitur ligula, vel posuere risus nunc eget purus. Ut lorem turpis, condimentum at sem sed, porta aliquam turpis. In ut sapien a nulla dictum tincidunt quis sit amet lorem. Fusce at est egestas, luctus neque eu, consectetur tortor. Phasellus eleifend ultricies nulla ac lobortis.  Morbi maximus quam cursus vehicula iaculis. Maecenas cursus vel justo ut rutrum. Curabitur magna orci, dignissim eget dapibus vitae, finibus id lacus. Praesent rhoncus mattis augue vitae bibendum. Praesent porta mauris non ultrices fermentum. Quisque vulputate ipsum in sodales pulvinar. Aliquam nec mollis felis. Donec vitae augue pulvinar, congue nisl sed, pretium purus. Fusce lobortis mi ac neque scelerisque semper. Pellentesque vel est vitae magna aliquet aliquet. Nam non dolor. Nulla facilisi. Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos himenaeos. Morbi ac lacinia felis metus.";
+  const char *hc_src = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa";
+  // Set and derive sizes.  Since we're using strings, use strlen() + 1 for \0.
+  const size_t src_size = strlen(src) + 1;
+  const size_t max_dst_size = LZ4_compressBound(src_size);
+  int bytes_returned = 0;
+  // Now build allocations for the data we'll be playing with.
+  char *dst               = calloc(1, max_dst_size);
+  char *known_good_dst    = calloc(1, max_dst_size);
+  char *known_good_hc_dst = calloc(1, max_dst_size);
+  if (dst == NULL || known_good_dst == NULL || known_good_hc_dst == NULL)
+    run_screaming("Couldn't allocate memory for the destination buffers.  Sad :(", 1);
+
+  // Create known-good buffers to verify our tests with other functions will produce the same results.
+  bytes_returned = LZ4_compress_default(src, known_good_dst, src_size, max_dst_size);
+  if (bytes_returned < 1)
+    run_screaming("Couldn't create a known-good destination buffer for comparison... this is bad.", 1);
+  const size_t src_comp_size = bytes_returned;
+  bytes_returned = LZ4_compress_default(hc_src, known_good_hc_dst, src_size, max_dst_size);
+  if (bytes_returned < 1)
+    run_screaming("Couldn't create a known-good (highly compressible) destination buffer for comparison... this is bad.", 1);
+  const size_t hc_src_comp_size = bytes_returned;
+
+
+  /* LZ4_compress_default() */
+  // This is the default function so we don't need to demonstrate how to use it.  See basics.c if you need more basal information.
+
+  /* LZ4_compress_fast() */
+  // Using this function is identical to LZ4_compress_default except we need to specify an "acceleration" value.  Defaults to 1.
+  memset(dst, 0, max_dst_size);
+  bytes_returned = LZ4_compress_fast(src, dst, src_size, max_dst_size, 1);
+  if (bytes_returned < 1)
+    run_screaming("Failed to compress src using LZ4_compress_fast.  echo $? for return code.", bytes_returned);
+  if (memcmp(dst, known_good_dst, bytes_returned) != 0)
+    run_screaming("According to memcmp(), the value we got in dst from LZ4_compress_fast doesn't match the known-good value.  This is bad.", 1);
+
+  /* LZ4_compress_fast_extState() */
+  // Using this function directly requires that we build an LZ4_stream_t struct ourselves.  We do NOT have to reset it ourselves.
+  memset(dst, 0, max_dst_size);
+  LZ4_stream_t state;
+  bytes_returned = LZ4_compress_fast_extState(&state, src, dst, src_size, max_dst_size, 1);
+  if (bytes_returned < 1)
+    run_screaming("Failed to compress src using LZ4_compress_fast_extState.  echo $? for return code.", bytes_returned);
+  if (memcmp(dst, known_good_dst, bytes_returned) != 0)
+    run_screaming("According to memcmp(), the value we got in dst from LZ4_compress_fast_extState doesn't match the known-good value.  This is bad.", 1);
+
+  /* LZ4_compress_generic */
+  // When you can exactly control the inputs and options of your LZ4 needs, you can use LZ4_compress_generic and fixed (const)
+  // values for the enum types such as dictionary and limitations.  Any other direct-use is probably a bad idea.
+  //
+  // That said, the LZ4_compress_generic() function is 'static inline' and does not have a prototype in lz4.h to expose a symbol
+  // for it.  In other words: we can't access it directly.  I don't want to submit a PR that modifies lz4.c/h.  Yann and others can
+  // do that if they feel it's worth expanding this example.
+  //
+  // I will, however, leave a skeleton of what would be required to use it directly:
+  /*
+    memset(dst, 0, max_dst_size);
+    // LZ4_stream_t state:  is already declared above.  We can reuse it BUT we have to reset the stream ourselves between each call.
+    LZ4_resetStream((LZ4_stream_t *)&state);
+    // Since src size is small we know the following enums will be used:  notLimited (0), byU16 (2), noDict (0), noDictIssue (0).
+    bytes_returned = LZ4_compress_generic(&state, src, dst, src_size, max_dst_size, notLimited, byU16, noDict, noDictIssue, 1);
+    if (bytes_returned < 1)
+      run_screaming("Failed to compress src using LZ4_compress_generic.  echo $? for return code.", bytes_returned);
+    if (memcmp(dst, known_good_dst, bytes_returned) != 0)
+      run_screaming("According to memcmp(), the value we got in dst from LZ4_compress_generic doesn't match the known-good value.  This is bad.", 1);
+  */
+
+
+  /* Benchmarking */
+  /* Now we'll run a few rudimentary benchmarks with each function to demonstrate differences in speed based on the function used.
+   * Remember, we cannot call LZ4_compress_generic() directly (yet) so it's disabled.
+   */
+  // Suite A - Normal Compressibility
+  char *dst_d = calloc(1, src_size);
+  memset(dst, 0, max_dst_size);
+  printf("\nStarting suite A:  Normal compressible text.\n");
+  uint64_t time_taken__default       = bench(known_good_dst, ID__LZ4_COMPRESS_DEFAULT,       iterations, src,            dst,   src_size, max_dst_size, src_comp_size);
+  uint64_t time_taken__fast          = bench(known_good_dst, ID__LZ4_COMPRESS_FAST,          iterations, src,            dst,   src_size, max_dst_size, src_comp_size);
+  uint64_t time_taken__fast_extstate = bench(known_good_dst, ID__LZ4_COMPRESS_FAST_EXTSTATE, iterations, src,            dst,   src_size, max_dst_size, src_comp_size);
+  //uint64_t time_taken__generic       = bench(known_good_dst, ID__LZ4_COMPRESS_GENERIC,       iterations, src,            dst,   src_size, max_dst_size, src_comp_size);
+  uint64_t time_taken__decomp_safe   = bench(src,            ID__LZ4_DECOMPRESS_SAFE,        iterations, known_good_dst, dst_d, src_size, max_dst_size, src_comp_size);
+  uint64_t time_taken__decomp_fast   = bench(src,            ID__LZ4_DECOMPRESS_FAST,        iterations, known_good_dst, dst_d, src_size, max_dst_size, src_comp_size);
+  // Suite B - Highly Compressible
+  memset(dst, 0, max_dst_size);
+  printf("\nStarting suite B:  Highly compressible text.\n");
+  uint64_t time_taken_hc__default       = bench(known_good_hc_dst, ID__LZ4_COMPRESS_DEFAULT,       iterations, hc_src,            dst,   src_size, max_dst_size, hc_src_comp_size);
+  uint64_t time_taken_hc__fast          = bench(known_good_hc_dst, ID__LZ4_COMPRESS_FAST,          iterations, hc_src,            dst,   src_size, max_dst_size, hc_src_comp_size);
+  uint64_t time_taken_hc__fast_extstate = bench(known_good_hc_dst, ID__LZ4_COMPRESS_FAST_EXTSTATE, iterations, hc_src,            dst,   src_size, max_dst_size, hc_src_comp_size);
+  //uint64_t time_taken_hc__generic       = bench(known_good_hc_dst, ID__LZ4_COMPRESS_GENERIC,       iterations, hc_src,            dst,   src_size, max_dst_size, hc_src_comp_size);
+  uint64_t time_taken_hc__decomp_safe   = bench(hc_src,            ID__LZ4_DECOMPRESS_SAFE,        iterations, known_good_hc_dst, dst_d, src_size, max_dst_size, hc_src_comp_size);
+  uint64_t time_taken_hc__decomp_fast   = bench(hc_src,            ID__LZ4_DECOMPRESS_FAST,        iterations, known_good_hc_dst, dst_d, src_size, max_dst_size, hc_src_comp_size);
+
+  // Report and leave.
+  setlocale(LC_ALL, "");
+  const char *format        = "|%-14s|%-30s|%'14.9f|%'16d|%'14d|%'13.2f%%|\n";
+  const char *header_format = "|%-14s|%-30s|%14s|%16s|%14s|%14s|\n";
+  const char *separator     = "+--------------+------------------------------+--------------+----------------+--------------+--------------+\n";
+  printf("\n");
+  printf("%s", separator);
+  printf(header_format, "Source", "Function Benchmarked", "Total Seconds", "Iterations/sec", "ns/Iteration", "% of default");
+  printf("%s", separator);
+  printf(format, "Normal Text", "LZ4_compress_default()",       (double)time_taken__default       / BILLION, (int)(iterations / ((double)time_taken__default       /BILLION)), (int)time_taken__default       / iterations, (double)time_taken__default       * 100 / time_taken__default);
+  printf(format, "Normal Text", "LZ4_compress_fast()",          (double)time_taken__fast          / BILLION, (int)(iterations / ((double)time_taken__fast          /BILLION)), (int)time_taken__fast          / iterations, (double)time_taken__fast          * 100 / time_taken__default);
+  printf(format, "Normal Text", "LZ4_compress_fast_extState()", (double)time_taken__fast_extstate / BILLION, (int)(iterations / ((double)time_taken__fast_extstate /BILLION)), (int)time_taken__fast_extstate / iterations, (double)time_taken__fast_extstate * 100 / time_taken__default);
+  //printf(format, "Normal Text", "LZ4_compress_generic()",       (double)time_taken__generic       / BILLION, (int)(iterations / ((double)time_taken__generic       /BILLION)), (int)time_taken__generic       / iterations, (double)time_taken__generic       * 100 / time_taken__default);
+  printf(format, "Normal Text", "LZ4_decompress_safe()",        (double)time_taken__decomp_safe   / BILLION, (int)(iterations / ((double)time_taken__decomp_safe   /BILLION)), (int)time_taken__decomp_safe   / iterations, (double)time_taken__decomp_safe   * 100 / time_taken__default);
+  printf(format, "Normal Text", "LZ4_decompress_fast()",        (double)time_taken__decomp_fast   / BILLION, (int)(iterations / ((double)time_taken__decomp_fast   /BILLION)), (int)time_taken__decomp_fast   / iterations, (double)time_taken__decomp_fast   * 100 / time_taken__default);
+  printf(header_format, "", "", "", "", "", "");
+  printf(format, "Compressible", "LZ4_compress_default()",       (double)time_taken_hc__default       / BILLION, (int)(iterations / ((double)time_taken_hc__default       /BILLION)), (int)time_taken_hc__default       / iterations, (double)time_taken_hc__default       * 100 / time_taken_hc__default);
+  printf(format, "Compressible", "LZ4_compress_fast()",          (double)time_taken_hc__fast          / BILLION, (int)(iterations / ((double)time_taken_hc__fast          /BILLION)), (int)time_taken_hc__fast          / iterations, (double)time_taken_hc__fast          * 100 / time_taken_hc__default);
+  printf(format, "Compressible", "LZ4_compress_fast_extState()", (double)time_taken_hc__fast_extstate / BILLION, (int)(iterations / ((double)time_taken_hc__fast_extstate /BILLION)), (int)time_taken_hc__fast_extstate / iterations, (double)time_taken_hc__fast_extstate * 100 / time_taken_hc__default);
+  //printf(format, "Compressible", "LZ4_compress_generic()",       (double)time_taken_hc__generic       / BILLION, (int)(iterations / ((double)time_taken_hc__generic       /BILLION)), (int)time_taken_hc__generic       / iterations, (double)time_taken_hc__generic       * 100 / time_taken_hc__default);
+  printf(format, "Compressible", "LZ4_decompress_safe()",        (double)time_taken_hc__decomp_safe   / BILLION, (int)(iterations / ((double)time_taken_hc__decomp_safe   /BILLION)), (int)time_taken_hc__decomp_safe   / iterations, (double)time_taken_hc__decomp_safe   * 100 / time_taken_hc__default);
+  printf(format, "Compressible", "LZ4_decompress_fast()",        (double)time_taken_hc__decomp_fast   / BILLION, (int)(iterations / ((double)time_taken_hc__decomp_fast   /BILLION)), (int)time_taken_hc__decomp_fast   / iterations, (double)time_taken_hc__decomp_fast   * 100 / time_taken_hc__default);
+  printf("%s", separator);
+  printf("\n");
+  printf("All done, ran %d iterations per test.\n", iterations);
+  return 0;
+}
diff --git a/lz4/examples/dictionaryRandomAccess.c b/lz4/examples/dictionaryRandomAccess.c
new file mode 100644
index 0000000..ecb3b2d
--- /dev/null
+++ b/lz4/examples/dictionaryRandomAccess.c
@@ -0,0 +1,280 @@
+// LZ4 API example : Dictionary Random Access
+
+#if defined(_MSC_VER) && (_MSC_VER <= 1800)  /* Visual Studio <= 2013 */
+#  define _CRT_SECURE_NO_WARNINGS
+#  define snprintf sprintf_s
+#endif
+#include "lz4.h"
+
+#include 
+#include 
+#include 
+#include 
+
+#define MIN(x, y)  ((x) < (y) ? (x) : (y))
+
+enum {
+    BLOCK_BYTES = 1024,  /* 1 KiB of uncompressed data in a block */
+    DICTIONARY_BYTES = 1024, /* Load a 1 KiB dictionary */
+    MAX_BLOCKS = 1024 /* For simplicity of implementation */
+};
+
+/**
+ * Magic bytes for this test case.
+ * This is not a great magic number because it is a common word in ASCII.
+ * However, it is important to have some versioning system in your format.
+ */
+const char kTestMagic[] = { 'T', 'E', 'S', 'T' };
+
+
+void write_int(FILE* fp, int i) {
+    size_t written = fwrite(&i, sizeof(i), 1, fp);
+    if (written != 1) { exit(10); }
+}
+
+void write_bin(FILE* fp, const void* array, size_t arrayBytes) {
+    size_t written = fwrite(array, 1, arrayBytes, fp);
+    if (written != arrayBytes) { exit(11); }
+}
+
+void read_int(FILE* fp, int* i) {
+    size_t read = fread(i, sizeof(*i), 1, fp);
+    if (read != 1) { exit(12); }
+}
+
+size_t read_bin(FILE* fp, void* array, size_t arrayBytes) {
+    size_t read = fread(array, 1, arrayBytes, fp);
+    if (ferror(fp)) { exit(12); }
+    return read;
+}
+
+void seek_bin(FILE* fp, long offset, int origin) {
+    if (fseek(fp, offset, origin)) { exit(14); }
+}
+
+
+void test_compress(FILE* outFp, FILE* inpFp, void *dict, int dictSize)
+{
+    LZ4_stream_t lz4Stream_body;
+    LZ4_stream_t* lz4Stream = &lz4Stream_body;
+
+    char inpBuf[BLOCK_BYTES];
+    int offsets[MAX_BLOCKS];
+    int *offsetsEnd = offsets;
+
+
+    LZ4_initStream(lz4Stream, sizeof(*lz4Stream));
+
+    /* Write header magic */
+    write_bin(outFp, kTestMagic, sizeof(kTestMagic));
+
+    *offsetsEnd++ = sizeof(kTestMagic);
+    /* Write compressed data blocks.  Each block contains BLOCK_BYTES of plain
+       data except possibly the last. */
+    for(;;) {
+        const int inpBytes = (int) read_bin(inpFp, inpBuf, BLOCK_BYTES);
+        if(0 == inpBytes) {
+            break;
+        }
+
+        /* Forget previously compressed data and load the dictionary */
+        LZ4_loadDict(lz4Stream, dict, dictSize);
+        {
+            char cmpBuf[LZ4_COMPRESSBOUND(BLOCK_BYTES)];
+            const int cmpBytes = LZ4_compress_fast_continue(
+                lz4Stream, inpBuf, cmpBuf, inpBytes, sizeof(cmpBuf), 1);
+            if(cmpBytes <= 0) { exit(1); }
+            write_bin(outFp, cmpBuf, (size_t)cmpBytes);
+            /* Keep track of the offsets */
+            *offsetsEnd = *(offsetsEnd - 1) + cmpBytes;
+            ++offsetsEnd;
+        }
+        if (offsetsEnd - offsets > MAX_BLOCKS) { exit(2); }
+    }
+    /* Write the tailing jump table */
+    {
+        int *ptr = offsets;
+        while (ptr != offsetsEnd) {
+            write_int(outFp, *ptr++);
+        }
+        write_int(outFp, offsetsEnd - offsets);
+    }
+}
+
+
+void test_decompress(FILE* outFp, FILE* inpFp, void *dict, int dictSize, int offset, int length)
+{
+    LZ4_streamDecode_t lz4StreamDecode_body;
+    LZ4_streamDecode_t* lz4StreamDecode = &lz4StreamDecode_body;
+
+    /* The blocks [currentBlock, endBlock) contain the data we want */
+    int currentBlock = offset / BLOCK_BYTES;
+    int endBlock = ((offset + length - 1) / BLOCK_BYTES) + 1;
+
+    char decBuf[BLOCK_BYTES];
+    int offsets[MAX_BLOCKS];
+
+    /* Special cases */
+    if (length == 0) { return; }
+
+    /* Read the magic bytes */
+    {
+        char magic[sizeof(kTestMagic)];
+        size_t read = read_bin(inpFp, magic, sizeof(magic));
+        if (read != sizeof(magic)) { exit(1); }
+        if (memcmp(kTestMagic, magic, sizeof(magic))) { exit(2); }
+    }
+
+    /* Read the offsets tail */
+    {
+        int numOffsets;
+        int block;
+        int *offsetsPtr = offsets;
+        seek_bin(inpFp, -4, SEEK_END);
+        read_int(inpFp, &numOffsets);
+        if (numOffsets <= endBlock) { exit(3); }
+        seek_bin(inpFp, -4 * (numOffsets + 1), SEEK_END);
+        for (block = 0; block <= endBlock; ++block) {
+            read_int(inpFp, offsetsPtr++);
+        }
+    }
+    /* Seek to the first block to read */
+    seek_bin(inpFp, offsets[currentBlock], SEEK_SET);
+    offset = offset % BLOCK_BYTES;
+
+    /* Start decoding */
+    for(; currentBlock < endBlock; ++currentBlock) {
+        char cmpBuf[LZ4_COMPRESSBOUND(BLOCK_BYTES)];
+        /* The difference in offsets is the size of the block */
+        int  cmpBytes = offsets[currentBlock + 1] - offsets[currentBlock];
+        {
+            const size_t read = read_bin(inpFp, cmpBuf, (size_t)cmpBytes);
+            if(read != (size_t)cmpBytes) { exit(4); }
+        }
+
+        /* Load the dictionary */
+        LZ4_setStreamDecode(lz4StreamDecode, dict, dictSize);
+        {
+            const int decBytes = LZ4_decompress_safe_continue(
+                lz4StreamDecode, cmpBuf, decBuf, cmpBytes, BLOCK_BYTES);
+            if(decBytes <= 0) { exit(5); }
+            {
+                /* Write out the part of the data we care about */
+                int blockLength = MIN(length, (decBytes - offset));
+                write_bin(outFp, decBuf + offset, (size_t)blockLength);
+                offset = 0;
+                length -= blockLength;
+            }
+        }
+    }
+}
+
+
+int compare(FILE* fp0, FILE* fp1, int length)
+{
+    int result = 0;
+
+    while(0 == result) {
+        char b0[4096];
+        char b1[4096];
+        const size_t r0 = read_bin(fp0, b0, MIN(length, (int)sizeof(b0)));
+        const size_t r1 = read_bin(fp1, b1, MIN(length, (int)sizeof(b1)));
+
+        result = (int) r0 - (int) r1;
+
+        if(0 == r0 || 0 == r1) {
+            break;
+        }
+        if(0 == result) {
+            result = memcmp(b0, b1, r0);
+        }
+        length -= r0;
+    }
+
+    return result;
+}
+
+
+int main(int argc, char* argv[])
+{
+    char inpFilename[256] = { 0 };
+    char lz4Filename[256] = { 0 };
+    char decFilename[256] = { 0 };
+    char dictFilename[256] = { 0 };
+    int offset;
+    int length;
+    char dict[DICTIONARY_BYTES];
+    int dictSize;
+
+    if(argc < 5) {
+        printf("Usage: %s input dictionary offset length", argv[0]);
+        return 0;
+    }
+
+    snprintf(inpFilename, 256, "%s", argv[1]);
+    snprintf(lz4Filename, 256, "%s.lz4s-%d", argv[1], BLOCK_BYTES);
+    snprintf(decFilename, 256, "%s.lz4s-%d.dec", argv[1], BLOCK_BYTES);
+    snprintf(dictFilename, 256, "%s", argv[2]);
+    offset = atoi(argv[3]);
+    length = atoi(argv[4]);
+
+    printf("inp    = [%s]\n", inpFilename);
+    printf("lz4    = [%s]\n", lz4Filename);
+    printf("dec    = [%s]\n", decFilename);
+    printf("dict   = [%s]\n", dictFilename);
+    printf("offset = [%d]\n", offset);
+    printf("length = [%d]\n", length);
+
+    /* Load dictionary */
+    {
+        FILE* dictFp = fopen(dictFilename, "rb");
+        dictSize = (int)read_bin(dictFp, dict, DICTIONARY_BYTES);
+        fclose(dictFp);
+    }
+
+    /* compress */
+    {
+        FILE* inpFp = fopen(inpFilename, "rb");
+        FILE* outFp = fopen(lz4Filename, "wb");
+
+        printf("compress : %s -> %s\n", inpFilename, lz4Filename);
+        test_compress(outFp, inpFp, dict, dictSize);
+        printf("compress : done\n");
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    /* decompress */
+    {
+        FILE* inpFp = fopen(lz4Filename, "rb");
+        FILE* outFp = fopen(decFilename, "wb");
+
+        printf("decompress : %s -> %s\n", lz4Filename, decFilename);
+        test_decompress(outFp, inpFp, dict, DICTIONARY_BYTES, offset, length);
+        printf("decompress : done\n");
+
+        fclose(outFp);
+        fclose(inpFp);
+    }
+
+    /* verify */
+    {
+        FILE* inpFp = fopen(inpFilename, "rb");
+        FILE* decFp = fopen(decFilename, "rb");
+        seek_bin(inpFp, offset, SEEK_SET);
+
+        printf("verify : %s <-> %s\n", inpFilename, decFilename);
+        const int cmp = compare(inpFp, decFp, length);
+        if(0 == cmp) {
+            printf("verify : OK\n");
+        } else {
+            printf("verify : NG\n");
+        }
+
+        fclose(decFp);
+        fclose(inpFp);
+    }
+
+    return 0;
+}
diff --git a/lz4/examples/dictionaryRandomAccess.md b/lz4/examples/dictionaryRandomAccess.md
new file mode 100644
index 0000000..53d825d
--- /dev/null
+++ b/lz4/examples/dictionaryRandomAccess.md
@@ -0,0 +1,67 @@
+# LZ4 API Example : Dictionary Random Access
+
+`dictionaryRandomAccess.c` is LZ4 API example which implements dictionary compression and random access decompression.
+
+Please note that the output file is not compatible with lz4frame and is platform dependent.
+
+
+## What's the point of this example ?
+
+ - Dictionary based compression for homogenous files.
+ - Random access to compressed blocks.
+
+
+## How the compression works
+
+Reads the dictionary from a file, and uses it as the history for each block.
+This allows each block to be independent, but maintains compression ratio.
+
+```
+    Dictionary
+         +
+         |
+         v
+    +---------+
+    | Block#1 |
+    +----+----+
+         |
+         v
+      {Out#1}
+
+
+    Dictionary
+         +
+         |
+         v
+    +---------+
+    | Block#2 |
+    +----+----+
+         |
+         v
+      {Out#2}
+```
+
+After writing the magic bytes `TEST` and then the compressed blocks, write out the jump table.
+The last 4 bytes is an integer containing the number of blocks in the stream.
+If there are `N` blocks, then just before the last 4 bytes is `N + 1` 4 byte integers containing the offsets at the beginning and end of each block.
+Let `Offset#K` be the total number of bytes written after writing out `Block#K` *including* the magic bytes for simplicity.
+
+```
++------+---------+     +---------+---+----------+     +----------+-----+
+| TEST | Block#1 | ... | Block#N | 4 | Offset#1 | ... | Offset#N | N+1 |
++------+---------+     +---------+---+----------+     +----------+-----+
+```
+
+## How the decompression works
+
+Decompression will do reverse order.
+
+ - Seek to the last 4 bytes of the file and read the number of offsets.
+ - Read each offset into an array.
+ - Seek to the first block containing data we want to read.
+   We know where to look because we know each block contains a fixed amount of uncompressed data, except possibly the last.
+ - Decompress it and write what data we need from it to the file.
+ - Read the next block.
+ - Decompress it and write that page to the file.
+
+Continue these procedure until all the required data has been read.
diff --git a/lz4/examples/frameCompress.c b/lz4/examples/frameCompress.c
new file mode 100644
index 0000000..aac4a3b
--- /dev/null
+++ b/lz4/examples/frameCompress.c
@@ -0,0 +1,401 @@
+/* LZ4frame API example : compress a file
+ * Modified from an example code by Zbigniew Jędrzejewski-Szmek
+ *
+ * This example streams an input file into an output file
+ * using a bounded memory budget.
+ * Input is read in chunks of IN_CHUNK_SIZE */
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+#include 
+
+
+#define IN_CHUNK_SIZE  (16*1024)
+
+static const LZ4F_preferences_t kPrefs = {
+    { LZ4F_max256KB, LZ4F_blockLinked, LZ4F_noContentChecksum, LZ4F_frame,
+      0 /* unknown content size */, 0 /* no dictID */ , LZ4F_noBlockChecksum },
+    0,   /* compression level; 0 == default */
+    0,   /* autoflush */
+    0,   /* favor decompression speed */
+    { 0, 0, 0 },  /* reserved, must be set to 0 */
+};
+
+
+/* safe_fwrite() :
+ * performs fwrite(), ensure operation success, or immediately exit() */
+static void safe_fwrite(void* buf, size_t eltSize, size_t nbElt, FILE* f)
+{
+    size_t const writtenSize = fwrite(buf, eltSize, nbElt, f);
+    size_t const expectedSize = eltSize * nbElt;
+    if (nbElt>0) assert(expectedSize / nbElt == eltSize);  /* check overflow */
+    if (writtenSize < expectedSize) {
+        if (ferror(f))  /* note : ferror() must follow fwrite */
+            fprintf(stderr, "Write failed \n");
+        else
+            fprintf(stderr, "Write too short \n");
+        exit(1);
+    }
+}
+
+
+/* ================================================= */
+/*     Streaming Compression example               */
+/* ================================================= */
+
+typedef struct {
+    int error;
+    unsigned long long size_in;
+    unsigned long long size_out;
+} compressResult_t;
+
+static compressResult_t
+compress_file_internal(FILE* f_in, FILE* f_out,
+                       LZ4F_compressionContext_t ctx,
+                       void* inBuff,  size_t inChunkSize,
+                       void* outBuff, size_t outCapacity)
+{
+    compressResult_t result = { 1, 0, 0 };  /* result for an error */
+    unsigned long long count_in = 0, count_out;
+
+    assert(f_in != NULL); assert(f_out != NULL);
+    assert(ctx != NULL);
+    assert(outCapacity >= LZ4F_HEADER_SIZE_MAX);
+    assert(outCapacity >= LZ4F_compressBound(inChunkSize, &kPrefs));
+
+    /* write frame header */
+    {   size_t const headerSize = LZ4F_compressBegin(ctx, outBuff, outCapacity, &kPrefs);
+        if (LZ4F_isError(headerSize)) {
+            printf("Failed to start compression: error %u \n", (unsigned)headerSize);
+            return result;
+        }
+        count_out = headerSize;
+        printf("Buffer size is %u bytes, header size %u bytes \n",
+                (unsigned)outCapacity, (unsigned)headerSize);
+        safe_fwrite(outBuff, 1, headerSize, f_out);
+    }
+
+    /* stream file */
+    for (;;) {
+        size_t const readSize = fread(inBuff, 1, IN_CHUNK_SIZE, f_in);
+        if (readSize == 0) break; /* nothing left to read from input file */
+        count_in += readSize;
+
+        size_t const compressedSize = LZ4F_compressUpdate(ctx,
+                                                outBuff, outCapacity,
+                                                inBuff, readSize,
+                                                NULL);
+        if (LZ4F_isError(compressedSize)) {
+            printf("Compression failed: error %u \n", (unsigned)compressedSize);
+            return result;
+        }
+
+        printf("Writing %u bytes\n", (unsigned)compressedSize);
+        safe_fwrite(outBuff, 1, compressedSize, f_out);
+        count_out += compressedSize;
+    }
+
+    /* flush whatever remains within internal buffers */
+    {   size_t const compressedSize = LZ4F_compressEnd(ctx,
+                                                outBuff, outCapacity,
+                                                NULL);
+        if (LZ4F_isError(compressedSize)) {
+            printf("Failed to end compression: error %u \n", (unsigned)compressedSize);
+            return result;
+        }
+
+        printf("Writing %u bytes \n", (unsigned)compressedSize);
+        safe_fwrite(outBuff, 1, compressedSize, f_out);
+        count_out += compressedSize;
+    }
+
+    result.size_in = count_in;
+    result.size_out = count_out;
+    result.error = 0;
+    return result;
+}
+
+static compressResult_t
+compress_file(FILE* f_in, FILE* f_out)
+{
+    assert(f_in != NULL);
+    assert(f_out != NULL);
+
+    /* ressource allocation */
+    LZ4F_compressionContext_t ctx;
+    size_t const ctxCreation = LZ4F_createCompressionContext(&ctx, LZ4F_VERSION);
+    void* const src = malloc(IN_CHUNK_SIZE);
+    size_t const outbufCapacity = LZ4F_compressBound(IN_CHUNK_SIZE, &kPrefs);   /* large enough for any input <= IN_CHUNK_SIZE */
+    void* const outbuff = malloc(outbufCapacity);
+
+    compressResult_t result = { 1, 0, 0 };  /* == error (default) */
+    if (!LZ4F_isError(ctxCreation) && src && outbuff) {
+        result = compress_file_internal(f_in, f_out,
+                                        ctx,
+                                        src, IN_CHUNK_SIZE,
+                                        outbuff, outbufCapacity);
+    } else {
+        printf("error : ressource allocation failed \n");
+    }
+
+    LZ4F_freeCompressionContext(ctx);   /* supports free on NULL */
+    free(src);
+    free(outbuff);
+    return result;
+}
+
+
+/* ================================================= */
+/*     Streaming decompression example               */
+/* ================================================= */
+
+static size_t get_block_size(const LZ4F_frameInfo_t* info) {
+    switch (info->blockSizeID) {
+        case LZ4F_default:
+        case LZ4F_max64KB:  return 1 << 16;
+        case LZ4F_max256KB: return 1 << 18;
+        case LZ4F_max1MB:   return 1 << 20;
+        case LZ4F_max4MB:   return 1 << 22;
+        default:
+            printf("Impossible with expected frame specification (<=v1.6.1)\n");
+            exit(1);
+    }
+}
+
+/* @return : 1==error, 0==success */
+static int
+decompress_file_internal(FILE* f_in, FILE* f_out,
+                         LZ4F_dctx* dctx,
+                         void* src, size_t srcCapacity, size_t filled, size_t alreadyConsumed,
+                         void* dst, size_t dstCapacity)
+{
+    int firstChunk = 1;
+    size_t ret = 1;
+
+    assert(f_in != NULL); assert(f_out != NULL);
+    assert(dctx != NULL);
+    assert(src != NULL); assert(srcCapacity > 0); assert(filled <= srcCapacity); assert(alreadyConsumed <= filled);
+    assert(dst != NULL); assert(dstCapacity > 0);
+
+    /* Decompression */
+    while (ret != 0) {
+        /* Load more input */
+        size_t readSize = firstChunk ? filled : fread(src, 1, srcCapacity, f_in); firstChunk=0;
+        const void* srcPtr = (const char*)src + alreadyConsumed; alreadyConsumed=0;
+        const void* const srcEnd = (const char*)srcPtr + readSize;
+        if (readSize == 0 || ferror(f_in)) {
+            printf("Decompress: not enough input or error reading file\n");
+            return 1;
+        }
+
+        /* Decompress:
+         * Continue while there is more input to read (srcPtr != srcEnd)
+         * and the frame isn't over (ret != 0)
+         */
+        while (srcPtr < srcEnd && ret != 0) {
+            /* Any data within dst has been flushed at this stage */
+            size_t dstSize = dstCapacity;
+            size_t srcSize = (const char*)srcEnd - (const char*)srcPtr;
+            ret = LZ4F_decompress(dctx, dst, &dstSize, srcPtr, &srcSize, /* LZ4F_decompressOptions_t */ NULL);
+            if (LZ4F_isError(ret)) {
+                printf("Decompression error: %s\n", LZ4F_getErrorName(ret));
+                return 1;
+            }
+            /* Flush output */
+            if (dstSize != 0) safe_fwrite(dst, 1, dstSize, f_out);
+            /* Update input */
+            srcPtr = (const char*)srcPtr + srcSize;
+        }
+
+        assert(srcPtr <= srcEnd);
+
+        /* Ensure all input data has been consumed.
+         * It is valid to have multiple frames in the same file,
+         * but this example only supports one frame.
+         */
+        if (srcPtr < srcEnd) {
+            printf("Decompress: Trailing data left in file after frame\n");
+            return 1;
+        }
+    }
+
+    /* Check that there isn't trailing data in the file after the frame.
+     * It is valid to have multiple frames in the same file,
+     * but this example only supports one frame.
+     */
+    {   size_t const readSize = fread(src, 1, 1, f_in);
+        if (readSize != 0 || !feof(f_in)) {
+            printf("Decompress: Trailing data left in file after frame\n");
+            return 1;
+    }   }
+
+    return 0;
+}
+
+
+/* @return : 1==error, 0==completed */
+static int
+decompress_file_allocDst(FILE* f_in, FILE* f_out,
+                        LZ4F_dctx* dctx,
+                        void* src, size_t srcCapacity)
+{
+    assert(f_in != NULL); assert(f_out != NULL);
+    assert(dctx != NULL);
+    assert(src != NULL);
+    assert(srcCapacity >= LZ4F_HEADER_SIZE_MAX);  /* ensure LZ4F_getFrameInfo() can read enough data */
+
+    /* Read Frame header */
+    size_t const readSize = fread(src, 1, srcCapacity, f_in);
+    if (readSize == 0 || ferror(f_in)) {
+        printf("Decompress: not enough input or error reading file\n");
+        return 1;
+    }
+
+    LZ4F_frameInfo_t info;
+    size_t consumedSize = readSize;
+    {   size_t const fires = LZ4F_getFrameInfo(dctx, &info, src, &consumedSize);
+        if (LZ4F_isError(fires)) {
+            printf("LZ4F_getFrameInfo error: %s\n", LZ4F_getErrorName(fires));
+            return 1;
+    }   }
+
+    /* Allocating enough space for an entire block isn't necessary for
+     * correctness, but it allows some memcpy's to be elided.
+     */
+    size_t const dstCapacity = get_block_size(&info);
+    void* const dst = malloc(dstCapacity);
+    if (!dst) { perror("decompress_file(dst)"); return 1; }
+
+    int const decompressionResult = decompress_file_internal(
+                        f_in, f_out,
+                        dctx,
+                        src, srcCapacity, readSize-consumedSize, consumedSize,
+                        dst, dstCapacity);
+
+    free(dst);
+    return decompressionResult;
+}
+
+
+/* @result : 1==error, 0==success */
+static int decompress_file(FILE* f_in, FILE* f_out)
+{
+    assert(f_in != NULL); assert(f_out != NULL);
+
+    /* Ressource allocation */
+    void* const src = malloc(IN_CHUNK_SIZE);
+    if (!src) { perror("decompress_file(src)"); return 1; }
+
+    LZ4F_dctx* dctx;
+    {   size_t const dctxStatus = LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION);
+        if (LZ4F_isError(dctxStatus)) {
+            printf("LZ4F_dctx creation error: %s\n", LZ4F_getErrorName(dctxStatus));
+    }   }
+
+    int const result = !dctx ? 1 /* error */ :
+                       decompress_file_allocDst(f_in, f_out, dctx, src, IN_CHUNK_SIZE);
+
+    free(src);
+    LZ4F_freeDecompressionContext(dctx);   /* note : free works on NULL */
+    return result;
+}
+
+
+int compareFiles(FILE* fp0, FILE* fp1)
+{
+    int result = 0;
+
+    while (result==0) {
+        char b0[1024];
+        char b1[1024];
+        size_t const r0 = fread(b0, 1, sizeof(b0), fp0);
+        size_t const r1 = fread(b1, 1, sizeof(b1), fp1);
+
+        result = (r0 != r1);
+        if (!r0 || !r1) break;
+        if (!result) result = memcmp(b0, b1, r0);
+    }
+
+    return result;
+}
+
+
+int main(int argc, const char **argv) {
+    char inpFilename[256] = { 0 };
+    char lz4Filename[256] = { 0 };
+    char decFilename[256] = { 0 };
+
+    if (argc < 2) {
+        printf("Please specify input filename\n");
+        return 0;
+    }
+
+    snprintf(inpFilename, 256, "%s", argv[1]);
+    snprintf(lz4Filename, 256, "%s.lz4", argv[1]);
+    snprintf(decFilename, 256, "%s.lz4.dec", argv[1]);
+
+    printf("inp = [%s]\n", inpFilename);
+    printf("lz4 = [%s]\n", lz4Filename);
+    printf("dec = [%s]\n", decFilename);
+
+    /* compress */
+    {   FILE* const inpFp = fopen(inpFilename, "rb");
+        FILE* const outFp = fopen(lz4Filename, "wb");
+
+        printf("compress : %s -> %s\n", inpFilename, lz4Filename);
+        compressResult_t const ret = compress_file(inpFp, outFp);
+
+        fclose(outFp);
+        fclose(inpFp);
+
+        if (ret.error) {
+            printf("compress : failed with code %i\n", ret.error);
+            return ret.error;
+        }
+        printf("%s: %zu → %zu bytes, %.1f%%\n",
+            inpFilename,
+            (size_t)ret.size_in, (size_t)ret.size_out,  /* might overflow is size_t is 32 bits and size_{in,out} > 4 GB */
+            (double)ret.size_out / ret.size_in * 100);
+        printf("compress : done\n");
+    }
+
+    /* decompress */
+    {   FILE* const inpFp = fopen(lz4Filename, "rb");
+        FILE* const outFp = fopen(decFilename, "wb");
+
+        printf("decompress : %s -> %s\n", lz4Filename, decFilename);
+        int const ret = decompress_file(inpFp, outFp);
+
+        fclose(outFp);
+        fclose(inpFp);
+
+        if (ret) {
+            printf("decompress : failed with code %i\n", ret);
+            return ret;
+        }
+        printf("decompress : done\n");
+    }
+
+    /* verify */
+    {   FILE* const inpFp = fopen(inpFilename, "rb");
+        FILE* const decFp = fopen(decFilename, "rb");
+
+        printf("verify : %s <-> %s\n", inpFilename, decFilename);
+        int const cmp = compareFiles(inpFp, decFp);
+
+        fclose(decFp);
+        fclose(inpFp);
+
+        if (cmp) {
+            printf("corruption detected : decompressed file differs from original\n");
+            return cmp;
+        }
+        printf("verify : OK\n");
+    }
+
+    return 0;
+}
diff --git a/lz4/examples/printVersion.c b/lz4/examples/printVersion.c
new file mode 100644
index 0000000..7af318a
--- /dev/null
+++ b/lz4/examples/printVersion.c
@@ -0,0 +1,13 @@
+// LZ4 trivial example : print Library version number
+// by Takayuki Matsuoka
+
+
+#include 
+#include "lz4.h"
+
+int main(int argc, char** argv)
+{
+	(void)argc; (void)argv;
+    printf("Hello World ! LZ4 Library version = %d\n", LZ4_versionNumber());
+    return 0;
+}
diff --git a/lz4/examples/simple_buffer.c b/lz4/examples/simple_buffer.c
new file mode 100644
index 0000000..6afc62a
--- /dev/null
+++ b/lz4/examples/simple_buffer.c
@@ -0,0 +1,99 @@
+/*
+ * simple_buffer.c
+ * Copyright  : Kyle Harper
+ * License    : Follows same licensing as the lz4.c/lz4.h program at any given time.  Currently, BSD 2.
+ * Description: Example program to demonstrate the basic usage of the compress/decompress functions within lz4.c/lz4.h.
+ *              The functions you'll likely want are LZ4_compress_default and LZ4_decompress_safe.
+ *              Both of these are documented in the lz4.h header file; I recommend reading them.
+ */
+
+/* Dependencies */
+#include    // For printf()
+#include   // For memcmp()
+#include   // For exit()
+#include "lz4.h"     // This is all that is required to expose the prototypes for basic compression and decompression.
+
+/*
+ * Simple show-error-and-bail function.
+ */
+void run_screaming(const char* message, const int code) {
+  printf("%s \n", message);
+  exit(code);
+}
+
+
+/*
+ * main
+ */
+int main(void) {
+  /* Introduction */
+  // Below we will have a Compression and Decompression section to demonstrate.
+  // There are a few important notes before we start:
+  //   1) The return codes of LZ4_ functions are important.
+  //      Read lz4.h if you're unsure what a given code means.
+  //   2) LZ4 uses char* pointers in all LZ4_ functions.
+  //      This is baked into the API and not going to change, for consistency.
+  //      If your program uses different pointer types,
+  //      you may need to do some casting or set the right -Wno compiler flags to ignore those warnings (e.g.: -Wno-pointer-sign).
+
+  /* Compression */
+  // We'll store some text into a variable pointed to by *src to be compressed later.
+  const char* const src = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Lorem ipsum dolor site amat.";
+  // The compression function needs to know how many bytes exist.  Since we're using a string, we can use strlen() + 1 (for \0).
+  const int src_size = (int)(strlen(src) + 1);
+  // LZ4 provides a function that will tell you the maximum size of compressed output based on input data via LZ4_compressBound().
+  const int max_dst_size = LZ4_compressBound(src_size);
+  // We will use that size for our destination boundary when allocating space.
+  char* compressed_data = malloc((size_t)max_dst_size);
+  if (compressed_data == NULL)
+    run_screaming("Failed to allocate memory for *compressed_data.", 1);
+  // That's all the information and preparation LZ4 needs to compress *src into *compressed_data.
+  // Invoke LZ4_compress_default now with our size values and pointers to our memory locations.
+  // Save the return value for error checking.
+  const int compressed_data_size = LZ4_compress_default(src, compressed_data, src_size, max_dst_size);
+  // Check return_value to determine what happened.
+  if (compressed_data_size <= 0)
+    run_screaming("A 0 or negative result from LZ4_compress_default() indicates a failure trying to compress the data. ", 1);
+  if (compressed_data_size > 0)
+    printf("We successfully compressed some data! Ratio: %.2f\n",
+        (float) compressed_data_size/src_size);
+  // Not only does a positive return_value mean success, the value returned == the number of bytes required.
+  // You can use this to realloc() *compress_data to free up memory, if desired.  We'll do so just to demonstrate the concept.
+  compressed_data = (char *)realloc(compressed_data, (size_t)compressed_data_size);
+  if (compressed_data == NULL)
+    run_screaming("Failed to re-alloc memory for compressed_data.  Sad :(", 1);
+
+
+  /* Decompression */
+  // Now that we've successfully compressed the information from *src to *compressed_data, let's do the opposite!
+  // The decompression will need to know the compressed size, and an upper bound of the decompressed size.
+  // In this example, we just re-use this information from previous section,
+  // but in a real-world scenario, metadata must be transmitted to the decompression side.
+  // Each implementation is in charge of this part. Oftentimes, it adds some header of its own.
+  // Sometimes, the metadata can be extracted from the local context.
+
+  // First, let's create a *new_src location of size src_size since we know that value.
+  char* const regen_buffer = malloc(src_size);
+  if (regen_buffer == NULL)
+    run_screaming("Failed to allocate memory for *regen_buffer.", 1);
+  // The LZ4_decompress_safe function needs to know where the compressed data is, how many bytes long it is,
+  // where the regen_buffer memory location is, and how large regen_buffer (uncompressed) output will be.
+  // Again, save the return_value.
+  const int decompressed_size = LZ4_decompress_safe(compressed_data, regen_buffer, compressed_data_size, src_size);
+  free(compressed_data);   /* no longer useful */
+  if (decompressed_size < 0)
+    run_screaming("A negative result from LZ4_decompress_safe indicates a failure trying to decompress the data.  See exit code (echo $?) for value returned.", decompressed_size);
+  if (decompressed_size >= 0)
+    printf("We successfully decompressed some data!\n");
+  // Not only does a positive return value mean success,
+  // value returned == number of bytes regenerated from compressed_data stream.
+  if (decompressed_size != src_size)
+    run_screaming("Decompressed data is different from original! \n", 1);
+
+  /* Validation */
+  // We should be able to compare our original *src with our *new_src and be byte-for-byte identical.
+  if (memcmp(src, regen_buffer, src_size) != 0)
+    run_screaming("Validation failed.  *src and *new_src are not identical.", 1);
+  printf("Validation done. The string we ended up with is:\n%s\n", regen_buffer);
+  return 0;
+}
diff --git a/lz4/examples/streaming_api_basics.md b/lz4/examples/streaming_api_basics.md
new file mode 100644
index 0000000..1ccc6e3
--- /dev/null
+++ b/lz4/examples/streaming_api_basics.md
@@ -0,0 +1,87 @@
+# LZ4 Streaming API Basics
+by *Takayuki Matsuoka*
+## LZ4 API sets
+
+LZ4 has the following API sets :
+
+ - "Auto Framing" API (lz4frame.h) :
+   This is most recommended API for usual application.
+   It guarantees interoperability with other LZ4 framing format compliant tools/libraries
+   such as LZ4 command line utility, node-lz4, etc.
+ - "Block" API : This is recommended for simple purpose.
+   It compress single raw memory block to LZ4 memory block and vice versa.
+ - "Streaming" API : This is designed for complex things.
+   For example, compress huge stream data in restricted memory environment.
+
+Basically, you should use "Auto Framing" API.
+But if you want to write advanced application, it's time to use Block or Streaming APIs.
+
+
+## What is difference between Block and Streaming API ?
+
+Block API (de)compresses a single contiguous memory block.
+In other words, LZ4 library finds redundancy from a single contiguous memory block.
+Streaming API does same thing but (de)compresses multiple adjacent contiguous memory blocks.
+So LZ4 library could find more redundancy than Block API.
+
+The following figure shows difference between API and block sizes.
+In these figures, the original data is split into 4KiBytes contiguous chunks.
+
+```
+Original Data
+    +---------------+---------------+----+----+----+
+    | 4KiB Chunk A  | 4KiB Chunk B  | C  | D  |... |
+    +---------------+---------------+----+----+----+
+
+Example (1) : Block API, 4KiB Block
+    +---------------+---------------+----+----+----+
+    | 4KiB Chunk A  | 4KiB Chunk B  | C  | D  |... |
+    +---------------+---------------+----+----+----+
+    | Block #1      | Block #2      | #3 | #4 |... |
+    +---------------+---------------+----+----+----+
+
+                    (No Dependency)
+
+
+Example (2) : Block API, 8KiB Block
+    +---------------+---------------+----+----+----+
+    | 4KiB Chunk A  | 4KiB Chunk B  | C  | D  |... |
+    +---------------+---------------+----+----+----+
+    |            Block #1           |Block #2 |... |
+    +--------------------+----------+-------+-+----+
+          ^              |             ^    |
+          |              |             |    |
+          +--------------+             +----+
+          Internal Dependency          Internal Dependency
+
+
+Example (3) : Streaming API, 4KiB Block
+    +---------------+---------------+-----+----+----+
+    | 4KiB Chunk A  | 4KiB Chunk B  | C   | D  |... |
+    +---------------+---------------+-----+----+----+
+    | Block #1      | Block #2      | #3  | #4 |... |
+    +---------------+----+----------+-+---+-+--+----+
+          ^              |   ^        | ^   |
+          |              |   |        | |   |
+          +--------------+   +--------+ +---+
+          Dependency         Dependency Dependency
+```
+
+ - In example (1), there is no dependency.
+   All blocks are compressed independently.
+ - In example (2), naturally 8KiBytes block has internal dependency.
+   But still block #1 and #2 are compressed independently.
+ - In example (3), block #2 has dependency to #1,
+   also #3 has dependency to #2 and #1, #4 has #3, #2 and #1, and so on.
+
+Here, we can observe difference between example (2) and (3).
+In (2), there's no dependency between chunk B and C, but (3) has dependency between B and C.
+This dependency improves compression ratio.
+
+
+## Restriction of Streaming API
+
+For efficiency, Streaming API doesn't keep a mirror copy of dependent (de)compressed memory.
+This means users should keep these dependent (de)compressed memory explicitly.
+Usually, "Dependent memory" is previous adjacent contiguous memory up to 64KiBytes.
+LZ4 will not access further memories.
diff --git a/lz4/lib/.gitignore b/lz4/lib/.gitignore
new file mode 100644
index 0000000..5d6f134
--- /dev/null
+++ b/lz4/lib/.gitignore
@@ -0,0 +1,2 @@
+# make install artefact
+liblz4.pc
diff --git a/lz4/lib/LICENSE b/lz4/lib/LICENSE
new file mode 100644
index 0000000..74c2cdd
--- /dev/null
+++ b/lz4/lib/LICENSE
@@ -0,0 +1,24 @@
+LZ4 Library
+Copyright (c) 2011-2016, Yann Collet
+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.
+
+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 HOLDER 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.
diff --git a/lz4/lib/Makefile b/lz4/lib/Makefile
new file mode 100644
index 0000000..c12949b
--- /dev/null
+++ b/lz4/lib/Makefile
@@ -0,0 +1,217 @@
+# ################################################################
+# LZ4 library - Makefile
+# Copyright (C) Yann Collet 2011-2016
+# All rights reserved.
+#
+# This Makefile is validated for Linux, macOS, *BSD, Hurd, Solaris, MSYS2 targets
+#
+# BSD license
+# 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.
+#
+# 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 HOLDER 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.
+#
+# You can contact the author at :
+#  - LZ4 source repository : https://github.com/lz4/lz4
+#  - LZ4 forum froup : https://groups.google.com/forum/#!forum/lz4c
+# ################################################################
+
+# Version numbers
+LIBVER_MAJOR_SCRIPT:=`sed -n '/define LZ4_VERSION_MAJOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < ./lz4.h`
+LIBVER_MINOR_SCRIPT:=`sed -n '/define LZ4_VERSION_MINOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < ./lz4.h`
+LIBVER_PATCH_SCRIPT:=`sed -n '/define LZ4_VERSION_RELEASE/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < ./lz4.h`
+LIBVER_SCRIPT:= $(LIBVER_MAJOR_SCRIPT).$(LIBVER_MINOR_SCRIPT).$(LIBVER_PATCH_SCRIPT)
+LIBVER_MAJOR := $(shell echo $(LIBVER_MAJOR_SCRIPT))
+LIBVER_MINOR := $(shell echo $(LIBVER_MINOR_SCRIPT))
+LIBVER_PATCH := $(shell echo $(LIBVER_PATCH_SCRIPT))
+LIBVER  := $(shell echo $(LIBVER_SCRIPT))
+
+BUILD_SHARED:=yes
+BUILD_STATIC:=yes
+
+CPPFLAGS+= -DXXH_NAMESPACE=LZ4_
+CFLAGS  ?= -O3
+DEBUGFLAGS:= -Wall -Wextra -Wcast-qual -Wcast-align -Wshadow \
+             -Wswitch-enum -Wdeclaration-after-statement -Wstrict-prototypes \
+             -Wundef -Wpointer-arith -Wstrict-aliasing=1
+CFLAGS  += $(DEBUGFLAGS) $(MOREFLAGS)
+FLAGS    = $(CPPFLAGS) $(CFLAGS) $(LDFLAGS)
+
+SRCFILES := $(sort $(wildcard *.c))
+
+include ../Makefile.inc
+
+# OS X linker doesn't support -soname, and use different extension
+# see : https://developer.apple.com/library/mac/documentation/DeveloperTools/Conceptual/DynamicLibraries/100-Articles/DynamicLibraryDesignGuidelines.html
+ifeq ($(TARGET_OS), Darwin)
+	SHARED_EXT = dylib
+	SHARED_EXT_MAJOR = $(LIBVER_MAJOR).$(SHARED_EXT)
+	SHARED_EXT_VER = $(LIBVER).$(SHARED_EXT)
+	SONAME_FLAGS = -install_name $(libdir)/liblz4.$(SHARED_EXT_MAJOR) -compatibility_version $(LIBVER_MAJOR) -current_version $(LIBVER)
+else
+	SONAME_FLAGS = -Wl,-soname=liblz4.$(SHARED_EXT).$(LIBVER_MAJOR)
+	SHARED_EXT = so
+	SHARED_EXT_MAJOR = $(SHARED_EXT).$(LIBVER_MAJOR)
+	SHARED_EXT_VER = $(SHARED_EXT).$(LIBVER)
+endif
+
+.PHONY: default
+default: lib-release
+
+lib-release: DEBUGFLAGS :=
+lib-release: lib
+
+lib: liblz4.a liblz4
+
+all: lib
+
+all32: CFLAGS+=-m32
+all32: all
+
+liblz4.a: $(SRCFILES)
+ifeq ($(BUILD_STATIC),yes)  # can be disabled on command line
+	@echo compiling static library
+	$(Q)$(CC) $(CPPFLAGS) $(CFLAGS) -c $^
+	$(Q)$(AR) rcs $@ *.o
+endif
+
+ifeq ($(WINBASED),yes)
+liblz4-dll.rc: liblz4-dll.rc.in
+	@echo creating library resource
+	$(Q)sed -e 's|@LIBLZ4@|$(LIBLZ4)|' \
+         -e 's|@LIBVER_MAJOR@|$(LIBVER_MAJOR)|g' \
+         -e 's|@LIBVER_MINOR@|$(LIBVER_MINOR)|g' \
+         -e 's|@LIBVER_PATCH@|$(LIBVER_PATCH)|g' \
+          $< >$@
+
+liblz4-dll.o: liblz4-dll.rc
+	$(WINDRES) -i liblz4-dll.rc -o liblz4-dll.o
+
+$(LIBLZ4): $(SRCFILES) liblz4-dll.o
+else
+$(LIBLZ4): $(SRCFILES)
+endif
+ifeq ($(BUILD_SHARED),yes)  # can be disabled on command line
+	@echo compiling dynamic library $(LIBVER)
+  ifeq ($(WINBASED),yes)
+	$(Q)$(CC) $(FLAGS) -DLZ4_DLL_EXPORT=1 -shared $^ -o dll/$@.dll -Wl,--out-implib,dll/$(LIBLZ4_EXP)
+  else
+	$(Q)$(CC) $(FLAGS) -shared $^ -fPIC -fvisibility=hidden $(SONAME_FLAGS) -o $@
+	@echo creating versioned links
+	$(Q)$(LN_SF) $@ liblz4.$(SHARED_EXT_MAJOR)
+	$(Q)$(LN_SF) $@ liblz4.$(SHARED_EXT)
+  endif
+endif
+
+ifeq (,$(filter MINGW%,$(TARGET_OS)))
+liblz4: $(LIBLZ4)
+endif
+
+clean:
+ifeq ($(WINBASED),yes)
+	$(Q)$(RM) *.rc
+endif
+	$(Q)$(RM) core *.o liblz4.pc dll/$(LIBLZ4).dll dll/$(LIBLZ4_EXP)
+	$(Q)$(RM) *.a *.$(SHARED_EXT) *.$(SHARED_EXT_MAJOR) *.$(SHARED_EXT_VER)
+	@echo Cleaning library completed
+
+#-----------------------------------------------------------------------------
+# make install is validated only for Linux, OSX, BSD, Hurd and Solaris targets
+#-----------------------------------------------------------------------------
+ifeq ($(POSIX_ENV),Yes)
+
+.PHONY: listL120
+listL120:  # extract lines >= 120 characters in *.{c,h}, by Takayuki Matsuoka (note : $$, for Makefile compatibility)
+	find . -type f -name '*.c' -o -name '*.h' | while read -r filename; do awk 'length > 120 {print FILENAME "(" FNR "): " $$0}' $$filename; done
+
+DESTDIR     ?=
+# directory variables : GNU conventions prefer lowercase
+# see https://www.gnu.org/prep/standards/html_node/Makefile-Conventions.html
+# support both lower and uppercase (BSD), use lower in script
+PREFIX      ?= /usr/local
+prefix      ?= $(PREFIX)
+EXEC_PREFIX ?= $(prefix)
+exec_prefix ?= $(EXEC_PREFIX)
+BINDIR      ?= $(exec_prefix)/bin
+bindir      ?= $(BINDIR)
+LIBDIR      ?= $(exec_prefix)/lib
+libdir      ?= $(LIBDIR)
+INCLUDEDIR  ?= $(prefix)/include
+includedir  ?= $(INCLUDEDIR)
+
+  ifneq (,$(filter $(TARGET_OS),OpenBSD FreeBSD NetBSD DragonFly MidnightBSD))
+PKGCONFIGDIR ?= $(prefix)/libdata/pkgconfig
+  else
+PKGCONFIGDIR ?= $(libdir)/pkgconfig
+  endif
+pkgconfigdir ?= $(PKGCONFIGDIR)
+
+liblz4.pc: liblz4.pc.in Makefile
+	@echo creating pkgconfig
+	$(Q)sed -e 's|@PREFIX@|$(prefix)|' \
+         -e 's|@LIBDIR@|$(libdir)|' \
+         -e 's|@INCLUDEDIR@|$(includedir)|' \
+         -e 's|@VERSION@|$(LIBVER)|' \
+          $< >$@
+
+install: lib liblz4.pc
+	$(Q)$(INSTALL_DIR) $(DESTDIR)$(pkgconfigdir)/ $(DESTDIR)$(includedir)/ $(DESTDIR)$(libdir)/ $(DESTDIR)$(bindir)/
+	$(Q)$(INSTALL_DATA) liblz4.pc $(DESTDIR)$(pkgconfigdir)/
+	@echo Installing libraries
+  ifeq ($(BUILD_STATIC),yes)
+	$(Q)$(INSTALL_DATA) liblz4.a $(DESTDIR)$(libdir)/liblz4.a
+	$(Q)$(INSTALL_DATA) lz4frame_static.h $(DESTDIR)$(includedir)/lz4frame_static.h
+  endif
+  ifeq ($(BUILD_SHARED),yes)
+# Traditionnally, one installs the DLLs in the bin directory as programs
+# search them first in their directory. This allows to not pollute system
+# directories (like c:/windows/system32), nor modify the PATH variable.
+    ifeq ($(WINBASED),yes)
+	$(Q)$(INSTALL_PROGRAM) dll/$(LIBLZ4).dll $(DESTDIR)$(bindir)
+	$(Q)$(INSTALL_PROGRAM) dll/$(LIBLZ4_EXP) $(DESTDIR)$(libdir)
+    else
+	$(Q)$(INSTALL_PROGRAM) liblz4.$(SHARED_EXT_VER) $(DESTDIR)$(libdir)
+	$(Q)$(LN_SF) liblz4.$(SHARED_EXT_VER) $(DESTDIR)$(libdir)/liblz4.$(SHARED_EXT_MAJOR)
+	$(Q)$(LN_SF) liblz4.$(SHARED_EXT_VER) $(DESTDIR)$(libdir)/liblz4.$(SHARED_EXT)
+    endif
+  endif
+	@echo Installing headers in $(includedir)
+	$(Q)$(INSTALL_DATA) lz4.h $(DESTDIR)$(includedir)/lz4.h
+	$(Q)$(INSTALL_DATA) lz4hc.h $(DESTDIR)$(includedir)/lz4hc.h
+	$(Q)$(INSTALL_DATA) lz4frame.h $(DESTDIR)$(includedir)/lz4frame.h
+	@echo lz4 libraries installed
+
+uninstall:
+	$(Q)$(RM) $(DESTDIR)$(pkgconfigdir)/liblz4.pc
+  ifeq (WINBASED,1)
+	$(Q)$(RM) $(DESTDIR)$(bindir)/$(LIBLZ4).dll
+	$(Q)$(RM) $(DESTDIR)$(libdir)/$(LIBLZ4_EXP)
+  else
+	$(Q)$(RM) $(DESTDIR)$(libdir)/liblz4.$(SHARED_EXT)
+	$(Q)$(RM) $(DESTDIR)$(libdir)/liblz4.$(SHARED_EXT_MAJOR)
+	$(Q)$(RM) $(DESTDIR)$(libdir)/liblz4.$(SHARED_EXT_VER)
+  endif
+	$(Q)$(RM) $(DESTDIR)$(libdir)/liblz4.a
+	$(Q)$(RM) $(DESTDIR)$(includedir)/lz4.h
+	$(Q)$(RM) $(DESTDIR)$(includedir)/lz4hc.h
+	$(Q)$(RM) $(DESTDIR)$(includedir)/lz4frame.h
+	$(Q)$(RM) $(DESTDIR)$(includedir)/lz4frame_static.h
+	@echo lz4 libraries successfully uninstalled
+
+endif
diff --git a/lz4/lib/README.md b/lz4/lib/README.md
new file mode 100644
index 0000000..e2af868
--- /dev/null
+++ b/lz4/lib/README.md
@@ -0,0 +1,137 @@
+LZ4 - Library Files
+================================
+
+The `/lib` directory contains many files, but depending on project's objectives,
+not all of them are necessary.
+
+#### Minimal LZ4 build
+
+The minimum required is **`lz4.c`** and **`lz4.h`**,
+which provides the fast compression and decompression algorithms.
+They generate and decode data using the [LZ4 block format].
+
+
+#### High Compression variant
+
+For more compression ratio at the cost of compression speed,
+the High Compression variant called **lz4hc** is available.
+Add files **`lz4hc.c`** and **`lz4hc.h`**.
+This variant also compresses data using the [LZ4 block format],
+and depends on regular `lib/lz4.*` source files.
+
+
+#### Frame support, for interoperability
+
+In order to produce compressed data compatible with `lz4` command line utility,
+it's necessary to use the [official interoperable frame format].
+This format is generated and decoded automatically by the **lz4frame** library.
+Its public API is described in `lib/lz4frame.h`.
+In order to work properly, lz4frame needs all other modules present in `/lib`,
+including, lz4 and lz4hc, and also **xxhash**.
+So it's necessary to include all `*.c` and `*.h` files present in `/lib`.
+
+
+#### Advanced / Experimental API
+
+Definitions which are not guaranteed to remain stable in future versions,
+are protected behind macros, such as `LZ4_STATIC_LINKING_ONLY`.
+As the name strongly implies, these definitions should only be invoked
+in the context of static linking ***only***.
+Otherwise, dependent application may fail on API or ABI break in the future.
+The associated symbols are also not exposed by the dynamic library by default.
+Should they be nonetheless needed, it's possible to force their publication
+by using build macros `LZ4_PUBLISH_STATIC_FUNCTIONS`
+and `LZ4F_PUBLISH_STATIC_FUNCTIONS`.
+
+
+#### Build macros
+
+The following build macro can be selected to adjust source code behavior at compilation time :
+
+- `LZ4_FAST_DEC_LOOP` : this triggers a speed optimized decompression loop, more powerful on modern cpus.
+  This loop works great on `x86`, `x64` and `aarch64` cpus, and is automatically enabled for them.
+  It's also possible to enable or disable it manually, by passing `LZ4_FAST_DEC_LOOP=1` or `0` to the preprocessor.
+  For example, with `gcc` : `-DLZ4_FAST_DEC_LOOP=1`,
+  and with `make` : `CPPFLAGS+=-DLZ4_FAST_DEC_LOOP=1 make lz4`.
+
+- `LZ4_DISTANCE_MAX` : control the maximum offset that the compressor will allow.
+  Set to 65535 by default, which is the maximum value supported by lz4 format.
+  Reducing maximum distance will reduce opportunities for LZ4 to find matches,
+  hence will produce a worse compression ratio.
+  However, a smaller max distance can allow compatibility with specific decoders using limited memory budget.
+  This build macro only influences the compressed output of the compressor.
+
+- `LZ4_DISABLE_DEPRECATE_WARNINGS` : invoking a deprecated function will make the compiler generate a warning.
+  This is meant to invite users to update their source code.
+  Should this be a problem, it's generally possible to make the compiler ignore these warnings,
+  for example with `-Wno-deprecated-declarations` on `gcc`,
+  or `_CRT_SECURE_NO_WARNINGS` for Visual Studio.
+  This build macro offers another project-specific method
+  by defining `LZ4_DISABLE_DEPRECATE_WARNINGS` before including the LZ4 header files.
+
+- `LZ4_USER_MEMORY_FUNCTIONS` : replace calls to 's `malloc`, `calloc` and `free`
+  by user-defined functions, which must be called `LZ4_malloc()`, `LZ4_calloc()` and `LZ4_free()`.
+  User functions must be available at link time.
+
+- `LZ4_FORCE_SW_BITCOUNT` : by default, the compression algorithm tries to determine lengths
+  by using bitcount instructions, generally implemented as fast single instructions in many cpus.
+  In case the target cpus doesn't support it, or compiler intrinsic doesn't work, or feature bad performance,
+  it's possible to use an optimized software path instead.
+  This is achieved by setting this build macros .
+  In most cases, it's not expected to be necessary,
+  but it can be legitimately considered for less common platforms.
+
+- `LZ4_ALIGN_TEST` : alignment test ensures that the memory area
+  passed as argument to become a compression state is suitably aligned.
+  This test can be disabled if it proves flaky, by setting this value to 0.
+
+
+#### Amalgamation
+
+lz4 source code can be amalgamated into a single file.
+One can combine all source code into `lz4_all.c` by using following command:
+```
+cat lz4.c lz4hc.c lz4frame.c > lz4_all.c
+```
+(`cat` file order is important) then compile `lz4_all.c`.
+All `*.h` files present in `/lib` remain necessary to compile `lz4_all.c`.
+
+
+#### Windows : using MinGW+MSYS to create DLL
+
+DLL can be created using MinGW+MSYS with the `make liblz4` command.
+This command creates `dll\liblz4.dll` and the import library `dll\liblz4.lib`.
+To override the `dlltool` command  when cross-compiling on Linux, just set the `DLLTOOL` variable. Example of cross compilation on Linux with mingw-w64 64 bits:
+```
+make BUILD_STATIC=no CC=x86_64-w64-mingw32-gcc DLLTOOL=x86_64-w64-mingw32-dlltool OS=Windows_NT
+```
+The import library is only required with Visual C++.
+The header files `lz4.h`, `lz4hc.h`, `lz4frame.h` and the dynamic library
+`dll\liblz4.dll` are required to compile a project using gcc/MinGW.
+The dynamic library has to be added to linking options.
+It means that if a project that uses LZ4 consists of a single `test-dll.c`
+file it should be linked with `dll\liblz4.dll`. For example:
+```
+    $(CC) $(CFLAGS) -Iinclude/ test-dll.c -o test-dll dll\liblz4.dll
+```
+The compiled executable will require LZ4 DLL which is available at `dll\liblz4.dll`.
+
+
+#### Miscellaneous
+
+Other files present in the directory are not source code. They are :
+
+ - `LICENSE` : contains the BSD license text
+ - `Makefile` : `make` script to compile and install lz4 library (static and dynamic)
+ - `liblz4.pc.in` : for `pkg-config` (used in `make install`)
+ - `README.md` : this file
+
+[official interoperable frame format]: ../doc/lz4_Frame_format.md
+[LZ4 block format]: ../doc/lz4_Block_format.md
+
+
+#### License
+
+All source material within __lib__ directory are BSD 2-Clause licensed.
+See [LICENSE](LICENSE) for details.
+The license is also reminded at the top of each source file.
diff --git a/lz4/lib/dll/example/Makefile b/lz4/lib/dll/example/Makefile
new file mode 100644
index 0000000..e987956
--- /dev/null
+++ b/lz4/lib/dll/example/Makefile
@@ -0,0 +1,63 @@
+# ##########################################################################
+# LZ4 programs - Makefile
+# Copyright (C) Yann Collet 2016
+#
+# GPL v2 License
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# You can contact the author at :
+#  - LZ4 homepage : http://www.lz4.org
+#  - LZ4 source repository : https://github.com/lz4/lz4
+# ##########################################################################
+
+VOID    := /dev/null
+LZ4DIR  := ../include
+LIBDIR  := ../static
+DLLDIR  := ../dll
+
+CFLAGS  ?= -O3   # can select custom flags. For example : CFLAGS="-O2 -g" make
+CFLAGS  += -Wall -Wextra -Wundef -Wcast-qual -Wcast-align -Wshadow -Wswitch-enum \
+           -Wdeclaration-after-statement -Wstrict-prototypes \
+           -Wpointer-arith -Wstrict-aliasing=1
+CFLAGS  += $(MOREFLAGS)
+CPPFLAGS:= -I$(LZ4DIR) -DXXH_NAMESPACE=LZ4_
+FLAGS   := $(CFLAGS) $(CPPFLAGS) $(LDFLAGS)
+
+
+# Define *.exe as extension for Windows systems
+ifneq (,$(filter Windows%,$(OS)))
+EXT =.exe
+else
+EXT =
+endif
+
+.PHONY: default fullbench-dll fullbench-lib
+
+
+default: all
+
+all: fullbench-dll fullbench-lib
+
+
+fullbench-lib: fullbench.c xxhash.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT) $(LIBDIR)/liblz4_static.lib
+
+fullbench-dll: fullbench.c xxhash.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT) -DLZ4_DLL_IMPORT=1 $(DLLDIR)/liblz4.dll
+
+clean:
+	@$(RM) fullbench-dll$(EXT) fullbench-lib$(EXT) \
+	@echo Cleaning completed
diff --git a/lz4/lib/dll/example/README.md b/lz4/lib/dll/example/README.md
new file mode 100644
index 0000000..223e473
--- /dev/null
+++ b/lz4/lib/dll/example/README.md
@@ -0,0 +1,69 @@
+LZ4 Windows binary package
+====================================
+
+#### The package contents
+
+- `lz4.exe`                  : Command Line Utility, supporting gzip-like arguments
+- `dll\liblz4.dll`           : The DLL of LZ4 library
+- `dll\liblz4.lib`           : The import library of LZ4 library for Visual C++
+- `example\`                 : The example of usage of LZ4 library
+- `include\`                 : Header files required with LZ4 library
+- `static\liblz4_static.lib` : The static LZ4 library
+
+
+#### Usage of Command Line Interface
+
+Command Line Interface (CLI) supports gzip-like arguments.
+By default CLI takes an input file and compresses it to an output file:
+```
+    Usage: lz4 [arg] [input] [output]
+```
+The full list of commands for CLI can be obtained with `-h` or `-H`. The ratio can
+be improved with commands from `-3` to `-16` but higher levels also have slower
+compression. CLI includes in-memory compression benchmark module with compression
+levels starting from `-b` and ending with `-e` with iteration time of `-i` seconds.
+CLI supports aggregation of parameters i.e. `-b1`, `-e18`, and `-i1` can be joined
+into `-b1e18i1`.
+
+
+#### The example of usage of static and dynamic LZ4 libraries with gcc/MinGW
+
+Use `cd example` and `make` to build `fullbench-dll` and `fullbench-lib`.
+`fullbench-dll` uses a dynamic LZ4 library from the `dll` directory.
+`fullbench-lib` uses a static LZ4 library from the `lib` directory.
+
+
+#### Using LZ4 DLL with gcc/MinGW
+
+The header files from `include\` and the dynamic library `dll\liblz4.dll`
+are required to compile a project using gcc/MinGW.
+The dynamic library has to be added to linking options.
+It means that if a project that uses LZ4 consists of a single `test-dll.c`
+file it should be linked with `dll\liblz4.dll`. For example:
+```
+    gcc $(CFLAGS) -Iinclude\ test-dll.c -o test-dll dll\liblz4.dll
+```
+The compiled executable will require LZ4 DLL which is available at `dll\liblz4.dll`.
+
+
+#### The example of usage of static and dynamic LZ4 libraries with Visual C++
+
+Open `example\fullbench-dll.sln` to compile `fullbench-dll` that uses a
+dynamic LZ4 library from the `dll` directory. The solution works with Visual C++
+2010 or newer. When one will open the solution with Visual C++ newer than 2010
+then the solution will upgraded to the current version.
+
+
+#### Using LZ4 DLL with Visual C++
+
+The header files from `include\` and the import library `dll\liblz4.lib`
+are required to compile a project using Visual C++.
+
+1. The header files should be added to `Additional Include Directories` that can
+   be found in project properties `C/C++` then `General`.
+2. The import library has to be added to `Additional Dependencies` that can
+   be found in project properties `Linker` then `Input`.
+   If one will provide only the name `liblz4.lib` without a full path to the library
+   the directory has to be added to `Linker\General\Additional Library Directories`.
+
+The compiled executable will require LZ4 DLL which is available at `dll\liblz4.dll`.
diff --git a/lz4/lib/dll/example/fullbench-dll.sln b/lz4/lib/dll/example/fullbench-dll.sln
new file mode 100644
index 0000000..72e302e
--- /dev/null
+++ b/lz4/lib/dll/example/fullbench-dll.sln
@@ -0,0 +1,25 @@
+Microsoft Visual Studio Solution File, Format Version 12.00
+# Visual Studio Express 2012 for Windows Desktop
+Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "fullbench-dll", "fullbench-dll.vcxproj", "{13992FD2-077E-4954-B065-A428198201A9}"
+EndProject
+Global
+	GlobalSection(SolutionConfigurationPlatforms) = preSolution
+		Debug|Win32 = Debug|Win32
+		Debug|x64 = Debug|x64
+		Release|Win32 = Release|Win32
+		Release|x64 = Release|x64
+	EndGlobalSection
+	GlobalSection(ProjectConfigurationPlatforms) = postSolution
+		{13992FD2-077E-4954-B065-A428198201A9}.Debug|Win32.ActiveCfg = Debug|Win32
+		{13992FD2-077E-4954-B065-A428198201A9}.Debug|Win32.Build.0 = Debug|Win32
+		{13992FD2-077E-4954-B065-A428198201A9}.Debug|x64.ActiveCfg = Debug|x64
+		{13992FD2-077E-4954-B065-A428198201A9}.Debug|x64.Build.0 = Debug|x64
+		{13992FD2-077E-4954-B065-A428198201A9}.Release|Win32.ActiveCfg = Release|Win32
+		{13992FD2-077E-4954-B065-A428198201A9}.Release|Win32.Build.0 = Release|Win32
+		{13992FD2-077E-4954-B065-A428198201A9}.Release|x64.ActiveCfg = Release|x64
+		{13992FD2-077E-4954-B065-A428198201A9}.Release|x64.Build.0 = Release|x64
+	EndGlobalSection
+	GlobalSection(SolutionProperties) = preSolution
+		HideSolutionNode = FALSE
+	EndGlobalSection
+EndGlobal
diff --git a/lz4/lib/dll/example/fullbench-dll.vcxproj b/lz4/lib/dll/example/fullbench-dll.vcxproj
new file mode 100644
index 0000000..cdb5534
--- /dev/null
+++ b/lz4/lib/dll/example/fullbench-dll.vcxproj
@@ -0,0 +1,182 @@
+
+
+  
+    
+      Debug
+      Win32
+    
+    
+      Debug
+      x64
+    
+    
+      Release
+      Win32
+    
+    
+      Release
+      x64
+    
+  
+  
+    {13992FD2-077E-4954-B065-A428198201A9}
+    Win32Proj
+    fullbench-dll
+    $(SolutionDir)bin\$(Platform)_$(Configuration)\
+    $(SolutionDir)bin\obj\$(RootNamespace)_$(Platform)_$(Configuration)\
+  
+  
+  
+    Application
+    true
+    Unicode
+  
+  
+    Application
+    true
+    Unicode
+  
+  
+    Application
+    false
+    true
+    Unicode
+  
+  
+    Application
+    false
+    true
+    Unicode
+  
+  
+  
+  
+  
+    
+  
+  
+    
+  
+  
+    
+  
+  
+    
+  
+  
+  
+    true
+    $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath);
+  
+  
+    true
+    $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath);
+    true
+  
+  
+    false
+    $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath);
+  
+  
+    false
+    $(IncludePath);$(UniversalCRT_IncludePath);$(SolutionDir)..\..\lib;$(VCInstallDir)include;$(VCInstallDir)atlmfc\include;$(WindowsSDK_IncludePath);
+    true
+  
+  
+    
+      
+      
+      Level4
+      Disabled
+      WIN32;_DEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions)
+      true
+      false
+      ..\include
+    
+    
+      Console
+      true
+      $(SolutionDir)..\dll;%(AdditionalLibraryDirectories)
+      liblz4.lib;%(AdditionalDependencies)
+      false
+    
+  
+  
+    
+      
+      
+      Level4
+      Disabled
+      WIN32;_DEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions)
+      true
+      true
+      /analyze:stacksize295252 %(AdditionalOptions)
+      ..\include
+    
+    
+      Console
+      true
+      $(SolutionDir)..\dll;%(AdditionalLibraryDirectories)
+      liblz4.lib;%(AdditionalDependencies)
+    
+  
+  
+    
+      Level4
+      
+      
+      MaxSpeed
+      true
+      true
+      WIN32;NDEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions)
+      false
+      false
+      ..\include
+    
+    
+      Console
+      true
+      true
+      true
+      $(SolutionDir)..\dll;%(AdditionalLibraryDirectories)
+      liblz4.lib;%(AdditionalDependencies)
+      false
+    
+  
+  
+    
+      Level4
+      
+      
+      MaxSpeed
+      true
+      true
+      WIN32;NDEBUG;_CONSOLE;LZ4_DLL_IMPORT=1;%(PreprocessorDefinitions)
+      false
+      true
+      /analyze:stacksize295252 %(AdditionalOptions)
+      ..\include
+    
+    
+      Console
+      true
+      true
+      true
+      $(SolutionDir)..\dll;%(AdditionalLibraryDirectories)
+      liblz4.lib;%(AdditionalDependencies)
+    
+  
+  
+    
+    
+  
+  
+    
+    
+    
+    
+  
+  
+  
+  
+
\ No newline at end of file
diff --git a/lz4/lib/liblz4-dll.rc.in b/lz4/lib/liblz4-dll.rc.in
new file mode 100644
index 0000000..bf9adf5
--- /dev/null
+++ b/lz4/lib/liblz4-dll.rc.in
@@ -0,0 +1,35 @@
+#include 
+
+// DLL version information.
+1 VERSIONINFO
+FILEVERSION       @LIBVER_MAJOR@,@LIBVER_MINOR@,@LIBVER_PATCH@,0
+PRODUCTVERSION    @LIBVER_MAJOR@,@LIBVER_MINOR@,@LIBVER_PATCH@,0
+FILEFLAGSMASK      VS_FFI_FILEFLAGSMASK
+#ifdef _DEBUG
+  FILEFLAGS        VS_FF_DEBUG | VS_FF_PRERELEASE
+#else
+  FILEFLAGS        0
+#endif
+FILEOS             VOS_NT_WINDOWS32
+FILETYPE           VFT_DLL
+FILESUBTYPE        VFT2_UNKNOWN
+BEGIN
+    BLOCK "StringFileInfo"
+    BEGIN
+        BLOCK "040904B0"
+        BEGIN
+            VALUE "CompanyName", "Yann Collet"
+            VALUE "FileDescription", "Extremely fast compression"
+            VALUE "FileVersion", "@LIBVER_MAJOR@.@LIBVER_MINOR@.@LIBVER_PATCH@.0"
+            VALUE "InternalName", "@LIBLZ4@"
+            VALUE "LegalCopyright", "Copyright (C) 2013-2016, Yann Collet"
+            VALUE "OriginalFilename", "@LIBLZ4@.dll"
+            VALUE "ProductName", "LZ4"
+            VALUE "ProductVersion", "@LIBVER_MAJOR@.@LIBVER_MINOR@.@LIBVER_PATCH@.0"
+        END
+    END
+    BLOCK "VarFileInfo"
+    BEGIN
+        VALUE "Translation", 0x0409, 1200
+    END
+END
diff --git a/lz4/lib/liblz4.pc.in b/lz4/lib/liblz4.pc.in
new file mode 100644
index 0000000..cb31cd7
--- /dev/null
+++ b/lz4/lib/liblz4.pc.in
@@ -0,0 +1,14 @@
+#   LZ4 - Fast LZ compression algorithm
+#   Copyright (C) 2011-2014, Yann Collet.
+#   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+prefix=@PREFIX@
+libdir=@LIBDIR@
+includedir=@INCLUDEDIR@
+
+Name: lz4
+Description: extremely fast lossless compression algorithm library
+URL: http://www.lz4.org/
+Version: @VERSION@
+Libs: -L@LIBDIR@ -llz4
+Cflags: -I@INCLUDEDIR@
diff --git a/lz4/lib/lz4.c b/lz4/lib/lz4.c
new file mode 100644
index 0000000..9f5e9bf
--- /dev/null
+++ b/lz4/lib/lz4.c
@@ -0,0 +1,2495 @@
+/*
+   LZ4 - Fast LZ compression algorithm
+   Copyright (C) 2011-present, Yann Collet.
+
+   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+   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.
+
+   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.
+
+   You can contact the author at :
+    - LZ4 homepage : http://www.lz4.org
+    - LZ4 source repository : https://github.com/lz4/lz4
+*/
+
+/*-************************************
+*  Tuning parameters
+**************************************/
+/*
+ * LZ4_HEAPMODE :
+ * Select how default compression functions will allocate memory for their hash table,
+ * in memory stack (0:default, fastest), or in memory heap (1:requires malloc()).
+ */
+#ifndef LZ4_HEAPMODE
+#  define LZ4_HEAPMODE 0
+#endif
+
+/*
+ * LZ4_ACCELERATION_DEFAULT :
+ * Select "acceleration" for LZ4_compress_fast() when parameter value <= 0
+ */
+#define LZ4_ACCELERATION_DEFAULT 1
+/*
+ * LZ4_ACCELERATION_MAX :
+ * Any "acceleration" value higher than this threshold
+ * get treated as LZ4_ACCELERATION_MAX instead (fix #876)
+ */
+#define LZ4_ACCELERATION_MAX 65537
+
+
+/*-************************************
+*  CPU Feature Detection
+**************************************/
+/* LZ4_FORCE_MEMORY_ACCESS
+ * By default, access to unaligned memory is controlled by `memcpy()`, which is safe and portable.
+ * Unfortunately, on some target/compiler combinations, the generated assembly is sub-optimal.
+ * The below switch allow to select different access method for improved performance.
+ * Method 0 (default) : use `memcpy()`. Safe and portable.
+ * Method 1 : `__packed` statement. It depends on compiler extension (ie, not portable).
+ *            This method is safe if your compiler supports it, and *generally* as fast or faster than `memcpy`.
+ * Method 2 : direct access. This method is portable but violate C standard.
+ *            It can generate buggy code on targets which assembly generation depends on alignment.
+ *            But in some circumstances, it's the only known way to get the most performance (ie GCC + ARMv6)
+ * See https://fastcompression.blogspot.fr/2015/08/accessing-unaligned-memory.html for details.
+ * Prefer these methods in priority order (0 > 1 > 2)
+ */
+#ifndef LZ4_FORCE_MEMORY_ACCESS   /* can be defined externally */
+#  if defined(__GNUC__) && \
+  ( defined(__ARM_ARCH_6__) || defined(__ARM_ARCH_6J__) || defined(__ARM_ARCH_6K__) \
+  || defined(__ARM_ARCH_6Z__) || defined(__ARM_ARCH_6ZK__) || defined(__ARM_ARCH_6T2__) )
+#    define LZ4_FORCE_MEMORY_ACCESS 2
+#  elif (defined(__INTEL_COMPILER) && !defined(_WIN32)) || defined(__GNUC__)
+#    define LZ4_FORCE_MEMORY_ACCESS 1
+#  endif
+#endif
+
+/*
+ * LZ4_FORCE_SW_BITCOUNT
+ * Define this parameter if your target system or compiler does not support hardware bit count
+ */
+#if defined(_MSC_VER) && defined(_WIN32_WCE)   /* Visual Studio for WinCE doesn't support Hardware bit count */
+#  undef  LZ4_FORCE_SW_BITCOUNT  /* avoid double def */
+#  define LZ4_FORCE_SW_BITCOUNT
+#endif
+
+
+
+/*-************************************
+*  Dependency
+**************************************/
+/*
+ * LZ4_SRC_INCLUDED:
+ * Amalgamation flag, whether lz4.c is included
+ */
+#ifndef LZ4_SRC_INCLUDED
+#  define LZ4_SRC_INCLUDED 1
+#endif
+
+#ifndef LZ4_STATIC_LINKING_ONLY
+#define LZ4_STATIC_LINKING_ONLY
+#endif
+
+#ifndef LZ4_DISABLE_DEPRECATE_WARNINGS
+#define LZ4_DISABLE_DEPRECATE_WARNINGS /* due to LZ4_decompress_safe_withPrefix64k */
+#endif
+
+#define LZ4_STATIC_LINKING_ONLY  /* LZ4_DISTANCE_MAX */
+#include "lz4.h"
+/* see also "memory routines" below */
+
+
+/*-************************************
+*  Compiler Options
+**************************************/
+#if defined(_MSC_VER) && (_MSC_VER >= 1400)  /* Visual Studio 2005+ */
+#  include                /* only present in VS2005+ */
+#  pragma warning(disable : 4127)   /* disable: C4127: conditional expression is constant */
+#endif  /* _MSC_VER */
+
+#ifndef LZ4_FORCE_INLINE
+#  ifdef _MSC_VER    /* Visual Studio */
+#    define LZ4_FORCE_INLINE static __forceinline
+#  else
+#    if defined (__cplusplus) || defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L   /* C99 */
+#      ifdef __GNUC__
+#        define LZ4_FORCE_INLINE static inline __attribute__((always_inline))
+#      else
+#        define LZ4_FORCE_INLINE static inline
+#      endif
+#    else
+#      define LZ4_FORCE_INLINE static
+#    endif /* __STDC_VERSION__ */
+#  endif  /* _MSC_VER */
+#endif /* LZ4_FORCE_INLINE */
+
+/* LZ4_FORCE_O2 and LZ4_FORCE_INLINE
+ * gcc on ppc64le generates an unrolled SIMDized loop for LZ4_wildCopy8,
+ * together with a simple 8-byte copy loop as a fall-back path.
+ * However, this optimization hurts the decompression speed by >30%,
+ * because the execution does not go to the optimized loop
+ * for typical compressible data, and all of the preamble checks
+ * before going to the fall-back path become useless overhead.
+ * This optimization happens only with the -O3 flag, and -O2 generates
+ * a simple 8-byte copy loop.
+ * With gcc on ppc64le, all of the LZ4_decompress_* and LZ4_wildCopy8
+ * functions are annotated with __attribute__((optimize("O2"))),
+ * and also LZ4_wildCopy8 is forcibly inlined, so that the O2 attribute
+ * of LZ4_wildCopy8 does not affect the compression speed.
+ */
+#if defined(__PPC64__) && defined(__LITTLE_ENDIAN__) && defined(__GNUC__) && !defined(__clang__)
+#  define LZ4_FORCE_O2  __attribute__((optimize("O2")))
+#  undef LZ4_FORCE_INLINE
+#  define LZ4_FORCE_INLINE  static __inline __attribute__((optimize("O2"),always_inline))
+#else
+#  define LZ4_FORCE_O2
+#endif
+
+#if (defined(__GNUC__) && (__GNUC__ >= 3)) || (defined(__INTEL_COMPILER) && (__INTEL_COMPILER >= 800)) || defined(__clang__)
+#  define expect(expr,value)    (__builtin_expect ((expr),(value)) )
+#else
+#  define expect(expr,value)    (expr)
+#endif
+
+#ifndef likely
+#define likely(expr)     expect((expr) != 0, 1)
+#endif
+#ifndef unlikely
+#define unlikely(expr)   expect((expr) != 0, 0)
+#endif
+
+/* Should the alignment test prove unreliable, for some reason,
+ * it can be disabled by setting LZ4_ALIGN_TEST to 0 */
+#ifndef LZ4_ALIGN_TEST  /* can be externally provided */
+# define LZ4_ALIGN_TEST 1
+#endif
+
+
+/*-************************************
+*  Memory routines
+**************************************/
+#ifdef LZ4_USER_MEMORY_FUNCTIONS
+/* memory management functions can be customized by user project.
+ * Below functions must exist somewhere in the Project
+ * and be available at link time */
+void* LZ4_malloc(size_t s);
+void* LZ4_calloc(size_t n, size_t s);
+void  LZ4_free(void* p);
+# define ALLOC(s)          LZ4_malloc(s)
+# define ALLOC_AND_ZERO(s) LZ4_calloc(1,s)
+# define FREEMEM(p)        LZ4_free(p)
+#else
+# include    /* malloc, calloc, free */
+# define ALLOC(s)          malloc(s)
+# define ALLOC_AND_ZERO(s) calloc(1,s)
+# define FREEMEM(p)        free(p)
+#endif
+
+#include    /* memset, memcpy */
+#define MEM_INIT(p,v,s)   memset((p),(v),(s))
+
+
+/*-************************************
+*  Common Constants
+**************************************/
+#define MINMATCH 4
+
+#define WILDCOPYLENGTH 8
+#define LASTLITERALS   5   /* see ../doc/lz4_Block_format.md#parsing-restrictions */
+#define MFLIMIT       12   /* see ../doc/lz4_Block_format.md#parsing-restrictions */
+#define MATCH_SAFEGUARD_DISTANCE  ((2*WILDCOPYLENGTH) - MINMATCH)   /* ensure it's possible to write 2 x wildcopyLength without overflowing output buffer */
+#define FASTLOOP_SAFE_DISTANCE 64
+static const int LZ4_minLength = (MFLIMIT+1);
+
+#define KB *(1 <<10)
+#define MB *(1 <<20)
+#define GB *(1U<<30)
+
+#define LZ4_DISTANCE_ABSOLUTE_MAX 65535
+#if (LZ4_DISTANCE_MAX > LZ4_DISTANCE_ABSOLUTE_MAX)   /* max supported by LZ4 format */
+#  error "LZ4_DISTANCE_MAX is too big : must be <= 65535"
+#endif
+
+#define ML_BITS  4
+#define ML_MASK  ((1U<=1)
+#  include 
+#else
+#  ifndef assert
+#    define assert(condition) ((void)0)
+#  endif
+#endif
+
+#define LZ4_STATIC_ASSERT(c)   { enum { LZ4_static_assert = 1/(int)(!!(c)) }; }   /* use after variable declarations */
+
+#if defined(LZ4_DEBUG) && (LZ4_DEBUG>=2)
+#  include 
+   static int g_debuglog_enable = 1;
+#  define DEBUGLOG(l, ...) {                          \
+        if ((g_debuglog_enable) && (l<=LZ4_DEBUG)) {  \
+            fprintf(stderr, __FILE__ ": ");           \
+            fprintf(stderr, __VA_ARGS__);             \
+            fprintf(stderr, " \n");                   \
+    }   }
+#else
+#  define DEBUGLOG(l, ...) {}    /* disabled */
+#endif
+
+static int LZ4_isAligned(const void* ptr, size_t alignment)
+{
+    return ((size_t)ptr & (alignment -1)) == 0;
+}
+
+
+/*-************************************
+*  Types
+**************************************/
+#include 
+#if defined(__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */)
+# include 
+  typedef  uint8_t BYTE;
+  typedef uint16_t U16;
+  typedef uint32_t U32;
+  typedef  int32_t S32;
+  typedef uint64_t U64;
+  typedef uintptr_t uptrval;
+#else
+# if UINT_MAX != 4294967295UL
+#   error "LZ4 code (when not C++ or C99) assumes that sizeof(int) == 4"
+# endif
+  typedef unsigned char       BYTE;
+  typedef unsigned short      U16;
+  typedef unsigned int        U32;
+  typedef   signed int        S32;
+  typedef unsigned long long  U64;
+  typedef size_t              uptrval;   /* generally true, except OpenVMS-64 */
+#endif
+
+#if defined(__x86_64__)
+  typedef U64    reg_t;   /* 64-bits in x32 mode */
+#else
+  typedef size_t reg_t;   /* 32-bits in x32 mode */
+#endif
+
+typedef enum {
+    notLimited = 0,
+    limitedOutput = 1,
+    fillOutput = 2
+} limitedOutput_directive;
+
+
+/*-************************************
+*  Reading and writing into memory
+**************************************/
+
+/**
+ * LZ4 relies on memcpy with a constant size being inlined. In freestanding
+ * environments, the compiler can't assume the implementation of memcpy() is
+ * standard compliant, so it can't apply its specialized memcpy() inlining
+ * logic. When possible, use __builtin_memcpy() to tell the compiler to analyze
+ * memcpy() as if it were standard compliant, so it can inline it in freestanding
+ * environments. This is needed when decompressing the Linux Kernel, for example.
+ */
+#if defined(__GNUC__) && (__GNUC__ >= 4)
+#define LZ4_memcpy(dst, src, size) __builtin_memcpy(dst, src, size)
+#else
+#define LZ4_memcpy(dst, src, size) memcpy(dst, src, size)
+#endif
+
+static unsigned LZ4_isLittleEndian(void)
+{
+    const union { U32 u; BYTE c[4]; } one = { 1 };   /* don't use static : performance detrimental */
+    return one.c[0];
+}
+
+
+#if defined(LZ4_FORCE_MEMORY_ACCESS) && (LZ4_FORCE_MEMORY_ACCESS==2)
+/* lie to the compiler about data alignment; use with caution */
+
+static U16 LZ4_read16(const void* memPtr) { return *(const U16*) memPtr; }
+static U32 LZ4_read32(const void* memPtr) { return *(const U32*) memPtr; }
+static reg_t LZ4_read_ARCH(const void* memPtr) { return *(const reg_t*) memPtr; }
+
+static void LZ4_write16(void* memPtr, U16 value) { *(U16*)memPtr = value; }
+static void LZ4_write32(void* memPtr, U32 value) { *(U32*)memPtr = value; }
+
+#elif defined(LZ4_FORCE_MEMORY_ACCESS) && (LZ4_FORCE_MEMORY_ACCESS==1)
+
+/* __pack instructions are safer, but compiler specific, hence potentially problematic for some compilers */
+/* currently only defined for gcc and icc */
+typedef union { U16 u16; U32 u32; reg_t uArch; } __attribute__((packed)) unalign;
+
+static U16 LZ4_read16(const void* ptr) { return ((const unalign*)ptr)->u16; }
+static U32 LZ4_read32(const void* ptr) { return ((const unalign*)ptr)->u32; }
+static reg_t LZ4_read_ARCH(const void* ptr) { return ((const unalign*)ptr)->uArch; }
+
+static void LZ4_write16(void* memPtr, U16 value) { ((unalign*)memPtr)->u16 = value; }
+static void LZ4_write32(void* memPtr, U32 value) { ((unalign*)memPtr)->u32 = value; }
+
+#else  /* safe and portable access using memcpy() */
+
+static U16 LZ4_read16(const void* memPtr)
+{
+    U16 val; LZ4_memcpy(&val, memPtr, sizeof(val)); return val;
+}
+
+static U32 LZ4_read32(const void* memPtr)
+{
+    U32 val; LZ4_memcpy(&val, memPtr, sizeof(val)); return val;
+}
+
+static reg_t LZ4_read_ARCH(const void* memPtr)
+{
+    reg_t val; LZ4_memcpy(&val, memPtr, sizeof(val)); return val;
+}
+
+static void LZ4_write16(void* memPtr, U16 value)
+{
+    LZ4_memcpy(memPtr, &value, sizeof(value));
+}
+
+static void LZ4_write32(void* memPtr, U32 value)
+{
+    LZ4_memcpy(memPtr, &value, sizeof(value));
+}
+
+#endif /* LZ4_FORCE_MEMORY_ACCESS */
+
+
+static U16 LZ4_readLE16(const void* memPtr)
+{
+    if (LZ4_isLittleEndian()) {
+        return LZ4_read16(memPtr);
+    } else {
+        const BYTE* p = (const BYTE*)memPtr;
+        return (U16)((U16)p[0] + (p[1]<<8));
+    }
+}
+
+static void LZ4_writeLE16(void* memPtr, U16 value)
+{
+    if (LZ4_isLittleEndian()) {
+        LZ4_write16(memPtr, value);
+    } else {
+        BYTE* p = (BYTE*)memPtr;
+        p[0] = (BYTE) value;
+        p[1] = (BYTE)(value>>8);
+    }
+}
+
+/* customized variant of memcpy, which can overwrite up to 8 bytes beyond dstEnd */
+LZ4_FORCE_INLINE
+void LZ4_wildCopy8(void* dstPtr, const void* srcPtr, void* dstEnd)
+{
+    BYTE* d = (BYTE*)dstPtr;
+    const BYTE* s = (const BYTE*)srcPtr;
+    BYTE* const e = (BYTE*)dstEnd;
+
+    do { LZ4_memcpy(d,s,8); d+=8; s+=8; } while (d= 16. */
+LZ4_FORCE_INLINE void
+LZ4_wildCopy32(void* dstPtr, const void* srcPtr, void* dstEnd)
+{
+    BYTE* d = (BYTE*)dstPtr;
+    const BYTE* s = (const BYTE*)srcPtr;
+    BYTE* const e = (BYTE*)dstEnd;
+
+    do { LZ4_memcpy(d,s,16); LZ4_memcpy(d+16,s+16,16); d+=32; s+=32; } while (d= dstPtr + MINMATCH
+ * - there is at least 8 bytes available to write after dstEnd */
+LZ4_FORCE_INLINE void
+LZ4_memcpy_using_offset(BYTE* dstPtr, const BYTE* srcPtr, BYTE* dstEnd, const size_t offset)
+{
+    BYTE v[8];
+
+    assert(dstEnd >= dstPtr + MINMATCH);
+
+    switch(offset) {
+    case 1:
+        MEM_INIT(v, *srcPtr, 8);
+        break;
+    case 2:
+        LZ4_memcpy(v, srcPtr, 2);
+        LZ4_memcpy(&v[2], srcPtr, 2);
+        LZ4_memcpy(&v[4], v, 4);
+        break;
+    case 4:
+        LZ4_memcpy(v, srcPtr, 4);
+        LZ4_memcpy(&v[4], srcPtr, 4);
+        break;
+    default:
+        LZ4_memcpy_using_offset_base(dstPtr, srcPtr, dstEnd, offset);
+        return;
+    }
+
+    LZ4_memcpy(dstPtr, v, 8);
+    dstPtr += 8;
+    while (dstPtr < dstEnd) {
+        LZ4_memcpy(dstPtr, v, 8);
+        dstPtr += 8;
+    }
+}
+#endif
+
+
+/*-************************************
+*  Common functions
+**************************************/
+static unsigned LZ4_NbCommonBytes (reg_t val)
+{
+    assert(val != 0);
+    if (LZ4_isLittleEndian()) {
+        if (sizeof(val) == 8) {
+#       if defined(_MSC_VER) && (_MSC_VER >= 1800) && defined(_M_AMD64) && !defined(LZ4_FORCE_SW_BITCOUNT)
+            /* x64 CPUS without BMI support interpret `TZCNT` as `REP BSF` */
+            return (unsigned)_tzcnt_u64(val) >> 3;
+#       elif defined(_MSC_VER) && defined(_WIN64) && !defined(LZ4_FORCE_SW_BITCOUNT)
+            unsigned long r = 0;
+            _BitScanForward64(&r, (U64)val);
+            return (unsigned)r >> 3;
+#       elif (defined(__clang__) || (defined(__GNUC__) && ((__GNUC__ > 3) || \
+                            ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 4))))) && \
+                                        !defined(LZ4_FORCE_SW_BITCOUNT)
+            return (unsigned)__builtin_ctzll((U64)val) >> 3;
+#       else
+            const U64 m = 0x0101010101010101ULL;
+            val ^= val - 1;
+            return (unsigned)(((U64)((val & (m - 1)) * m)) >> 56);
+#       endif
+        } else /* 32 bits */ {
+#       if defined(_MSC_VER) && (_MSC_VER >= 1400) && !defined(LZ4_FORCE_SW_BITCOUNT)
+            unsigned long r;
+            _BitScanForward(&r, (U32)val);
+            return (unsigned)r >> 3;
+#       elif (defined(__clang__) || (defined(__GNUC__) && ((__GNUC__ > 3) || \
+                            ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 4))))) && \
+                        !defined(__TINYC__) && !defined(LZ4_FORCE_SW_BITCOUNT)
+            return (unsigned)__builtin_ctz((U32)val) >> 3;
+#       else
+            const U32 m = 0x01010101;
+            return (unsigned)((((val - 1) ^ val) & (m - 1)) * m) >> 24;
+#       endif
+        }
+    } else   /* Big Endian CPU */ {
+        if (sizeof(val)==8) {
+#       if (defined(__clang__) || (defined(__GNUC__) && ((__GNUC__ > 3) || \
+                            ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 4))))) && \
+                        !defined(__TINYC__) && !defined(LZ4_FORCE_SW_BITCOUNT)
+            return (unsigned)__builtin_clzll((U64)val) >> 3;
+#       else
+#if 1
+            /* this method is probably faster,
+             * but adds a 128 bytes lookup table */
+            static const unsigned char ctz7_tab[128] = {
+                7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+                4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
+            };
+            U64 const mask = 0x0101010101010101ULL;
+            U64 const t = (((val >> 8) - mask) | val) & mask;
+            return ctz7_tab[(t * 0x0080402010080402ULL) >> 57];
+#else
+            /* this method doesn't consume memory space like the previous one,
+             * but it contains several branches,
+             * that may end up slowing execution */
+            static const U32 by32 = sizeof(val)*4;  /* 32 on 64 bits (goal), 16 on 32 bits.
+            Just to avoid some static analyzer complaining about shift by 32 on 32-bits target.
+            Note that this code path is never triggered in 32-bits mode. */
+            unsigned r;
+            if (!(val>>by32)) { r=4; } else { r=0; val>>=by32; }
+            if (!(val>>16)) { r+=2; val>>=8; } else { val>>=24; }
+            r += (!val);
+            return r;
+#endif
+#       endif
+        } else /* 32 bits */ {
+#       if (defined(__clang__) || (defined(__GNUC__) && ((__GNUC__ > 3) || \
+                            ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 4))))) && \
+                                        !defined(LZ4_FORCE_SW_BITCOUNT)
+            return (unsigned)__builtin_clz((U32)val) >> 3;
+#       else
+            val >>= 8;
+            val = ((((val + 0x00FFFF00) | 0x00FFFFFF) + val) |
+              (val + 0x00FF0000)) >> 24;
+            return (unsigned)val ^ 3;
+#       endif
+        }
+    }
+}
+
+
+#define STEPSIZE sizeof(reg_t)
+LZ4_FORCE_INLINE
+unsigned LZ4_count(const BYTE* pIn, const BYTE* pMatch, const BYTE* pInLimit)
+{
+    const BYTE* const pStart = pIn;
+
+    if (likely(pIn < pInLimit-(STEPSIZE-1))) {
+        reg_t const diff = LZ4_read_ARCH(pMatch) ^ LZ4_read_ARCH(pIn);
+        if (!diff) {
+            pIn+=STEPSIZE; pMatch+=STEPSIZE;
+        } else {
+            return LZ4_NbCommonBytes(diff);
+    }   }
+
+    while (likely(pIn < pInLimit-(STEPSIZE-1))) {
+        reg_t const diff = LZ4_read_ARCH(pMatch) ^ LZ4_read_ARCH(pIn);
+        if (!diff) { pIn+=STEPSIZE; pMatch+=STEPSIZE; continue; }
+        pIn += LZ4_NbCommonBytes(diff);
+        return (unsigned)(pIn - pStart);
+    }
+
+    if ((STEPSIZE==8) && (pIn<(pInLimit-3)) && (LZ4_read32(pMatch) == LZ4_read32(pIn))) { pIn+=4; pMatch+=4; }
+    if ((pIn<(pInLimit-1)) && (LZ4_read16(pMatch) == LZ4_read16(pIn))) { pIn+=2; pMatch+=2; }
+    if ((pIn compression run slower on incompressible data */
+
+
+/*-************************************
+*  Local Structures and types
+**************************************/
+typedef enum { clearedTable = 0, byPtr, byU32, byU16 } tableType_t;
+
+/**
+ * This enum distinguishes several different modes of accessing previous
+ * content in the stream.
+ *
+ * - noDict        : There is no preceding content.
+ * - withPrefix64k : Table entries up to ctx->dictSize before the current blob
+ *                   blob being compressed are valid and refer to the preceding
+ *                   content (of length ctx->dictSize), which is available
+ *                   contiguously preceding in memory the content currently
+ *                   being compressed.
+ * - usingExtDict  : Like withPrefix64k, but the preceding content is somewhere
+ *                   else in memory, starting at ctx->dictionary with length
+ *                   ctx->dictSize.
+ * - usingDictCtx  : Like usingExtDict, but everything concerning the preceding
+ *                   content is in a separate context, pointed to by
+ *                   ctx->dictCtx. ctx->dictionary, ctx->dictSize, and table
+ *                   entries in the current context that refer to positions
+ *                   preceding the beginning of the current compression are
+ *                   ignored. Instead, ctx->dictCtx->dictionary and ctx->dictCtx
+ *                   ->dictSize describe the location and size of the preceding
+ *                   content, and matches are found by looking in the ctx
+ *                   ->dictCtx->hashTable.
+ */
+typedef enum { noDict = 0, withPrefix64k, usingExtDict, usingDictCtx } dict_directive;
+typedef enum { noDictIssue = 0, dictSmall } dictIssue_directive;
+
+
+/*-************************************
+*  Local Utils
+**************************************/
+int LZ4_versionNumber (void) { return LZ4_VERSION_NUMBER; }
+const char* LZ4_versionString(void) { return LZ4_VERSION_STRING; }
+int LZ4_compressBound(int isize)  { return LZ4_COMPRESSBOUND(isize); }
+int LZ4_sizeofState(void) { return LZ4_STREAMSIZE; }
+
+
+/*-************************************
+*  Internal Definitions used in Tests
+**************************************/
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+int LZ4_compress_forceExtDict (LZ4_stream_t* LZ4_dict, const char* source, char* dest, int srcSize);
+
+int LZ4_decompress_safe_forceExtDict(const char* source, char* dest,
+                                     int compressedSize, int maxOutputSize,
+                                     const void* dictStart, size_t dictSize);
+
+#if defined (__cplusplus)
+}
+#endif
+
+/*-******************************
+*  Compression functions
+********************************/
+LZ4_FORCE_INLINE U32 LZ4_hash4(U32 sequence, tableType_t const tableType)
+{
+    if (tableType == byU16)
+        return ((sequence * 2654435761U) >> ((MINMATCH*8)-(LZ4_HASHLOG+1)));
+    else
+        return ((sequence * 2654435761U) >> ((MINMATCH*8)-LZ4_HASHLOG));
+}
+
+LZ4_FORCE_INLINE U32 LZ4_hash5(U64 sequence, tableType_t const tableType)
+{
+    const U32 hashLog = (tableType == byU16) ? LZ4_HASHLOG+1 : LZ4_HASHLOG;
+    if (LZ4_isLittleEndian()) {
+        const U64 prime5bytes = 889523592379ULL;
+        return (U32)(((sequence << 24) * prime5bytes) >> (64 - hashLog));
+    } else {
+        const U64 prime8bytes = 11400714785074694791ULL;
+        return (U32)(((sequence >> 24) * prime8bytes) >> (64 - hashLog));
+    }
+}
+
+LZ4_FORCE_INLINE U32 LZ4_hashPosition(const void* const p, tableType_t const tableType)
+{
+    if ((sizeof(reg_t)==8) && (tableType != byU16)) return LZ4_hash5(LZ4_read_ARCH(p), tableType);
+    return LZ4_hash4(LZ4_read32(p), tableType);
+}
+
+LZ4_FORCE_INLINE void LZ4_clearHash(U32 h, void* tableBase, tableType_t const tableType)
+{
+    switch (tableType)
+    {
+    default: /* fallthrough */
+    case clearedTable: { /* illegal! */ assert(0); return; }
+    case byPtr: { const BYTE** hashTable = (const BYTE**)tableBase; hashTable[h] = NULL; return; }
+    case byU32: { U32* hashTable = (U32*) tableBase; hashTable[h] = 0; return; }
+    case byU16: { U16* hashTable = (U16*) tableBase; hashTable[h] = 0; return; }
+    }
+}
+
+LZ4_FORCE_INLINE void LZ4_putIndexOnHash(U32 idx, U32 h, void* tableBase, tableType_t const tableType)
+{
+    switch (tableType)
+    {
+    default: /* fallthrough */
+    case clearedTable: /* fallthrough */
+    case byPtr: { /* illegal! */ assert(0); return; }
+    case byU32: { U32* hashTable = (U32*) tableBase; hashTable[h] = idx; return; }
+    case byU16: { U16* hashTable = (U16*) tableBase; assert(idx < 65536); hashTable[h] = (U16)idx; return; }
+    }
+}
+
+LZ4_FORCE_INLINE void LZ4_putPositionOnHash(const BYTE* p, U32 h,
+                                  void* tableBase, tableType_t const tableType,
+                            const BYTE* srcBase)
+{
+    switch (tableType)
+    {
+    case clearedTable: { /* illegal! */ assert(0); return; }
+    case byPtr: { const BYTE** hashTable = (const BYTE**)tableBase; hashTable[h] = p; return; }
+    case byU32: { U32* hashTable = (U32*) tableBase; hashTable[h] = (U32)(p-srcBase); return; }
+    case byU16: { U16* hashTable = (U16*) tableBase; hashTable[h] = (U16)(p-srcBase); return; }
+    }
+}
+
+LZ4_FORCE_INLINE void LZ4_putPosition(const BYTE* p, void* tableBase, tableType_t tableType, const BYTE* srcBase)
+{
+    U32 const h = LZ4_hashPosition(p, tableType);
+    LZ4_putPositionOnHash(p, h, tableBase, tableType, srcBase);
+}
+
+/* LZ4_getIndexOnHash() :
+ * Index of match position registered in hash table.
+ * hash position must be calculated by using base+index, or dictBase+index.
+ * Assumption 1 : only valid if tableType == byU32 or byU16.
+ * Assumption 2 : h is presumed valid (within limits of hash table)
+ */
+LZ4_FORCE_INLINE U32 LZ4_getIndexOnHash(U32 h, const void* tableBase, tableType_t tableType)
+{
+    LZ4_STATIC_ASSERT(LZ4_MEMORY_USAGE > 2);
+    if (tableType == byU32) {
+        const U32* const hashTable = (const U32*) tableBase;
+        assert(h < (1U << (LZ4_MEMORY_USAGE-2)));
+        return hashTable[h];
+    }
+    if (tableType == byU16) {
+        const U16* const hashTable = (const U16*) tableBase;
+        assert(h < (1U << (LZ4_MEMORY_USAGE-1)));
+        return hashTable[h];
+    }
+    assert(0); return 0;  /* forbidden case */
+}
+
+static const BYTE* LZ4_getPositionOnHash(U32 h, const void* tableBase, tableType_t tableType, const BYTE* srcBase)
+{
+    if (tableType == byPtr) { const BYTE* const* hashTable = (const BYTE* const*) tableBase; return hashTable[h]; }
+    if (tableType == byU32) { const U32* const hashTable = (const U32*) tableBase; return hashTable[h] + srcBase; }
+    { const U16* const hashTable = (const U16*) tableBase; return hashTable[h] + srcBase; }   /* default, to ensure a return */
+}
+
+LZ4_FORCE_INLINE const BYTE*
+LZ4_getPosition(const BYTE* p,
+                const void* tableBase, tableType_t tableType,
+                const BYTE* srcBase)
+{
+    U32 const h = LZ4_hashPosition(p, tableType);
+    return LZ4_getPositionOnHash(h, tableBase, tableType, srcBase);
+}
+
+LZ4_FORCE_INLINE void
+LZ4_prepareTable(LZ4_stream_t_internal* const cctx,
+           const int inputSize,
+           const tableType_t tableType) {
+    /* If the table hasn't been used, it's guaranteed to be zeroed out, and is
+     * therefore safe to use no matter what mode we're in. Otherwise, we figure
+     * out if it's safe to leave as is or whether it needs to be reset.
+     */
+    if ((tableType_t)cctx->tableType != clearedTable) {
+        assert(inputSize >= 0);
+        if ((tableType_t)cctx->tableType != tableType
+          || ((tableType == byU16) && cctx->currentOffset + (unsigned)inputSize >= 0xFFFFU)
+          || ((tableType == byU32) && cctx->currentOffset > 1 GB)
+          || tableType == byPtr
+          || inputSize >= 4 KB)
+        {
+            DEBUGLOG(4, "LZ4_prepareTable: Resetting table in %p", cctx);
+            MEM_INIT(cctx->hashTable, 0, LZ4_HASHTABLESIZE);
+            cctx->currentOffset = 0;
+            cctx->tableType = (U32)clearedTable;
+        } else {
+            DEBUGLOG(4, "LZ4_prepareTable: Re-use hash table (no reset)");
+        }
+    }
+
+    /* Adding a gap, so all previous entries are > LZ4_DISTANCE_MAX back, is faster
+     * than compressing without a gap. However, compressing with
+     * currentOffset == 0 is faster still, so we preserve that case.
+     */
+    if (cctx->currentOffset != 0 && tableType == byU32) {
+        DEBUGLOG(5, "LZ4_prepareTable: adding 64KB to currentOffset");
+        cctx->currentOffset += 64 KB;
+    }
+
+    /* Finally, clear history */
+    cctx->dictCtx = NULL;
+    cctx->dictionary = NULL;
+    cctx->dictSize = 0;
+}
+
+/** LZ4_compress_generic() :
+ *  inlined, to ensure branches are decided at compilation time.
+ *  Presumed already validated at this stage:
+ *  - source != NULL
+ *  - inputSize > 0
+ */
+LZ4_FORCE_INLINE int LZ4_compress_generic_validated(
+                 LZ4_stream_t_internal* const cctx,
+                 const char* const source,
+                 char* const dest,
+                 const int inputSize,
+                 int *inputConsumed, /* only written when outputDirective == fillOutput */
+                 const int maxOutputSize,
+                 const limitedOutput_directive outputDirective,
+                 const tableType_t tableType,
+                 const dict_directive dictDirective,
+                 const dictIssue_directive dictIssue,
+                 const int acceleration)
+{
+    int result;
+    const BYTE* ip = (const BYTE*) source;
+
+    U32 const startIndex = cctx->currentOffset;
+    const BYTE* base = (const BYTE*) source - startIndex;
+    const BYTE* lowLimit;
+
+    const LZ4_stream_t_internal* dictCtx = (const LZ4_stream_t_internal*) cctx->dictCtx;
+    const BYTE* const dictionary =
+        dictDirective == usingDictCtx ? dictCtx->dictionary : cctx->dictionary;
+    const U32 dictSize =
+        dictDirective == usingDictCtx ? dictCtx->dictSize : cctx->dictSize;
+    const U32 dictDelta = (dictDirective == usingDictCtx) ? startIndex - dictCtx->currentOffset : 0;   /* make indexes in dictCtx comparable with index in current context */
+
+    int const maybe_extMem = (dictDirective == usingExtDict) || (dictDirective == usingDictCtx);
+    U32 const prefixIdxLimit = startIndex - dictSize;   /* used when dictDirective == dictSmall */
+    const BYTE* const dictEnd = dictionary ? dictionary + dictSize : dictionary;
+    const BYTE* anchor = (const BYTE*) source;
+    const BYTE* const iend = ip + inputSize;
+    const BYTE* const mflimitPlusOne = iend - MFLIMIT + 1;
+    const BYTE* const matchlimit = iend - LASTLITERALS;
+
+    /* the dictCtx currentOffset is indexed on the start of the dictionary,
+     * while a dictionary in the current context precedes the currentOffset */
+    const BYTE* dictBase = !dictionary ? NULL : (dictDirective == usingDictCtx) ?
+                            dictionary + dictSize - dictCtx->currentOffset :
+                            dictionary + dictSize - startIndex;
+
+    BYTE* op = (BYTE*) dest;
+    BYTE* const olimit = op + maxOutputSize;
+
+    U32 offset = 0;
+    U32 forwardH;
+
+    DEBUGLOG(5, "LZ4_compress_generic_validated: srcSize=%i, tableType=%u", inputSize, tableType);
+    assert(ip != NULL);
+    /* If init conditions are not met, we don't have to mark stream
+     * as having dirty context, since no action was taken yet */
+    if (outputDirective == fillOutput && maxOutputSize < 1) { return 0; } /* Impossible to store anything */
+    if ((tableType == byU16) && (inputSize>=LZ4_64Klimit)) { return 0; }  /* Size too large (not within 64K limit) */
+    if (tableType==byPtr) assert(dictDirective==noDict);      /* only supported use case with byPtr */
+    assert(acceleration >= 1);
+
+    lowLimit = (const BYTE*)source - (dictDirective == withPrefix64k ? dictSize : 0);
+
+    /* Update context state */
+    if (dictDirective == usingDictCtx) {
+        /* Subsequent linked blocks can't use the dictionary. */
+        /* Instead, they use the block we just compressed. */
+        cctx->dictCtx = NULL;
+        cctx->dictSize = (U32)inputSize;
+    } else {
+        cctx->dictSize += (U32)inputSize;
+    }
+    cctx->currentOffset += (U32)inputSize;
+    cctx->tableType = (U32)tableType;
+
+    if (inputSizehashTable, tableType, base);
+    ip++; forwardH = LZ4_hashPosition(ip, tableType);
+
+    /* Main Loop */
+    for ( ; ; ) {
+        const BYTE* match;
+        BYTE* token;
+        const BYTE* filledIp;
+
+        /* Find a match */
+        if (tableType == byPtr) {
+            const BYTE* forwardIp = ip;
+            int step = 1;
+            int searchMatchNb = acceleration << LZ4_skipTrigger;
+            do {
+                U32 const h = forwardH;
+                ip = forwardIp;
+                forwardIp += step;
+                step = (searchMatchNb++ >> LZ4_skipTrigger);
+
+                if (unlikely(forwardIp > mflimitPlusOne)) goto _last_literals;
+                assert(ip < mflimitPlusOne);
+
+                match = LZ4_getPositionOnHash(h, cctx->hashTable, tableType, base);
+                forwardH = LZ4_hashPosition(forwardIp, tableType);
+                LZ4_putPositionOnHash(ip, h, cctx->hashTable, tableType, base);
+
+            } while ( (match+LZ4_DISTANCE_MAX < ip)
+                   || (LZ4_read32(match) != LZ4_read32(ip)) );
+
+        } else {   /* byU32, byU16 */
+
+            const BYTE* forwardIp = ip;
+            int step = 1;
+            int searchMatchNb = acceleration << LZ4_skipTrigger;
+            do {
+                U32 const h = forwardH;
+                U32 const current = (U32)(forwardIp - base);
+                U32 matchIndex = LZ4_getIndexOnHash(h, cctx->hashTable, tableType);
+                assert(matchIndex <= current);
+                assert(forwardIp - base < (ptrdiff_t)(2 GB - 1));
+                ip = forwardIp;
+                forwardIp += step;
+                step = (searchMatchNb++ >> LZ4_skipTrigger);
+
+                if (unlikely(forwardIp > mflimitPlusOne)) goto _last_literals;
+                assert(ip < mflimitPlusOne);
+
+                if (dictDirective == usingDictCtx) {
+                    if (matchIndex < startIndex) {
+                        /* there was no match, try the dictionary */
+                        assert(tableType == byU32);
+                        matchIndex = LZ4_getIndexOnHash(h, dictCtx->hashTable, byU32);
+                        match = dictBase + matchIndex;
+                        matchIndex += dictDelta;   /* make dictCtx index comparable with current context */
+                        lowLimit = dictionary;
+                    } else {
+                        match = base + matchIndex;
+                        lowLimit = (const BYTE*)source;
+                    }
+                } else if (dictDirective==usingExtDict) {
+                    if (matchIndex < startIndex) {
+                        DEBUGLOG(7, "extDict candidate: matchIndex=%5u  <  startIndex=%5u", matchIndex, startIndex);
+                        assert(startIndex - matchIndex >= MINMATCH);
+                        match = dictBase + matchIndex;
+                        lowLimit = dictionary;
+                    } else {
+                        match = base + matchIndex;
+                        lowLimit = (const BYTE*)source;
+                    }
+                } else {   /* single continuous memory segment */
+                    match = base + matchIndex;
+                }
+                forwardH = LZ4_hashPosition(forwardIp, tableType);
+                LZ4_putIndexOnHash(current, h, cctx->hashTable, tableType);
+
+                DEBUGLOG(7, "candidate at pos=%u  (offset=%u \n", matchIndex, current - matchIndex);
+                if ((dictIssue == dictSmall) && (matchIndex < prefixIdxLimit)) { continue; }    /* match outside of valid area */
+                assert(matchIndex < current);
+                if ( ((tableType != byU16) || (LZ4_DISTANCE_MAX < LZ4_DISTANCE_ABSOLUTE_MAX))
+                  && (matchIndex+LZ4_DISTANCE_MAX < current)) {
+                    continue;
+                } /* too far */
+                assert((current - matchIndex) <= LZ4_DISTANCE_MAX);  /* match now expected within distance */
+
+                if (LZ4_read32(match) == LZ4_read32(ip)) {
+                    if (maybe_extMem) offset = current - matchIndex;
+                    break;   /* match found */
+                }
+
+            } while(1);
+        }
+
+        /* Catch up */
+        filledIp = ip;
+        while (((ip>anchor) & (match > lowLimit)) && (unlikely(ip[-1]==match[-1]))) { ip--; match--; }
+
+        /* Encode Literals */
+        {   unsigned const litLength = (unsigned)(ip - anchor);
+            token = op++;
+            if ((outputDirective == limitedOutput) &&  /* Check output buffer overflow */
+                (unlikely(op + litLength + (2 + 1 + LASTLITERALS) + (litLength/255) > olimit)) ) {
+                return 0;   /* cannot compress within `dst` budget. Stored indexes in hash table are nonetheless fine */
+            }
+            if ((outputDirective == fillOutput) &&
+                (unlikely(op + (litLength+240)/255 /* litlen */ + litLength /* literals */ + 2 /* offset */ + 1 /* token */ + MFLIMIT - MINMATCH /* min last literals so last match is <= end - MFLIMIT */ > olimit))) {
+                op--;
+                goto _last_literals;
+            }
+            if (litLength >= RUN_MASK) {
+                int len = (int)(litLength - RUN_MASK);
+                *token = (RUN_MASK<= 255 ; len-=255) *op++ = 255;
+                *op++ = (BYTE)len;
+            }
+            else *token = (BYTE)(litLength< olimit)) {
+            /* the match was too close to the end, rewind and go to last literals */
+            op = token;
+            goto _last_literals;
+        }
+
+        /* Encode Offset */
+        if (maybe_extMem) {   /* static test */
+            DEBUGLOG(6, "             with offset=%u  (ext if > %i)", offset, (int)(ip - (const BYTE*)source));
+            assert(offset <= LZ4_DISTANCE_MAX && offset > 0);
+            LZ4_writeLE16(op, (U16)offset); op+=2;
+        } else  {
+            DEBUGLOG(6, "             with offset=%u  (same segment)", (U32)(ip - match));
+            assert(ip-match <= LZ4_DISTANCE_MAX);
+            LZ4_writeLE16(op, (U16)(ip - match)); op+=2;
+        }
+
+        /* Encode MatchLength */
+        {   unsigned matchCode;
+
+            if ( (dictDirective==usingExtDict || dictDirective==usingDictCtx)
+              && (lowLimit==dictionary) /* match within extDict */ ) {
+                const BYTE* limit = ip + (dictEnd-match);
+                assert(dictEnd > match);
+                if (limit > matchlimit) limit = matchlimit;
+                matchCode = LZ4_count(ip+MINMATCH, match+MINMATCH, limit);
+                ip += (size_t)matchCode + MINMATCH;
+                if (ip==limit) {
+                    unsigned const more = LZ4_count(limit, (const BYTE*)source, matchlimit);
+                    matchCode += more;
+                    ip += more;
+                }
+                DEBUGLOG(6, "             with matchLength=%u starting in extDict", matchCode+MINMATCH);
+            } else {
+                matchCode = LZ4_count(ip+MINMATCH, match+MINMATCH, matchlimit);
+                ip += (size_t)matchCode + MINMATCH;
+                DEBUGLOG(6, "             with matchLength=%u", matchCode+MINMATCH);
+            }
+
+            if ((outputDirective) &&    /* Check output buffer overflow */
+                (unlikely(op + (1 + LASTLITERALS) + (matchCode+240)/255 > olimit)) ) {
+                if (outputDirective == fillOutput) {
+                    /* Match description too long : reduce it */
+                    U32 newMatchCode = 15 /* in token */ - 1 /* to avoid needing a zero byte */ + ((U32)(olimit - op) - 1 - LASTLITERALS) * 255;
+                    ip -= matchCode - newMatchCode;
+                    assert(newMatchCode < matchCode);
+                    matchCode = newMatchCode;
+                    if (unlikely(ip <= filledIp)) {
+                        /* We have already filled up to filledIp so if ip ends up less than filledIp
+                         * we have positions in the hash table beyond the current position. This is
+                         * a problem if we reuse the hash table. So we have to remove these positions
+                         * from the hash table.
+                         */
+                        const BYTE* ptr;
+                        DEBUGLOG(5, "Clearing %u positions", (U32)(filledIp - ip));
+                        for (ptr = ip; ptr <= filledIp; ++ptr) {
+                            U32 const h = LZ4_hashPosition(ptr, tableType);
+                            LZ4_clearHash(h, cctx->hashTable, tableType);
+                        }
+                    }
+                } else {
+                    assert(outputDirective == limitedOutput);
+                    return 0;   /* cannot compress within `dst` budget. Stored indexes in hash table are nonetheless fine */
+                }
+            }
+            if (matchCode >= ML_MASK) {
+                *token += ML_MASK;
+                matchCode -= ML_MASK;
+                LZ4_write32(op, 0xFFFFFFFF);
+                while (matchCode >= 4*255) {
+                    op+=4;
+                    LZ4_write32(op, 0xFFFFFFFF);
+                    matchCode -= 4*255;
+                }
+                op += matchCode / 255;
+                *op++ = (BYTE)(matchCode % 255);
+            } else
+                *token += (BYTE)(matchCode);
+        }
+        /* Ensure we have enough space for the last literals. */
+        assert(!(outputDirective == fillOutput && op + 1 + LASTLITERALS > olimit));
+
+        anchor = ip;
+
+        /* Test end of chunk */
+        if (ip >= mflimitPlusOne) break;
+
+        /* Fill table */
+        LZ4_putPosition(ip-2, cctx->hashTable, tableType, base);
+
+        /* Test next position */
+        if (tableType == byPtr) {
+
+            match = LZ4_getPosition(ip, cctx->hashTable, tableType, base);
+            LZ4_putPosition(ip, cctx->hashTable, tableType, base);
+            if ( (match+LZ4_DISTANCE_MAX >= ip)
+              && (LZ4_read32(match) == LZ4_read32(ip)) )
+            { token=op++; *token=0; goto _next_match; }
+
+        } else {   /* byU32, byU16 */
+
+            U32 const h = LZ4_hashPosition(ip, tableType);
+            U32 const current = (U32)(ip-base);
+            U32 matchIndex = LZ4_getIndexOnHash(h, cctx->hashTable, tableType);
+            assert(matchIndex < current);
+            if (dictDirective == usingDictCtx) {
+                if (matchIndex < startIndex) {
+                    /* there was no match, try the dictionary */
+                    matchIndex = LZ4_getIndexOnHash(h, dictCtx->hashTable, byU32);
+                    match = dictBase + matchIndex;
+                    lowLimit = dictionary;   /* required for match length counter */
+                    matchIndex += dictDelta;
+                } else {
+                    match = base + matchIndex;
+                    lowLimit = (const BYTE*)source;  /* required for match length counter */
+                }
+            } else if (dictDirective==usingExtDict) {
+                if (matchIndex < startIndex) {
+                    match = dictBase + matchIndex;
+                    lowLimit = dictionary;   /* required for match length counter */
+                } else {
+                    match = base + matchIndex;
+                    lowLimit = (const BYTE*)source;   /* required for match length counter */
+                }
+            } else {   /* single memory segment */
+                match = base + matchIndex;
+            }
+            LZ4_putIndexOnHash(current, h, cctx->hashTable, tableType);
+            assert(matchIndex < current);
+            if ( ((dictIssue==dictSmall) ? (matchIndex >= prefixIdxLimit) : 1)
+              && (((tableType==byU16) && (LZ4_DISTANCE_MAX == LZ4_DISTANCE_ABSOLUTE_MAX)) ? 1 : (matchIndex+LZ4_DISTANCE_MAX >= current))
+              && (LZ4_read32(match) == LZ4_read32(ip)) ) {
+                token=op++;
+                *token=0;
+                if (maybe_extMem) offset = current - matchIndex;
+                DEBUGLOG(6, "seq.start:%i, literals=%u, match.start:%i",
+                            (int)(anchor-(const BYTE*)source), 0, (int)(ip-(const BYTE*)source));
+                goto _next_match;
+            }
+        }
+
+        /* Prepare next loop */
+        forwardH = LZ4_hashPosition(++ip, tableType);
+
+    }
+
+_last_literals:
+    /* Encode Last Literals */
+    {   size_t lastRun = (size_t)(iend - anchor);
+        if ( (outputDirective) &&  /* Check output buffer overflow */
+            (op + lastRun + 1 + ((lastRun+255-RUN_MASK)/255) > olimit)) {
+            if (outputDirective == fillOutput) {
+                /* adapt lastRun to fill 'dst' */
+                assert(olimit >= op);
+                lastRun  = (size_t)(olimit-op) - 1/*token*/;
+                lastRun -= (lastRun + 256 - RUN_MASK) / 256;  /*additional length tokens*/
+            } else {
+                assert(outputDirective == limitedOutput);
+                return 0;   /* cannot compress within `dst` budget. Stored indexes in hash table are nonetheless fine */
+            }
+        }
+        DEBUGLOG(6, "Final literal run : %i literals", (int)lastRun);
+        if (lastRun >= RUN_MASK) {
+            size_t accumulator = lastRun - RUN_MASK;
+            *op++ = RUN_MASK << ML_BITS;
+            for(; accumulator >= 255 ; accumulator-=255) *op++ = 255;
+            *op++ = (BYTE) accumulator;
+        } else {
+            *op++ = (BYTE)(lastRun< 0);
+    DEBUGLOG(5, "LZ4_compress_generic: compressed %i bytes into %i bytes", inputSize, result);
+    return result;
+}
+
+/** LZ4_compress_generic() :
+ *  inlined, to ensure branches are decided at compilation time;
+ *  takes care of src == (NULL, 0)
+ *  and forward the rest to LZ4_compress_generic_validated */
+LZ4_FORCE_INLINE int LZ4_compress_generic(
+                 LZ4_stream_t_internal* const cctx,
+                 const char* const src,
+                 char* const dst,
+                 const int srcSize,
+                 int *inputConsumed, /* only written when outputDirective == fillOutput */
+                 const int dstCapacity,
+                 const limitedOutput_directive outputDirective,
+                 const tableType_t tableType,
+                 const dict_directive dictDirective,
+                 const dictIssue_directive dictIssue,
+                 const int acceleration)
+{
+    DEBUGLOG(5, "LZ4_compress_generic: srcSize=%i, dstCapacity=%i",
+                srcSize, dstCapacity);
+
+    if ((U32)srcSize > (U32)LZ4_MAX_INPUT_SIZE) { return 0; }  /* Unsupported srcSize, too large (or negative) */
+    if (srcSize == 0) {   /* src == NULL supported if srcSize == 0 */
+        if (outputDirective != notLimited && dstCapacity <= 0) return 0;  /* no output, can't write anything */
+        DEBUGLOG(5, "Generating an empty block");
+        assert(outputDirective == notLimited || dstCapacity >= 1);
+        assert(dst != NULL);
+        dst[0] = 0;
+        if (outputDirective == fillOutput) {
+            assert (inputConsumed != NULL);
+            *inputConsumed = 0;
+        }
+        return 1;
+    }
+    assert(src != NULL);
+
+    return LZ4_compress_generic_validated(cctx, src, dst, srcSize,
+                inputConsumed, /* only written into if outputDirective == fillOutput */
+                dstCapacity, outputDirective,
+                tableType, dictDirective, dictIssue, acceleration);
+}
+
+
+int LZ4_compress_fast_extState(void* state, const char* source, char* dest, int inputSize, int maxOutputSize, int acceleration)
+{
+    LZ4_stream_t_internal* const ctx = & LZ4_initStream(state, sizeof(LZ4_stream_t)) -> internal_donotuse;
+    assert(ctx != NULL);
+    if (acceleration < 1) acceleration = LZ4_ACCELERATION_DEFAULT;
+    if (acceleration > LZ4_ACCELERATION_MAX) acceleration = LZ4_ACCELERATION_MAX;
+    if (maxOutputSize >= LZ4_compressBound(inputSize)) {
+        if (inputSize < LZ4_64Klimit) {
+            return LZ4_compress_generic(ctx, source, dest, inputSize, NULL, 0, notLimited, byU16, noDict, noDictIssue, acceleration);
+        } else {
+            const tableType_t tableType = ((sizeof(void*)==4) && ((uptrval)source > LZ4_DISTANCE_MAX)) ? byPtr : byU32;
+            return LZ4_compress_generic(ctx, source, dest, inputSize, NULL, 0, notLimited, tableType, noDict, noDictIssue, acceleration);
+        }
+    } else {
+        if (inputSize < LZ4_64Klimit) {
+            return LZ4_compress_generic(ctx, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, byU16, noDict, noDictIssue, acceleration);
+        } else {
+            const tableType_t tableType = ((sizeof(void*)==4) && ((uptrval)source > LZ4_DISTANCE_MAX)) ? byPtr : byU32;
+            return LZ4_compress_generic(ctx, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, noDict, noDictIssue, acceleration);
+        }
+    }
+}
+
+/**
+ * LZ4_compress_fast_extState_fastReset() :
+ * A variant of LZ4_compress_fast_extState().
+ *
+ * Using this variant avoids an expensive initialization step. It is only safe
+ * to call if the state buffer is known to be correctly initialized already
+ * (see comment in lz4.h on LZ4_resetStream_fast() for a definition of
+ * "correctly initialized").
+ */
+int LZ4_compress_fast_extState_fastReset(void* state, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration)
+{
+    LZ4_stream_t_internal* ctx = &((LZ4_stream_t*)state)->internal_donotuse;
+    if (acceleration < 1) acceleration = LZ4_ACCELERATION_DEFAULT;
+    if (acceleration > LZ4_ACCELERATION_MAX) acceleration = LZ4_ACCELERATION_MAX;
+
+    if (dstCapacity >= LZ4_compressBound(srcSize)) {
+        if (srcSize < LZ4_64Klimit) {
+            const tableType_t tableType = byU16;
+            LZ4_prepareTable(ctx, srcSize, tableType);
+            if (ctx->currentOffset) {
+                return LZ4_compress_generic(ctx, src, dst, srcSize, NULL, 0, notLimited, tableType, noDict, dictSmall, acceleration);
+            } else {
+                return LZ4_compress_generic(ctx, src, dst, srcSize, NULL, 0, notLimited, tableType, noDict, noDictIssue, acceleration);
+            }
+        } else {
+            const tableType_t tableType = ((sizeof(void*)==4) && ((uptrval)src > LZ4_DISTANCE_MAX)) ? byPtr : byU32;
+            LZ4_prepareTable(ctx, srcSize, tableType);
+            return LZ4_compress_generic(ctx, src, dst, srcSize, NULL, 0, notLimited, tableType, noDict, noDictIssue, acceleration);
+        }
+    } else {
+        if (srcSize < LZ4_64Klimit) {
+            const tableType_t tableType = byU16;
+            LZ4_prepareTable(ctx, srcSize, tableType);
+            if (ctx->currentOffset) {
+                return LZ4_compress_generic(ctx, src, dst, srcSize, NULL, dstCapacity, limitedOutput, tableType, noDict, dictSmall, acceleration);
+            } else {
+                return LZ4_compress_generic(ctx, src, dst, srcSize, NULL, dstCapacity, limitedOutput, tableType, noDict, noDictIssue, acceleration);
+            }
+        } else {
+            const tableType_t tableType = ((sizeof(void*)==4) && ((uptrval)src > LZ4_DISTANCE_MAX)) ? byPtr : byU32;
+            LZ4_prepareTable(ctx, srcSize, tableType);
+            return LZ4_compress_generic(ctx, src, dst, srcSize, NULL, dstCapacity, limitedOutput, tableType, noDict, noDictIssue, acceleration);
+        }
+    }
+}
+
+
+int LZ4_compress_fast(const char* source, char* dest, int inputSize, int maxOutputSize, int acceleration)
+{
+    int result;
+#if (LZ4_HEAPMODE)
+    LZ4_stream_t* ctxPtr = ALLOC(sizeof(LZ4_stream_t));   /* malloc-calloc always properly aligned */
+    if (ctxPtr == NULL) return 0;
+#else
+    LZ4_stream_t ctx;
+    LZ4_stream_t* const ctxPtr = &ctx;
+#endif
+    result = LZ4_compress_fast_extState(ctxPtr, source, dest, inputSize, maxOutputSize, acceleration);
+
+#if (LZ4_HEAPMODE)
+    FREEMEM(ctxPtr);
+#endif
+    return result;
+}
+
+
+int LZ4_compress_default(const char* src, char* dst, int srcSize, int maxOutputSize)
+{
+    return LZ4_compress_fast(src, dst, srcSize, maxOutputSize, 1);
+}
+
+
+/* Note!: This function leaves the stream in an unclean/broken state!
+ * It is not safe to subsequently use the same state with a _fastReset() or
+ * _continue() call without resetting it. */
+static int LZ4_compress_destSize_extState (LZ4_stream_t* state, const char* src, char* dst, int* srcSizePtr, int targetDstSize)
+{
+    void* const s = LZ4_initStream(state, sizeof (*state));
+    assert(s != NULL); (void)s;
+
+    if (targetDstSize >= LZ4_compressBound(*srcSizePtr)) {  /* compression success is guaranteed */
+        return LZ4_compress_fast_extState(state, src, dst, *srcSizePtr, targetDstSize, 1);
+    } else {
+        if (*srcSizePtr < LZ4_64Klimit) {
+            return LZ4_compress_generic(&state->internal_donotuse, src, dst, *srcSizePtr, srcSizePtr, targetDstSize, fillOutput, byU16, noDict, noDictIssue, 1);
+        } else {
+            tableType_t const addrMode = ((sizeof(void*)==4) && ((uptrval)src > LZ4_DISTANCE_MAX)) ? byPtr : byU32;
+            return LZ4_compress_generic(&state->internal_donotuse, src, dst, *srcSizePtr, srcSizePtr, targetDstSize, fillOutput, addrMode, noDict, noDictIssue, 1);
+    }   }
+}
+
+
+int LZ4_compress_destSize(const char* src, char* dst, int* srcSizePtr, int targetDstSize)
+{
+#if (LZ4_HEAPMODE)
+    LZ4_stream_t* ctx = (LZ4_stream_t*)ALLOC(sizeof(LZ4_stream_t));   /* malloc-calloc always properly aligned */
+    if (ctx == NULL) return 0;
+#else
+    LZ4_stream_t ctxBody;
+    LZ4_stream_t* ctx = &ctxBody;
+#endif
+
+    int result = LZ4_compress_destSize_extState(ctx, src, dst, srcSizePtr, targetDstSize);
+
+#if (LZ4_HEAPMODE)
+    FREEMEM(ctx);
+#endif
+    return result;
+}
+
+
+
+/*-******************************
+*  Streaming functions
+********************************/
+
+LZ4_stream_t* LZ4_createStream(void)
+{
+    LZ4_stream_t* const lz4s = (LZ4_stream_t*)ALLOC(sizeof(LZ4_stream_t));
+    LZ4_STATIC_ASSERT(LZ4_STREAMSIZE >= sizeof(LZ4_stream_t_internal));    /* A compilation error here means LZ4_STREAMSIZE is not large enough */
+    DEBUGLOG(4, "LZ4_createStream %p", lz4s);
+    if (lz4s == NULL) return NULL;
+    LZ4_initStream(lz4s, sizeof(*lz4s));
+    return lz4s;
+}
+
+static size_t LZ4_stream_t_alignment(void)
+{
+#if LZ4_ALIGN_TEST
+    typedef struct { char c; LZ4_stream_t t; } t_a;
+    return sizeof(t_a) - sizeof(LZ4_stream_t);
+#else
+    return 1;  /* effectively disabled */
+#endif
+}
+
+LZ4_stream_t* LZ4_initStream (void* buffer, size_t size)
+{
+    DEBUGLOG(5, "LZ4_initStream");
+    if (buffer == NULL) { return NULL; }
+    if (size < sizeof(LZ4_stream_t)) { return NULL; }
+    if (!LZ4_isAligned(buffer, LZ4_stream_t_alignment())) return NULL;
+    MEM_INIT(buffer, 0, sizeof(LZ4_stream_t_internal));
+    return (LZ4_stream_t*)buffer;
+}
+
+/* resetStream is now deprecated,
+ * prefer initStream() which is more general */
+void LZ4_resetStream (LZ4_stream_t* LZ4_stream)
+{
+    DEBUGLOG(5, "LZ4_resetStream (ctx:%p)", LZ4_stream);
+    MEM_INIT(LZ4_stream, 0, sizeof(LZ4_stream_t_internal));
+}
+
+void LZ4_resetStream_fast(LZ4_stream_t* ctx) {
+    LZ4_prepareTable(&(ctx->internal_donotuse), 0, byU32);
+}
+
+int LZ4_freeStream (LZ4_stream_t* LZ4_stream)
+{
+    if (!LZ4_stream) return 0;   /* support free on NULL */
+    DEBUGLOG(5, "LZ4_freeStream %p", LZ4_stream);
+    FREEMEM(LZ4_stream);
+    return (0);
+}
+
+
+#define HASH_UNIT sizeof(reg_t)
+int LZ4_loadDict (LZ4_stream_t* LZ4_dict, const char* dictionary, int dictSize)
+{
+    LZ4_stream_t_internal* dict = &LZ4_dict->internal_donotuse;
+    const tableType_t tableType = byU32;
+    const BYTE* p = (const BYTE*)dictionary;
+    const BYTE* const dictEnd = p + dictSize;
+    const BYTE* base;
+
+    DEBUGLOG(4, "LZ4_loadDict (%i bytes from %p into %p)", dictSize, dictionary, LZ4_dict);
+
+    /* It's necessary to reset the context,
+     * and not just continue it with prepareTable()
+     * to avoid any risk of generating overflowing matchIndex
+     * when compressing using this dictionary */
+    LZ4_resetStream(LZ4_dict);
+
+    /* We always increment the offset by 64 KB, since, if the dict is longer,
+     * we truncate it to the last 64k, and if it's shorter, we still want to
+     * advance by a whole window length so we can provide the guarantee that
+     * there are only valid offsets in the window, which allows an optimization
+     * in LZ4_compress_fast_continue() where it uses noDictIssue even when the
+     * dictionary isn't a full 64k. */
+    dict->currentOffset += 64 KB;
+
+    if (dictSize < (int)HASH_UNIT) {
+        return 0;
+    }
+
+    if ((dictEnd - p) > 64 KB) p = dictEnd - 64 KB;
+    base = dictEnd - dict->currentOffset;
+    dict->dictionary = p;
+    dict->dictSize = (U32)(dictEnd - p);
+    dict->tableType = (U32)tableType;
+
+    while (p <= dictEnd-HASH_UNIT) {
+        LZ4_putPosition(p, dict->hashTable, tableType, base);
+        p+=3;
+    }
+
+    return (int)dict->dictSize;
+}
+
+void LZ4_attach_dictionary(LZ4_stream_t* workingStream, const LZ4_stream_t* dictionaryStream) {
+    const LZ4_stream_t_internal* dictCtx = dictionaryStream == NULL ? NULL :
+        &(dictionaryStream->internal_donotuse);
+
+    DEBUGLOG(4, "LZ4_attach_dictionary (%p, %p, size %u)",
+             workingStream, dictionaryStream,
+             dictCtx != NULL ? dictCtx->dictSize : 0);
+
+    if (dictCtx != NULL) {
+        /* If the current offset is zero, we will never look in the
+         * external dictionary context, since there is no value a table
+         * entry can take that indicate a miss. In that case, we need
+         * to bump the offset to something non-zero.
+         */
+        if (workingStream->internal_donotuse.currentOffset == 0) {
+            workingStream->internal_donotuse.currentOffset = 64 KB;
+        }
+
+        /* Don't actually attach an empty dictionary.
+         */
+        if (dictCtx->dictSize == 0) {
+            dictCtx = NULL;
+        }
+    }
+    workingStream->internal_donotuse.dictCtx = dictCtx;
+}
+
+
+static void LZ4_renormDictT(LZ4_stream_t_internal* LZ4_dict, int nextSize)
+{
+    assert(nextSize >= 0);
+    if (LZ4_dict->currentOffset + (unsigned)nextSize > 0x80000000) {   /* potential ptrdiff_t overflow (32-bits mode) */
+        /* rescale hash table */
+        U32 const delta = LZ4_dict->currentOffset - 64 KB;
+        const BYTE* dictEnd = LZ4_dict->dictionary + LZ4_dict->dictSize;
+        int i;
+        DEBUGLOG(4, "LZ4_renormDictT");
+        for (i=0; ihashTable[i] < delta) LZ4_dict->hashTable[i]=0;
+            else LZ4_dict->hashTable[i] -= delta;
+        }
+        LZ4_dict->currentOffset = 64 KB;
+        if (LZ4_dict->dictSize > 64 KB) LZ4_dict->dictSize = 64 KB;
+        LZ4_dict->dictionary = dictEnd - LZ4_dict->dictSize;
+    }
+}
+
+
+int LZ4_compress_fast_continue (LZ4_stream_t* LZ4_stream,
+                                const char* source, char* dest,
+                                int inputSize, int maxOutputSize,
+                                int acceleration)
+{
+    const tableType_t tableType = byU32;
+    LZ4_stream_t_internal* streamPtr = &LZ4_stream->internal_donotuse;
+    const BYTE* dictEnd = streamPtr->dictionary + streamPtr->dictSize;
+
+    DEBUGLOG(5, "LZ4_compress_fast_continue (inputSize=%i)", inputSize);
+
+    LZ4_renormDictT(streamPtr, inputSize);   /* avoid index overflow */
+    if (acceleration < 1) acceleration = LZ4_ACCELERATION_DEFAULT;
+    if (acceleration > LZ4_ACCELERATION_MAX) acceleration = LZ4_ACCELERATION_MAX;
+
+    /* invalidate tiny dictionaries */
+    if ( (streamPtr->dictSize-1 < 4-1)   /* intentional underflow */
+      && (dictEnd != (const BYTE*)source) ) {
+        DEBUGLOG(5, "LZ4_compress_fast_continue: dictSize(%u) at addr:%p is too small", streamPtr->dictSize, streamPtr->dictionary);
+        streamPtr->dictSize = 0;
+        streamPtr->dictionary = (const BYTE*)source;
+        dictEnd = (const BYTE*)source;
+    }
+
+    /* Check overlapping input/dictionary space */
+    {   const BYTE* sourceEnd = (const BYTE*) source + inputSize;
+        if ((sourceEnd > streamPtr->dictionary) && (sourceEnd < dictEnd)) {
+            streamPtr->dictSize = (U32)(dictEnd - sourceEnd);
+            if (streamPtr->dictSize > 64 KB) streamPtr->dictSize = 64 KB;
+            if (streamPtr->dictSize < 4) streamPtr->dictSize = 0;
+            streamPtr->dictionary = dictEnd - streamPtr->dictSize;
+        }
+    }
+
+    /* prefix mode : source data follows dictionary */
+    if (dictEnd == (const BYTE*)source) {
+        if ((streamPtr->dictSize < 64 KB) && (streamPtr->dictSize < streamPtr->currentOffset))
+            return LZ4_compress_generic(streamPtr, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, withPrefix64k, dictSmall, acceleration);
+        else
+            return LZ4_compress_generic(streamPtr, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, withPrefix64k, noDictIssue, acceleration);
+    }
+
+    /* external dictionary mode */
+    {   int result;
+        if (streamPtr->dictCtx) {
+            /* We depend here on the fact that dictCtx'es (produced by
+             * LZ4_loadDict) guarantee that their tables contain no references
+             * to offsets between dictCtx->currentOffset - 64 KB and
+             * dictCtx->currentOffset - dictCtx->dictSize. This makes it safe
+             * to use noDictIssue even when the dict isn't a full 64 KB.
+             */
+            if (inputSize > 4 KB) {
+                /* For compressing large blobs, it is faster to pay the setup
+                 * cost to copy the dictionary's tables into the active context,
+                 * so that the compression loop is only looking into one table.
+                 */
+                LZ4_memcpy(streamPtr, streamPtr->dictCtx, sizeof(*streamPtr));
+                result = LZ4_compress_generic(streamPtr, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, usingExtDict, noDictIssue, acceleration);
+            } else {
+                result = LZ4_compress_generic(streamPtr, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, usingDictCtx, noDictIssue, acceleration);
+            }
+        } else {
+            if ((streamPtr->dictSize < 64 KB) && (streamPtr->dictSize < streamPtr->currentOffset)) {
+                result = LZ4_compress_generic(streamPtr, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, usingExtDict, dictSmall, acceleration);
+            } else {
+                result = LZ4_compress_generic(streamPtr, source, dest, inputSize, NULL, maxOutputSize, limitedOutput, tableType, usingExtDict, noDictIssue, acceleration);
+            }
+        }
+        streamPtr->dictionary = (const BYTE*)source;
+        streamPtr->dictSize = (U32)inputSize;
+        return result;
+    }
+}
+
+
+/* Hidden debug function, to force-test external dictionary mode */
+int LZ4_compress_forceExtDict (LZ4_stream_t* LZ4_dict, const char* source, char* dest, int srcSize)
+{
+    LZ4_stream_t_internal* streamPtr = &LZ4_dict->internal_donotuse;
+    int result;
+
+    LZ4_renormDictT(streamPtr, srcSize);
+
+    if ((streamPtr->dictSize < 64 KB) && (streamPtr->dictSize < streamPtr->currentOffset)) {
+        result = LZ4_compress_generic(streamPtr, source, dest, srcSize, NULL, 0, notLimited, byU32, usingExtDict, dictSmall, 1);
+    } else {
+        result = LZ4_compress_generic(streamPtr, source, dest, srcSize, NULL, 0, notLimited, byU32, usingExtDict, noDictIssue, 1);
+    }
+
+    streamPtr->dictionary = (const BYTE*)source;
+    streamPtr->dictSize = (U32)srcSize;
+
+    return result;
+}
+
+
+/*! LZ4_saveDict() :
+ *  If previously compressed data block is not guaranteed to remain available at its memory location,
+ *  save it into a safer place (char* safeBuffer).
+ *  Note : you don't need to call LZ4_loadDict() afterwards,
+ *         dictionary is immediately usable, you can therefore call LZ4_compress_fast_continue().
+ *  Return : saved dictionary size in bytes (necessarily <= dictSize), or 0 if error.
+ */
+int LZ4_saveDict (LZ4_stream_t* LZ4_dict, char* safeBuffer, int dictSize)
+{
+    LZ4_stream_t_internal* const dict = &LZ4_dict->internal_donotuse;
+    const BYTE* const previousDictEnd = dict->dictionary + dict->dictSize;
+
+    if ((U32)dictSize > 64 KB) { dictSize = 64 KB; } /* useless to define a dictionary > 64 KB */
+    if ((U32)dictSize > dict->dictSize) { dictSize = (int)dict->dictSize; }
+
+    if (safeBuffer == NULL) assert(dictSize == 0);
+    if (dictSize > 0)
+        memmove(safeBuffer, previousDictEnd - dictSize, dictSize);
+
+    dict->dictionary = (const BYTE*)safeBuffer;
+    dict->dictSize = (U32)dictSize;
+
+    return dictSize;
+}
+
+
+
+/*-*******************************
+ *  Decompression functions
+ ********************************/
+
+typedef enum { endOnOutputSize = 0, endOnInputSize = 1 } endCondition_directive;
+typedef enum { decode_full_block = 0, partial_decode = 1 } earlyEnd_directive;
+
+#undef MIN
+#define MIN(a,b)    ( (a) < (b) ? (a) : (b) )
+
+/* Read the variable-length literal or match length.
+ *
+ * ip - pointer to use as input.
+ * lencheck - end ip.  Return an error if ip advances >= lencheck.
+ * loop_check - check ip >= lencheck in body of loop.  Returns loop_error if so.
+ * initial_check - check ip >= lencheck before start of loop.  Returns initial_error if so.
+ * error (output) - error code.  Should be set to 0 before call.
+ */
+typedef enum { loop_error = -2, initial_error = -1, ok = 0 } variable_length_error;
+LZ4_FORCE_INLINE unsigned
+read_variable_length(const BYTE**ip, const BYTE* lencheck,
+                     int loop_check, int initial_check,
+                     variable_length_error* error)
+{
+    U32 length = 0;
+    U32 s;
+    if (initial_check && unlikely((*ip) >= lencheck)) {    /* overflow detection */
+        *error = initial_error;
+        return length;
+    }
+    do {
+        s = **ip;
+        (*ip)++;
+        length += s;
+        if (loop_check && unlikely((*ip) >= lencheck)) {    /* overflow detection */
+            *error = loop_error;
+            return length;
+        }
+    } while (s==255);
+
+    return length;
+}
+
+/*! LZ4_decompress_generic() :
+ *  This generic decompression function covers all use cases.
+ *  It shall be instantiated several times, using different sets of directives.
+ *  Note that it is important for performance that this function really get inlined,
+ *  in order to remove useless branches during compilation optimization.
+ */
+LZ4_FORCE_INLINE int
+LZ4_decompress_generic(
+                 const char* const src,
+                 char* const dst,
+                 int srcSize,
+                 int outputSize,         /* If endOnInput==endOnInputSize, this value is `dstCapacity` */
+
+                 endCondition_directive endOnInput,   /* endOnOutputSize, endOnInputSize */
+                 earlyEnd_directive partialDecoding,  /* full, partial */
+                 dict_directive dict,                 /* noDict, withPrefix64k, usingExtDict */
+                 const BYTE* const lowPrefix,  /* always <= dst, == dst when no prefix */
+                 const BYTE* const dictStart,  /* only if dict==usingExtDict */
+                 const size_t dictSize         /* note : = 0 if noDict */
+                 )
+{
+    if (src == NULL) { return -1; }
+
+    {   const BYTE* ip = (const BYTE*) src;
+        const BYTE* const iend = ip + srcSize;
+
+        BYTE* op = (BYTE*) dst;
+        BYTE* const oend = op + outputSize;
+        BYTE* cpy;
+
+        const BYTE* const dictEnd = (dictStart == NULL) ? NULL : dictStart + dictSize;
+
+        const int safeDecode = (endOnInput==endOnInputSize);
+        const int checkOffset = ((safeDecode) && (dictSize < (int)(64 KB)));
+
+
+        /* Set up the "end" pointers for the shortcut. */
+        const BYTE* const shortiend = iend - (endOnInput ? 14 : 8) /*maxLL*/ - 2 /*offset*/;
+        const BYTE* const shortoend = oend - (endOnInput ? 14 : 8) /*maxLL*/ - 18 /*maxML*/;
+
+        const BYTE* match;
+        size_t offset;
+        unsigned token;
+        size_t length;
+
+
+        DEBUGLOG(5, "LZ4_decompress_generic (srcSize:%i, dstSize:%i)", srcSize, outputSize);
+
+        /* Special cases */
+        assert(lowPrefix <= op);
+        if ((endOnInput) && (unlikely(outputSize==0))) {
+            /* Empty output buffer */
+            if (partialDecoding) return 0;
+            return ((srcSize==1) && (*ip==0)) ? 0 : -1;
+        }
+        if ((!endOnInput) && (unlikely(outputSize==0))) { return (*ip==0 ? 1 : -1); }
+        if ((endOnInput) && unlikely(srcSize==0)) { return -1; }
+
+	/* Currently the fast loop shows a regression on qualcomm arm chips. */
+#if LZ4_FAST_DEC_LOOP
+        if ((oend - op) < FASTLOOP_SAFE_DISTANCE) {
+            DEBUGLOG(6, "skip fast decode loop");
+            goto safe_decode;
+        }
+
+        /* Fast loop : decode sequences as long as output < iend-FASTLOOP_SAFE_DISTANCE */
+        while (1) {
+            /* Main fastloop assertion: We can always wildcopy FASTLOOP_SAFE_DISTANCE */
+            assert(oend - op >= FASTLOOP_SAFE_DISTANCE);
+            if (endOnInput) { assert(ip < iend); }
+            token = *ip++;
+            length = token >> ML_BITS;  /* literal length */
+
+            assert(!endOnInput || ip <= iend); /* ip < iend before the increment */
+
+            /* decode literal length */
+            if (length == RUN_MASK) {
+                variable_length_error error = ok;
+                length += read_variable_length(&ip, iend-RUN_MASK, (int)endOnInput, (int)endOnInput, &error);
+                if (error == initial_error) { goto _output_error; }
+                if ((safeDecode) && unlikely((uptrval)(op)+length<(uptrval)(op))) { goto _output_error; } /* overflow detection */
+                if ((safeDecode) && unlikely((uptrval)(ip)+length<(uptrval)(ip))) { goto _output_error; } /* overflow detection */
+
+                /* copy literals */
+                cpy = op+length;
+                LZ4_STATIC_ASSERT(MFLIMIT >= WILDCOPYLENGTH);
+                if (endOnInput) {  /* LZ4_decompress_safe() */
+                    if ((cpy>oend-32) || (ip+length>iend-32)) { goto safe_literal_copy; }
+                    LZ4_wildCopy32(op, ip, cpy);
+                } else {   /* LZ4_decompress_fast() */
+                    if (cpy>oend-8) { goto safe_literal_copy; }
+                    LZ4_wildCopy8(op, ip, cpy); /* LZ4_decompress_fast() cannot copy more than 8 bytes at a time :
+                                                 * it doesn't know input length, and only relies on end-of-block properties */
+                }
+                ip += length; op = cpy;
+            } else {
+                cpy = op+length;
+                if (endOnInput) {  /* LZ4_decompress_safe() */
+                    DEBUGLOG(7, "copy %u bytes in a 16-bytes stripe", (unsigned)length);
+                    /* We don't need to check oend, since we check it once for each loop below */
+                    if (ip > iend-(16 + 1/*max lit + offset + nextToken*/)) { goto safe_literal_copy; }
+                    /* Literals can only be 14, but hope compilers optimize if we copy by a register size */
+                    LZ4_memcpy(op, ip, 16);
+                } else {  /* LZ4_decompress_fast() */
+                    /* LZ4_decompress_fast() cannot copy more than 8 bytes at a time :
+                     * it doesn't know input length, and relies on end-of-block properties */
+                    LZ4_memcpy(op, ip, 8);
+                    if (length > 8) { LZ4_memcpy(op+8, ip+8, 8); }
+                }
+                ip += length; op = cpy;
+            }
+
+            /* get offset */
+            offset = LZ4_readLE16(ip); ip+=2;
+            match = op - offset;
+            assert(match <= op);
+
+            /* get matchlength */
+            length = token & ML_MASK;
+
+            if (length == ML_MASK) {
+                variable_length_error error = ok;
+                if ((checkOffset) && (unlikely(match + dictSize < lowPrefix))) { goto _output_error; } /* Error : offset outside buffers */
+                length += read_variable_length(&ip, iend - LASTLITERALS + 1, (int)endOnInput, 0, &error);
+                if (error != ok) { goto _output_error; }
+                if ((safeDecode) && unlikely((uptrval)(op)+length<(uptrval)op)) { goto _output_error; } /* overflow detection */
+                length += MINMATCH;
+                if (op + length >= oend - FASTLOOP_SAFE_DISTANCE) {
+                    goto safe_match_copy;
+                }
+            } else {
+                length += MINMATCH;
+                if (op + length >= oend - FASTLOOP_SAFE_DISTANCE) {
+                    goto safe_match_copy;
+                }
+
+                /* Fastpath check: Avoids a branch in LZ4_wildCopy32 if true */
+                if ((dict == withPrefix64k) || (match >= lowPrefix)) {
+                    if (offset >= 8) {
+                        assert(match >= lowPrefix);
+                        assert(match <= op);
+                        assert(op + 18 <= oend);
+
+                        LZ4_memcpy(op, match, 8);
+                        LZ4_memcpy(op+8, match+8, 8);
+                        LZ4_memcpy(op+16, match+16, 2);
+                        op += length;
+                        continue;
+            }   }   }
+
+            if (checkOffset && (unlikely(match + dictSize < lowPrefix))) { goto _output_error; } /* Error : offset outside buffers */
+            /* match starting within external dictionary */
+            if ((dict==usingExtDict) && (match < lowPrefix)) {
+                if (unlikely(op+length > oend-LASTLITERALS)) {
+                    if (partialDecoding) {
+                        DEBUGLOG(7, "partialDecoding: dictionary match, close to dstEnd");
+                        length = MIN(length, (size_t)(oend-op));
+                    } else {
+                        goto _output_error;  /* end-of-block condition violated */
+                }   }
+
+                if (length <= (size_t)(lowPrefix-match)) {
+                    /* match fits entirely within external dictionary : just copy */
+                    memmove(op, dictEnd - (lowPrefix-match), length);
+                    op += length;
+                } else {
+                    /* match stretches into both external dictionary and current block */
+                    size_t const copySize = (size_t)(lowPrefix - match);
+                    size_t const restSize = length - copySize;
+                    LZ4_memcpy(op, dictEnd - copySize, copySize);
+                    op += copySize;
+                    if (restSize > (size_t)(op - lowPrefix)) {  /* overlap copy */
+                        BYTE* const endOfMatch = op + restSize;
+                        const BYTE* copyFrom = lowPrefix;
+                        while (op < endOfMatch) { *op++ = *copyFrom++; }
+                    } else {
+                        LZ4_memcpy(op, lowPrefix, restSize);
+                        op += restSize;
+                }   }
+                continue;
+            }
+
+            /* copy match within block */
+            cpy = op + length;
+
+            assert((op <= oend) && (oend-op >= 32));
+            if (unlikely(offset<16)) {
+                LZ4_memcpy_using_offset(op, match, cpy, offset);
+            } else {
+                LZ4_wildCopy32(op, match, cpy);
+            }
+
+            op = cpy;   /* wildcopy correction */
+        }
+    safe_decode:
+#endif
+
+        /* Main Loop : decode remaining sequences where output < FASTLOOP_SAFE_DISTANCE */
+        while (1) {
+            token = *ip++;
+            length = token >> ML_BITS;  /* literal length */
+
+            assert(!endOnInput || ip <= iend); /* ip < iend before the increment */
+
+            /* A two-stage shortcut for the most common case:
+             * 1) If the literal length is 0..14, and there is enough space,
+             * enter the shortcut and copy 16 bytes on behalf of the literals
+             * (in the fast mode, only 8 bytes can be safely copied this way).
+             * 2) Further if the match length is 4..18, copy 18 bytes in a similar
+             * manner; but we ensure that there's enough space in the output for
+             * those 18 bytes earlier, upon entering the shortcut (in other words,
+             * there is a combined check for both stages).
+             */
+            if ( (endOnInput ? length != RUN_MASK : length <= 8)
+                /* strictly "less than" on input, to re-enter the loop with at least one byte */
+              && likely((endOnInput ? ip < shortiend : 1) & (op <= shortoend)) ) {
+                /* Copy the literals */
+                LZ4_memcpy(op, ip, endOnInput ? 16 : 8);
+                op += length; ip += length;
+
+                /* The second stage: prepare for match copying, decode full info.
+                 * If it doesn't work out, the info won't be wasted. */
+                length = token & ML_MASK; /* match length */
+                offset = LZ4_readLE16(ip); ip += 2;
+                match = op - offset;
+                assert(match <= op); /* check overflow */
+
+                /* Do not deal with overlapping matches. */
+                if ( (length != ML_MASK)
+                  && (offset >= 8)
+                  && (dict==withPrefix64k || match >= lowPrefix) ) {
+                    /* Copy the match. */
+                    LZ4_memcpy(op + 0, match + 0, 8);
+                    LZ4_memcpy(op + 8, match + 8, 8);
+                    LZ4_memcpy(op +16, match +16, 2);
+                    op += length + MINMATCH;
+                    /* Both stages worked, load the next token. */
+                    continue;
+                }
+
+                /* The second stage didn't work out, but the info is ready.
+                 * Propel it right to the point of match copying. */
+                goto _copy_match;
+            }
+
+            /* decode literal length */
+            if (length == RUN_MASK) {
+                variable_length_error error = ok;
+                length += read_variable_length(&ip, iend-RUN_MASK, (int)endOnInput, (int)endOnInput, &error);
+                if (error == initial_error) { goto _output_error; }
+                if ((safeDecode) && unlikely((uptrval)(op)+length<(uptrval)(op))) { goto _output_error; } /* overflow detection */
+                if ((safeDecode) && unlikely((uptrval)(ip)+length<(uptrval)(ip))) { goto _output_error; } /* overflow detection */
+            }
+
+            /* copy literals */
+            cpy = op+length;
+#if LZ4_FAST_DEC_LOOP
+        safe_literal_copy:
+#endif
+            LZ4_STATIC_ASSERT(MFLIMIT >= WILDCOPYLENGTH);
+            if ( ((endOnInput) && ((cpy>oend-MFLIMIT) || (ip+length>iend-(2+1+LASTLITERALS))) )
+              || ((!endOnInput) && (cpy>oend-WILDCOPYLENGTH)) )
+            {
+                /* We've either hit the input parsing restriction or the output parsing restriction.
+                 * In the normal scenario, decoding a full block, it must be the last sequence,
+                 * otherwise it's an error (invalid input or dimensions).
+                 * In partialDecoding scenario, it's necessary to ensure there is no buffer overflow.
+                 */
+                if (partialDecoding) {
+                    /* Since we are partial decoding we may be in this block because of the output parsing
+                     * restriction, which is not valid since the output buffer is allowed to be undersized.
+                     */
+                    assert(endOnInput);
+                    DEBUGLOG(7, "partialDecoding: copying literals, close to input or output end")
+                    DEBUGLOG(7, "partialDecoding: literal length = %u", (unsigned)length);
+                    DEBUGLOG(7, "partialDecoding: remaining space in dstBuffer : %i", (int)(oend - op));
+                    DEBUGLOG(7, "partialDecoding: remaining space in srcBuffer : %i", (int)(iend - ip));
+                    /* Finishing in the middle of a literals segment,
+                     * due to lack of input.
+                     */
+                    if (ip+length > iend) {
+                        length = (size_t)(iend-ip);
+                        cpy = op + length;
+                    }
+                    /* Finishing in the middle of a literals segment,
+                     * due to lack of output space.
+                     */
+                    if (cpy > oend) {
+                        cpy = oend;
+                        assert(op<=oend);
+                        length = (size_t)(oend-op);
+                    }
+                } else {
+                    /* We must be on the last sequence because of the parsing limitations so check
+                     * that we exactly regenerate the original size (must be exact when !endOnInput).
+                     */
+                    if ((!endOnInput) && (cpy != oend)) { goto _output_error; }
+                     /* We must be on the last sequence (or invalid) because of the parsing limitations
+                      * so check that we exactly consume the input and don't overrun the output buffer.
+                      */
+                    if ((endOnInput) && ((ip+length != iend) || (cpy > oend))) {
+                        DEBUGLOG(6, "should have been last run of literals")
+                        DEBUGLOG(6, "ip(%p) + length(%i) = %p != iend (%p)", ip, (int)length, ip+length, iend);
+                        DEBUGLOG(6, "or cpy(%p) > oend(%p)", cpy, oend);
+                        goto _output_error;
+                    }
+                }
+                memmove(op, ip, length);  /* supports overlapping memory regions; only matters for in-place decompression scenarios */
+                ip += length;
+                op += length;
+                /* Necessarily EOF when !partialDecoding.
+                 * When partialDecoding, it is EOF if we've either
+                 * filled the output buffer or
+                 * can't proceed with reading an offset for following match.
+                 */
+                if (!partialDecoding || (cpy == oend) || (ip >= (iend-2))) {
+                    break;
+                }
+            } else {
+                LZ4_wildCopy8(op, ip, cpy);   /* may overwrite up to WILDCOPYLENGTH beyond cpy */
+                ip += length; op = cpy;
+            }
+
+            /* get offset */
+            offset = LZ4_readLE16(ip); ip+=2;
+            match = op - offset;
+
+            /* get matchlength */
+            length = token & ML_MASK;
+
+    _copy_match:
+            if (length == ML_MASK) {
+              variable_length_error error = ok;
+              length += read_variable_length(&ip, iend - LASTLITERALS + 1, (int)endOnInput, 0, &error);
+              if (error != ok) goto _output_error;
+                if ((safeDecode) && unlikely((uptrval)(op)+length<(uptrval)op)) goto _output_error;   /* overflow detection */
+            }
+            length += MINMATCH;
+
+#if LZ4_FAST_DEC_LOOP
+        safe_match_copy:
+#endif
+            if ((checkOffset) && (unlikely(match + dictSize < lowPrefix))) goto _output_error;   /* Error : offset outside buffers */
+            /* match starting within external dictionary */
+            if ((dict==usingExtDict) && (match < lowPrefix)) {
+                if (unlikely(op+length > oend-LASTLITERALS)) {
+                    if (partialDecoding) length = MIN(length, (size_t)(oend-op));
+                    else goto _output_error;   /* doesn't respect parsing restriction */
+                }
+
+                if (length <= (size_t)(lowPrefix-match)) {
+                    /* match fits entirely within external dictionary : just copy */
+                    memmove(op, dictEnd - (lowPrefix-match), length);
+                    op += length;
+                } else {
+                    /* match stretches into both external dictionary and current block */
+                    size_t const copySize = (size_t)(lowPrefix - match);
+                    size_t const restSize = length - copySize;
+                    LZ4_memcpy(op, dictEnd - copySize, copySize);
+                    op += copySize;
+                    if (restSize > (size_t)(op - lowPrefix)) {  /* overlap copy */
+                        BYTE* const endOfMatch = op + restSize;
+                        const BYTE* copyFrom = lowPrefix;
+                        while (op < endOfMatch) *op++ = *copyFrom++;
+                    } else {
+                        LZ4_memcpy(op, lowPrefix, restSize);
+                        op += restSize;
+                }   }
+                continue;
+            }
+            assert(match >= lowPrefix);
+
+            /* copy match within block */
+            cpy = op + length;
+
+            /* partialDecoding : may end anywhere within the block */
+            assert(op<=oend);
+            if (partialDecoding && (cpy > oend-MATCH_SAFEGUARD_DISTANCE)) {
+                size_t const mlen = MIN(length, (size_t)(oend-op));
+                const BYTE* const matchEnd = match + mlen;
+                BYTE* const copyEnd = op + mlen;
+                if (matchEnd > op) {   /* overlap copy */
+                    while (op < copyEnd) { *op++ = *match++; }
+                } else {
+                    LZ4_memcpy(op, match, mlen);
+                }
+                op = copyEnd;
+                if (op == oend) { break; }
+                continue;
+            }
+
+            if (unlikely(offset<8)) {
+                LZ4_write32(op, 0);   /* silence msan warning when offset==0 */
+                op[0] = match[0];
+                op[1] = match[1];
+                op[2] = match[2];
+                op[3] = match[3];
+                match += inc32table[offset];
+                LZ4_memcpy(op+4, match, 4);
+                match -= dec64table[offset];
+            } else {
+                LZ4_memcpy(op, match, 8);
+                match += 8;
+            }
+            op += 8;
+
+            if (unlikely(cpy > oend-MATCH_SAFEGUARD_DISTANCE)) {
+                BYTE* const oCopyLimit = oend - (WILDCOPYLENGTH-1);
+                if (cpy > oend-LASTLITERALS) { goto _output_error; } /* Error : last LASTLITERALS bytes must be literals (uncompressed) */
+                if (op < oCopyLimit) {
+                    LZ4_wildCopy8(op, match, oCopyLimit);
+                    match += oCopyLimit - op;
+                    op = oCopyLimit;
+                }
+                while (op < cpy) { *op++ = *match++; }
+            } else {
+                LZ4_memcpy(op, match, 8);
+                if (length > 16)  { LZ4_wildCopy8(op+8, match+8, cpy); }
+            }
+            op = cpy;   /* wildcopy correction */
+        }
+
+        /* end of decoding */
+        if (endOnInput) {
+            DEBUGLOG(5, "decoded %i bytes", (int) (((char*)op)-dst));
+           return (int) (((char*)op)-dst);     /* Nb of output bytes decoded */
+       } else {
+           return (int) (((const char*)ip)-src);   /* Nb of input bytes read */
+       }
+
+        /* Overflow error detected */
+    _output_error:
+        return (int) (-(((const char*)ip)-src))-1;
+    }
+}
+
+
+/*===== Instantiate the API decoding functions. =====*/
+
+LZ4_FORCE_O2
+int LZ4_decompress_safe(const char* source, char* dest, int compressedSize, int maxDecompressedSize)
+{
+    return LZ4_decompress_generic(source, dest, compressedSize, maxDecompressedSize,
+                                  endOnInputSize, decode_full_block, noDict,
+                                  (BYTE*)dest, NULL, 0);
+}
+
+LZ4_FORCE_O2
+int LZ4_decompress_safe_partial(const char* src, char* dst, int compressedSize, int targetOutputSize, int dstCapacity)
+{
+    dstCapacity = MIN(targetOutputSize, dstCapacity);
+    return LZ4_decompress_generic(src, dst, compressedSize, dstCapacity,
+                                  endOnInputSize, partial_decode,
+                                  noDict, (BYTE*)dst, NULL, 0);
+}
+
+LZ4_FORCE_O2
+int LZ4_decompress_fast(const char* source, char* dest, int originalSize)
+{
+    return LZ4_decompress_generic(source, dest, 0, originalSize,
+                                  endOnOutputSize, decode_full_block, withPrefix64k,
+                                  (BYTE*)dest - 64 KB, NULL, 0);
+}
+
+/*===== Instantiate a few more decoding cases, used more than once. =====*/
+
+LZ4_FORCE_O2 /* Exported, an obsolete API function. */
+int LZ4_decompress_safe_withPrefix64k(const char* source, char* dest, int compressedSize, int maxOutputSize)
+{
+    return LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize,
+                                  endOnInputSize, decode_full_block, withPrefix64k,
+                                  (BYTE*)dest - 64 KB, NULL, 0);
+}
+
+/* Another obsolete API function, paired with the previous one. */
+int LZ4_decompress_fast_withPrefix64k(const char* source, char* dest, int originalSize)
+{
+    /* LZ4_decompress_fast doesn't validate match offsets,
+     * and thus serves well with any prefixed dictionary. */
+    return LZ4_decompress_fast(source, dest, originalSize);
+}
+
+LZ4_FORCE_O2
+static int LZ4_decompress_safe_withSmallPrefix(const char* source, char* dest, int compressedSize, int maxOutputSize,
+                                               size_t prefixSize)
+{
+    return LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize,
+                                  endOnInputSize, decode_full_block, noDict,
+                                  (BYTE*)dest-prefixSize, NULL, 0);
+}
+
+LZ4_FORCE_O2
+int LZ4_decompress_safe_forceExtDict(const char* source, char* dest,
+                                     int compressedSize, int maxOutputSize,
+                                     const void* dictStart, size_t dictSize)
+{
+    return LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize,
+                                  endOnInputSize, decode_full_block, usingExtDict,
+                                  (BYTE*)dest, (const BYTE*)dictStart, dictSize);
+}
+
+LZ4_FORCE_O2
+static int LZ4_decompress_fast_extDict(const char* source, char* dest, int originalSize,
+                                       const void* dictStart, size_t dictSize)
+{
+    return LZ4_decompress_generic(source, dest, 0, originalSize,
+                                  endOnOutputSize, decode_full_block, usingExtDict,
+                                  (BYTE*)dest, (const BYTE*)dictStart, dictSize);
+}
+
+/* The "double dictionary" mode, for use with e.g. ring buffers: the first part
+ * of the dictionary is passed as prefix, and the second via dictStart + dictSize.
+ * These routines are used only once, in LZ4_decompress_*_continue().
+ */
+LZ4_FORCE_INLINE
+int LZ4_decompress_safe_doubleDict(const char* source, char* dest, int compressedSize, int maxOutputSize,
+                                   size_t prefixSize, const void* dictStart, size_t dictSize)
+{
+    return LZ4_decompress_generic(source, dest, compressedSize, maxOutputSize,
+                                  endOnInputSize, decode_full_block, usingExtDict,
+                                  (BYTE*)dest-prefixSize, (const BYTE*)dictStart, dictSize);
+}
+
+LZ4_FORCE_INLINE
+int LZ4_decompress_fast_doubleDict(const char* source, char* dest, int originalSize,
+                                   size_t prefixSize, const void* dictStart, size_t dictSize)
+{
+    return LZ4_decompress_generic(source, dest, 0, originalSize,
+                                  endOnOutputSize, decode_full_block, usingExtDict,
+                                  (BYTE*)dest-prefixSize, (const BYTE*)dictStart, dictSize);
+}
+
+/*===== streaming decompression functions =====*/
+
+LZ4_streamDecode_t* LZ4_createStreamDecode(void)
+{
+    LZ4_streamDecode_t* lz4s = (LZ4_streamDecode_t*) ALLOC_AND_ZERO(sizeof(LZ4_streamDecode_t));
+    LZ4_STATIC_ASSERT(LZ4_STREAMDECODESIZE >= sizeof(LZ4_streamDecode_t_internal));    /* A compilation error here means LZ4_STREAMDECODESIZE is not large enough */
+    return lz4s;
+}
+
+int LZ4_freeStreamDecode (LZ4_streamDecode_t* LZ4_stream)
+{
+    if (LZ4_stream == NULL) { return 0; }  /* support free on NULL */
+    FREEMEM(LZ4_stream);
+    return 0;
+}
+
+/*! LZ4_setStreamDecode() :
+ *  Use this function to instruct where to find the dictionary.
+ *  This function is not necessary if previous data is still available where it was decoded.
+ *  Loading a size of 0 is allowed (same effect as no dictionary).
+ * @return : 1 if OK, 0 if error
+ */
+int LZ4_setStreamDecode (LZ4_streamDecode_t* LZ4_streamDecode, const char* dictionary, int dictSize)
+{
+    LZ4_streamDecode_t_internal* lz4sd = &LZ4_streamDecode->internal_donotuse;
+    lz4sd->prefixSize = (size_t) dictSize;
+    lz4sd->prefixEnd = (const BYTE*) dictionary + dictSize;
+    lz4sd->externalDict = NULL;
+    lz4sd->extDictSize  = 0;
+    return 1;
+}
+
+/*! LZ4_decoderRingBufferSize() :
+ *  when setting a ring buffer for streaming decompression (optional scenario),
+ *  provides the minimum size of this ring buffer
+ *  to be compatible with any source respecting maxBlockSize condition.
+ *  Note : in a ring buffer scenario,
+ *  blocks are presumed decompressed next to each other.
+ *  When not enough space remains for next block (remainingSize < maxBlockSize),
+ *  decoding resumes from beginning of ring buffer.
+ * @return : minimum ring buffer size,
+ *           or 0 if there is an error (invalid maxBlockSize).
+ */
+int LZ4_decoderRingBufferSize(int maxBlockSize)
+{
+    if (maxBlockSize < 0) return 0;
+    if (maxBlockSize > LZ4_MAX_INPUT_SIZE) return 0;
+    if (maxBlockSize < 16) maxBlockSize = 16;
+    return LZ4_DECODER_RING_BUFFER_SIZE(maxBlockSize);
+}
+
+/*
+*_continue() :
+    These decoding functions allow decompression of multiple blocks in "streaming" mode.
+    Previously decoded blocks must still be available at the memory position where they were decoded.
+    If it's not possible, save the relevant part of decoded data into a safe buffer,
+    and indicate where it stands using LZ4_setStreamDecode()
+*/
+LZ4_FORCE_O2
+int LZ4_decompress_safe_continue (LZ4_streamDecode_t* LZ4_streamDecode, const char* source, char* dest, int compressedSize, int maxOutputSize)
+{
+    LZ4_streamDecode_t_internal* lz4sd = &LZ4_streamDecode->internal_donotuse;
+    int result;
+
+    if (lz4sd->prefixSize == 0) {
+        /* The first call, no dictionary yet. */
+        assert(lz4sd->extDictSize == 0);
+        result = LZ4_decompress_safe(source, dest, compressedSize, maxOutputSize);
+        if (result <= 0) return result;
+        lz4sd->prefixSize = (size_t)result;
+        lz4sd->prefixEnd = (BYTE*)dest + result;
+    } else if (lz4sd->prefixEnd == (BYTE*)dest) {
+        /* They're rolling the current segment. */
+        if (lz4sd->prefixSize >= 64 KB - 1)
+            result = LZ4_decompress_safe_withPrefix64k(source, dest, compressedSize, maxOutputSize);
+        else if (lz4sd->extDictSize == 0)
+            result = LZ4_decompress_safe_withSmallPrefix(source, dest, compressedSize, maxOutputSize,
+                                                         lz4sd->prefixSize);
+        else
+            result = LZ4_decompress_safe_doubleDict(source, dest, compressedSize, maxOutputSize,
+                                                    lz4sd->prefixSize, lz4sd->externalDict, lz4sd->extDictSize);
+        if (result <= 0) return result;
+        lz4sd->prefixSize += (size_t)result;
+        lz4sd->prefixEnd  += result;
+    } else {
+        /* The buffer wraps around, or they're switching to another buffer. */
+        lz4sd->extDictSize = lz4sd->prefixSize;
+        lz4sd->externalDict = lz4sd->prefixEnd - lz4sd->extDictSize;
+        result = LZ4_decompress_safe_forceExtDict(source, dest, compressedSize, maxOutputSize,
+                                                  lz4sd->externalDict, lz4sd->extDictSize);
+        if (result <= 0) return result;
+        lz4sd->prefixSize = (size_t)result;
+        lz4sd->prefixEnd  = (BYTE*)dest + result;
+    }
+
+    return result;
+}
+
+LZ4_FORCE_O2
+int LZ4_decompress_fast_continue (LZ4_streamDecode_t* LZ4_streamDecode, const char* source, char* dest, int originalSize)
+{
+    LZ4_streamDecode_t_internal* lz4sd = &LZ4_streamDecode->internal_donotuse;
+    int result;
+    assert(originalSize >= 0);
+
+    if (lz4sd->prefixSize == 0) {
+        assert(lz4sd->extDictSize == 0);
+        result = LZ4_decompress_fast(source, dest, originalSize);
+        if (result <= 0) return result;
+        lz4sd->prefixSize = (size_t)originalSize;
+        lz4sd->prefixEnd = (BYTE*)dest + originalSize;
+    } else if (lz4sd->prefixEnd == (BYTE*)dest) {
+        if (lz4sd->prefixSize >= 64 KB - 1 || lz4sd->extDictSize == 0)
+            result = LZ4_decompress_fast(source, dest, originalSize);
+        else
+            result = LZ4_decompress_fast_doubleDict(source, dest, originalSize,
+                                                    lz4sd->prefixSize, lz4sd->externalDict, lz4sd->extDictSize);
+        if (result <= 0) return result;
+        lz4sd->prefixSize += (size_t)originalSize;
+        lz4sd->prefixEnd  += originalSize;
+    } else {
+        lz4sd->extDictSize = lz4sd->prefixSize;
+        lz4sd->externalDict = lz4sd->prefixEnd - lz4sd->extDictSize;
+        result = LZ4_decompress_fast_extDict(source, dest, originalSize,
+                                             lz4sd->externalDict, lz4sd->extDictSize);
+        if (result <= 0) return result;
+        lz4sd->prefixSize = (size_t)originalSize;
+        lz4sd->prefixEnd  = (BYTE*)dest + originalSize;
+    }
+
+    return result;
+}
+
+
+/*
+Advanced decoding functions :
+*_usingDict() :
+    These decoding functions work the same as "_continue" ones,
+    the dictionary must be explicitly provided within parameters
+*/
+
+int LZ4_decompress_safe_usingDict(const char* source, char* dest, int compressedSize, int maxOutputSize, const char* dictStart, int dictSize)
+{
+    if (dictSize==0)
+        return LZ4_decompress_safe(source, dest, compressedSize, maxOutputSize);
+    if (dictStart+dictSize == dest) {
+        if (dictSize >= 64 KB - 1) {
+            return LZ4_decompress_safe_withPrefix64k(source, dest, compressedSize, maxOutputSize);
+        }
+        assert(dictSize >= 0);
+        return LZ4_decompress_safe_withSmallPrefix(source, dest, compressedSize, maxOutputSize, (size_t)dictSize);
+    }
+    assert(dictSize >= 0);
+    return LZ4_decompress_safe_forceExtDict(source, dest, compressedSize, maxOutputSize, dictStart, (size_t)dictSize);
+}
+
+int LZ4_decompress_fast_usingDict(const char* source, char* dest, int originalSize, const char* dictStart, int dictSize)
+{
+    if (dictSize==0 || dictStart+dictSize == dest)
+        return LZ4_decompress_fast(source, dest, originalSize);
+    assert(dictSize >= 0);
+    return LZ4_decompress_fast_extDict(source, dest, originalSize, dictStart, (size_t)dictSize);
+}
+
+
+/*=*************************************************
+*  Obsolete Functions
+***************************************************/
+/* obsolete compression functions */
+int LZ4_compress_limitedOutput(const char* source, char* dest, int inputSize, int maxOutputSize)
+{
+    return LZ4_compress_default(source, dest, inputSize, maxOutputSize);
+}
+int LZ4_compress(const char* src, char* dest, int srcSize)
+{
+    return LZ4_compress_default(src, dest, srcSize, LZ4_compressBound(srcSize));
+}
+int LZ4_compress_limitedOutput_withState (void* state, const char* src, char* dst, int srcSize, int dstSize)
+{
+    return LZ4_compress_fast_extState(state, src, dst, srcSize, dstSize, 1);
+}
+int LZ4_compress_withState (void* state, const char* src, char* dst, int srcSize)
+{
+    return LZ4_compress_fast_extState(state, src, dst, srcSize, LZ4_compressBound(srcSize), 1);
+}
+int LZ4_compress_limitedOutput_continue (LZ4_stream_t* LZ4_stream, const char* src, char* dst, int srcSize, int dstCapacity)
+{
+    return LZ4_compress_fast_continue(LZ4_stream, src, dst, srcSize, dstCapacity, 1);
+}
+int LZ4_compress_continue (LZ4_stream_t* LZ4_stream, const char* source, char* dest, int inputSize)
+{
+    return LZ4_compress_fast_continue(LZ4_stream, source, dest, inputSize, LZ4_compressBound(inputSize), 1);
+}
+
+/*
+These decompression functions are deprecated and should no longer be used.
+They are only provided here for compatibility with older user programs.
+- LZ4_uncompress is totally equivalent to LZ4_decompress_fast
+- LZ4_uncompress_unknownOutputSize is totally equivalent to LZ4_decompress_safe
+*/
+int LZ4_uncompress (const char* source, char* dest, int outputSize)
+{
+    return LZ4_decompress_fast(source, dest, outputSize);
+}
+int LZ4_uncompress_unknownOutputSize (const char* source, char* dest, int isize, int maxOutputSize)
+{
+    return LZ4_decompress_safe(source, dest, isize, maxOutputSize);
+}
+
+/* Obsolete Streaming functions */
+
+int LZ4_sizeofStreamState(void) { return LZ4_STREAMSIZE; }
+
+int LZ4_resetStreamState(void* state, char* inputBuffer)
+{
+    (void)inputBuffer;
+    LZ4_resetStream((LZ4_stream_t*)state);
+    return 0;
+}
+
+void* LZ4_create (char* inputBuffer)
+{
+    (void)inputBuffer;
+    return LZ4_createStream();
+}
+
+char* LZ4_slideInputBuffer (void* state)
+{
+    /* avoid const char * -> char * conversion warning */
+    return (char *)(uptrval)((LZ4_stream_t*)state)->internal_donotuse.dictionary;
+}
+
+#endif   /* LZ4_COMMONDEFS_ONLY */
diff --git a/lz4/lib/lz4.h b/lz4/lib/lz4.h
new file mode 100644
index 0000000..7ab1e48
--- /dev/null
+++ b/lz4/lib/lz4.h
@@ -0,0 +1,774 @@
+/*
+ *  LZ4 - Fast LZ compression algorithm
+ *  Header File
+ *  Copyright (C) 2011-present, Yann Collet.
+
+   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+   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.
+
+   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.
+
+   You can contact the author at :
+    - LZ4 homepage : http://www.lz4.org
+    - LZ4 source repository : https://github.com/lz4/lz4
+*/
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+#ifndef LZ4_H_2983827168210
+#define LZ4_H_2983827168210
+
+/* --- Dependency --- */
+#include    /* size_t */
+
+
+/**
+  Introduction
+
+  LZ4 is lossless compression algorithm, providing compression speed >500 MB/s per core,
+  scalable with multi-cores CPU. It features an extremely fast decoder, with speed in
+  multiple GB/s per core, typically reaching RAM speed limits on multi-core systems.
+
+  The LZ4 compression library provides in-memory compression and decompression functions.
+  It gives full buffer control to user.
+  Compression can be done in:
+    - a single step (described as Simple Functions)
+    - a single step, reusing a context (described in Advanced Functions)
+    - unbounded multiple steps (described as Streaming compression)
+
+  lz4.h generates and decodes LZ4-compressed blocks (doc/lz4_Block_format.md).
+  Decompressing such a compressed block requires additional metadata.
+  Exact metadata depends on exact decompression function.
+  For the typical case of LZ4_decompress_safe(),
+  metadata includes block's compressed size, and maximum bound of decompressed size.
+  Each application is free to encode and pass such metadata in whichever way it wants.
+
+  lz4.h only handle blocks, it can not generate Frames.
+
+  Blocks are different from Frames (doc/lz4_Frame_format.md).
+  Frames bundle both blocks and metadata in a specified manner.
+  Embedding metadata is required for compressed data to be self-contained and portable.
+  Frame format is delivered through a companion API, declared in lz4frame.h.
+  The `lz4` CLI can only manage frames.
+*/
+
+/*^***************************************************************
+*  Export parameters
+*****************************************************************/
+/*
+*  LZ4_DLL_EXPORT :
+*  Enable exporting of functions when building a Windows DLL
+*  LZ4LIB_VISIBILITY :
+*  Control library symbols visibility.
+*/
+#ifndef LZ4LIB_VISIBILITY
+#  if defined(__GNUC__) && (__GNUC__ >= 4)
+#    define LZ4LIB_VISIBILITY __attribute__ ((visibility ("default")))
+#  else
+#    define LZ4LIB_VISIBILITY
+#  endif
+#endif
+#if defined(LZ4_DLL_EXPORT) && (LZ4_DLL_EXPORT==1)
+#  define LZ4LIB_API __declspec(dllexport) LZ4LIB_VISIBILITY
+#elif defined(LZ4_DLL_IMPORT) && (LZ4_DLL_IMPORT==1)
+#  define LZ4LIB_API __declspec(dllimport) LZ4LIB_VISIBILITY /* It isn't required but allows to generate better code, saving a function pointer load from the IAT and an indirect jump.*/
+#else
+#  define LZ4LIB_API LZ4LIB_VISIBILITY
+#endif
+
+/*------   Version   ------*/
+#define LZ4_VERSION_MAJOR    1    /* for breaking interface changes  */
+#define LZ4_VERSION_MINOR    9    /* for new (non-breaking) interface capabilities */
+#define LZ4_VERSION_RELEASE  3    /* for tweaks, bug-fixes, or development */
+
+#define LZ4_VERSION_NUMBER (LZ4_VERSION_MAJOR *100*100 + LZ4_VERSION_MINOR *100 + LZ4_VERSION_RELEASE)
+
+#define LZ4_LIB_VERSION LZ4_VERSION_MAJOR.LZ4_VERSION_MINOR.LZ4_VERSION_RELEASE
+#define LZ4_QUOTE(str) #str
+#define LZ4_EXPAND_AND_QUOTE(str) LZ4_QUOTE(str)
+#define LZ4_VERSION_STRING LZ4_EXPAND_AND_QUOTE(LZ4_LIB_VERSION)
+
+LZ4LIB_API int LZ4_versionNumber (void);  /**< library version number; useful to check dll version */
+LZ4LIB_API const char* LZ4_versionString (void);   /**< library version string; useful to check dll version */
+
+
+/*-************************************
+*  Tuning parameter
+**************************************/
+/*!
+ * LZ4_MEMORY_USAGE :
+ * Memory usage formula : N->2^N Bytes (examples : 10 -> 1KB; 12 -> 4KB ; 16 -> 64KB; 20 -> 1MB; etc.)
+ * Increasing memory usage improves compression ratio.
+ * Reduced memory usage may improve speed, thanks to better cache locality.
+ * Default value is 14, for 16KB, which nicely fits into Intel x86 L1 cache
+ */
+#ifndef LZ4_MEMORY_USAGE
+# define LZ4_MEMORY_USAGE 14
+#endif
+
+
+/*-************************************
+*  Simple Functions
+**************************************/
+/*! LZ4_compress_default() :
+ *  Compresses 'srcSize' bytes from buffer 'src'
+ *  into already allocated 'dst' buffer of size 'dstCapacity'.
+ *  Compression is guaranteed to succeed if 'dstCapacity' >= LZ4_compressBound(srcSize).
+ *  It also runs faster, so it's a recommended setting.
+ *  If the function cannot compress 'src' into a more limited 'dst' budget,
+ *  compression stops *immediately*, and the function result is zero.
+ *  In which case, 'dst' content is undefined (invalid).
+ *      srcSize : max supported value is LZ4_MAX_INPUT_SIZE.
+ *      dstCapacity : size of buffer 'dst' (which must be already allocated)
+ *     @return  : the number of bytes written into buffer 'dst' (necessarily <= dstCapacity)
+ *                or 0 if compression fails
+ * Note : This function is protected against buffer overflow scenarios (never writes outside 'dst' buffer, nor read outside 'source' buffer).
+ */
+LZ4LIB_API int LZ4_compress_default(const char* src, char* dst, int srcSize, int dstCapacity);
+
+/*! LZ4_decompress_safe() :
+ *  compressedSize : is the exact complete size of the compressed block.
+ *  dstCapacity : is the size of destination buffer (which must be already allocated), presumed an upper bound of decompressed size.
+ * @return : the number of bytes decompressed into destination buffer (necessarily <= dstCapacity)
+ *           If destination buffer is not large enough, decoding will stop and output an error code (negative value).
+ *           If the source stream is detected malformed, the function will stop decoding and return a negative result.
+ * Note 1 : This function is protected against malicious data packets :
+ *          it will never writes outside 'dst' buffer, nor read outside 'source' buffer,
+ *          even if the compressed block is maliciously modified to order the decoder to do these actions.
+ *          In such case, the decoder stops immediately, and considers the compressed block malformed.
+ * Note 2 : compressedSize and dstCapacity must be provided to the function, the compressed block does not contain them.
+ *          The implementation is free to send / store / derive this information in whichever way is most beneficial.
+ *          If there is a need for a different format which bundles together both compressed data and its metadata, consider looking at lz4frame.h instead.
+ */
+LZ4LIB_API int LZ4_decompress_safe (const char* src, char* dst, int compressedSize, int dstCapacity);
+
+
+/*-************************************
+*  Advanced Functions
+**************************************/
+#define LZ4_MAX_INPUT_SIZE        0x7E000000   /* 2 113 929 216 bytes */
+#define LZ4_COMPRESSBOUND(isize)  ((unsigned)(isize) > (unsigned)LZ4_MAX_INPUT_SIZE ? 0 : (isize) + ((isize)/255) + 16)
+
+/*! LZ4_compressBound() :
+    Provides the maximum size that LZ4 compression may output in a "worst case" scenario (input data not compressible)
+    This function is primarily useful for memory allocation purposes (destination buffer size).
+    Macro LZ4_COMPRESSBOUND() is also provided for compilation-time evaluation (stack memory allocation for example).
+    Note that LZ4_compress_default() compresses faster when dstCapacity is >= LZ4_compressBound(srcSize)
+        inputSize  : max supported value is LZ4_MAX_INPUT_SIZE
+        return : maximum output size in a "worst case" scenario
+              or 0, if input size is incorrect (too large or negative)
+*/
+LZ4LIB_API int LZ4_compressBound(int inputSize);
+
+/*! LZ4_compress_fast() :
+    Same as LZ4_compress_default(), but allows selection of "acceleration" factor.
+    The larger the acceleration value, the faster the algorithm, but also the lesser the compression.
+    It's a trade-off. It can be fine tuned, with each successive value providing roughly +~3% to speed.
+    An acceleration value of "1" is the same as regular LZ4_compress_default()
+    Values <= 0 will be replaced by LZ4_ACCELERATION_DEFAULT (currently == 1, see lz4.c).
+    Values > LZ4_ACCELERATION_MAX will be replaced by LZ4_ACCELERATION_MAX (currently == 65537, see lz4.c).
+*/
+LZ4LIB_API int LZ4_compress_fast (const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
+
+/*! LZ4_compress_fast_extState() :
+ *  Same as LZ4_compress_fast(), using an externally allocated memory space for its state.
+ *  Use LZ4_sizeofState() to know how much memory must be allocated,
+ *  and allocate it on 8-bytes boundaries (using `malloc()` typically).
+ *  Then, provide this buffer as `void* state` to compression function.
+ */
+LZ4LIB_API int LZ4_sizeofState(void);
+LZ4LIB_API int LZ4_compress_fast_extState (void* state, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
+
+/*! LZ4_compress_destSize() :
+ *  Reverse the logic : compresses as much data as possible from 'src' buffer
+ *  into already allocated buffer 'dst', of size >= 'targetDestSize'.
+ *  This function either compresses the entire 'src' content into 'dst' if it's large enough,
+ *  or fill 'dst' buffer completely with as much data as possible from 'src'.
+ *  note: acceleration parameter is fixed to "default".
+ *
+ * *srcSizePtr : will be modified to indicate how many bytes where read from 'src' to fill 'dst'.
+ *               New value is necessarily <= input value.
+ * @return : Nb bytes written into 'dst' (necessarily <= targetDestSize)
+ *           or 0 if compression fails.
+ *
+ * Note : from v1.8.2 to v1.9.1, this function had a bug (fixed un v1.9.2+):
+ *        the produced compressed content could, in specific circumstances,
+ *        require to be decompressed into a destination buffer larger
+ *        by at least 1 byte than the content to decompress.
+ *        If an application uses `LZ4_compress_destSize()`,
+ *        it's highly recommended to update liblz4 to v1.9.2 or better.
+ *        If this can't be done or ensured,
+ *        the receiving decompression function should provide
+ *        a dstCapacity which is > decompressedSize, by at least 1 byte.
+ *        See https://github.com/lz4/lz4/issues/859 for details
+ */
+LZ4LIB_API int LZ4_compress_destSize (const char* src, char* dst, int* srcSizePtr, int targetDstSize);
+
+
+/*! LZ4_decompress_safe_partial() :
+ *  Decompress an LZ4 compressed block, of size 'srcSize' at position 'src',
+ *  into destination buffer 'dst' of size 'dstCapacity'.
+ *  Up to 'targetOutputSize' bytes will be decoded.
+ *  The function stops decoding on reaching this objective.
+ *  This can be useful to boost performance
+ *  whenever only the beginning of a block is required.
+ *
+ * @return : the number of bytes decoded in `dst` (necessarily <= targetOutputSize)
+ *           If source stream is detected malformed, function returns a negative result.
+ *
+ *  Note 1 : @return can be < targetOutputSize, if compressed block contains less data.
+ *
+ *  Note 2 : targetOutputSize must be <= dstCapacity
+ *
+ *  Note 3 : this function effectively stops decoding on reaching targetOutputSize,
+ *           so dstCapacity is kind of redundant.
+ *           This is because in older versions of this function,
+ *           decoding operation would still write complete sequences.
+ *           Therefore, there was no guarantee that it would stop writing at exactly targetOutputSize,
+ *           it could write more bytes, though only up to dstCapacity.
+ *           Some "margin" used to be required for this operation to work properly.
+ *           Thankfully, this is no longer necessary.
+ *           The function nonetheless keeps the same signature, in an effort to preserve API compatibility.
+ *
+ *  Note 4 : If srcSize is the exact size of the block,
+ *           then targetOutputSize can be any value,
+ *           including larger than the block's decompressed size.
+ *           The function will, at most, generate block's decompressed size.
+ *
+ *  Note 5 : If srcSize is _larger_ than block's compressed size,
+ *           then targetOutputSize **MUST** be <= block's decompressed size.
+ *           Otherwise, *silent corruption will occur*.
+ */
+LZ4LIB_API int LZ4_decompress_safe_partial (const char* src, char* dst, int srcSize, int targetOutputSize, int dstCapacity);
+
+
+/*-*********************************************
+*  Streaming Compression Functions
+***********************************************/
+typedef union LZ4_stream_u LZ4_stream_t;  /* incomplete type (defined later) */
+
+LZ4LIB_API LZ4_stream_t* LZ4_createStream(void);
+LZ4LIB_API int           LZ4_freeStream (LZ4_stream_t* streamPtr);
+
+/*! LZ4_resetStream_fast() : v1.9.0+
+ *  Use this to prepare an LZ4_stream_t for a new chain of dependent blocks
+ *  (e.g., LZ4_compress_fast_continue()).
+ *
+ *  An LZ4_stream_t must be initialized once before usage.
+ *  This is automatically done when created by LZ4_createStream().
+ *  However, should the LZ4_stream_t be simply declared on stack (for example),
+ *  it's necessary to initialize it first, using LZ4_initStream().
+ *
+ *  After init, start any new stream with LZ4_resetStream_fast().
+ *  A same LZ4_stream_t can be re-used multiple times consecutively
+ *  and compress multiple streams,
+ *  provided that it starts each new stream with LZ4_resetStream_fast().
+ *
+ *  LZ4_resetStream_fast() is much faster than LZ4_initStream(),
+ *  but is not compatible with memory regions containing garbage data.
+ *
+ *  Note: it's only useful to call LZ4_resetStream_fast()
+ *        in the context of streaming compression.
+ *        The *extState* functions perform their own resets.
+ *        Invoking LZ4_resetStream_fast() before is redundant, and even counterproductive.
+ */
+LZ4LIB_API void LZ4_resetStream_fast (LZ4_stream_t* streamPtr);
+
+/*! LZ4_loadDict() :
+ *  Use this function to reference a static dictionary into LZ4_stream_t.
+ *  The dictionary must remain available during compression.
+ *  LZ4_loadDict() triggers a reset, so any previous data will be forgotten.
+ *  The same dictionary will have to be loaded on decompression side for successful decoding.
+ *  Dictionary are useful for better compression of small data (KB range).
+ *  While LZ4 accept any input as dictionary,
+ *  results are generally better when using Zstandard's Dictionary Builder.
+ *  Loading a size of 0 is allowed, and is the same as reset.
+ * @return : loaded dictionary size, in bytes (necessarily <= 64 KB)
+ */
+LZ4LIB_API int LZ4_loadDict (LZ4_stream_t* streamPtr, const char* dictionary, int dictSize);
+
+/*! LZ4_compress_fast_continue() :
+ *  Compress 'src' content using data from previously compressed blocks, for better compression ratio.
+ * 'dst' buffer must be already allocated.
+ *  If dstCapacity >= LZ4_compressBound(srcSize), compression is guaranteed to succeed, and runs faster.
+ *
+ * @return : size of compressed block
+ *           or 0 if there is an error (typically, cannot fit into 'dst').
+ *
+ *  Note 1 : Each invocation to LZ4_compress_fast_continue() generates a new block.
+ *           Each block has precise boundaries.
+ *           Each block must be decompressed separately, calling LZ4_decompress_*() with relevant metadata.
+ *           It's not possible to append blocks together and expect a single invocation of LZ4_decompress_*() to decompress them together.
+ *
+ *  Note 2 : The previous 64KB of source data is __assumed__ to remain present, unmodified, at same address in memory !
+ *
+ *  Note 3 : When input is structured as a double-buffer, each buffer can have any size, including < 64 KB.
+ *           Make sure that buffers are separated, by at least one byte.
+ *           This construction ensures that each block only depends on previous block.
+ *
+ *  Note 4 : If input buffer is a ring-buffer, it can have any size, including < 64 KB.
+ *
+ *  Note 5 : After an error, the stream status is undefined (invalid), it can only be reset or freed.
+ */
+LZ4LIB_API int LZ4_compress_fast_continue (LZ4_stream_t* streamPtr, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
+/*! LZ4_saveDict() :
+ *  If last 64KB data cannot be guaranteed to remain available at its current memory location,
+ *  save it into a safer place (char* safeBuffer).
+ *  This is schematically equivalent to a memcpy() followed by LZ4_loadDict(),
+ *  but is much faster, because LZ4_saveDict() doesn't need to rebuild tables.
+ * @return : saved dictionary size in bytes (necessarily <= maxDictSize), or 0 if error.
+ */
+LZ4LIB_API int LZ4_saveDict (LZ4_stream_t* streamPtr, char* safeBuffer, int maxDictSize);
+
+
+/*-**********************************************
+*  Streaming Decompression Functions
+*  Bufferless synchronous API
+************************************************/
+typedef union LZ4_streamDecode_u LZ4_streamDecode_t;   /* tracking context */
+
+/*! LZ4_createStreamDecode() and LZ4_freeStreamDecode() :
+ *  creation / destruction of streaming decompression tracking context.
+ *  A tracking context can be re-used multiple times.
+ */
+LZ4LIB_API LZ4_streamDecode_t* LZ4_createStreamDecode(void);
+LZ4LIB_API int                 LZ4_freeStreamDecode (LZ4_streamDecode_t* LZ4_stream);
+
+/*! LZ4_setStreamDecode() :
+ *  An LZ4_streamDecode_t context can be allocated once and re-used multiple times.
+ *  Use this function to start decompression of a new stream of blocks.
+ *  A dictionary can optionally be set. Use NULL or size 0 for a reset order.
+ *  Dictionary is presumed stable : it must remain accessible and unmodified during next decompression.
+ * @return : 1 if OK, 0 if error
+ */
+LZ4LIB_API int LZ4_setStreamDecode (LZ4_streamDecode_t* LZ4_streamDecode, const char* dictionary, int dictSize);
+
+/*! LZ4_decoderRingBufferSize() : v1.8.2+
+ *  Note : in a ring buffer scenario (optional),
+ *  blocks are presumed decompressed next to each other
+ *  up to the moment there is not enough remaining space for next block (remainingSize < maxBlockSize),
+ *  at which stage it resumes from beginning of ring buffer.
+ *  When setting such a ring buffer for streaming decompression,
+ *  provides the minimum size of this ring buffer
+ *  to be compatible with any source respecting maxBlockSize condition.
+ * @return : minimum ring buffer size,
+ *           or 0 if there is an error (invalid maxBlockSize).
+ */
+LZ4LIB_API int LZ4_decoderRingBufferSize(int maxBlockSize);
+#define LZ4_DECODER_RING_BUFFER_SIZE(maxBlockSize) (65536 + 14 + (maxBlockSize))  /* for static allocation; maxBlockSize presumed valid */
+
+/*! LZ4_decompress_*_continue() :
+ *  These decoding functions allow decompression of consecutive blocks in "streaming" mode.
+ *  A block is an unsplittable entity, it must be presented entirely to a decompression function.
+ *  Decompression functions only accepts one block at a time.
+ *  The last 64KB of previously decoded data *must* remain available and unmodified at the memory position where they were decoded.
+ *  If less than 64KB of data has been decoded, all the data must be present.
+ *
+ *  Special : if decompression side sets a ring buffer, it must respect one of the following conditions :
+ *  - Decompression buffer size is _at least_ LZ4_decoderRingBufferSize(maxBlockSize).
+ *    maxBlockSize is the maximum size of any single block. It can have any value > 16 bytes.
+ *    In which case, encoding and decoding buffers do not need to be synchronized.
+ *    Actually, data can be produced by any source compliant with LZ4 format specification, and respecting maxBlockSize.
+ *  - Synchronized mode :
+ *    Decompression buffer size is _exactly_ the same as compression buffer size,
+ *    and follows exactly same update rule (block boundaries at same positions),
+ *    and decoding function is provided with exact decompressed size of each block (exception for last block of the stream),
+ *    _then_ decoding & encoding ring buffer can have any size, including small ones ( < 64 KB).
+ *  - Decompression buffer is larger than encoding buffer, by a minimum of maxBlockSize more bytes.
+ *    In which case, encoding and decoding buffers do not need to be synchronized,
+ *    and encoding ring buffer can have any size, including small ones ( < 64 KB).
+ *
+ *  Whenever these conditions are not possible,
+ *  save the last 64KB of decoded data into a safe buffer where it can't be modified during decompression,
+ *  then indicate where this data is saved using LZ4_setStreamDecode(), before decompressing next block.
+*/
+LZ4LIB_API int LZ4_decompress_safe_continue (LZ4_streamDecode_t* LZ4_streamDecode, const char* src, char* dst, int srcSize, int dstCapacity);
+
+
+/*! LZ4_decompress_*_usingDict() :
+ *  These decoding functions work the same as
+ *  a combination of LZ4_setStreamDecode() followed by LZ4_decompress_*_continue()
+ *  They are stand-alone, and don't need an LZ4_streamDecode_t structure.
+ *  Dictionary is presumed stable : it must remain accessible and unmodified during decompression.
+ *  Performance tip : Decompression speed can be substantially increased
+ *                    when dst == dictStart + dictSize.
+ */
+LZ4LIB_API int LZ4_decompress_safe_usingDict (const char* src, char* dst, int srcSize, int dstCapcity, const char* dictStart, int dictSize);
+
+#endif /* LZ4_H_2983827168210 */
+
+
+/*^*************************************
+ * !!!!!!   STATIC LINKING ONLY   !!!!!!
+ ***************************************/
+
+/*-****************************************************************************
+ * Experimental section
+ *
+ * Symbols declared in this section must be considered unstable. Their
+ * signatures or semantics may change, or they may be removed altogether in the
+ * future. They are therefore only safe to depend on when the caller is
+ * statically linked against the library.
+ *
+ * To protect against unsafe usage, not only are the declarations guarded,
+ * the definitions are hidden by default
+ * when building LZ4 as a shared/dynamic library.
+ *
+ * In order to access these declarations,
+ * define LZ4_STATIC_LINKING_ONLY in your application
+ * before including LZ4's headers.
+ *
+ * In order to make their implementations accessible dynamically, you must
+ * define LZ4_PUBLISH_STATIC_FUNCTIONS when building the LZ4 library.
+ ******************************************************************************/
+
+#ifdef LZ4_STATIC_LINKING_ONLY
+
+#ifndef LZ4_STATIC_3504398509
+#define LZ4_STATIC_3504398509
+
+#ifdef LZ4_PUBLISH_STATIC_FUNCTIONS
+#define LZ4LIB_STATIC_API LZ4LIB_API
+#else
+#define LZ4LIB_STATIC_API
+#endif
+
+
+/*! LZ4_compress_fast_extState_fastReset() :
+ *  A variant of LZ4_compress_fast_extState().
+ *
+ *  Using this variant avoids an expensive initialization step.
+ *  It is only safe to call if the state buffer is known to be correctly initialized already
+ *  (see above comment on LZ4_resetStream_fast() for a definition of "correctly initialized").
+ *  From a high level, the difference is that
+ *  this function initializes the provided state with a call to something like LZ4_resetStream_fast()
+ *  while LZ4_compress_fast_extState() starts with a call to LZ4_resetStream().
+ */
+LZ4LIB_STATIC_API int LZ4_compress_fast_extState_fastReset (void* state, const char* src, char* dst, int srcSize, int dstCapacity, int acceleration);
+
+/*! LZ4_attach_dictionary() :
+ *  This is an experimental API that allows
+ *  efficient use of a static dictionary many times.
+ *
+ *  Rather than re-loading the dictionary buffer into a working context before
+ *  each compression, or copying a pre-loaded dictionary's LZ4_stream_t into a
+ *  working LZ4_stream_t, this function introduces a no-copy setup mechanism,
+ *  in which the working stream references the dictionary stream in-place.
+ *
+ *  Several assumptions are made about the state of the dictionary stream.
+ *  Currently, only streams which have been prepared by LZ4_loadDict() should
+ *  be expected to work.
+ *
+ *  Alternatively, the provided dictionaryStream may be NULL,
+ *  in which case any existing dictionary stream is unset.
+ *
+ *  If a dictionary is provided, it replaces any pre-existing stream history.
+ *  The dictionary contents are the only history that can be referenced and
+ *  logically immediately precede the data compressed in the first subsequent
+ *  compression call.
+ *
+ *  The dictionary will only remain attached to the working stream through the
+ *  first compression call, at the end of which it is cleared. The dictionary
+ *  stream (and source buffer) must remain in-place / accessible / unchanged
+ *  through the completion of the first compression call on the stream.
+ */
+LZ4LIB_STATIC_API void LZ4_attach_dictionary(LZ4_stream_t* workingStream, const LZ4_stream_t* dictionaryStream);
+
+
+/*! In-place compression and decompression
+ *
+ * It's possible to have input and output sharing the same buffer,
+ * for highly contrained memory environments.
+ * In both cases, it requires input to lay at the end of the buffer,
+ * and decompression to start at beginning of the buffer.
+ * Buffer size must feature some margin, hence be larger than final size.
+ *
+ * |<------------------------buffer--------------------------------->|
+ *                             |<-----------compressed data--------->|
+ * |<-----------decompressed size------------------>|
+ *                                                  |<----margin---->|
+ *
+ * This technique is more useful for decompression,
+ * since decompressed size is typically larger,
+ * and margin is short.
+ *
+ * In-place decompression will work inside any buffer
+ * which size is >= LZ4_DECOMPRESS_INPLACE_BUFFER_SIZE(decompressedSize).
+ * This presumes that decompressedSize > compressedSize.
+ * Otherwise, it means compression actually expanded data,
+ * and it would be more efficient to store such data with a flag indicating it's not compressed.
+ * This can happen when data is not compressible (already compressed, or encrypted).
+ *
+ * For in-place compression, margin is larger, as it must be able to cope with both
+ * history preservation, requiring input data to remain unmodified up to LZ4_DISTANCE_MAX,
+ * and data expansion, which can happen when input is not compressible.
+ * As a consequence, buffer size requirements are much higher,
+ * and memory savings offered by in-place compression are more limited.
+ *
+ * There are ways to limit this cost for compression :
+ * - Reduce history size, by modifying LZ4_DISTANCE_MAX.
+ *   Note that it is a compile-time constant, so all compressions will apply this limit.
+ *   Lower values will reduce compression ratio, except when input_size < LZ4_DISTANCE_MAX,
+ *   so it's a reasonable trick when inputs are known to be small.
+ * - Require the compressor to deliver a "maximum compressed size".
+ *   This is the `dstCapacity` parameter in `LZ4_compress*()`.
+ *   When this size is < LZ4_COMPRESSBOUND(inputSize), then compression can fail,
+ *   in which case, the return code will be 0 (zero).
+ *   The caller must be ready for these cases to happen,
+ *   and typically design a backup scheme to send data uncompressed.
+ * The combination of both techniques can significantly reduce
+ * the amount of margin required for in-place compression.
+ *
+ * In-place compression can work in any buffer
+ * which size is >= (maxCompressedSize)
+ * with maxCompressedSize == LZ4_COMPRESSBOUND(srcSize) for guaranteed compression success.
+ * LZ4_COMPRESS_INPLACE_BUFFER_SIZE() depends on both maxCompressedSize and LZ4_DISTANCE_MAX,
+ * so it's possible to reduce memory requirements by playing with them.
+ */
+
+#define LZ4_DECOMPRESS_INPLACE_MARGIN(compressedSize)          (((compressedSize) >> 8) + 32)
+#define LZ4_DECOMPRESS_INPLACE_BUFFER_SIZE(decompressedSize)   ((decompressedSize) + LZ4_DECOMPRESS_INPLACE_MARGIN(decompressedSize))  /**< note: presumes that compressedSize < decompressedSize. note2: margin is overestimated a bit, since it could use compressedSize instead */
+
+#ifndef LZ4_DISTANCE_MAX   /* history window size; can be user-defined at compile time */
+#  define LZ4_DISTANCE_MAX 65535   /* set to maximum value by default */
+#endif
+
+#define LZ4_COMPRESS_INPLACE_MARGIN                           (LZ4_DISTANCE_MAX + 32)   /* LZ4_DISTANCE_MAX can be safely replaced by srcSize when it's smaller */
+#define LZ4_COMPRESS_INPLACE_BUFFER_SIZE(maxCompressedSize)   ((maxCompressedSize) + LZ4_COMPRESS_INPLACE_MARGIN)  /**< maxCompressedSize is generally LZ4_COMPRESSBOUND(inputSize), but can be set to any lower value, with the risk that compression can fail (return code 0(zero)) */
+
+#endif   /* LZ4_STATIC_3504398509 */
+#endif   /* LZ4_STATIC_LINKING_ONLY */
+
+
+
+#ifndef LZ4_H_98237428734687
+#define LZ4_H_98237428734687
+
+/*-************************************************************
+ *  Private Definitions
+ **************************************************************
+ * Do not use these definitions directly.
+ * They are only exposed to allow static allocation of `LZ4_stream_t` and `LZ4_streamDecode_t`.
+ * Accessing members will expose user code to API and/or ABI break in future versions of the library.
+ **************************************************************/
+#define LZ4_HASHLOG   (LZ4_MEMORY_USAGE-2)
+#define LZ4_HASHTABLESIZE (1 << LZ4_MEMORY_USAGE)
+#define LZ4_HASH_SIZE_U32 (1 << LZ4_HASHLOG)       /* required as macro for static allocation */
+
+#if defined(__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */)
+# include 
+  typedef  int8_t  LZ4_i8;
+  typedef uint8_t  LZ4_byte;
+  typedef uint16_t LZ4_u16;
+  typedef uint32_t LZ4_u32;
+#else
+  typedef   signed char  LZ4_i8;
+  typedef unsigned char  LZ4_byte;
+  typedef unsigned short LZ4_u16;
+  typedef unsigned int   LZ4_u32;
+#endif
+
+typedef struct LZ4_stream_t_internal LZ4_stream_t_internal;
+struct LZ4_stream_t_internal {
+    LZ4_u32 hashTable[LZ4_HASH_SIZE_U32];
+    LZ4_u32 currentOffset;
+    LZ4_u32 tableType;
+    const LZ4_byte* dictionary;
+    const LZ4_stream_t_internal* dictCtx;
+    LZ4_u32 dictSize;
+};
+
+typedef struct {
+    const LZ4_byte* externalDict;
+    size_t extDictSize;
+    const LZ4_byte* prefixEnd;
+    size_t prefixSize;
+} LZ4_streamDecode_t_internal;
+
+
+/*! LZ4_stream_t :
+ *  Do not use below internal definitions directly !
+ *  Declare or allocate an LZ4_stream_t instead.
+ *  LZ4_stream_t can also be created using LZ4_createStream(), which is recommended.
+ *  The structure definition can be convenient for static allocation
+ *  (on stack, or as part of larger structure).
+ *  Init this structure with LZ4_initStream() before first use.
+ *  note : only use this definition in association with static linking !
+ *  this definition is not API/ABI safe, and may change in future versions.
+ */
+#define LZ4_STREAMSIZE       16416  /* static size, for inter-version compatibility */
+#define LZ4_STREAMSIZE_VOIDP (LZ4_STREAMSIZE / sizeof(void*))
+union LZ4_stream_u {
+    void* table[LZ4_STREAMSIZE_VOIDP];
+    LZ4_stream_t_internal internal_donotuse;
+}; /* previously typedef'd to LZ4_stream_t */
+
+
+/*! LZ4_initStream() : v1.9.0+
+ *  An LZ4_stream_t structure must be initialized at least once.
+ *  This is automatically done when invoking LZ4_createStream(),
+ *  but it's not when the structure is simply declared on stack (for example).
+ *
+ *  Use LZ4_initStream() to properly initialize a newly declared LZ4_stream_t.
+ *  It can also initialize any arbitrary buffer of sufficient size,
+ *  and will @return a pointer of proper type upon initialization.
+ *
+ *  Note : initialization fails if size and alignment conditions are not respected.
+ *         In which case, the function will @return NULL.
+ *  Note2: An LZ4_stream_t structure guarantees correct alignment and size.
+ *  Note3: Before v1.9.0, use LZ4_resetStream() instead
+ */
+LZ4LIB_API LZ4_stream_t* LZ4_initStream (void* buffer, size_t size);
+
+
+/*! LZ4_streamDecode_t :
+ *  information structure to track an LZ4 stream during decompression.
+ *  init this structure  using LZ4_setStreamDecode() before first use.
+ *  note : only use in association with static linking !
+ *         this definition is not API/ABI safe,
+ *         and may change in a future version !
+ */
+#define LZ4_STREAMDECODESIZE_U64 (4 + ((sizeof(void*)==16) ? 2 : 0) /*AS-400*/ )
+#define LZ4_STREAMDECODESIZE     (LZ4_STREAMDECODESIZE_U64 * sizeof(unsigned long long))
+union LZ4_streamDecode_u {
+    unsigned long long table[LZ4_STREAMDECODESIZE_U64];
+    LZ4_streamDecode_t_internal internal_donotuse;
+} ;   /* previously typedef'd to LZ4_streamDecode_t */
+
+
+
+/*-************************************
+*  Obsolete Functions
+**************************************/
+
+/*! Deprecation warnings
+ *
+ *  Deprecated functions make the compiler generate a warning when invoked.
+ *  This is meant to invite users to update their source code.
+ *  Should deprecation warnings be a problem, it is generally possible to disable them,
+ *  typically with -Wno-deprecated-declarations for gcc
+ *  or _CRT_SECURE_NO_WARNINGS in Visual.
+ *
+ *  Another method is to define LZ4_DISABLE_DEPRECATE_WARNINGS
+ *  before including the header file.
+ */
+#ifdef LZ4_DISABLE_DEPRECATE_WARNINGS
+#  define LZ4_DEPRECATED(message)   /* disable deprecation warnings */
+#else
+#  if defined (__cplusplus) && (__cplusplus >= 201402) /* C++14 or greater */
+#    define LZ4_DEPRECATED(message) [[deprecated(message)]]
+#  elif defined(_MSC_VER)
+#    define LZ4_DEPRECATED(message) __declspec(deprecated(message))
+#  elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ * 10 + __GNUC_MINOR__ >= 45))
+#    define LZ4_DEPRECATED(message) __attribute__((deprecated(message)))
+#  elif defined(__GNUC__) && (__GNUC__ * 10 + __GNUC_MINOR__ >= 31)
+#    define LZ4_DEPRECATED(message) __attribute__((deprecated))
+#  else
+#    pragma message("WARNING: LZ4_DEPRECATED needs custom implementation for this compiler")
+#    define LZ4_DEPRECATED(message)   /* disabled */
+#  endif
+#endif /* LZ4_DISABLE_DEPRECATE_WARNINGS */
+
+/*! Obsolete compression functions (since v1.7.3) */
+LZ4_DEPRECATED("use LZ4_compress_default() instead")       LZ4LIB_API int LZ4_compress               (const char* src, char* dest, int srcSize);
+LZ4_DEPRECATED("use LZ4_compress_default() instead")       LZ4LIB_API int LZ4_compress_limitedOutput (const char* src, char* dest, int srcSize, int maxOutputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_extState() instead") LZ4LIB_API int LZ4_compress_withState               (void* state, const char* source, char* dest, int inputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_extState() instead") LZ4LIB_API int LZ4_compress_limitedOutput_withState (void* state, const char* source, char* dest, int inputSize, int maxOutputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_continue() instead") LZ4LIB_API int LZ4_compress_continue                (LZ4_stream_t* LZ4_streamPtr, const char* source, char* dest, int inputSize);
+LZ4_DEPRECATED("use LZ4_compress_fast_continue() instead") LZ4LIB_API int LZ4_compress_limitedOutput_continue  (LZ4_stream_t* LZ4_streamPtr, const char* source, char* dest, int inputSize, int maxOutputSize);
+
+/*! Obsolete decompression functions (since v1.8.0) */
+LZ4_DEPRECATED("use LZ4_decompress_fast() instead") LZ4LIB_API int LZ4_uncompress (const char* source, char* dest, int outputSize);
+LZ4_DEPRECATED("use LZ4_decompress_safe() instead") LZ4LIB_API int LZ4_uncompress_unknownOutputSize (const char* source, char* dest, int isize, int maxOutputSize);
+
+/* Obsolete streaming functions (since v1.7.0)
+ * degraded functionality; do not use!
+ *
+ * In order to perform streaming compression, these functions depended on data
+ * that is no longer tracked in the state. They have been preserved as well as
+ * possible: using them will still produce a correct output. However, they don't
+ * actually retain any history between compression calls. The compression ratio
+ * achieved will therefore be no better than compressing each chunk
+ * independently.
+ */
+LZ4_DEPRECATED("Use LZ4_createStream() instead") LZ4LIB_API void* LZ4_create (char* inputBuffer);
+LZ4_DEPRECATED("Use LZ4_createStream() instead") LZ4LIB_API int   LZ4_sizeofStreamState(void);
+LZ4_DEPRECATED("Use LZ4_resetStream() instead")  LZ4LIB_API int   LZ4_resetStreamState(void* state, char* inputBuffer);
+LZ4_DEPRECATED("Use LZ4_saveDict() instead")     LZ4LIB_API char* LZ4_slideInputBuffer (void* state);
+
+/*! Obsolete streaming decoding functions (since v1.7.0) */
+LZ4_DEPRECATED("use LZ4_decompress_safe_usingDict() instead") LZ4LIB_API int LZ4_decompress_safe_withPrefix64k (const char* src, char* dst, int compressedSize, int maxDstSize);
+LZ4_DEPRECATED("use LZ4_decompress_fast_usingDict() instead") LZ4LIB_API int LZ4_decompress_fast_withPrefix64k (const char* src, char* dst, int originalSize);
+
+/*! Obsolete LZ4_decompress_fast variants (since v1.9.0) :
+ *  These functions used to be faster than LZ4_decompress_safe(),
+ *  but this is no longer the case. They are now slower.
+ *  This is because LZ4_decompress_fast() doesn't know the input size,
+ *  and therefore must progress more cautiously into the input buffer to not read beyond the end of block.
+ *  On top of that `LZ4_decompress_fast()` is not protected vs malformed or malicious inputs, making it a security liability.
+ *  As a consequence, LZ4_decompress_fast() is strongly discouraged, and deprecated.
+ *
+ *  The last remaining LZ4_decompress_fast() specificity is that
+ *  it can decompress a block without knowing its compressed size.
+ *  Such functionality can be achieved in a more secure manner
+ *  by employing LZ4_decompress_safe_partial().
+ *
+ *  Parameters:
+ *  originalSize : is the uncompressed size to regenerate.
+ *                 `dst` must be already allocated, its size must be >= 'originalSize' bytes.
+ * @return : number of bytes read from source buffer (== compressed size).
+ *           The function expects to finish at block's end exactly.
+ *           If the source stream is detected malformed, the function stops decoding and returns a negative result.
+ *  note : LZ4_decompress_fast*() requires originalSize. Thanks to this information, it never writes past the output buffer.
+ *         However, since it doesn't know its 'src' size, it may read an unknown amount of input, past input buffer bounds.
+ *         Also, since match offsets are not validated, match reads from 'src' may underflow too.
+ *         These issues never happen if input (compressed) data is correct.
+ *         But they may happen if input data is invalid (error or intentional tampering).
+ *         As a consequence, use these functions in trusted environments with trusted data **only**.
+ */
+LZ4_DEPRECATED("This function is deprecated and unsafe. Consider using LZ4_decompress_safe() instead")
+LZ4LIB_API int LZ4_decompress_fast (const char* src, char* dst, int originalSize);
+LZ4_DEPRECATED("This function is deprecated and unsafe. Consider using LZ4_decompress_safe_continue() instead")
+LZ4LIB_API int LZ4_decompress_fast_continue (LZ4_streamDecode_t* LZ4_streamDecode, const char* src, char* dst, int originalSize);
+LZ4_DEPRECATED("This function is deprecated and unsafe. Consider using LZ4_decompress_safe_usingDict() instead")
+LZ4LIB_API int LZ4_decompress_fast_usingDict (const char* src, char* dst, int originalSize, const char* dictStart, int dictSize);
+
+/*! LZ4_resetStream() :
+ *  An LZ4_stream_t structure must be initialized at least once.
+ *  This is done with LZ4_initStream(), or LZ4_resetStream().
+ *  Consider switching to LZ4_initStream(),
+ *  invoking LZ4_resetStream() will trigger deprecation warnings in the future.
+ */
+LZ4LIB_API void LZ4_resetStream (LZ4_stream_t* streamPtr);
+
+
+#endif /* LZ4_H_98237428734687 */
+
+
+#if defined (__cplusplus)
+}
+#endif
diff --git a/lz4/lib/lz4frame.c b/lz4/lib/lz4frame.c
new file mode 100644
index 0000000..ec02c92
--- /dev/null
+++ b/lz4/lib/lz4frame.c
@@ -0,0 +1,1899 @@
+/*
+ * LZ4 auto-framing library
+ * Copyright (C) 2011-2016, Yann Collet.
+ *
+ * BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+ *
+ * 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.
+ *
+ * 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.
+ *
+ * You can contact the author at :
+ * - LZ4 homepage : http://www.lz4.org
+ * - LZ4 source repository : https://github.com/lz4/lz4
+ */
+
+/* LZ4F is a stand-alone API to create LZ4-compressed Frames
+ * in full conformance with specification v1.6.1 .
+ * This library rely upon memory management capabilities (malloc, free)
+ * provided either by ,
+ * or redirected towards another library of user's choice
+ * (see Memory Routines below).
+ */
+
+
+/*-************************************
+*  Compiler Options
+**************************************/
+#ifdef _MSC_VER    /* Visual Studio */
+#  pragma warning(disable : 4127)        /* disable: C4127: conditional expression is constant */
+#endif
+
+
+/*-************************************
+*  Tuning parameters
+**************************************/
+/*
+ * LZ4F_HEAPMODE :
+ * Select how default compression functions will allocate memory for their hash table,
+ * in memory stack (0:default, fastest), or in memory heap (1:requires malloc()).
+ */
+#ifndef LZ4F_HEAPMODE
+#  define LZ4F_HEAPMODE 0
+#endif
+
+
+/*-************************************
+*  Memory routines
+**************************************/
+/*
+ * User may redirect invocations of
+ * malloc(), calloc() and free()
+ * towards another library or solution of their choice
+ * by modifying below section.
+ */
+#ifndef LZ4_SRC_INCLUDED   /* avoid redefinition when sources are coalesced */
+#  include    /* malloc, calloc, free */
+#  define ALLOC(s)          malloc(s)
+#  define ALLOC_AND_ZERO(s) calloc(1,(s))
+#  define FREEMEM(p)        free(p)
+#endif
+
+#include    /* memset, memcpy, memmove */
+#ifndef LZ4_SRC_INCLUDED  /* avoid redefinition when sources are coalesced */
+#  define MEM_INIT(p,v,s)   memset((p),(v),(s))
+#endif
+
+
+/*-************************************
+*  Library declarations
+**************************************/
+#define LZ4F_STATIC_LINKING_ONLY
+#include "lz4frame.h"
+#define LZ4_STATIC_LINKING_ONLY
+#include "lz4.h"
+#define LZ4_HC_STATIC_LINKING_ONLY
+#include "lz4hc.h"
+#define XXH_STATIC_LINKING_ONLY
+#include "xxhash.h"
+
+
+/*-************************************
+*  Debug
+**************************************/
+#if defined(LZ4_DEBUG) && (LZ4_DEBUG>=1)
+#  include 
+#else
+#  ifndef assert
+#    define assert(condition) ((void)0)
+#  endif
+#endif
+
+#define LZ4F_STATIC_ASSERT(c)    { enum { LZ4F_static_assert = 1/(int)(!!(c)) }; }   /* use only *after* variable declarations */
+
+#if defined(LZ4_DEBUG) && (LZ4_DEBUG>=2) && !defined(DEBUGLOG)
+#  include 
+static int g_debuglog_enable = 1;
+#  define DEBUGLOG(l, ...) {                                  \
+                if ((g_debuglog_enable) && (l<=LZ4_DEBUG)) {  \
+                    fprintf(stderr, __FILE__ ": ");           \
+                    fprintf(stderr, __VA_ARGS__);             \
+                    fprintf(stderr, " \n");                   \
+            }   }
+#else
+#  define DEBUGLOG(l, ...)      {}    /* disabled */
+#endif
+
+
+/*-************************************
+*  Basic Types
+**************************************/
+#if !defined (__VMS) && (defined (__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) )
+# include 
+  typedef  uint8_t BYTE;
+  typedef uint16_t U16;
+  typedef uint32_t U32;
+  typedef  int32_t S32;
+  typedef uint64_t U64;
+#else
+  typedef unsigned char       BYTE;
+  typedef unsigned short      U16;
+  typedef unsigned int        U32;
+  typedef   signed int        S32;
+  typedef unsigned long long  U64;
+#endif
+
+
+/* unoptimized version; solves endianess & alignment issues */
+static U32 LZ4F_readLE32 (const void* src)
+{
+    const BYTE* const srcPtr = (const BYTE*)src;
+    U32 value32 = srcPtr[0];
+    value32 += ((U32)srcPtr[1])<< 8;
+    value32 += ((U32)srcPtr[2])<<16;
+    value32 += ((U32)srcPtr[3])<<24;
+    return value32;
+}
+
+static void LZ4F_writeLE32 (void* dst, U32 value32)
+{
+    BYTE* const dstPtr = (BYTE*)dst;
+    dstPtr[0] = (BYTE)value32;
+    dstPtr[1] = (BYTE)(value32 >> 8);
+    dstPtr[2] = (BYTE)(value32 >> 16);
+    dstPtr[3] = (BYTE)(value32 >> 24);
+}
+
+static U64 LZ4F_readLE64 (const void* src)
+{
+    const BYTE* const srcPtr = (const BYTE*)src;
+    U64 value64 = srcPtr[0];
+    value64 += ((U64)srcPtr[1]<<8);
+    value64 += ((U64)srcPtr[2]<<16);
+    value64 += ((U64)srcPtr[3]<<24);
+    value64 += ((U64)srcPtr[4]<<32);
+    value64 += ((U64)srcPtr[5]<<40);
+    value64 += ((U64)srcPtr[6]<<48);
+    value64 += ((U64)srcPtr[7]<<56);
+    return value64;
+}
+
+static void LZ4F_writeLE64 (void* dst, U64 value64)
+{
+    BYTE* const dstPtr = (BYTE*)dst;
+    dstPtr[0] = (BYTE)value64;
+    dstPtr[1] = (BYTE)(value64 >> 8);
+    dstPtr[2] = (BYTE)(value64 >> 16);
+    dstPtr[3] = (BYTE)(value64 >> 24);
+    dstPtr[4] = (BYTE)(value64 >> 32);
+    dstPtr[5] = (BYTE)(value64 >> 40);
+    dstPtr[6] = (BYTE)(value64 >> 48);
+    dstPtr[7] = (BYTE)(value64 >> 56);
+}
+
+
+/*-************************************
+*  Constants
+**************************************/
+#ifndef LZ4_SRC_INCLUDED   /* avoid double definition */
+#  define KB *(1<<10)
+#  define MB *(1<<20)
+#  define GB *(1<<30)
+#endif
+
+#define _1BIT  0x01
+#define _2BITS 0x03
+#define _3BITS 0x07
+#define _4BITS 0x0F
+#define _8BITS 0xFF
+
+#define LZ4F_MAGIC_SKIPPABLE_START 0x184D2A50U
+#define LZ4F_MAGICNUMBER 0x184D2204U
+#define LZ4F_BLOCKUNCOMPRESSED_FLAG 0x80000000U
+#define LZ4F_BLOCKSIZEID_DEFAULT LZ4F_max64KB
+
+static const size_t minFHSize = LZ4F_HEADER_SIZE_MIN;   /*  7 */
+static const size_t maxFHSize = LZ4F_HEADER_SIZE_MAX;   /* 19 */
+static const size_t BHSize = LZ4F_BLOCK_HEADER_SIZE;  /* block header : size, and compress flag */
+static const size_t BFSize = LZ4F_BLOCK_CHECKSUM_SIZE;  /* block footer : checksum (optional) */
+
+
+/*-************************************
+*  Structures and local types
+**************************************/
+typedef struct LZ4F_cctx_s
+{
+    LZ4F_preferences_t prefs;
+    U32    version;
+    U32    cStage;
+    const LZ4F_CDict* cdict;
+    size_t maxBlockSize;
+    size_t maxBufferSize;
+    BYTE*  tmpBuff;
+    BYTE*  tmpIn;
+    size_t tmpInSize;
+    U64    totalInSize;
+    XXH32_state_t xxh;
+    void*  lz4CtxPtr;
+    U16    lz4CtxAlloc; /* sized for: 0 = none, 1 = lz4 ctx, 2 = lz4hc ctx */
+    U16    lz4CtxState; /* in use as: 0 = none, 1 = lz4 ctx, 2 = lz4hc ctx */
+} LZ4F_cctx_t;
+
+
+/*-************************************
+*  Error management
+**************************************/
+#define LZ4F_GENERATE_STRING(STRING) #STRING,
+static const char* LZ4F_errorStrings[] = { LZ4F_LIST_ERRORS(LZ4F_GENERATE_STRING) };
+
+
+unsigned LZ4F_isError(LZ4F_errorCode_t code)
+{
+    return (code > (LZ4F_errorCode_t)(-LZ4F_ERROR_maxCode));
+}
+
+const char* LZ4F_getErrorName(LZ4F_errorCode_t code)
+{
+    static const char* codeError = "Unspecified error code";
+    if (LZ4F_isError(code)) return LZ4F_errorStrings[-(int)(code)];
+    return codeError;
+}
+
+LZ4F_errorCodes LZ4F_getErrorCode(size_t functionResult)
+{
+    if (!LZ4F_isError(functionResult)) return LZ4F_OK_NoError;
+    return (LZ4F_errorCodes)(-(ptrdiff_t)functionResult);
+}
+
+static LZ4F_errorCode_t err0r(LZ4F_errorCodes code)
+{
+    /* A compilation error here means sizeof(ptrdiff_t) is not large enough */
+    LZ4F_STATIC_ASSERT(sizeof(ptrdiff_t) >= sizeof(size_t));
+    return (LZ4F_errorCode_t)-(ptrdiff_t)code;
+}
+
+unsigned LZ4F_getVersion(void) { return LZ4F_VERSION; }
+
+int LZ4F_compressionLevel_max(void) { return LZ4HC_CLEVEL_MAX; }
+
+size_t LZ4F_getBlockSize(unsigned blockSizeID)
+{
+    static const size_t blockSizes[4] = { 64 KB, 256 KB, 1 MB, 4 MB };
+
+    if (blockSizeID == 0) blockSizeID = LZ4F_BLOCKSIZEID_DEFAULT;
+    if (blockSizeID < LZ4F_max64KB || blockSizeID > LZ4F_max4MB)
+        return err0r(LZ4F_ERROR_maxBlockSize_invalid);
+    blockSizeID -= LZ4F_max64KB;
+    return blockSizes[blockSizeID];
+}
+
+/*-************************************
+*  Private functions
+**************************************/
+#define MIN(a,b)   ( (a) < (b) ? (a) : (b) )
+
+static BYTE LZ4F_headerChecksum (const void* header, size_t length)
+{
+    U32 const xxh = XXH32(header, length, 0);
+    return (BYTE)(xxh >> 8);
+}
+
+
+/*-************************************
+*  Simple-pass compression functions
+**************************************/
+static LZ4F_blockSizeID_t LZ4F_optimalBSID(const LZ4F_blockSizeID_t requestedBSID,
+                                           const size_t srcSize)
+{
+    LZ4F_blockSizeID_t proposedBSID = LZ4F_max64KB;
+    size_t maxBlockSize = 64 KB;
+    while (requestedBSID > proposedBSID) {
+        if (srcSize <= maxBlockSize)
+            return proposedBSID;
+        proposedBSID = (LZ4F_blockSizeID_t)((int)proposedBSID + 1);
+        maxBlockSize <<= 2;
+    }
+    return requestedBSID;
+}
+
+/*! LZ4F_compressBound_internal() :
+ *  Provides dstCapacity given a srcSize to guarantee operation success in worst case situations.
+ *  prefsPtr is optional : if NULL is provided, preferences will be set to cover worst case scenario.
+ * @return is always the same for a srcSize and prefsPtr, so it can be relied upon to size reusable buffers.
+ *  When srcSize==0, LZ4F_compressBound() provides an upper bound for LZ4F_flush() and LZ4F_compressEnd() operations.
+ */
+static size_t LZ4F_compressBound_internal(size_t srcSize,
+                                    const LZ4F_preferences_t* preferencesPtr,
+                                          size_t alreadyBuffered)
+{
+    LZ4F_preferences_t prefsNull = LZ4F_INIT_PREFERENCES;
+    prefsNull.frameInfo.contentChecksumFlag = LZ4F_contentChecksumEnabled;   /* worst case */
+    prefsNull.frameInfo.blockChecksumFlag = LZ4F_blockChecksumEnabled;   /* worst case */
+    {   const LZ4F_preferences_t* const prefsPtr = (preferencesPtr==NULL) ? &prefsNull : preferencesPtr;
+        U32 const flush = prefsPtr->autoFlush | (srcSize==0);
+        LZ4F_blockSizeID_t const blockID = prefsPtr->frameInfo.blockSizeID;
+        size_t const blockSize = LZ4F_getBlockSize(blockID);
+        size_t const maxBuffered = blockSize - 1;
+        size_t const bufferedSize = MIN(alreadyBuffered, maxBuffered);
+        size_t const maxSrcSize = srcSize + bufferedSize;
+        unsigned const nbFullBlocks = (unsigned)(maxSrcSize / blockSize);
+        size_t const partialBlockSize = maxSrcSize & (blockSize-1);
+        size_t const lastBlockSize = flush ? partialBlockSize : 0;
+        unsigned const nbBlocks = nbFullBlocks + (lastBlockSize>0);
+
+        size_t const blockCRCSize = BFSize * prefsPtr->frameInfo.blockChecksumFlag;
+        size_t const frameEnd = BHSize + (prefsPtr->frameInfo.contentChecksumFlag*BFSize);
+
+        return ((BHSize + blockCRCSize) * nbBlocks) +
+               (blockSize * nbFullBlocks) + lastBlockSize + frameEnd;
+    }
+}
+
+size_t LZ4F_compressFrameBound(size_t srcSize, const LZ4F_preferences_t* preferencesPtr)
+{
+    LZ4F_preferences_t prefs;
+    size_t const headerSize = maxFHSize;      /* max header size, including optional fields */
+
+    if (preferencesPtr!=NULL) prefs = *preferencesPtr;
+    else MEM_INIT(&prefs, 0, sizeof(prefs));
+    prefs.autoFlush = 1;
+
+    return headerSize + LZ4F_compressBound_internal(srcSize, &prefs, 0);;
+}
+
+
+/*! LZ4F_compressFrame_usingCDict() :
+ *  Compress srcBuffer using a dictionary, in a single step.
+ *  cdict can be NULL, in which case, no dictionary is used.
+ *  dstBuffer MUST be >= LZ4F_compressFrameBound(srcSize, preferencesPtr).
+ *  The LZ4F_preferences_t structure is optional : you may provide NULL as argument,
+ *  however, it's the only way to provide a dictID, so it's not recommended.
+ * @return : number of bytes written into dstBuffer,
+ *           or an error code if it fails (can be tested using LZ4F_isError())
+ */
+size_t LZ4F_compressFrame_usingCDict(LZ4F_cctx* cctx,
+                                     void* dstBuffer, size_t dstCapacity,
+                               const void* srcBuffer, size_t srcSize,
+                               const LZ4F_CDict* cdict,
+                               const LZ4F_preferences_t* preferencesPtr)
+{
+    LZ4F_preferences_t prefs;
+    LZ4F_compressOptions_t options;
+    BYTE* const dstStart = (BYTE*) dstBuffer;
+    BYTE* dstPtr = dstStart;
+    BYTE* const dstEnd = dstStart + dstCapacity;
+
+    if (preferencesPtr!=NULL)
+        prefs = *preferencesPtr;
+    else
+        MEM_INIT(&prefs, 0, sizeof(prefs));
+    if (prefs.frameInfo.contentSize != 0)
+        prefs.frameInfo.contentSize = (U64)srcSize;   /* auto-correct content size if selected (!=0) */
+
+    prefs.frameInfo.blockSizeID = LZ4F_optimalBSID(prefs.frameInfo.blockSizeID, srcSize);
+    prefs.autoFlush = 1;
+    if (srcSize <= LZ4F_getBlockSize(prefs.frameInfo.blockSizeID))
+        prefs.frameInfo.blockMode = LZ4F_blockIndependent;   /* only one block => no need for inter-block link */
+
+    MEM_INIT(&options, 0, sizeof(options));
+    options.stableSrc = 1;
+
+    if (dstCapacity < LZ4F_compressFrameBound(srcSize, &prefs))  /* condition to guarantee success */
+        return err0r(LZ4F_ERROR_dstMaxSize_tooSmall);
+
+    { size_t const headerSize = LZ4F_compressBegin_usingCDict(cctx, dstBuffer, dstCapacity, cdict, &prefs);  /* write header */
+      if (LZ4F_isError(headerSize)) return headerSize;
+      dstPtr += headerSize;   /* header size */ }
+
+    assert(dstEnd >= dstPtr);
+    { size_t const cSize = LZ4F_compressUpdate(cctx, dstPtr, (size_t)(dstEnd-dstPtr), srcBuffer, srcSize, &options);
+      if (LZ4F_isError(cSize)) return cSize;
+      dstPtr += cSize; }
+
+    assert(dstEnd >= dstPtr);
+    { size_t const tailSize = LZ4F_compressEnd(cctx, dstPtr, (size_t)(dstEnd-dstPtr), &options);   /* flush last block, and generate suffix */
+      if (LZ4F_isError(tailSize)) return tailSize;
+      dstPtr += tailSize; }
+
+    assert(dstEnd >= dstStart);
+    return (size_t)(dstPtr - dstStart);
+}
+
+
+/*! LZ4F_compressFrame() :
+ *  Compress an entire srcBuffer into a valid LZ4 frame, in a single step.
+ *  dstBuffer MUST be >= LZ4F_compressFrameBound(srcSize, preferencesPtr).
+ *  The LZ4F_preferences_t structure is optional : you can provide NULL as argument. All preferences will be set to default.
+ * @return : number of bytes written into dstBuffer.
+ *           or an error code if it fails (can be tested using LZ4F_isError())
+ */
+size_t LZ4F_compressFrame(void* dstBuffer, size_t dstCapacity,
+                    const void* srcBuffer, size_t srcSize,
+                    const LZ4F_preferences_t* preferencesPtr)
+{
+    size_t result;
+#if (LZ4F_HEAPMODE)
+    LZ4F_cctx_t *cctxPtr;
+    result = LZ4F_createCompressionContext(&cctxPtr, LZ4F_VERSION);
+    if (LZ4F_isError(result)) return result;
+#else
+    LZ4F_cctx_t cctx;
+    LZ4_stream_t lz4ctx;
+    LZ4F_cctx_t *cctxPtr = &cctx;
+
+    DEBUGLOG(4, "LZ4F_compressFrame");
+    MEM_INIT(&cctx, 0, sizeof(cctx));
+    cctx.version = LZ4F_VERSION;
+    cctx.maxBufferSize = 5 MB;   /* mess with real buffer size to prevent dynamic allocation; works only because autoflush==1 & stableSrc==1 */
+    if (preferencesPtr == NULL ||
+        preferencesPtr->compressionLevel < LZ4HC_CLEVEL_MIN)
+    {
+        LZ4_initStream(&lz4ctx, sizeof(lz4ctx));
+        cctxPtr->lz4CtxPtr = &lz4ctx;
+        cctxPtr->lz4CtxAlloc = 1;
+        cctxPtr->lz4CtxState = 1;
+    }
+#endif
+
+    result = LZ4F_compressFrame_usingCDict(cctxPtr, dstBuffer, dstCapacity,
+                                           srcBuffer, srcSize,
+                                           NULL, preferencesPtr);
+
+#if (LZ4F_HEAPMODE)
+    LZ4F_freeCompressionContext(cctxPtr);
+#else
+    if (preferencesPtr != NULL &&
+        preferencesPtr->compressionLevel >= LZ4HC_CLEVEL_MIN)
+    {
+        FREEMEM(cctxPtr->lz4CtxPtr);
+    }
+#endif
+    return result;
+}
+
+
+/*-***************************************************
+*   Dictionary compression
+*****************************************************/
+
+struct LZ4F_CDict_s {
+    void* dictContent;
+    LZ4_stream_t* fastCtx;
+    LZ4_streamHC_t* HCCtx;
+}; /* typedef'd to LZ4F_CDict within lz4frame_static.h */
+
+/*! LZ4F_createCDict() :
+ *  When compressing multiple messages / blocks with the same dictionary, it's recommended to load it just once.
+ *  LZ4F_createCDict() will create a digested dictionary, ready to start future compression operations without startup delay.
+ *  LZ4F_CDict can be created once and shared by multiple threads concurrently, since its usage is read-only.
+ * `dictBuffer` can be released after LZ4F_CDict creation, since its content is copied within CDict
+ * @return : digested dictionary for compression, or NULL if failed */
+LZ4F_CDict* LZ4F_createCDict(const void* dictBuffer, size_t dictSize)
+{
+    const char* dictStart = (const char*)dictBuffer;
+    LZ4F_CDict* cdict = (LZ4F_CDict*) ALLOC(sizeof(*cdict));
+    DEBUGLOG(4, "LZ4F_createCDict");
+    if (!cdict) return NULL;
+    if (dictSize > 64 KB) {
+        dictStart += dictSize - 64 KB;
+        dictSize = 64 KB;
+    }
+    cdict->dictContent = ALLOC(dictSize);
+    cdict->fastCtx = LZ4_createStream();
+    cdict->HCCtx = LZ4_createStreamHC();
+    if (!cdict->dictContent || !cdict->fastCtx || !cdict->HCCtx) {
+        LZ4F_freeCDict(cdict);
+        return NULL;
+    }
+    memcpy(cdict->dictContent, dictStart, dictSize);
+    LZ4_loadDict (cdict->fastCtx, (const char*)cdict->dictContent, (int)dictSize);
+    LZ4_setCompressionLevel(cdict->HCCtx, LZ4HC_CLEVEL_DEFAULT);
+    LZ4_loadDictHC(cdict->HCCtx, (const char*)cdict->dictContent, (int)dictSize);
+    return cdict;
+}
+
+void LZ4F_freeCDict(LZ4F_CDict* cdict)
+{
+    if (cdict==NULL) return;  /* support free on NULL */
+    FREEMEM(cdict->dictContent);
+    LZ4_freeStream(cdict->fastCtx);
+    LZ4_freeStreamHC(cdict->HCCtx);
+    FREEMEM(cdict);
+}
+
+
+/*-*********************************
+*  Advanced compression functions
+***********************************/
+
+/*! LZ4F_createCompressionContext() :
+ *  The first thing to do is to create a compressionContext object, which will be used in all compression operations.
+ *  This is achieved using LZ4F_createCompressionContext(), which takes as argument a version and an LZ4F_preferences_t structure.
+ *  The version provided MUST be LZ4F_VERSION. It is intended to track potential incompatible differences between different binaries.
+ *  The function will provide a pointer to an allocated LZ4F_compressionContext_t object.
+ *  If the result LZ4F_errorCode_t is not OK_NoError, there was an error during context creation.
+ *  Object can release its memory using LZ4F_freeCompressionContext();
+ */
+LZ4F_errorCode_t LZ4F_createCompressionContext(LZ4F_cctx** LZ4F_compressionContextPtr, unsigned version)
+{
+    LZ4F_cctx_t* const cctxPtr = (LZ4F_cctx_t*)ALLOC_AND_ZERO(sizeof(LZ4F_cctx_t));
+    if (cctxPtr==NULL) return err0r(LZ4F_ERROR_allocation_failed);
+
+    cctxPtr->version = version;
+    cctxPtr->cStage = 0;   /* Next stage : init stream */
+
+    *LZ4F_compressionContextPtr = cctxPtr;
+
+    return LZ4F_OK_NoError;
+}
+
+
+LZ4F_errorCode_t LZ4F_freeCompressionContext(LZ4F_cctx* cctxPtr)
+{
+    if (cctxPtr != NULL) {  /* support free on NULL */
+       FREEMEM(cctxPtr->lz4CtxPtr);  /* note: LZ4_streamHC_t and LZ4_stream_t are simple POD types */
+       FREEMEM(cctxPtr->tmpBuff);
+       FREEMEM(cctxPtr);
+    }
+
+    return LZ4F_OK_NoError;
+}
+
+
+/**
+ * This function prepares the internal LZ4(HC) stream for a new compression,
+ * resetting the context and attaching the dictionary, if there is one.
+ *
+ * It needs to be called at the beginning of each independent compression
+ * stream (i.e., at the beginning of a frame in blockLinked mode, or at the
+ * beginning of each block in blockIndependent mode).
+ */
+static void LZ4F_initStream(void* ctx,
+                            const LZ4F_CDict* cdict,
+                            int level,
+                            LZ4F_blockMode_t blockMode) {
+    if (level < LZ4HC_CLEVEL_MIN) {
+        if (cdict != NULL || blockMode == LZ4F_blockLinked) {
+            /* In these cases, we will call LZ4_compress_fast_continue(),
+             * which needs an already reset context. Otherwise, we'll call a
+             * one-shot API. The non-continued APIs internally perform their own
+             * resets at the beginning of their calls, where they know what
+             * tableType they need the context to be in. So in that case this
+             * would be misguided / wasted work. */
+            LZ4_resetStream_fast((LZ4_stream_t*)ctx);
+        }
+        LZ4_attach_dictionary((LZ4_stream_t *)ctx, cdict ? cdict->fastCtx : NULL);
+    } else {
+        LZ4_resetStreamHC_fast((LZ4_streamHC_t*)ctx, level);
+        LZ4_attach_HC_dictionary((LZ4_streamHC_t *)ctx, cdict ? cdict->HCCtx : NULL);
+    }
+}
+
+
+/*! LZ4F_compressBegin_usingCDict() :
+ *  init streaming compression and writes frame header into dstBuffer.
+ *  dstBuffer must be >= LZ4F_HEADER_SIZE_MAX bytes.
+ * @return : number of bytes written into dstBuffer for the header
+ *           or an error code (can be tested using LZ4F_isError())
+ */
+size_t LZ4F_compressBegin_usingCDict(LZ4F_cctx* cctxPtr,
+                          void* dstBuffer, size_t dstCapacity,
+                          const LZ4F_CDict* cdict,
+                          const LZ4F_preferences_t* preferencesPtr)
+{
+    LZ4F_preferences_t prefNull;
+    BYTE* const dstStart = (BYTE*)dstBuffer;
+    BYTE* dstPtr = dstStart;
+    BYTE* headerStart;
+
+    if (dstCapacity < maxFHSize) return err0r(LZ4F_ERROR_dstMaxSize_tooSmall);
+    MEM_INIT(&prefNull, 0, sizeof(prefNull));
+    if (preferencesPtr == NULL) preferencesPtr = &prefNull;
+    cctxPtr->prefs = *preferencesPtr;
+
+    /* Ctx Management */
+    {   U16 const ctxTypeID = (cctxPtr->prefs.compressionLevel < LZ4HC_CLEVEL_MIN) ? 1 : 2;
+        if (cctxPtr->lz4CtxAlloc < ctxTypeID) {
+            FREEMEM(cctxPtr->lz4CtxPtr);
+            if (cctxPtr->prefs.compressionLevel < LZ4HC_CLEVEL_MIN) {
+                cctxPtr->lz4CtxPtr = LZ4_createStream();
+            } else {
+                cctxPtr->lz4CtxPtr = LZ4_createStreamHC();
+            }
+            if (cctxPtr->lz4CtxPtr == NULL)
+                return err0r(LZ4F_ERROR_allocation_failed);
+            cctxPtr->lz4CtxAlloc = ctxTypeID;
+            cctxPtr->lz4CtxState = ctxTypeID;
+        } else if (cctxPtr->lz4CtxState != ctxTypeID) {
+            /* otherwise, a sufficient buffer is allocated, but we need to
+             * reset it to the correct context type */
+            if (cctxPtr->prefs.compressionLevel < LZ4HC_CLEVEL_MIN) {
+                LZ4_initStream((LZ4_stream_t *) cctxPtr->lz4CtxPtr, sizeof (LZ4_stream_t));
+            } else {
+                LZ4_initStreamHC((LZ4_streamHC_t *) cctxPtr->lz4CtxPtr, sizeof(LZ4_streamHC_t));
+                LZ4_setCompressionLevel((LZ4_streamHC_t *) cctxPtr->lz4CtxPtr, cctxPtr->prefs.compressionLevel);
+            }
+            cctxPtr->lz4CtxState = ctxTypeID;
+        }
+    }
+
+    /* Buffer Management */
+    if (cctxPtr->prefs.frameInfo.blockSizeID == 0)
+        cctxPtr->prefs.frameInfo.blockSizeID = LZ4F_BLOCKSIZEID_DEFAULT;
+    cctxPtr->maxBlockSize = LZ4F_getBlockSize(cctxPtr->prefs.frameInfo.blockSizeID);
+
+    {   size_t const requiredBuffSize = preferencesPtr->autoFlush ?
+                ((cctxPtr->prefs.frameInfo.blockMode == LZ4F_blockLinked) ? 64 KB : 0) :  /* only needs past data up to window size */
+                cctxPtr->maxBlockSize + ((cctxPtr->prefs.frameInfo.blockMode == LZ4F_blockLinked) ? 128 KB : 0);
+
+        if (cctxPtr->maxBufferSize < requiredBuffSize) {
+            cctxPtr->maxBufferSize = 0;
+            FREEMEM(cctxPtr->tmpBuff);
+            cctxPtr->tmpBuff = (BYTE*)ALLOC_AND_ZERO(requiredBuffSize);
+            if (cctxPtr->tmpBuff == NULL) return err0r(LZ4F_ERROR_allocation_failed);
+            cctxPtr->maxBufferSize = requiredBuffSize;
+    }   }
+    cctxPtr->tmpIn = cctxPtr->tmpBuff;
+    cctxPtr->tmpInSize = 0;
+    (void)XXH32_reset(&(cctxPtr->xxh), 0);
+
+    /* context init */
+    cctxPtr->cdict = cdict;
+    if (cctxPtr->prefs.frameInfo.blockMode == LZ4F_blockLinked) {
+        /* frame init only for blockLinked : blockIndependent will be init at each block */
+        LZ4F_initStream(cctxPtr->lz4CtxPtr, cdict, cctxPtr->prefs.compressionLevel, LZ4F_blockLinked);
+    }
+    if (preferencesPtr->compressionLevel >= LZ4HC_CLEVEL_MIN) {
+        LZ4_favorDecompressionSpeed((LZ4_streamHC_t*)cctxPtr->lz4CtxPtr, (int)preferencesPtr->favorDecSpeed);
+    }
+
+    /* Magic Number */
+    LZ4F_writeLE32(dstPtr, LZ4F_MAGICNUMBER);
+    dstPtr += 4;
+    headerStart = dstPtr;
+
+    /* FLG Byte */
+    *dstPtr++ = (BYTE)(((1 & _2BITS) << 6)    /* Version('01') */
+        + ((cctxPtr->prefs.frameInfo.blockMode & _1BIT ) << 5)
+        + ((cctxPtr->prefs.frameInfo.blockChecksumFlag & _1BIT ) << 4)
+        + ((unsigned)(cctxPtr->prefs.frameInfo.contentSize > 0) << 3)
+        + ((cctxPtr->prefs.frameInfo.contentChecksumFlag & _1BIT ) << 2)
+        +  (cctxPtr->prefs.frameInfo.dictID > 0) );
+    /* BD Byte */
+    *dstPtr++ = (BYTE)((cctxPtr->prefs.frameInfo.blockSizeID & _3BITS) << 4);
+    /* Optional Frame content size field */
+    if (cctxPtr->prefs.frameInfo.contentSize) {
+        LZ4F_writeLE64(dstPtr, cctxPtr->prefs.frameInfo.contentSize);
+        dstPtr += 8;
+        cctxPtr->totalInSize = 0;
+    }
+    /* Optional dictionary ID field */
+    if (cctxPtr->prefs.frameInfo.dictID) {
+        LZ4F_writeLE32(dstPtr, cctxPtr->prefs.frameInfo.dictID);
+        dstPtr += 4;
+    }
+    /* Header CRC Byte */
+    *dstPtr = LZ4F_headerChecksum(headerStart, (size_t)(dstPtr - headerStart));
+    dstPtr++;
+
+    cctxPtr->cStage = 1;   /* header written, now request input data block */
+    return (size_t)(dstPtr - dstStart);
+}
+
+
+/*! LZ4F_compressBegin() :
+ *  init streaming compression and writes frame header into dstBuffer.
+ *  dstBuffer must be >= LZ4F_HEADER_SIZE_MAX bytes.
+ *  preferencesPtr can be NULL, in which case default parameters are selected.
+ * @return : number of bytes written into dstBuffer for the header
+ *        or an error code (can be tested using LZ4F_isError())
+ */
+size_t LZ4F_compressBegin(LZ4F_cctx* cctxPtr,
+                          void* dstBuffer, size_t dstCapacity,
+                          const LZ4F_preferences_t* preferencesPtr)
+{
+    return LZ4F_compressBegin_usingCDict(cctxPtr, dstBuffer, dstCapacity,
+                                         NULL, preferencesPtr);
+}
+
+
+/*  LZ4F_compressBound() :
+ * @return minimum capacity of dstBuffer for a given srcSize to handle worst case scenario.
+ *  LZ4F_preferences_t structure is optional : if NULL, preferences will be set to cover worst case scenario.
+ *  This function cannot fail.
+ */
+size_t LZ4F_compressBound(size_t srcSize, const LZ4F_preferences_t* preferencesPtr)
+{
+    if (preferencesPtr && preferencesPtr->autoFlush) {
+        return LZ4F_compressBound_internal(srcSize, preferencesPtr, 0);
+    }
+    return LZ4F_compressBound_internal(srcSize, preferencesPtr, (size_t)-1);
+}
+
+
+typedef int (*compressFunc_t)(void* ctx, const char* src, char* dst, int srcSize, int dstSize, int level, const LZ4F_CDict* cdict);
+
+
+/*! LZ4F_makeBlock():
+ *  compress a single block, add header and optional checksum.
+ *  assumption : dst buffer capacity is >= BHSize + srcSize + crcSize
+ */
+static size_t LZ4F_makeBlock(void* dst,
+                       const void* src, size_t srcSize,
+                             compressFunc_t compress, void* lz4ctx, int level,
+                       const LZ4F_CDict* cdict,
+                             LZ4F_blockChecksum_t crcFlag)
+{
+    BYTE* const cSizePtr = (BYTE*)dst;
+    U32 cSize = (U32)compress(lz4ctx, (const char*)src, (char*)(cSizePtr+BHSize),
+                                      (int)(srcSize), (int)(srcSize-1),
+                                      level, cdict);
+    if (cSize == 0) {  /* compression failed */
+        DEBUGLOG(5, "LZ4F_makeBlock: compression failed, creating a raw block (size %u)", (U32)srcSize);
+        cSize = (U32)srcSize;
+        LZ4F_writeLE32(cSizePtr, cSize | LZ4F_BLOCKUNCOMPRESSED_FLAG);
+        memcpy(cSizePtr+BHSize, src, srcSize);
+    } else {
+        LZ4F_writeLE32(cSizePtr, cSize);
+    }
+    if (crcFlag) {
+        U32 const crc32 = XXH32(cSizePtr+BHSize, cSize, 0);  /* checksum of compressed data */
+        LZ4F_writeLE32(cSizePtr+BHSize+cSize, crc32);
+    }
+    return BHSize + cSize + ((U32)crcFlag)*BFSize;
+}
+
+
+static int LZ4F_compressBlock(void* ctx, const char* src, char* dst, int srcSize, int dstCapacity, int level, const LZ4F_CDict* cdict)
+{
+    int const acceleration = (level < 0) ? -level + 1 : 1;
+    LZ4F_initStream(ctx, cdict, level, LZ4F_blockIndependent);
+    if (cdict) {
+        return LZ4_compress_fast_continue((LZ4_stream_t*)ctx, src, dst, srcSize, dstCapacity, acceleration);
+    } else {
+        return LZ4_compress_fast_extState_fastReset(ctx, src, dst, srcSize, dstCapacity, acceleration);
+    }
+}
+
+static int LZ4F_compressBlock_continue(void* ctx, const char* src, char* dst, int srcSize, int dstCapacity, int level, const LZ4F_CDict* cdict)
+{
+    int const acceleration = (level < 0) ? -level + 1 : 1;
+    (void)cdict; /* init once at beginning of frame */
+    return LZ4_compress_fast_continue((LZ4_stream_t*)ctx, src, dst, srcSize, dstCapacity, acceleration);
+}
+
+static int LZ4F_compressBlockHC(void* ctx, const char* src, char* dst, int srcSize, int dstCapacity, int level, const LZ4F_CDict* cdict)
+{
+    LZ4F_initStream(ctx, cdict, level, LZ4F_blockIndependent);
+    if (cdict) {
+        return LZ4_compress_HC_continue((LZ4_streamHC_t*)ctx, src, dst, srcSize, dstCapacity);
+    }
+    return LZ4_compress_HC_extStateHC_fastReset(ctx, src, dst, srcSize, dstCapacity, level);
+}
+
+static int LZ4F_compressBlockHC_continue(void* ctx, const char* src, char* dst, int srcSize, int dstCapacity, int level, const LZ4F_CDict* cdict)
+{
+    (void)level; (void)cdict; /* init once at beginning of frame */
+    return LZ4_compress_HC_continue((LZ4_streamHC_t*)ctx, src, dst, srcSize, dstCapacity);
+}
+
+static compressFunc_t LZ4F_selectCompression(LZ4F_blockMode_t blockMode, int level)
+{
+    if (level < LZ4HC_CLEVEL_MIN) {
+        if (blockMode == LZ4F_blockIndependent) return LZ4F_compressBlock;
+        return LZ4F_compressBlock_continue;
+    }
+    if (blockMode == LZ4F_blockIndependent) return LZ4F_compressBlockHC;
+    return LZ4F_compressBlockHC_continue;
+}
+
+static int LZ4F_localSaveDict(LZ4F_cctx_t* cctxPtr)
+{
+    if (cctxPtr->prefs.compressionLevel < LZ4HC_CLEVEL_MIN)
+        return LZ4_saveDict ((LZ4_stream_t*)(cctxPtr->lz4CtxPtr), (char*)(cctxPtr->tmpBuff), 64 KB);
+    return LZ4_saveDictHC ((LZ4_streamHC_t*)(cctxPtr->lz4CtxPtr), (char*)(cctxPtr->tmpBuff), 64 KB);
+}
+
+typedef enum { notDone, fromTmpBuffer, fromSrcBuffer } LZ4F_lastBlockStatus;
+
+/*! LZ4F_compressUpdate() :
+ *  LZ4F_compressUpdate() can be called repetitively to compress as much data as necessary.
+ *  dstBuffer MUST be >= LZ4F_compressBound(srcSize, preferencesPtr).
+ *  LZ4F_compressOptions_t structure is optional : you can provide NULL as argument.
+ * @return : the number of bytes written into dstBuffer. It can be zero, meaning input data was just buffered.
+ *           or an error code if it fails (which can be tested using LZ4F_isError())
+ */
+size_t LZ4F_compressUpdate(LZ4F_cctx* cctxPtr,
+                           void* dstBuffer, size_t dstCapacity,
+                     const void* srcBuffer, size_t srcSize,
+                     const LZ4F_compressOptions_t* compressOptionsPtr)
+{
+    LZ4F_compressOptions_t cOptionsNull;
+    size_t const blockSize = cctxPtr->maxBlockSize;
+    const BYTE* srcPtr = (const BYTE*)srcBuffer;
+    const BYTE* const srcEnd = srcPtr + srcSize;
+    BYTE* const dstStart = (BYTE*)dstBuffer;
+    BYTE* dstPtr = dstStart;
+    LZ4F_lastBlockStatus lastBlockCompressed = notDone;
+    compressFunc_t const compress = LZ4F_selectCompression(cctxPtr->prefs.frameInfo.blockMode, cctxPtr->prefs.compressionLevel);
+
+    DEBUGLOG(4, "LZ4F_compressUpdate (srcSize=%zu)", srcSize);
+
+    if (cctxPtr->cStage != 1) return err0r(LZ4F_ERROR_GENERIC);
+    if (dstCapacity < LZ4F_compressBound_internal(srcSize, &(cctxPtr->prefs), cctxPtr->tmpInSize))
+        return err0r(LZ4F_ERROR_dstMaxSize_tooSmall);
+    MEM_INIT(&cOptionsNull, 0, sizeof(cOptionsNull));
+    if (compressOptionsPtr == NULL) compressOptionsPtr = &cOptionsNull;
+
+    /* complete tmp buffer */
+    if (cctxPtr->tmpInSize > 0) {   /* some data already within tmp buffer */
+        size_t const sizeToCopy = blockSize - cctxPtr->tmpInSize;
+        if (sizeToCopy > srcSize) {
+            /* add src to tmpIn buffer */
+            memcpy(cctxPtr->tmpIn + cctxPtr->tmpInSize, srcBuffer, srcSize);
+            srcPtr = srcEnd;
+            cctxPtr->tmpInSize += srcSize;
+            /* still needs some CRC */
+        } else {
+            /* complete tmpIn block and then compress it */
+            lastBlockCompressed = fromTmpBuffer;
+            memcpy(cctxPtr->tmpIn + cctxPtr->tmpInSize, srcBuffer, sizeToCopy);
+            srcPtr += sizeToCopy;
+
+            dstPtr += LZ4F_makeBlock(dstPtr,
+                                     cctxPtr->tmpIn, blockSize,
+                                     compress, cctxPtr->lz4CtxPtr, cctxPtr->prefs.compressionLevel,
+                                     cctxPtr->cdict,
+                                     cctxPtr->prefs.frameInfo.blockChecksumFlag);
+
+            if (cctxPtr->prefs.frameInfo.blockMode==LZ4F_blockLinked) cctxPtr->tmpIn += blockSize;
+            cctxPtr->tmpInSize = 0;
+        }
+    }
+
+    while ((size_t)(srcEnd - srcPtr) >= blockSize) {
+        /* compress full blocks */
+        lastBlockCompressed = fromSrcBuffer;
+        dstPtr += LZ4F_makeBlock(dstPtr,
+                                 srcPtr, blockSize,
+                                 compress, cctxPtr->lz4CtxPtr, cctxPtr->prefs.compressionLevel,
+                                 cctxPtr->cdict,
+                                 cctxPtr->prefs.frameInfo.blockChecksumFlag);
+        srcPtr += blockSize;
+    }
+
+    if ((cctxPtr->prefs.autoFlush) && (srcPtr < srcEnd)) {
+        /* compress remaining input < blockSize */
+        lastBlockCompressed = fromSrcBuffer;
+        dstPtr += LZ4F_makeBlock(dstPtr,
+                                 srcPtr, (size_t)(srcEnd - srcPtr),
+                                 compress, cctxPtr->lz4CtxPtr, cctxPtr->prefs.compressionLevel,
+                                 cctxPtr->cdict,
+                                 cctxPtr->prefs.frameInfo.blockChecksumFlag);
+        srcPtr  = srcEnd;
+    }
+
+    /* preserve dictionary if necessary */
+    if ((cctxPtr->prefs.frameInfo.blockMode==LZ4F_blockLinked) && (lastBlockCompressed==fromSrcBuffer)) {
+        if (compressOptionsPtr->stableSrc) {
+            cctxPtr->tmpIn = cctxPtr->tmpBuff;
+        } else {
+            int const realDictSize = LZ4F_localSaveDict(cctxPtr);
+            if (realDictSize==0) return err0r(LZ4F_ERROR_GENERIC);
+            cctxPtr->tmpIn = cctxPtr->tmpBuff + realDictSize;
+        }
+    }
+
+    /* keep tmpIn within limits */
+    if ((cctxPtr->tmpIn + blockSize) > (cctxPtr->tmpBuff + cctxPtr->maxBufferSize)   /* necessarily LZ4F_blockLinked && lastBlockCompressed==fromTmpBuffer */
+        && !(cctxPtr->prefs.autoFlush))
+    {
+        int const realDictSize = LZ4F_localSaveDict(cctxPtr);
+        cctxPtr->tmpIn = cctxPtr->tmpBuff + realDictSize;
+    }
+
+    /* some input data left, necessarily < blockSize */
+    if (srcPtr < srcEnd) {
+        /* fill tmp buffer */
+        size_t const sizeToCopy = (size_t)(srcEnd - srcPtr);
+        memcpy(cctxPtr->tmpIn, srcPtr, sizeToCopy);
+        cctxPtr->tmpInSize = sizeToCopy;
+    }
+
+    if (cctxPtr->prefs.frameInfo.contentChecksumFlag == LZ4F_contentChecksumEnabled)
+        (void)XXH32_update(&(cctxPtr->xxh), srcBuffer, srcSize);
+
+    cctxPtr->totalInSize += srcSize;
+    return (size_t)(dstPtr - dstStart);
+}
+
+
+/*! LZ4F_flush() :
+ *  When compressed data must be sent immediately, without waiting for a block to be filled,
+ *  invoke LZ4_flush(), which will immediately compress any remaining data stored within LZ4F_cctx.
+ *  The result of the function is the number of bytes written into dstBuffer.
+ *  It can be zero, this means there was no data left within LZ4F_cctx.
+ *  The function outputs an error code if it fails (can be tested using LZ4F_isError())
+ *  LZ4F_compressOptions_t* is optional. NULL is a valid argument.
+ */
+size_t LZ4F_flush(LZ4F_cctx* cctxPtr,
+                  void* dstBuffer, size_t dstCapacity,
+            const LZ4F_compressOptions_t* compressOptionsPtr)
+{
+    BYTE* const dstStart = (BYTE*)dstBuffer;
+    BYTE* dstPtr = dstStart;
+    compressFunc_t compress;
+
+    if (cctxPtr->tmpInSize == 0) return 0;   /* nothing to flush */
+    if (cctxPtr->cStage != 1) return err0r(LZ4F_ERROR_GENERIC);
+    if (dstCapacity < (cctxPtr->tmpInSize + BHSize + BFSize))
+        return err0r(LZ4F_ERROR_dstMaxSize_tooSmall);
+    (void)compressOptionsPtr;   /* not yet useful */
+
+    /* select compression function */
+    compress = LZ4F_selectCompression(cctxPtr->prefs.frameInfo.blockMode, cctxPtr->prefs.compressionLevel);
+
+    /* compress tmp buffer */
+    dstPtr += LZ4F_makeBlock(dstPtr,
+                             cctxPtr->tmpIn, cctxPtr->tmpInSize,
+                             compress, cctxPtr->lz4CtxPtr, cctxPtr->prefs.compressionLevel,
+                             cctxPtr->cdict,
+                             cctxPtr->prefs.frameInfo.blockChecksumFlag);
+    assert(((void)"flush overflows dstBuffer!", (size_t)(dstPtr - dstStart) <= dstCapacity));
+
+    if (cctxPtr->prefs.frameInfo.blockMode == LZ4F_blockLinked)
+        cctxPtr->tmpIn += cctxPtr->tmpInSize;
+    cctxPtr->tmpInSize = 0;
+
+    /* keep tmpIn within limits */
+    if ((cctxPtr->tmpIn + cctxPtr->maxBlockSize) > (cctxPtr->tmpBuff + cctxPtr->maxBufferSize)) {  /* necessarily LZ4F_blockLinked */
+        int const realDictSize = LZ4F_localSaveDict(cctxPtr);
+        cctxPtr->tmpIn = cctxPtr->tmpBuff + realDictSize;
+    }
+
+    return (size_t)(dstPtr - dstStart);
+}
+
+
+/*! LZ4F_compressEnd() :
+ *  When you want to properly finish the compressed frame, just call LZ4F_compressEnd().
+ *  It will flush whatever data remained within compressionContext (like LZ4_flush())
+ *  but also properly finalize the frame, with an endMark and an (optional) checksum.
+ *  LZ4F_compressOptions_t structure is optional : you can provide NULL as argument.
+ * @return: the number of bytes written into dstBuffer (necessarily >= 4 (endMark size))
+ *       or an error code if it fails (can be tested using LZ4F_isError())
+ *  The context can then be used again to compress a new frame, starting with LZ4F_compressBegin().
+ */
+size_t LZ4F_compressEnd(LZ4F_cctx* cctxPtr,
+                        void* dstBuffer, size_t dstCapacity,
+                  const LZ4F_compressOptions_t* compressOptionsPtr)
+{
+    BYTE* const dstStart = (BYTE*)dstBuffer;
+    BYTE* dstPtr = dstStart;
+
+    size_t const flushSize = LZ4F_flush(cctxPtr, dstBuffer, dstCapacity, compressOptionsPtr);
+    DEBUGLOG(5,"LZ4F_compressEnd: dstCapacity=%u", (unsigned)dstCapacity);
+    if (LZ4F_isError(flushSize)) return flushSize;
+    dstPtr += flushSize;
+
+    assert(flushSize <= dstCapacity);
+    dstCapacity -= flushSize;
+
+    if (dstCapacity < 4) return err0r(LZ4F_ERROR_dstMaxSize_tooSmall);
+    LZ4F_writeLE32(dstPtr, 0);
+    dstPtr += 4;   /* endMark */
+
+    if (cctxPtr->prefs.frameInfo.contentChecksumFlag == LZ4F_contentChecksumEnabled) {
+        U32 const xxh = XXH32_digest(&(cctxPtr->xxh));
+        if (dstCapacity < 8) return err0r(LZ4F_ERROR_dstMaxSize_tooSmall);
+        DEBUGLOG(5,"Writing 32-bit content checksum");
+        LZ4F_writeLE32(dstPtr, xxh);
+        dstPtr+=4;   /* content Checksum */
+    }
+
+    cctxPtr->cStage = 0;   /* state is now re-usable (with identical preferences) */
+    cctxPtr->maxBufferSize = 0;  /* reuse HC context */
+
+    if (cctxPtr->prefs.frameInfo.contentSize) {
+        if (cctxPtr->prefs.frameInfo.contentSize != cctxPtr->totalInSize)
+            return err0r(LZ4F_ERROR_frameSize_wrong);
+    }
+
+    return (size_t)(dstPtr - dstStart);
+}
+
+
+/*-***************************************************
+*   Frame Decompression
+*****************************************************/
+
+typedef enum {
+    dstage_getFrameHeader=0, dstage_storeFrameHeader,
+    dstage_init,
+    dstage_getBlockHeader, dstage_storeBlockHeader,
+    dstage_copyDirect, dstage_getBlockChecksum,
+    dstage_getCBlock, dstage_storeCBlock,
+    dstage_flushOut,
+    dstage_getSuffix, dstage_storeSuffix,
+    dstage_getSFrameSize, dstage_storeSFrameSize,
+    dstage_skipSkippable
+} dStage_t;
+
+struct LZ4F_dctx_s {
+    LZ4F_frameInfo_t frameInfo;
+    U32    version;
+    dStage_t dStage;
+    U64    frameRemainingSize;
+    size_t maxBlockSize;
+    size_t maxBufferSize;
+    BYTE*  tmpIn;
+    size_t tmpInSize;
+    size_t tmpInTarget;
+    BYTE*  tmpOutBuffer;
+    const BYTE* dict;
+    size_t dictSize;
+    BYTE*  tmpOut;
+    size_t tmpOutSize;
+    size_t tmpOutStart;
+    XXH32_state_t xxh;
+    XXH32_state_t blockChecksum;
+    BYTE   header[LZ4F_HEADER_SIZE_MAX];
+};  /* typedef'd to LZ4F_dctx in lz4frame.h */
+
+
+/*! LZ4F_createDecompressionContext() :
+ *  Create a decompressionContext object, which will track all decompression operations.
+ *  Provides a pointer to a fully allocated and initialized LZ4F_decompressionContext object.
+ *  Object can later be released using LZ4F_freeDecompressionContext().
+ * @return : if != 0, there was an error during context creation.
+ */
+LZ4F_errorCode_t LZ4F_createDecompressionContext(LZ4F_dctx** LZ4F_decompressionContextPtr, unsigned versionNumber)
+{
+    LZ4F_dctx* const dctx = (LZ4F_dctx*)ALLOC_AND_ZERO(sizeof(LZ4F_dctx));
+    if (dctx == NULL) {  /* failed allocation */
+        *LZ4F_decompressionContextPtr = NULL;
+        return err0r(LZ4F_ERROR_allocation_failed);
+    }
+
+    dctx->version = versionNumber;
+    *LZ4F_decompressionContextPtr = dctx;
+    return LZ4F_OK_NoError;
+}
+
+LZ4F_errorCode_t LZ4F_freeDecompressionContext(LZ4F_dctx* dctx)
+{
+    LZ4F_errorCode_t result = LZ4F_OK_NoError;
+    if (dctx != NULL) {   /* can accept NULL input, like free() */
+      result = (LZ4F_errorCode_t)dctx->dStage;
+      FREEMEM(dctx->tmpIn);
+      FREEMEM(dctx->tmpOutBuffer);
+      FREEMEM(dctx);
+    }
+    return result;
+}
+
+
+/*==---   Streaming Decompression operations   ---==*/
+
+void LZ4F_resetDecompressionContext(LZ4F_dctx* dctx)
+{
+    dctx->dStage = dstage_getFrameHeader;
+    dctx->dict = NULL;
+    dctx->dictSize = 0;
+}
+
+
+/*! LZ4F_decodeHeader() :
+ *  input   : `src` points at the **beginning of the frame**
+ *  output  : set internal values of dctx, such as
+ *            dctx->frameInfo and dctx->dStage.
+ *            Also allocates internal buffers.
+ *  @return : nb Bytes read from src (necessarily <= srcSize)
+ *            or an error code (testable with LZ4F_isError())
+ */
+static size_t LZ4F_decodeHeader(LZ4F_dctx* dctx, const void* src, size_t srcSize)
+{
+    unsigned blockMode, blockChecksumFlag, contentSizeFlag, contentChecksumFlag, dictIDFlag, blockSizeID;
+    size_t frameHeaderSize;
+    const BYTE* srcPtr = (const BYTE*)src;
+
+    DEBUGLOG(5, "LZ4F_decodeHeader");
+    /* need to decode header to get frameInfo */
+    if (srcSize < minFHSize) return err0r(LZ4F_ERROR_frameHeader_incomplete);   /* minimal frame header size */
+    MEM_INIT(&(dctx->frameInfo), 0, sizeof(dctx->frameInfo));
+
+    /* special case : skippable frames */
+    if ((LZ4F_readLE32(srcPtr) & 0xFFFFFFF0U) == LZ4F_MAGIC_SKIPPABLE_START) {
+        dctx->frameInfo.frameType = LZ4F_skippableFrame;
+        if (src == (void*)(dctx->header)) {
+            dctx->tmpInSize = srcSize;
+            dctx->tmpInTarget = 8;
+            dctx->dStage = dstage_storeSFrameSize;
+            return srcSize;
+        } else {
+            dctx->dStage = dstage_getSFrameSize;
+            return 4;
+        }
+    }
+
+    /* control magic number */
+#ifndef FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+    if (LZ4F_readLE32(srcPtr) != LZ4F_MAGICNUMBER) {
+        DEBUGLOG(4, "frame header error : unknown magic number");
+        return err0r(LZ4F_ERROR_frameType_unknown);
+    }
+#endif
+    dctx->frameInfo.frameType = LZ4F_frame;
+
+    /* Flags */
+    {   U32 const FLG = srcPtr[4];
+        U32 const version = (FLG>>6) & _2BITS;
+        blockChecksumFlag = (FLG>>4) & _1BIT;
+        blockMode = (FLG>>5) & _1BIT;
+        contentSizeFlag = (FLG>>3) & _1BIT;
+        contentChecksumFlag = (FLG>>2) & _1BIT;
+        dictIDFlag = FLG & _1BIT;
+        /* validate */
+        if (((FLG>>1)&_1BIT) != 0) return err0r(LZ4F_ERROR_reservedFlag_set); /* Reserved bit */
+        if (version != 1) return err0r(LZ4F_ERROR_headerVersion_wrong);        /* Version Number, only supported value */
+    }
+
+    /* Frame Header Size */
+    frameHeaderSize = minFHSize + (contentSizeFlag?8:0) + (dictIDFlag?4:0);
+
+    if (srcSize < frameHeaderSize) {
+        /* not enough input to fully decode frame header */
+        if (srcPtr != dctx->header)
+            memcpy(dctx->header, srcPtr, srcSize);
+        dctx->tmpInSize = srcSize;
+        dctx->tmpInTarget = frameHeaderSize;
+        dctx->dStage = dstage_storeFrameHeader;
+        return srcSize;
+    }
+
+    {   U32 const BD = srcPtr[5];
+        blockSizeID = (BD>>4) & _3BITS;
+        /* validate */
+        if (((BD>>7)&_1BIT) != 0) return err0r(LZ4F_ERROR_reservedFlag_set);   /* Reserved bit */
+        if (blockSizeID < 4) return err0r(LZ4F_ERROR_maxBlockSize_invalid);    /* 4-7 only supported values for the time being */
+        if (((BD>>0)&_4BITS) != 0) return err0r(LZ4F_ERROR_reservedFlag_set);  /* Reserved bits */
+    }
+
+    /* check header */
+    assert(frameHeaderSize > 5);
+#ifndef FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+    {   BYTE const HC = LZ4F_headerChecksum(srcPtr+4, frameHeaderSize-5);
+        if (HC != srcPtr[frameHeaderSize-1])
+            return err0r(LZ4F_ERROR_headerChecksum_invalid);
+    }
+#endif
+
+    /* save */
+    dctx->frameInfo.blockMode = (LZ4F_blockMode_t)blockMode;
+    dctx->frameInfo.blockChecksumFlag = (LZ4F_blockChecksum_t)blockChecksumFlag;
+    dctx->frameInfo.contentChecksumFlag = (LZ4F_contentChecksum_t)contentChecksumFlag;
+    dctx->frameInfo.blockSizeID = (LZ4F_blockSizeID_t)blockSizeID;
+    dctx->maxBlockSize = LZ4F_getBlockSize(blockSizeID);
+    if (contentSizeFlag)
+        dctx->frameRemainingSize =
+            dctx->frameInfo.contentSize = LZ4F_readLE64(srcPtr+6);
+    if (dictIDFlag)
+        dctx->frameInfo.dictID = LZ4F_readLE32(srcPtr + frameHeaderSize - 5);
+
+    dctx->dStage = dstage_init;
+
+    return frameHeaderSize;
+}
+
+
+/*! LZ4F_headerSize() :
+ * @return : size of frame header
+ *           or an error code, which can be tested using LZ4F_isError()
+ */
+size_t LZ4F_headerSize(const void* src, size_t srcSize)
+{
+    if (src == NULL) return err0r(LZ4F_ERROR_srcPtr_wrong);
+
+    /* minimal srcSize to determine header size */
+    if (srcSize < LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH)
+        return err0r(LZ4F_ERROR_frameHeader_incomplete);
+
+    /* special case : skippable frames */
+    if ((LZ4F_readLE32(src) & 0xFFFFFFF0U) == LZ4F_MAGIC_SKIPPABLE_START)
+        return 8;
+
+    /* control magic number */
+#ifndef FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+    if (LZ4F_readLE32(src) != LZ4F_MAGICNUMBER)
+        return err0r(LZ4F_ERROR_frameType_unknown);
+#endif
+
+    /* Frame Header Size */
+    {   BYTE const FLG = ((const BYTE*)src)[4];
+        U32 const contentSizeFlag = (FLG>>3) & _1BIT;
+        U32 const dictIDFlag = FLG & _1BIT;
+        return minFHSize + (contentSizeFlag?8:0) + (dictIDFlag?4:0);
+    }
+}
+
+/*! LZ4F_getFrameInfo() :
+ *  This function extracts frame parameters (max blockSize, frame checksum, etc.).
+ *  Usage is optional. Objective is to provide relevant information for allocation purposes.
+ *  This function works in 2 situations :
+ *   - At the beginning of a new frame, in which case it will decode this information from `srcBuffer`, and start the decoding process.
+ *     Amount of input data provided must be large enough to successfully decode the frame header.
+ *     A header size is variable, but is guaranteed to be <= LZ4F_HEADER_SIZE_MAX bytes. It's possible to provide more input data than this minimum.
+ *   - After decoding has been started. In which case, no input is read, frame parameters are extracted from dctx.
+ *  The number of bytes consumed from srcBuffer will be updated within *srcSizePtr (necessarily <= original value).
+ *  Decompression must resume from (srcBuffer + *srcSizePtr).
+ * @return : an hint about how many srcSize bytes LZ4F_decompress() expects for next call,
+ *           or an error code which can be tested using LZ4F_isError()
+ *  note 1 : in case of error, dctx is not modified. Decoding operations can resume from where they stopped.
+ *  note 2 : frame parameters are *copied into* an already allocated LZ4F_frameInfo_t structure.
+ */
+LZ4F_errorCode_t LZ4F_getFrameInfo(LZ4F_dctx* dctx,
+                                   LZ4F_frameInfo_t* frameInfoPtr,
+                             const void* srcBuffer, size_t* srcSizePtr)
+{
+    LZ4F_STATIC_ASSERT(dstage_getFrameHeader < dstage_storeFrameHeader);
+    if (dctx->dStage > dstage_storeFrameHeader) {
+        /* frameInfo already decoded */
+        size_t o=0, i=0;
+        *srcSizePtr = 0;
+        *frameInfoPtr = dctx->frameInfo;
+        /* returns : recommended nb of bytes for LZ4F_decompress() */
+        return LZ4F_decompress(dctx, NULL, &o, NULL, &i, NULL);
+    } else {
+        if (dctx->dStage == dstage_storeFrameHeader) {
+            /* frame decoding already started, in the middle of header => automatic fail */
+            *srcSizePtr = 0;
+            return err0r(LZ4F_ERROR_frameDecoding_alreadyStarted);
+        } else {
+            size_t const hSize = LZ4F_headerSize(srcBuffer, *srcSizePtr);
+            if (LZ4F_isError(hSize)) { *srcSizePtr=0; return hSize; }
+            if (*srcSizePtr < hSize) {
+                *srcSizePtr=0;
+                return err0r(LZ4F_ERROR_frameHeader_incomplete);
+            }
+
+            {   size_t decodeResult = LZ4F_decodeHeader(dctx, srcBuffer, hSize);
+                if (LZ4F_isError(decodeResult)) {
+                    *srcSizePtr = 0;
+                } else {
+                    *srcSizePtr = decodeResult;
+                    decodeResult = BHSize;   /* block header size */
+                }
+                *frameInfoPtr = dctx->frameInfo;
+                return decodeResult;
+    }   }   }
+}
+
+
+/* LZ4F_updateDict() :
+ * only used for LZ4F_blockLinked mode
+ * Condition : dstPtr != NULL
+ */
+static void LZ4F_updateDict(LZ4F_dctx* dctx,
+                      const BYTE* dstPtr, size_t dstSize, const BYTE* dstBufferStart,
+                      unsigned withinTmp)
+{
+    assert(dstPtr != NULL);
+    if (dctx->dictSize==0) {
+        dctx->dict = (const BYTE*)dstPtr;   /* priority to prefix mode */
+    }
+    assert(dctx->dict != NULL);
+
+    if (dctx->dict + dctx->dictSize == dstPtr) {  /* prefix mode, everything within dstBuffer */
+        dctx->dictSize += dstSize;
+        return;
+    }
+
+    assert(dstPtr >= dstBufferStart);
+    if ((size_t)(dstPtr - dstBufferStart) + dstSize >= 64 KB) {  /* history in dstBuffer becomes large enough to become dictionary */
+        dctx->dict = (const BYTE*)dstBufferStart;
+        dctx->dictSize = (size_t)(dstPtr - dstBufferStart) + dstSize;
+        return;
+    }
+
+    assert(dstSize < 64 KB);   /* if dstSize >= 64 KB, dictionary would be set into dstBuffer directly */
+
+    /* dstBuffer does not contain whole useful history (64 KB), so it must be saved within tmpOutBuffer */
+    assert(dctx->tmpOutBuffer != NULL);
+
+    if (withinTmp && (dctx->dict == dctx->tmpOutBuffer)) {   /* continue history within tmpOutBuffer */
+        /* withinTmp expectation : content of [dstPtr,dstSize] is same as [dict+dictSize,dstSize], so we just extend it */
+        assert(dctx->dict + dctx->dictSize == dctx->tmpOut + dctx->tmpOutStart);
+        dctx->dictSize += dstSize;
+        return;
+    }
+
+    if (withinTmp) { /* copy relevant dict portion in front of tmpOut within tmpOutBuffer */
+        size_t const preserveSize = (size_t)(dctx->tmpOut - dctx->tmpOutBuffer);
+        size_t copySize = 64 KB - dctx->tmpOutSize;
+        const BYTE* const oldDictEnd = dctx->dict + dctx->dictSize - dctx->tmpOutStart;
+        if (dctx->tmpOutSize > 64 KB) copySize = 0;
+        if (copySize > preserveSize) copySize = preserveSize;
+
+        memcpy(dctx->tmpOutBuffer + preserveSize - copySize, oldDictEnd - copySize, copySize);
+
+        dctx->dict = dctx->tmpOutBuffer;
+        dctx->dictSize = preserveSize + dctx->tmpOutStart + dstSize;
+        return;
+    }
+
+    if (dctx->dict == dctx->tmpOutBuffer) {    /* copy dst into tmp to complete dict */
+        if (dctx->dictSize + dstSize > dctx->maxBufferSize) {  /* tmp buffer not large enough */
+            size_t const preserveSize = 64 KB - dstSize;
+            memcpy(dctx->tmpOutBuffer, dctx->dict + dctx->dictSize - preserveSize, preserveSize);
+            dctx->dictSize = preserveSize;
+        }
+        memcpy(dctx->tmpOutBuffer + dctx->dictSize, dstPtr, dstSize);
+        dctx->dictSize += dstSize;
+        return;
+    }
+
+    /* join dict & dest into tmp */
+    {   size_t preserveSize = 64 KB - dstSize;
+        if (preserveSize > dctx->dictSize) preserveSize = dctx->dictSize;
+        memcpy(dctx->tmpOutBuffer, dctx->dict + dctx->dictSize - preserveSize, preserveSize);
+        memcpy(dctx->tmpOutBuffer + preserveSize, dstPtr, dstSize);
+        dctx->dict = dctx->tmpOutBuffer;
+        dctx->dictSize = preserveSize + dstSize;
+    }
+}
+
+
+
+/*! LZ4F_decompress() :
+ *  Call this function repetitively to regenerate compressed data in srcBuffer.
+ *  The function will attempt to decode up to *srcSizePtr bytes from srcBuffer
+ *  into dstBuffer of capacity *dstSizePtr.
+ *
+ *  The number of bytes regenerated into dstBuffer will be provided within *dstSizePtr (necessarily <= original value).
+ *
+ *  The number of bytes effectively read from srcBuffer will be provided within *srcSizePtr (necessarily <= original value).
+ *  If number of bytes read is < number of bytes provided, then decompression operation is not complete.
+ *  Remaining data will have to be presented again in a subsequent invocation.
+ *
+ *  The function result is an hint of the better srcSize to use for next call to LZ4F_decompress.
+ *  Schematically, it's the size of the current (or remaining) compressed block + header of next block.
+ *  Respecting the hint provides a small boost to performance, since it allows less buffer shuffling.
+ *  Note that this is just a hint, and it's always possible to any srcSize value.
+ *  When a frame is fully decoded, @return will be 0.
+ *  If decompression failed, @return is an error code which can be tested using LZ4F_isError().
+ */
+size_t LZ4F_decompress(LZ4F_dctx* dctx,
+                       void* dstBuffer, size_t* dstSizePtr,
+                       const void* srcBuffer, size_t* srcSizePtr,
+                       const LZ4F_decompressOptions_t* decompressOptionsPtr)
+{
+    LZ4F_decompressOptions_t optionsNull;
+    const BYTE* const srcStart = (const BYTE*)srcBuffer;
+    const BYTE* const srcEnd = srcStart + *srcSizePtr;
+    const BYTE* srcPtr = srcStart;
+    BYTE* const dstStart = (BYTE*)dstBuffer;
+    BYTE* const dstEnd = dstStart ? dstStart + *dstSizePtr : NULL;
+    BYTE* dstPtr = dstStart;
+    const BYTE* selectedIn = NULL;
+    unsigned doAnotherStage = 1;
+    size_t nextSrcSizeHint = 1;
+
+
+    DEBUGLOG(5, "LZ4F_decompress : %p,%u => %p,%u",
+            srcBuffer, (unsigned)*srcSizePtr, dstBuffer, (unsigned)*dstSizePtr);
+    if (dstBuffer == NULL) assert(*dstSizePtr == 0);
+    MEM_INIT(&optionsNull, 0, sizeof(optionsNull));
+    if (decompressOptionsPtr==NULL) decompressOptionsPtr = &optionsNull;
+    *srcSizePtr = 0;
+    *dstSizePtr = 0;
+    assert(dctx != NULL);
+
+    /* behaves as a state machine */
+
+    while (doAnotherStage) {
+
+        switch(dctx->dStage)
+        {
+
+        case dstage_getFrameHeader:
+            DEBUGLOG(6, "dstage_getFrameHeader");
+            if ((size_t)(srcEnd-srcPtr) >= maxFHSize) {  /* enough to decode - shortcut */
+                size_t const hSize = LZ4F_decodeHeader(dctx, srcPtr, (size_t)(srcEnd-srcPtr));  /* will update dStage appropriately */
+                if (LZ4F_isError(hSize)) return hSize;
+                srcPtr += hSize;
+                break;
+            }
+            dctx->tmpInSize = 0;
+            if (srcEnd-srcPtr == 0) return minFHSize;   /* 0-size input */
+            dctx->tmpInTarget = minFHSize;   /* minimum size to decode header */
+            dctx->dStage = dstage_storeFrameHeader;
+            /* fall-through */
+
+        case dstage_storeFrameHeader:
+            DEBUGLOG(6, "dstage_storeFrameHeader");
+            {   size_t const sizeToCopy = MIN(dctx->tmpInTarget - dctx->tmpInSize, (size_t)(srcEnd - srcPtr));
+                memcpy(dctx->header + dctx->tmpInSize, srcPtr, sizeToCopy);
+                dctx->tmpInSize += sizeToCopy;
+                srcPtr += sizeToCopy;
+            }
+            if (dctx->tmpInSize < dctx->tmpInTarget) {
+                nextSrcSizeHint = (dctx->tmpInTarget - dctx->tmpInSize) + BHSize;   /* rest of header + nextBlockHeader */
+                doAnotherStage = 0;   /* not enough src data, ask for some more */
+                break;
+            }
+            {   size_t const hSize = LZ4F_decodeHeader(dctx, dctx->header, dctx->tmpInTarget);  /* will update dStage appropriately */
+                if (LZ4F_isError(hSize)) return hSize;
+            }
+            break;
+
+        case dstage_init:
+            DEBUGLOG(6, "dstage_init");
+            if (dctx->frameInfo.contentChecksumFlag) (void)XXH32_reset(&(dctx->xxh), 0);
+            /* internal buffers allocation */
+            {   size_t const bufferNeeded = dctx->maxBlockSize
+                    + ((dctx->frameInfo.blockMode==LZ4F_blockLinked) ? 128 KB : 0);
+                if (bufferNeeded > dctx->maxBufferSize) {   /* tmp buffers too small */
+                    dctx->maxBufferSize = 0;   /* ensure allocation will be re-attempted on next entry*/
+                    FREEMEM(dctx->tmpIn);
+                    dctx->tmpIn = (BYTE*)ALLOC(dctx->maxBlockSize + BFSize /* block checksum */);
+                    if (dctx->tmpIn == NULL)
+                        return err0r(LZ4F_ERROR_allocation_failed);
+                    FREEMEM(dctx->tmpOutBuffer);
+                    dctx->tmpOutBuffer= (BYTE*)ALLOC(bufferNeeded);
+                    if (dctx->tmpOutBuffer== NULL)
+                        return err0r(LZ4F_ERROR_allocation_failed);
+                    dctx->maxBufferSize = bufferNeeded;
+            }   }
+            dctx->tmpInSize = 0;
+            dctx->tmpInTarget = 0;
+            dctx->tmpOut = dctx->tmpOutBuffer;
+            dctx->tmpOutStart = 0;
+            dctx->tmpOutSize = 0;
+
+            dctx->dStage = dstage_getBlockHeader;
+            /* fall-through */
+
+        case dstage_getBlockHeader:
+            if ((size_t)(srcEnd - srcPtr) >= BHSize) {
+                selectedIn = srcPtr;
+                srcPtr += BHSize;
+            } else {
+                /* not enough input to read cBlockSize field */
+                dctx->tmpInSize = 0;
+                dctx->dStage = dstage_storeBlockHeader;
+            }
+
+            if (dctx->dStage == dstage_storeBlockHeader)   /* can be skipped */
+        case dstage_storeBlockHeader:
+            {   size_t const remainingInput = (size_t)(srcEnd - srcPtr);
+                size_t const wantedData = BHSize - dctx->tmpInSize;
+                size_t const sizeToCopy = MIN(wantedData, remainingInput);
+                memcpy(dctx->tmpIn + dctx->tmpInSize, srcPtr, sizeToCopy);
+                srcPtr += sizeToCopy;
+                dctx->tmpInSize += sizeToCopy;
+
+                if (dctx->tmpInSize < BHSize) {   /* not enough input for cBlockSize */
+                    nextSrcSizeHint = BHSize - dctx->tmpInSize;
+                    doAnotherStage  = 0;
+                    break;
+                }
+                selectedIn = dctx->tmpIn;
+            }   /* if (dctx->dStage == dstage_storeBlockHeader) */
+
+        /* decode block header */
+            {   U32 const blockHeader = LZ4F_readLE32(selectedIn);
+                size_t const nextCBlockSize = blockHeader & 0x7FFFFFFFU;
+                size_t const crcSize = dctx->frameInfo.blockChecksumFlag * BFSize;
+                if (blockHeader==0) {  /* frameEnd signal, no more block */
+                    DEBUGLOG(5, "end of frame");
+                    dctx->dStage = dstage_getSuffix;
+                    break;
+                }
+                if (nextCBlockSize > dctx->maxBlockSize) {
+                    return err0r(LZ4F_ERROR_maxBlockSize_invalid);
+                }
+                if (blockHeader & LZ4F_BLOCKUNCOMPRESSED_FLAG) {
+                    /* next block is uncompressed */
+                    dctx->tmpInTarget = nextCBlockSize;
+                    DEBUGLOG(5, "next block is uncompressed (size %u)", (U32)nextCBlockSize);
+                    if (dctx->frameInfo.blockChecksumFlag) {
+                        (void)XXH32_reset(&dctx->blockChecksum, 0);
+                    }
+                    dctx->dStage = dstage_copyDirect;
+                    break;
+                }
+                /* next block is a compressed block */
+                dctx->tmpInTarget = nextCBlockSize + crcSize;
+                dctx->dStage = dstage_getCBlock;
+                if (dstPtr==dstEnd || srcPtr==srcEnd) {
+                    nextSrcSizeHint = BHSize + nextCBlockSize + crcSize;
+                    doAnotherStage = 0;
+                }
+                break;
+            }
+
+        case dstage_copyDirect:   /* uncompressed block */
+            DEBUGLOG(6, "dstage_copyDirect");
+            {   size_t sizeToCopy;
+                if (dstPtr == NULL) {
+                    sizeToCopy = 0;
+                } else {
+                    size_t const minBuffSize = MIN((size_t)(srcEnd-srcPtr), (size_t)(dstEnd-dstPtr));
+                    sizeToCopy = MIN(dctx->tmpInTarget, minBuffSize);
+                    memcpy(dstPtr, srcPtr, sizeToCopy);
+                    if (dctx->frameInfo.blockChecksumFlag) {
+                        (void)XXH32_update(&dctx->blockChecksum, srcPtr, sizeToCopy);
+                    }
+                    if (dctx->frameInfo.contentChecksumFlag)
+                        (void)XXH32_update(&dctx->xxh, srcPtr, sizeToCopy);
+                    if (dctx->frameInfo.contentSize)
+                        dctx->frameRemainingSize -= sizeToCopy;
+
+                    /* history management (linked blocks only)*/
+                    if (dctx->frameInfo.blockMode == LZ4F_blockLinked) {
+                        LZ4F_updateDict(dctx, dstPtr, sizeToCopy, dstStart, 0);
+                }   }
+
+                srcPtr += sizeToCopy;
+                dstPtr += sizeToCopy;
+                if (sizeToCopy == dctx->tmpInTarget) {   /* all done */
+                    if (dctx->frameInfo.blockChecksumFlag) {
+                        dctx->tmpInSize = 0;
+                        dctx->dStage = dstage_getBlockChecksum;
+                    } else
+                        dctx->dStage = dstage_getBlockHeader;  /* new block */
+                    break;
+                }
+                dctx->tmpInTarget -= sizeToCopy;  /* need to copy more */
+            }
+            nextSrcSizeHint = dctx->tmpInTarget +
+                            +(dctx->frameInfo.blockChecksumFlag ? BFSize : 0)
+                            + BHSize /* next header size */;
+            doAnotherStage = 0;
+            break;
+
+        /* check block checksum for recently transferred uncompressed block */
+        case dstage_getBlockChecksum:
+            DEBUGLOG(6, "dstage_getBlockChecksum");
+            {   const void* crcSrc;
+                if ((srcEnd-srcPtr >= 4) && (dctx->tmpInSize==0)) {
+                    crcSrc = srcPtr;
+                    srcPtr += 4;
+                } else {
+                    size_t const stillToCopy = 4 - dctx->tmpInSize;
+                    size_t const sizeToCopy = MIN(stillToCopy, (size_t)(srcEnd-srcPtr));
+                    memcpy(dctx->header + dctx->tmpInSize, srcPtr, sizeToCopy);
+                    dctx->tmpInSize += sizeToCopy;
+                    srcPtr += sizeToCopy;
+                    if (dctx->tmpInSize < 4) {  /* all input consumed */
+                        doAnotherStage = 0;
+                        break;
+                    }
+                    crcSrc = dctx->header;
+                }
+                {   U32 const readCRC = LZ4F_readLE32(crcSrc);
+                    U32 const calcCRC = XXH32_digest(&dctx->blockChecksum);
+#ifndef FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+                    DEBUGLOG(6, "compare block checksum");
+                    if (readCRC != calcCRC) {
+                        DEBUGLOG(4, "incorrect block checksum: %08X != %08X",
+                                readCRC, calcCRC);
+                        return err0r(LZ4F_ERROR_blockChecksum_invalid);
+                    }
+#else
+                    (void)readCRC;
+                    (void)calcCRC;
+#endif
+            }   }
+            dctx->dStage = dstage_getBlockHeader;  /* new block */
+            break;
+
+        case dstage_getCBlock:
+            DEBUGLOG(6, "dstage_getCBlock");
+            if ((size_t)(srcEnd-srcPtr) < dctx->tmpInTarget) {
+                dctx->tmpInSize = 0;
+                dctx->dStage = dstage_storeCBlock;
+                break;
+            }
+            /* input large enough to read full block directly */
+            selectedIn = srcPtr;
+            srcPtr += dctx->tmpInTarget;
+
+            if (0)  /* always jump over next block */
+        case dstage_storeCBlock:
+            {   size_t const wantedData = dctx->tmpInTarget - dctx->tmpInSize;
+                size_t const inputLeft = (size_t)(srcEnd-srcPtr);
+                size_t const sizeToCopy = MIN(wantedData, inputLeft);
+                memcpy(dctx->tmpIn + dctx->tmpInSize, srcPtr, sizeToCopy);
+                dctx->tmpInSize += sizeToCopy;
+                srcPtr += sizeToCopy;
+                if (dctx->tmpInSize < dctx->tmpInTarget) { /* need more input */
+                    nextSrcSizeHint = (dctx->tmpInTarget - dctx->tmpInSize)
+                                    + (dctx->frameInfo.blockChecksumFlag ? BFSize : 0)
+                                    + BHSize /* next header size */;
+                    doAnotherStage = 0;
+                    break;
+                }
+                selectedIn = dctx->tmpIn;
+            }
+
+            /* At this stage, input is large enough to decode a block */
+            if (dctx->frameInfo.blockChecksumFlag) {
+                dctx->tmpInTarget -= 4;
+                assert(selectedIn != NULL);  /* selectedIn is defined at this stage (either srcPtr, or dctx->tmpIn) */
+                {   U32 const readBlockCrc = LZ4F_readLE32(selectedIn + dctx->tmpInTarget);
+                    U32 const calcBlockCrc = XXH32(selectedIn, dctx->tmpInTarget, 0);
+#ifndef FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+                    if (readBlockCrc != calcBlockCrc)
+                        return err0r(LZ4F_ERROR_blockChecksum_invalid);
+#else
+                    (void)readBlockCrc;
+                    (void)calcBlockCrc;
+#endif
+            }   }
+
+            if ((size_t)(dstEnd-dstPtr) >= dctx->maxBlockSize) {
+                const char* dict = (const char*)dctx->dict;
+                size_t dictSize = dctx->dictSize;
+                int decodedSize;
+                assert(dstPtr != NULL);
+                if (dict && dictSize > 1 GB) {
+                    /* the dictSize param is an int, avoid truncation / sign issues */
+                    dict += dictSize - 64 KB;
+                    dictSize = 64 KB;
+                }
+                /* enough capacity in `dst` to decompress directly there */
+                decodedSize = LZ4_decompress_safe_usingDict(
+                        (const char*)selectedIn, (char*)dstPtr,
+                        (int)dctx->tmpInTarget, (int)dctx->maxBlockSize,
+                        dict, (int)dictSize);
+                if (decodedSize < 0) return err0r(LZ4F_ERROR_GENERIC);   /* decompression failed */
+                if (dctx->frameInfo.contentChecksumFlag)
+                    XXH32_update(&(dctx->xxh), dstPtr, (size_t)decodedSize);
+                if (dctx->frameInfo.contentSize)
+                    dctx->frameRemainingSize -= (size_t)decodedSize;
+
+                /* dictionary management */
+                if (dctx->frameInfo.blockMode==LZ4F_blockLinked) {
+                    LZ4F_updateDict(dctx, dstPtr, (size_t)decodedSize, dstStart, 0);
+                }
+
+                dstPtr += decodedSize;
+                dctx->dStage = dstage_getBlockHeader;
+                break;
+            }
+
+            /* not enough place into dst : decode into tmpOut */
+            /* ensure enough place for tmpOut */
+            if (dctx->frameInfo.blockMode == LZ4F_blockLinked) {
+                if (dctx->dict == dctx->tmpOutBuffer) {
+                    if (dctx->dictSize > 128 KB) {
+                        memcpy(dctx->tmpOutBuffer, dctx->dict + dctx->dictSize - 64 KB, 64 KB);
+                        dctx->dictSize = 64 KB;
+                    }
+                    dctx->tmpOut = dctx->tmpOutBuffer + dctx->dictSize;
+                } else {  /* dict not within tmp */
+                    size_t const reservedDictSpace = MIN(dctx->dictSize, 64 KB);
+                    dctx->tmpOut = dctx->tmpOutBuffer + reservedDictSpace;
+            }   }
+
+            /* Decode block */
+            {   const char* dict = (const char*)dctx->dict;
+                size_t dictSize = dctx->dictSize;
+                int decodedSize;
+                if (dict && dictSize > 1 GB) {
+                    /* the dictSize param is an int, avoid truncation / sign issues */
+                    dict += dictSize - 64 KB;
+                    dictSize = 64 KB;
+                }
+                decodedSize = LZ4_decompress_safe_usingDict(
+                        (const char*)selectedIn, (char*)dctx->tmpOut,
+                        (int)dctx->tmpInTarget, (int)dctx->maxBlockSize,
+                        dict, (int)dictSize);
+                if (decodedSize < 0)  /* decompression failed */
+                    return err0r(LZ4F_ERROR_decompressionFailed);
+                if (dctx->frameInfo.contentChecksumFlag)
+                    XXH32_update(&(dctx->xxh), dctx->tmpOut, (size_t)decodedSize);
+                if (dctx->frameInfo.contentSize)
+                    dctx->frameRemainingSize -= (size_t)decodedSize;
+                dctx->tmpOutSize = (size_t)decodedSize;
+                dctx->tmpOutStart = 0;
+                dctx->dStage = dstage_flushOut;
+            }
+            /* fall-through */
+
+        case dstage_flushOut:  /* flush decoded data from tmpOut to dstBuffer */
+            DEBUGLOG(6, "dstage_flushOut");
+            if (dstPtr != NULL) {
+                size_t const sizeToCopy = MIN(dctx->tmpOutSize - dctx->tmpOutStart, (size_t)(dstEnd-dstPtr));
+                memcpy(dstPtr, dctx->tmpOut + dctx->tmpOutStart, sizeToCopy);
+
+                /* dictionary management */
+                if (dctx->frameInfo.blockMode == LZ4F_blockLinked)
+                    LZ4F_updateDict(dctx, dstPtr, sizeToCopy, dstStart, 1 /*withinTmp*/);
+
+                dctx->tmpOutStart += sizeToCopy;
+                dstPtr += sizeToCopy;
+            }
+            if (dctx->tmpOutStart == dctx->tmpOutSize) { /* all flushed */
+                dctx->dStage = dstage_getBlockHeader;  /* get next block */
+                break;
+            }
+            /* could not flush everything : stop there, just request a block header */
+            doAnotherStage = 0;
+            nextSrcSizeHint = BHSize;
+            break;
+
+        case dstage_getSuffix:
+            if (dctx->frameRemainingSize)
+                return err0r(LZ4F_ERROR_frameSize_wrong);   /* incorrect frame size decoded */
+            if (!dctx->frameInfo.contentChecksumFlag) {  /* no checksum, frame is completed */
+                nextSrcSizeHint = 0;
+                LZ4F_resetDecompressionContext(dctx);
+                doAnotherStage = 0;
+                break;
+            }
+            if ((srcEnd - srcPtr) < 4) {  /* not enough size for entire CRC */
+                dctx->tmpInSize = 0;
+                dctx->dStage = dstage_storeSuffix;
+            } else {
+                selectedIn = srcPtr;
+                srcPtr += 4;
+            }
+
+            if (dctx->dStage == dstage_storeSuffix)   /* can be skipped */
+        case dstage_storeSuffix:
+            {   size_t const remainingInput = (size_t)(srcEnd - srcPtr);
+                size_t const wantedData = 4 - dctx->tmpInSize;
+                size_t const sizeToCopy = MIN(wantedData, remainingInput);
+                memcpy(dctx->tmpIn + dctx->tmpInSize, srcPtr, sizeToCopy);
+                srcPtr += sizeToCopy;
+                dctx->tmpInSize += sizeToCopy;
+                if (dctx->tmpInSize < 4) { /* not enough input to read complete suffix */
+                    nextSrcSizeHint = 4 - dctx->tmpInSize;
+                    doAnotherStage=0;
+                    break;
+                }
+                selectedIn = dctx->tmpIn;
+            }   /* if (dctx->dStage == dstage_storeSuffix) */
+
+        /* case dstage_checkSuffix: */   /* no direct entry, avoid initialization risks */
+            {   U32 const readCRC = LZ4F_readLE32(selectedIn);
+                U32 const resultCRC = XXH32_digest(&(dctx->xxh));
+#ifndef FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+                if (readCRC != resultCRC)
+                    return err0r(LZ4F_ERROR_contentChecksum_invalid);
+#else
+                (void)readCRC;
+                (void)resultCRC;
+#endif
+                nextSrcSizeHint = 0;
+                LZ4F_resetDecompressionContext(dctx);
+                doAnotherStage = 0;
+                break;
+            }
+
+        case dstage_getSFrameSize:
+            if ((srcEnd - srcPtr) >= 4) {
+                selectedIn = srcPtr;
+                srcPtr += 4;
+            } else {
+                /* not enough input to read cBlockSize field */
+                dctx->tmpInSize = 4;
+                dctx->tmpInTarget = 8;
+                dctx->dStage = dstage_storeSFrameSize;
+            }
+
+            if (dctx->dStage == dstage_storeSFrameSize)
+        case dstage_storeSFrameSize:
+            {   size_t const sizeToCopy = MIN(dctx->tmpInTarget - dctx->tmpInSize,
+                                             (size_t)(srcEnd - srcPtr) );
+                memcpy(dctx->header + dctx->tmpInSize, srcPtr, sizeToCopy);
+                srcPtr += sizeToCopy;
+                dctx->tmpInSize += sizeToCopy;
+                if (dctx->tmpInSize < dctx->tmpInTarget) {
+                    /* not enough input to get full sBlockSize; wait for more */
+                    nextSrcSizeHint = dctx->tmpInTarget - dctx->tmpInSize;
+                    doAnotherStage = 0;
+                    break;
+                }
+                selectedIn = dctx->header + 4;
+            }   /* if (dctx->dStage == dstage_storeSFrameSize) */
+
+        /* case dstage_decodeSFrameSize: */   /* no direct entry */
+            {   size_t const SFrameSize = LZ4F_readLE32(selectedIn);
+                dctx->frameInfo.contentSize = SFrameSize;
+                dctx->tmpInTarget = SFrameSize;
+                dctx->dStage = dstage_skipSkippable;
+                break;
+            }
+
+        case dstage_skipSkippable:
+            {   size_t const skipSize = MIN(dctx->tmpInTarget, (size_t)(srcEnd-srcPtr));
+                srcPtr += skipSize;
+                dctx->tmpInTarget -= skipSize;
+                doAnotherStage = 0;
+                nextSrcSizeHint = dctx->tmpInTarget;
+                if (nextSrcSizeHint) break;  /* still more to skip */
+                /* frame fully skipped : prepare context for a new frame */
+                LZ4F_resetDecompressionContext(dctx);
+                break;
+            }
+        }   /* switch (dctx->dStage) */
+    }   /* while (doAnotherStage) */
+
+    /* preserve history within tmp whenever necessary */
+    LZ4F_STATIC_ASSERT((unsigned)dstage_init == 2);
+    if ( (dctx->frameInfo.blockMode==LZ4F_blockLinked)  /* next block will use up to 64KB from previous ones */
+      && (dctx->dict != dctx->tmpOutBuffer)             /* dictionary is not already within tmp */
+      && (dctx->dict != NULL)                           /* dictionary exists */
+      && (!decompressOptionsPtr->stableDst)             /* cannot rely on dst data to remain there for next call */
+      && ((unsigned)(dctx->dStage)-2 < (unsigned)(dstage_getSuffix)-2) )  /* valid stages : [init ... getSuffix[ */
+    {
+        if (dctx->dStage == dstage_flushOut) {
+            size_t const preserveSize = (size_t)(dctx->tmpOut - dctx->tmpOutBuffer);
+            size_t copySize = 64 KB - dctx->tmpOutSize;
+            const BYTE* oldDictEnd = dctx->dict + dctx->dictSize - dctx->tmpOutStart;
+            if (dctx->tmpOutSize > 64 KB) copySize = 0;
+            if (copySize > preserveSize) copySize = preserveSize;
+            assert(dctx->tmpOutBuffer != NULL);
+
+            memcpy(dctx->tmpOutBuffer + preserveSize - copySize, oldDictEnd - copySize, copySize);
+
+            dctx->dict = dctx->tmpOutBuffer;
+            dctx->dictSize = preserveSize + dctx->tmpOutStart;
+        } else {
+            const BYTE* const oldDictEnd = dctx->dict + dctx->dictSize;
+            size_t const newDictSize = MIN(dctx->dictSize, 64 KB);
+
+            memcpy(dctx->tmpOutBuffer, oldDictEnd - newDictSize, newDictSize);
+
+            dctx->dict = dctx->tmpOutBuffer;
+            dctx->dictSize = newDictSize;
+            dctx->tmpOut = dctx->tmpOutBuffer + newDictSize;
+        }
+    }
+
+    *srcSizePtr = (size_t)(srcPtr - srcStart);
+    *dstSizePtr = (size_t)(dstPtr - dstStart);
+    return nextSrcSizeHint;
+}
+
+/*! LZ4F_decompress_usingDict() :
+ *  Same as LZ4F_decompress(), using a predefined dictionary.
+ *  Dictionary is used "in place", without any preprocessing.
+ *  It must remain accessible throughout the entire frame decoding.
+ */
+size_t LZ4F_decompress_usingDict(LZ4F_dctx* dctx,
+                       void* dstBuffer, size_t* dstSizePtr,
+                       const void* srcBuffer, size_t* srcSizePtr,
+                       const void* dict, size_t dictSize,
+                       const LZ4F_decompressOptions_t* decompressOptionsPtr)
+{
+    if (dctx->dStage <= dstage_init) {
+        dctx->dict = (const BYTE*)dict;
+        dctx->dictSize = dictSize;
+    }
+    return LZ4F_decompress(dctx, dstBuffer, dstSizePtr,
+                           srcBuffer, srcSizePtr,
+                           decompressOptionsPtr);
+}
diff --git a/lz4/lib/lz4frame.h b/lz4/lib/lz4frame.h
new file mode 100644
index 0000000..4573317
--- /dev/null
+++ b/lz4/lib/lz4frame.h
@@ -0,0 +1,623 @@
+/*
+   LZ4 auto-framing library
+   Header File
+   Copyright (C) 2011-2017, Yann Collet.
+   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+   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.
+
+   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.
+
+   You can contact the author at :
+   - LZ4 source repository : https://github.com/lz4/lz4
+   - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+
+/* LZ4F is a stand-alone API able to create and decode LZ4 frames
+ * conformant with specification v1.6.1 in doc/lz4_Frame_format.md .
+ * Generated frames are compatible with `lz4` CLI.
+ *
+ * LZ4F also offers streaming capabilities.
+ *
+ * lz4.h is not required when using lz4frame.h,
+ * except to extract common constant such as LZ4_VERSION_NUMBER.
+ * */
+
+#ifndef LZ4F_H_09782039843
+#define LZ4F_H_09782039843
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+/* ---   Dependency   --- */
+#include    /* size_t */
+
+
+/**
+  Introduction
+
+  lz4frame.h implements LZ4 frame specification (doc/lz4_Frame_format.md).
+  lz4frame.h provides frame compression functions that take care
+  of encoding standard metadata alongside LZ4-compressed blocks.
+*/
+
+/*-***************************************************************
+ *  Compiler specifics
+ *****************************************************************/
+/*  LZ4_DLL_EXPORT :
+ *  Enable exporting of functions when building a Windows DLL
+ *  LZ4FLIB_VISIBILITY :
+ *  Control library symbols visibility.
+ */
+#ifndef LZ4FLIB_VISIBILITY
+#  if defined(__GNUC__) && (__GNUC__ >= 4)
+#    define LZ4FLIB_VISIBILITY __attribute__ ((visibility ("default")))
+#  else
+#    define LZ4FLIB_VISIBILITY
+#  endif
+#endif
+#if defined(LZ4_DLL_EXPORT) && (LZ4_DLL_EXPORT==1)
+#  define LZ4FLIB_API __declspec(dllexport) LZ4FLIB_VISIBILITY
+#elif defined(LZ4_DLL_IMPORT) && (LZ4_DLL_IMPORT==1)
+#  define LZ4FLIB_API __declspec(dllimport) LZ4FLIB_VISIBILITY
+#else
+#  define LZ4FLIB_API LZ4FLIB_VISIBILITY
+#endif
+
+#ifdef LZ4F_DISABLE_DEPRECATE_WARNINGS
+#  define LZ4F_DEPRECATE(x) x
+#else
+#  if defined(_MSC_VER)
+#    define LZ4F_DEPRECATE(x) x   /* __declspec(deprecated) x - only works with C++ */
+#  elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ >= 6))
+#    define LZ4F_DEPRECATE(x) x __attribute__((deprecated))
+#  else
+#    define LZ4F_DEPRECATE(x) x   /* no deprecation warning for this compiler */
+#  endif
+#endif
+
+
+/*-************************************
+ *  Error management
+ **************************************/
+typedef size_t LZ4F_errorCode_t;
+
+LZ4FLIB_API unsigned    LZ4F_isError(LZ4F_errorCode_t code);   /**< tells when a function result is an error code */
+LZ4FLIB_API const char* LZ4F_getErrorName(LZ4F_errorCode_t code);   /**< return error code string; for debugging */
+
+
+/*-************************************
+ *  Frame compression types
+ ************************************* */
+/* #define LZ4F_ENABLE_OBSOLETE_ENUMS   // uncomment to enable obsolete enums */
+#ifdef LZ4F_ENABLE_OBSOLETE_ENUMS
+#  define LZ4F_OBSOLETE_ENUM(x) , LZ4F_DEPRECATE(x) = LZ4F_##x
+#else
+#  define LZ4F_OBSOLETE_ENUM(x)
+#endif
+
+/* The larger the block size, the (slightly) better the compression ratio,
+ * though there are diminishing returns.
+ * Larger blocks also increase memory usage on both compression and decompression sides.
+ */
+typedef enum {
+    LZ4F_default=0,
+    LZ4F_max64KB=4,
+    LZ4F_max256KB=5,
+    LZ4F_max1MB=6,
+    LZ4F_max4MB=7
+    LZ4F_OBSOLETE_ENUM(max64KB)
+    LZ4F_OBSOLETE_ENUM(max256KB)
+    LZ4F_OBSOLETE_ENUM(max1MB)
+    LZ4F_OBSOLETE_ENUM(max4MB)
+} LZ4F_blockSizeID_t;
+
+/* Linked blocks sharply reduce inefficiencies when using small blocks,
+ * they compress better.
+ * However, some LZ4 decoders are only compatible with independent blocks */
+typedef enum {
+    LZ4F_blockLinked=0,
+    LZ4F_blockIndependent
+    LZ4F_OBSOLETE_ENUM(blockLinked)
+    LZ4F_OBSOLETE_ENUM(blockIndependent)
+} LZ4F_blockMode_t;
+
+typedef enum {
+    LZ4F_noContentChecksum=0,
+    LZ4F_contentChecksumEnabled
+    LZ4F_OBSOLETE_ENUM(noContentChecksum)
+    LZ4F_OBSOLETE_ENUM(contentChecksumEnabled)
+} LZ4F_contentChecksum_t;
+
+typedef enum {
+    LZ4F_noBlockChecksum=0,
+    LZ4F_blockChecksumEnabled
+} LZ4F_blockChecksum_t;
+
+typedef enum {
+    LZ4F_frame=0,
+    LZ4F_skippableFrame
+    LZ4F_OBSOLETE_ENUM(skippableFrame)
+} LZ4F_frameType_t;
+
+#ifdef LZ4F_ENABLE_OBSOLETE_ENUMS
+typedef LZ4F_blockSizeID_t blockSizeID_t;
+typedef LZ4F_blockMode_t blockMode_t;
+typedef LZ4F_frameType_t frameType_t;
+typedef LZ4F_contentChecksum_t contentChecksum_t;
+#endif
+
+/*! LZ4F_frameInfo_t :
+ *  makes it possible to set or read frame parameters.
+ *  Structure must be first init to 0, using memset() or LZ4F_INIT_FRAMEINFO,
+ *  setting all parameters to default.
+ *  It's then possible to update selectively some parameters */
+typedef struct {
+  LZ4F_blockSizeID_t     blockSizeID;         /* max64KB, max256KB, max1MB, max4MB; 0 == default */
+  LZ4F_blockMode_t       blockMode;           /* LZ4F_blockLinked, LZ4F_blockIndependent; 0 == default */
+  LZ4F_contentChecksum_t contentChecksumFlag; /* 1: frame terminated with 32-bit checksum of decompressed data; 0: disabled (default) */
+  LZ4F_frameType_t       frameType;           /* read-only field : LZ4F_frame or LZ4F_skippableFrame */
+  unsigned long long     contentSize;         /* Size of uncompressed content ; 0 == unknown */
+  unsigned               dictID;              /* Dictionary ID, sent by compressor to help decoder select correct dictionary; 0 == no dictID provided */
+  LZ4F_blockChecksum_t   blockChecksumFlag;   /* 1: each block followed by a checksum of block's compressed data; 0: disabled (default) */
+} LZ4F_frameInfo_t;
+
+#define LZ4F_INIT_FRAMEINFO   { LZ4F_default, LZ4F_blockLinked, LZ4F_noContentChecksum, LZ4F_frame, 0ULL, 0U, LZ4F_noBlockChecksum }    /* v1.8.3+ */
+
+/*! LZ4F_preferences_t :
+ *  makes it possible to supply advanced compression instructions to streaming interface.
+ *  Structure must be first init to 0, using memset() or LZ4F_INIT_PREFERENCES,
+ *  setting all parameters to default.
+ *  All reserved fields must be set to zero. */
+typedef struct {
+  LZ4F_frameInfo_t frameInfo;
+  int      compressionLevel;    /* 0: default (fast mode); values > LZ4HC_CLEVEL_MAX count as LZ4HC_CLEVEL_MAX; values < 0 trigger "fast acceleration" */
+  unsigned autoFlush;           /* 1: always flush; reduces usage of internal buffers */
+  unsigned favorDecSpeed;       /* 1: parser favors decompression speed vs compression ratio. Only works for high compression modes (>= LZ4HC_CLEVEL_OPT_MIN) */  /* v1.8.2+ */
+  unsigned reserved[3];         /* must be zero for forward compatibility */
+} LZ4F_preferences_t;
+
+#define LZ4F_INIT_PREFERENCES   { LZ4F_INIT_FRAMEINFO, 0, 0u, 0u, { 0u, 0u, 0u } }    /* v1.8.3+ */
+
+
+/*-*********************************
+*  Simple compression function
+***********************************/
+
+LZ4FLIB_API int LZ4F_compressionLevel_max(void);   /* v1.8.0+ */
+
+/*! LZ4F_compressFrameBound() :
+ *  Returns the maximum possible compressed size with LZ4F_compressFrame() given srcSize and preferences.
+ * `preferencesPtr` is optional. It can be replaced by NULL, in which case, the function will assume default preferences.
+ *  Note : this result is only usable with LZ4F_compressFrame().
+ *         It may also be used with LZ4F_compressUpdate() _if no flush() operation_ is performed.
+ */
+LZ4FLIB_API size_t LZ4F_compressFrameBound(size_t srcSize, const LZ4F_preferences_t* preferencesPtr);
+
+/*! LZ4F_compressFrame() :
+ *  Compress an entire srcBuffer into a valid LZ4 frame.
+ *  dstCapacity MUST be >= LZ4F_compressFrameBound(srcSize, preferencesPtr).
+ *  The LZ4F_preferences_t structure is optional : you can provide NULL as argument. All preferences will be set to default.
+ * @return : number of bytes written into dstBuffer.
+ *           or an error code if it fails (can be tested using LZ4F_isError())
+ */
+LZ4FLIB_API size_t LZ4F_compressFrame(void* dstBuffer, size_t dstCapacity,
+                                const void* srcBuffer, size_t srcSize,
+                                const LZ4F_preferences_t* preferencesPtr);
+
+
+/*-***********************************
+*  Advanced compression functions
+*************************************/
+typedef struct LZ4F_cctx_s LZ4F_cctx;   /* incomplete type */
+typedef LZ4F_cctx* LZ4F_compressionContext_t;   /* for compatibility with previous API version */
+
+typedef struct {
+  unsigned stableSrc;    /* 1 == src content will remain present on future calls to LZ4F_compress(); skip copying src content within tmp buffer */
+  unsigned reserved[3];
+} LZ4F_compressOptions_t;
+
+/*---   Resource Management   ---*/
+
+#define LZ4F_VERSION 100    /* This number can be used to check for an incompatible API breaking change */
+LZ4FLIB_API unsigned LZ4F_getVersion(void);
+
+/*! LZ4F_createCompressionContext() :
+ * The first thing to do is to create a compressionContext object, which will be used in all compression operations.
+ * This is achieved using LZ4F_createCompressionContext(), which takes as argument a version.
+ * The version provided MUST be LZ4F_VERSION. It is intended to track potential version mismatch, notably when using DLL.
+ * The function will provide a pointer to a fully allocated LZ4F_cctx object.
+ * If @return != zero, there was an error during context creation.
+ * Object can release its memory using LZ4F_freeCompressionContext();
+ */
+LZ4FLIB_API LZ4F_errorCode_t LZ4F_createCompressionContext(LZ4F_cctx** cctxPtr, unsigned version);
+LZ4FLIB_API LZ4F_errorCode_t LZ4F_freeCompressionContext(LZ4F_cctx* cctx);
+
+
+/*----    Compression    ----*/
+
+#define LZ4F_HEADER_SIZE_MIN  7   /* LZ4 Frame header size can vary, depending on selected paramaters */
+#define LZ4F_HEADER_SIZE_MAX 19
+
+/* Size in bytes of a block header in little-endian format. Highest bit indicates if block data is uncompressed */
+#define LZ4F_BLOCK_HEADER_SIZE 4
+
+/* Size in bytes of a block checksum footer in little-endian format. */
+#define LZ4F_BLOCK_CHECKSUM_SIZE 4
+
+/* Size in bytes of the content checksum. */
+#define LZ4F_CONTENT_CHECKSUM_SIZE 4
+
+/*! LZ4F_compressBegin() :
+ *  will write the frame header into dstBuffer.
+ *  dstCapacity must be >= LZ4F_HEADER_SIZE_MAX bytes.
+ * `prefsPtr` is optional : you can provide NULL as argument, all preferences will then be set to default.
+ * @return : number of bytes written into dstBuffer for the header
+ *           or an error code (which can be tested using LZ4F_isError())
+ */
+LZ4FLIB_API size_t LZ4F_compressBegin(LZ4F_cctx* cctx,
+                                      void* dstBuffer, size_t dstCapacity,
+                                      const LZ4F_preferences_t* prefsPtr);
+
+/*! LZ4F_compressBound() :
+ *  Provides minimum dstCapacity required to guarantee success of
+ *  LZ4F_compressUpdate(), given a srcSize and preferences, for a worst case scenario.
+ *  When srcSize==0, LZ4F_compressBound() provides an upper bound for LZ4F_flush() and LZ4F_compressEnd() instead.
+ *  Note that the result is only valid for a single invocation of LZ4F_compressUpdate().
+ *  When invoking LZ4F_compressUpdate() multiple times,
+ *  if the output buffer is gradually filled up instead of emptied and re-used from its start,
+ *  one must check if there is enough remaining capacity before each invocation, using LZ4F_compressBound().
+ * @return is always the same for a srcSize and prefsPtr.
+ *  prefsPtr is optional : when NULL is provided, preferences will be set to cover worst case scenario.
+ *  tech details :
+ * @return if automatic flushing is not enabled, includes the possibility that internal buffer might already be filled by up to (blockSize-1) bytes.
+ *  It also includes frame footer (ending + checksum), since it might be generated by LZ4F_compressEnd().
+ * @return doesn't include frame header, as it was already generated by LZ4F_compressBegin().
+ */
+LZ4FLIB_API size_t LZ4F_compressBound(size_t srcSize, const LZ4F_preferences_t* prefsPtr);
+
+/*! LZ4F_compressUpdate() :
+ *  LZ4F_compressUpdate() can be called repetitively to compress as much data as necessary.
+ *  Important rule: dstCapacity MUST be large enough to ensure operation success even in worst case situations.
+ *  This value is provided by LZ4F_compressBound().
+ *  If this condition is not respected, LZ4F_compress() will fail (result is an errorCode).
+ *  LZ4F_compressUpdate() doesn't guarantee error recovery.
+ *  When an error occurs, compression context must be freed or resized.
+ * `cOptPtr` is optional : NULL can be provided, in which case all options are set to default.
+ * @return : number of bytes written into `dstBuffer` (it can be zero, meaning input data was just buffered).
+ *           or an error code if it fails (which can be tested using LZ4F_isError())
+ */
+LZ4FLIB_API size_t LZ4F_compressUpdate(LZ4F_cctx* cctx,
+                                       void* dstBuffer, size_t dstCapacity,
+                                 const void* srcBuffer, size_t srcSize,
+                                 const LZ4F_compressOptions_t* cOptPtr);
+
+/*! LZ4F_flush() :
+ *  When data must be generated and sent immediately, without waiting for a block to be completely filled,
+ *  it's possible to call LZ4_flush(). It will immediately compress any data buffered within cctx.
+ * `dstCapacity` must be large enough to ensure the operation will be successful.
+ * `cOptPtr` is optional : it's possible to provide NULL, all options will be set to default.
+ * @return : nb of bytes written into dstBuffer (can be zero, when there is no data stored within cctx)
+ *           or an error code if it fails (which can be tested using LZ4F_isError())
+ *  Note : LZ4F_flush() is guaranteed to be successful when dstCapacity >= LZ4F_compressBound(0, prefsPtr).
+ */
+LZ4FLIB_API size_t LZ4F_flush(LZ4F_cctx* cctx,
+                              void* dstBuffer, size_t dstCapacity,
+                        const LZ4F_compressOptions_t* cOptPtr);
+
+/*! LZ4F_compressEnd() :
+ *  To properly finish an LZ4 frame, invoke LZ4F_compressEnd().
+ *  It will flush whatever data remained within `cctx` (like LZ4_flush())
+ *  and properly finalize the frame, with an endMark and a checksum.
+ * `cOptPtr` is optional : NULL can be provided, in which case all options will be set to default.
+ * @return : nb of bytes written into dstBuffer, necessarily >= 4 (endMark),
+ *           or an error code if it fails (which can be tested using LZ4F_isError())
+ *  Note : LZ4F_compressEnd() is guaranteed to be successful when dstCapacity >= LZ4F_compressBound(0, prefsPtr).
+ *  A successful call to LZ4F_compressEnd() makes `cctx` available again for another compression task.
+ */
+LZ4FLIB_API size_t LZ4F_compressEnd(LZ4F_cctx* cctx,
+                                    void* dstBuffer, size_t dstCapacity,
+                              const LZ4F_compressOptions_t* cOptPtr);
+
+
+/*-*********************************
+*  Decompression functions
+***********************************/
+typedef struct LZ4F_dctx_s LZ4F_dctx;   /* incomplete type */
+typedef LZ4F_dctx* LZ4F_decompressionContext_t;   /* compatibility with previous API versions */
+
+typedef struct {
+  unsigned stableDst;    /* pledges that last 64KB decompressed data will remain available unmodified. This optimization skips storage operations in tmp buffers. */
+  unsigned reserved[3];  /* must be set to zero for forward compatibility */
+} LZ4F_decompressOptions_t;
+
+
+/* Resource management */
+
+/*! LZ4F_createDecompressionContext() :
+ *  Create an LZ4F_dctx object, to track all decompression operations.
+ *  The version provided MUST be LZ4F_VERSION.
+ *  The function provides a pointer to an allocated and initialized LZ4F_dctx object.
+ *  The result is an errorCode, which can be tested using LZ4F_isError().
+ *  dctx memory can be released using LZ4F_freeDecompressionContext();
+ *  Result of LZ4F_freeDecompressionContext() indicates current state of decompressionContext when being released.
+ *  That is, it should be == 0 if decompression has been completed fully and correctly.
+ */
+LZ4FLIB_API LZ4F_errorCode_t LZ4F_createDecompressionContext(LZ4F_dctx** dctxPtr, unsigned version);
+LZ4FLIB_API LZ4F_errorCode_t LZ4F_freeDecompressionContext(LZ4F_dctx* dctx);
+
+
+/*-***********************************
+*  Streaming decompression functions
+*************************************/
+
+#define LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH 5
+
+/*! LZ4F_headerSize() : v1.9.0+
+ *  Provide the header size of a frame starting at `src`.
+ * `srcSize` must be >= LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH,
+ *  which is enough to decode the header length.
+ * @return : size of frame header
+ *           or an error code, which can be tested using LZ4F_isError()
+ *  note : Frame header size is variable, but is guaranteed to be
+ *         >= LZ4F_HEADER_SIZE_MIN bytes, and <= LZ4F_HEADER_SIZE_MAX bytes.
+ */
+LZ4FLIB_API size_t LZ4F_headerSize(const void* src, size_t srcSize);
+
+/*! LZ4F_getFrameInfo() :
+ *  This function extracts frame parameters (max blockSize, dictID, etc.).
+ *  Its usage is optional: user can call LZ4F_decompress() directly.
+ *
+ *  Extracted information will fill an existing LZ4F_frameInfo_t structure.
+ *  This can be useful for allocation and dictionary identification purposes.
+ *
+ *  LZ4F_getFrameInfo() can work in the following situations :
+ *
+ *  1) At the beginning of a new frame, before any invocation of LZ4F_decompress().
+ *     It will decode header from `srcBuffer`,
+ *     consuming the header and starting the decoding process.
+ *
+ *     Input size must be large enough to contain the full frame header.
+ *     Frame header size can be known beforehand by LZ4F_headerSize().
+ *     Frame header size is variable, but is guaranteed to be >= LZ4F_HEADER_SIZE_MIN bytes,
+ *     and not more than <= LZ4F_HEADER_SIZE_MAX bytes.
+ *     Hence, blindly providing LZ4F_HEADER_SIZE_MAX bytes or more will always work.
+ *     It's allowed to provide more input data than the header size,
+ *     LZ4F_getFrameInfo() will only consume the header.
+ *
+ *     If input size is not large enough,
+ *     aka if it's smaller than header size,
+ *     function will fail and return an error code.
+ *
+ *  2) After decoding has been started,
+ *     it's possible to invoke LZ4F_getFrameInfo() anytime
+ *     to extract already decoded frame parameters stored within dctx.
+ *
+ *     Note that, if decoding has barely started,
+ *     and not yet read enough information to decode the header,
+ *     LZ4F_getFrameInfo() will fail.
+ *
+ *  The number of bytes consumed from srcBuffer will be updated in *srcSizePtr (necessarily <= original value).
+ *  LZ4F_getFrameInfo() only consumes bytes when decoding has not yet started,
+ *  and when decoding the header has been successful.
+ *  Decompression must then resume from (srcBuffer + *srcSizePtr).
+ *
+ * @return : a hint about how many srcSize bytes LZ4F_decompress() expects for next call,
+ *           or an error code which can be tested using LZ4F_isError().
+ *  note 1 : in case of error, dctx is not modified. Decoding operation can resume from beginning safely.
+ *  note 2 : frame parameters are *copied into* an already allocated LZ4F_frameInfo_t structure.
+ */
+LZ4FLIB_API size_t LZ4F_getFrameInfo(LZ4F_dctx* dctx,
+                                     LZ4F_frameInfo_t* frameInfoPtr,
+                                     const void* srcBuffer, size_t* srcSizePtr);
+
+/*! LZ4F_decompress() :
+ *  Call this function repetitively to regenerate data compressed in `srcBuffer`.
+ *
+ *  The function requires a valid dctx state.
+ *  It will read up to *srcSizePtr bytes from srcBuffer,
+ *  and decompress data into dstBuffer, of capacity *dstSizePtr.
+ *
+ *  The nb of bytes consumed from srcBuffer will be written into *srcSizePtr (necessarily <= original value).
+ *  The nb of bytes decompressed into dstBuffer will be written into *dstSizePtr (necessarily <= original value).
+ *
+ *  The function does not necessarily read all input bytes, so always check value in *srcSizePtr.
+ *  Unconsumed source data must be presented again in subsequent invocations.
+ *
+ * `dstBuffer` can freely change between each consecutive function invocation.
+ * `dstBuffer` content will be overwritten.
+ *
+ * @return : an hint of how many `srcSize` bytes LZ4F_decompress() expects for next call.
+ *  Schematically, it's the size of the current (or remaining) compressed block + header of next block.
+ *  Respecting the hint provides some small speed benefit, because it skips intermediate buffers.
+ *  This is just a hint though, it's always possible to provide any srcSize.
+ *
+ *  When a frame is fully decoded, @return will be 0 (no more data expected).
+ *  When provided with more bytes than necessary to decode a frame,
+ *  LZ4F_decompress() will stop reading exactly at end of current frame, and @return 0.
+ *
+ *  If decompression failed, @return is an error code, which can be tested using LZ4F_isError().
+ *  After a decompression error, the `dctx` context is not resumable.
+ *  Use LZ4F_resetDecompressionContext() to return to clean state.
+ *
+ *  After a frame is fully decoded, dctx can be used again to decompress another frame.
+ */
+LZ4FLIB_API size_t LZ4F_decompress(LZ4F_dctx* dctx,
+                                   void* dstBuffer, size_t* dstSizePtr,
+                                   const void* srcBuffer, size_t* srcSizePtr,
+                                   const LZ4F_decompressOptions_t* dOptPtr);
+
+
+/*! LZ4F_resetDecompressionContext() : added in v1.8.0
+ *  In case of an error, the context is left in "undefined" state.
+ *  In which case, it's necessary to reset it, before re-using it.
+ *  This method can also be used to abruptly stop any unfinished decompression,
+ *  and start a new one using same context resources. */
+LZ4FLIB_API void LZ4F_resetDecompressionContext(LZ4F_dctx* dctx);   /* always successful */
+
+
+
+#if defined (__cplusplus)
+}
+#endif
+
+#endif  /* LZ4F_H_09782039843 */
+
+#if defined(LZ4F_STATIC_LINKING_ONLY) && !defined(LZ4F_H_STATIC_09782039843)
+#define LZ4F_H_STATIC_09782039843
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+/* These declarations are not stable and may change in the future.
+ * They are therefore only safe to depend on
+ * when the caller is statically linked against the library.
+ * To access their declarations, define LZ4F_STATIC_LINKING_ONLY.
+ *
+ * By default, these symbols aren't published into shared/dynamic libraries.
+ * You can override this behavior and force them to be published
+ * by defining LZ4F_PUBLISH_STATIC_FUNCTIONS.
+ * Use at your own risk.
+ */
+#ifdef LZ4F_PUBLISH_STATIC_FUNCTIONS
+# define LZ4FLIB_STATIC_API LZ4FLIB_API
+#else
+# define LZ4FLIB_STATIC_API
+#endif
+
+
+/* ---   Error List   --- */
+#define LZ4F_LIST_ERRORS(ITEM) \
+        ITEM(OK_NoError) \
+        ITEM(ERROR_GENERIC) \
+        ITEM(ERROR_maxBlockSize_invalid) \
+        ITEM(ERROR_blockMode_invalid) \
+        ITEM(ERROR_contentChecksumFlag_invalid) \
+        ITEM(ERROR_compressionLevel_invalid) \
+        ITEM(ERROR_headerVersion_wrong) \
+        ITEM(ERROR_blockChecksum_invalid) \
+        ITEM(ERROR_reservedFlag_set) \
+        ITEM(ERROR_allocation_failed) \
+        ITEM(ERROR_srcSize_tooLarge) \
+        ITEM(ERROR_dstMaxSize_tooSmall) \
+        ITEM(ERROR_frameHeader_incomplete) \
+        ITEM(ERROR_frameType_unknown) \
+        ITEM(ERROR_frameSize_wrong) \
+        ITEM(ERROR_srcPtr_wrong) \
+        ITEM(ERROR_decompressionFailed) \
+        ITEM(ERROR_headerChecksum_invalid) \
+        ITEM(ERROR_contentChecksum_invalid) \
+        ITEM(ERROR_frameDecoding_alreadyStarted) \
+        ITEM(ERROR_maxCode)
+
+#define LZ4F_GENERATE_ENUM(ENUM) LZ4F_##ENUM,
+
+/* enum list is exposed, to handle specific errors */
+typedef enum { LZ4F_LIST_ERRORS(LZ4F_GENERATE_ENUM)
+              _LZ4F_dummy_error_enum_for_c89_never_used } LZ4F_errorCodes;
+
+LZ4FLIB_STATIC_API LZ4F_errorCodes LZ4F_getErrorCode(size_t functionResult);
+
+LZ4FLIB_STATIC_API size_t LZ4F_getBlockSize(unsigned);
+
+/**********************************
+ *  Bulk processing dictionary API
+ *********************************/
+
+/* A Dictionary is useful for the compression of small messages (KB range).
+ * It dramatically improves compression efficiency.
+ *
+ * LZ4 can ingest any input as dictionary, though only the last 64 KB are useful.
+ * Best results are generally achieved by using Zstandard's Dictionary Builder
+ * to generate a high-quality dictionary from a set of samples.
+ *
+ * Loading a dictionary has a cost, since it involves construction of tables.
+ * The Bulk processing dictionary API makes it possible to share this cost
+ * over an arbitrary number of compression jobs, even concurrently,
+ * markedly improving compression latency for these cases.
+ *
+ * The same dictionary will have to be used on the decompression side
+ * for decoding to be successful.
+ * To help identify the correct dictionary at decoding stage,
+ * the frame header allows optional embedding of a dictID field.
+ */
+typedef struct LZ4F_CDict_s LZ4F_CDict;
+
+/*! LZ4_createCDict() :
+ *  When compressing multiple messages / blocks using the same dictionary, it's recommended to load it just once.
+ *  LZ4_createCDict() will create a digested dictionary, ready to start future compression operations without startup delay.
+ *  LZ4_CDict can be created once and shared by multiple threads concurrently, since its usage is read-only.
+ * `dictBuffer` can be released after LZ4_CDict creation, since its content is copied within CDict */
+LZ4FLIB_STATIC_API LZ4F_CDict* LZ4F_createCDict(const void* dictBuffer, size_t dictSize);
+LZ4FLIB_STATIC_API void        LZ4F_freeCDict(LZ4F_CDict* CDict);
+
+
+/*! LZ4_compressFrame_usingCDict() :
+ *  Compress an entire srcBuffer into a valid LZ4 frame using a digested Dictionary.
+ *  cctx must point to a context created by LZ4F_createCompressionContext().
+ *  If cdict==NULL, compress without a dictionary.
+ *  dstBuffer MUST be >= LZ4F_compressFrameBound(srcSize, preferencesPtr).
+ *  If this condition is not respected, function will fail (@return an errorCode).
+ *  The LZ4F_preferences_t structure is optional : you may provide NULL as argument,
+ *  but it's not recommended, as it's the only way to provide dictID in the frame header.
+ * @return : number of bytes written into dstBuffer.
+ *           or an error code if it fails (can be tested using LZ4F_isError()) */
+LZ4FLIB_STATIC_API size_t LZ4F_compressFrame_usingCDict(
+    LZ4F_cctx* cctx,
+    void* dst, size_t dstCapacity,
+    const void* src, size_t srcSize,
+    const LZ4F_CDict* cdict,
+    const LZ4F_preferences_t* preferencesPtr);
+
+
+/*! LZ4F_compressBegin_usingCDict() :
+ *  Inits streaming dictionary compression, and writes the frame header into dstBuffer.
+ *  dstCapacity must be >= LZ4F_HEADER_SIZE_MAX bytes.
+ * `prefsPtr` is optional : you may provide NULL as argument,
+ *  however, it's the only way to provide dictID in the frame header.
+ * @return : number of bytes written into dstBuffer for the header,
+ *           or an error code (which can be tested using LZ4F_isError()) */
+LZ4FLIB_STATIC_API size_t LZ4F_compressBegin_usingCDict(
+    LZ4F_cctx* cctx,
+    void* dstBuffer, size_t dstCapacity,
+    const LZ4F_CDict* cdict,
+    const LZ4F_preferences_t* prefsPtr);
+
+
+/*! LZ4F_decompress_usingDict() :
+ *  Same as LZ4F_decompress(), using a predefined dictionary.
+ *  Dictionary is used "in place", without any preprocessing.
+ *  It must remain accessible throughout the entire frame decoding. */
+LZ4FLIB_STATIC_API size_t LZ4F_decompress_usingDict(
+    LZ4F_dctx* dctxPtr,
+    void* dstBuffer, size_t* dstSizePtr,
+    const void* srcBuffer, size_t* srcSizePtr,
+    const void* dict, size_t dictSize,
+    const LZ4F_decompressOptions_t* decompressOptionsPtr);
+
+#if defined (__cplusplus)
+}
+#endif
+
+#endif  /* defined(LZ4F_STATIC_LINKING_ONLY) && !defined(LZ4F_H_STATIC_09782039843) */
diff --git a/lz4/lib/lz4frame_static.h b/lz4/lib/lz4frame_static.h
new file mode 100644
index 0000000..925a2c5
--- /dev/null
+++ b/lz4/lib/lz4frame_static.h
@@ -0,0 +1,47 @@
+/*
+   LZ4 auto-framing library
+   Header File for static linking only
+   Copyright (C) 2011-2016, Yann Collet.
+
+   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+   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.
+
+   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.
+
+   You can contact the author at :
+   - LZ4 source repository : https://github.com/lz4/lz4
+   - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+
+#ifndef LZ4FRAME_STATIC_H_0398209384
+#define LZ4FRAME_STATIC_H_0398209384
+
+/* The declarations that formerly were made here have been merged into
+ * lz4frame.h, protected by the LZ4F_STATIC_LINKING_ONLY macro. Going forward,
+ * it is recommended to simply include that header directly.
+ */
+
+#define LZ4F_STATIC_LINKING_ONLY
+#include "lz4frame.h"
+
+#endif /* LZ4FRAME_STATIC_H_0398209384 */
diff --git a/lz4/lib/lz4hc.c b/lz4/lib/lz4hc.c
new file mode 100644
index 0000000..77c9f43
--- /dev/null
+++ b/lz4/lib/lz4hc.c
@@ -0,0 +1,1615 @@
+/*
+    LZ4 HC - High Compression Mode of LZ4
+    Copyright (C) 2011-2017, Yann Collet.
+
+    BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+    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.
+
+    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.
+
+    You can contact the author at :
+       - LZ4 source repository : https://github.com/lz4/lz4
+       - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+/* note : lz4hc is not an independent module, it requires lz4.h/lz4.c for proper compilation */
+
+
+/* *************************************
+*  Tuning Parameter
+***************************************/
+
+/*! HEAPMODE :
+ *  Select how default compression function will allocate workplace memory,
+ *  in stack (0:fastest), or in heap (1:requires malloc()).
+ *  Since workplace is rather large, heap mode is recommended.
+ */
+#ifndef LZ4HC_HEAPMODE
+#  define LZ4HC_HEAPMODE 1
+#endif
+
+
+/*===    Dependency    ===*/
+#define LZ4_HC_STATIC_LINKING_ONLY
+#include "lz4hc.h"
+
+
+/*===   Common definitions   ===*/
+#if defined(__GNUC__)
+#  pragma GCC diagnostic ignored "-Wunused-function"
+#endif
+#if defined (__clang__)
+#  pragma clang diagnostic ignored "-Wunused-function"
+#endif
+
+#define LZ4_COMMONDEFS_ONLY
+#ifndef LZ4_SRC_INCLUDED
+#include "lz4.c"   /* LZ4_count, constants, mem */
+#endif
+
+
+/*===   Enums   ===*/
+typedef enum { noDictCtx, usingDictCtxHc } dictCtx_directive;
+
+
+/*===   Constants   ===*/
+#define OPTIMAL_ML (int)((ML_MASK-1)+MINMATCH)
+#define LZ4_OPT_NUM   (1<<12)
+
+
+/*===   Macros   ===*/
+#define MIN(a,b)   ( (a) < (b) ? (a) : (b) )
+#define MAX(a,b)   ( (a) > (b) ? (a) : (b) )
+#define HASH_FUNCTION(i)         (((i) * 2654435761U) >> ((MINMATCH*8)-LZ4HC_HASH_LOG))
+#define DELTANEXTMAXD(p)         chainTable[(p) & LZ4HC_MAXD_MASK]    /* flexible, LZ4HC_MAXD dependent */
+#define DELTANEXTU16(table, pos) table[(U16)(pos)]   /* faster */
+/* Make fields passed to, and updated by LZ4HC_encodeSequence explicit */
+#define UPDATABLE(ip, op, anchor) &ip, &op, &anchor
+
+static U32 LZ4HC_hashPtr(const void* ptr) { return HASH_FUNCTION(LZ4_read32(ptr)); }
+
+
+/**************************************
+*  HC Compression
+**************************************/
+static void LZ4HC_clearTables (LZ4HC_CCtx_internal* hc4)
+{
+    MEM_INIT(hc4->hashTable, 0, sizeof(hc4->hashTable));
+    MEM_INIT(hc4->chainTable, 0xFF, sizeof(hc4->chainTable));
+}
+
+static void LZ4HC_init_internal (LZ4HC_CCtx_internal* hc4, const BYTE* start)
+{
+    uptrval startingOffset = (uptrval)(hc4->end - hc4->base);
+    if (startingOffset > 1 GB) {
+        LZ4HC_clearTables(hc4);
+        startingOffset = 0;
+    }
+    startingOffset += 64 KB;
+    hc4->nextToUpdate = (U32) startingOffset;
+    hc4->base = start - startingOffset;
+    hc4->end = start;
+    hc4->dictBase = start - startingOffset;
+    hc4->dictLimit = (U32) startingOffset;
+    hc4->lowLimit = (U32) startingOffset;
+}
+
+
+/* Update chains up to ip (excluded) */
+LZ4_FORCE_INLINE void LZ4HC_Insert (LZ4HC_CCtx_internal* hc4, const BYTE* ip)
+{
+    U16* const chainTable = hc4->chainTable;
+    U32* const hashTable  = hc4->hashTable;
+    const BYTE* const base = hc4->base;
+    U32 const target = (U32)(ip - base);
+    U32 idx = hc4->nextToUpdate;
+
+    while (idx < target) {
+        U32 const h = LZ4HC_hashPtr(base+idx);
+        size_t delta = idx - hashTable[h];
+        if (delta>LZ4_DISTANCE_MAX) delta = LZ4_DISTANCE_MAX;
+        DELTANEXTU16(chainTable, idx) = (U16)delta;
+        hashTable[h] = idx;
+        idx++;
+    }
+
+    hc4->nextToUpdate = target;
+}
+
+/** LZ4HC_countBack() :
+ * @return : negative value, nb of common bytes before ip/match */
+LZ4_FORCE_INLINE
+int LZ4HC_countBack(const BYTE* const ip, const BYTE* const match,
+                    const BYTE* const iMin, const BYTE* const mMin)
+{
+    int back = 0;
+    int const min = (int)MAX(iMin - ip, mMin - match);
+    assert(min <= 0);
+    assert(ip >= iMin); assert((size_t)(ip-iMin) < (1U<<31));
+    assert(match >= mMin); assert((size_t)(match - mMin) < (1U<<31));
+    while ( (back > min)
+         && (ip[back-1] == match[back-1]) )
+            back--;
+    return back;
+}
+
+#if defined(_MSC_VER)
+#  define LZ4HC_rotl32(x,r) _rotl(x,r)
+#else
+#  define LZ4HC_rotl32(x,r) ((x << r) | (x >> (32 - r)))
+#endif
+
+
+static U32 LZ4HC_rotatePattern(size_t const rotate, U32 const pattern)
+{
+    size_t const bitsToRotate = (rotate & (sizeof(pattern) - 1)) << 3;
+    if (bitsToRotate == 0) return pattern;
+    return LZ4HC_rotl32(pattern, (int)bitsToRotate);
+}
+
+/* LZ4HC_countPattern() :
+ * pattern32 must be a sample of repetitive pattern of length 1, 2 or 4 (but not 3!) */
+static unsigned
+LZ4HC_countPattern(const BYTE* ip, const BYTE* const iEnd, U32 const pattern32)
+{
+    const BYTE* const iStart = ip;
+    reg_t const pattern = (sizeof(pattern)==8) ?
+        (reg_t)pattern32 + (((reg_t)pattern32) << (sizeof(pattern)*4)) : pattern32;
+
+    while (likely(ip < iEnd-(sizeof(pattern)-1))) {
+        reg_t const diff = LZ4_read_ARCH(ip) ^ pattern;
+        if (!diff) { ip+=sizeof(pattern); continue; }
+        ip += LZ4_NbCommonBytes(diff);
+        return (unsigned)(ip - iStart);
+    }
+
+    if (LZ4_isLittleEndian()) {
+        reg_t patternByte = pattern;
+        while ((ip>= 8;
+        }
+    } else {  /* big endian */
+        U32 bitOffset = (sizeof(pattern)*8) - 8;
+        while (ip < iEnd) {
+            BYTE const byte = (BYTE)(pattern >> bitOffset);
+            if (*ip != byte) break;
+            ip ++; bitOffset -= 8;
+        }
+    }
+
+    return (unsigned)(ip - iStart);
+}
+
+/* LZ4HC_reverseCountPattern() :
+ * pattern must be a sample of repetitive pattern of length 1, 2 or 4 (but not 3!)
+ * read using natural platform endianess */
+static unsigned
+LZ4HC_reverseCountPattern(const BYTE* ip, const BYTE* const iLow, U32 pattern)
+{
+    const BYTE* const iStart = ip;
+
+    while (likely(ip >= iLow+4)) {
+        if (LZ4_read32(ip-4) != pattern) break;
+        ip -= 4;
+    }
+    {   const BYTE* bytePtr = (const BYTE*)(&pattern) + 3; /* works for any endianess */
+        while (likely(ip>iLow)) {
+            if (ip[-1] != *bytePtr) break;
+            ip--; bytePtr--;
+    }   }
+    return (unsigned)(iStart - ip);
+}
+
+/* LZ4HC_protectDictEnd() :
+ * Checks if the match is in the last 3 bytes of the dictionary, so reading the
+ * 4 byte MINMATCH would overflow.
+ * @returns true if the match index is okay.
+ */
+static int LZ4HC_protectDictEnd(U32 const dictLimit, U32 const matchIndex)
+{
+    return ((U32)((dictLimit - 1) - matchIndex) >= 3);
+}
+
+typedef enum { rep_untested, rep_not, rep_confirmed } repeat_state_e;
+typedef enum { favorCompressionRatio=0, favorDecompressionSpeed } HCfavor_e;
+
+LZ4_FORCE_INLINE int
+LZ4HC_InsertAndGetWiderMatch (
+    LZ4HC_CCtx_internal* hc4,
+    const BYTE* const ip,
+    const BYTE* const iLowLimit,
+    const BYTE* const iHighLimit,
+    int longest,
+    const BYTE** matchpos,
+    const BYTE** startpos,
+    const int maxNbAttempts,
+    const int patternAnalysis,
+    const int chainSwap,
+    const dictCtx_directive dict,
+    const HCfavor_e favorDecSpeed)
+{
+    U16* const chainTable = hc4->chainTable;
+    U32* const HashTable = hc4->hashTable;
+    const LZ4HC_CCtx_internal * const dictCtx = hc4->dictCtx;
+    const BYTE* const base = hc4->base;
+    const U32 dictLimit = hc4->dictLimit;
+    const BYTE* const lowPrefixPtr = base + dictLimit;
+    const U32 ipIndex = (U32)(ip - base);
+    const U32 lowestMatchIndex = (hc4->lowLimit + (LZ4_DISTANCE_MAX + 1) > ipIndex) ? hc4->lowLimit : ipIndex - LZ4_DISTANCE_MAX;
+    const BYTE* const dictBase = hc4->dictBase;
+    int const lookBackLength = (int)(ip-iLowLimit);
+    int nbAttempts = maxNbAttempts;
+    U32 matchChainPos = 0;
+    U32 const pattern = LZ4_read32(ip);
+    U32 matchIndex;
+    repeat_state_e repeat = rep_untested;
+    size_t srcPatternLength = 0;
+
+    DEBUGLOG(7, "LZ4HC_InsertAndGetWiderMatch");
+    /* First Match */
+    LZ4HC_Insert(hc4, ip);
+    matchIndex = HashTable[LZ4HC_hashPtr(ip)];
+    DEBUGLOG(7, "First match at index %u / %u (lowestMatchIndex)",
+                matchIndex, lowestMatchIndex);
+
+    while ((matchIndex>=lowestMatchIndex) && (nbAttempts>0)) {
+        int matchLength=0;
+        nbAttempts--;
+        assert(matchIndex < ipIndex);
+        if (favorDecSpeed && (ipIndex - matchIndex < 8)) {
+            /* do nothing */
+        } else if (matchIndex >= dictLimit) {   /* within current Prefix */
+            const BYTE* const matchPtr = base + matchIndex;
+            assert(matchPtr >= lowPrefixPtr);
+            assert(matchPtr < ip);
+            assert(longest >= 1);
+            if (LZ4_read16(iLowLimit + longest - 1) == LZ4_read16(matchPtr - lookBackLength + longest - 1)) {
+                if (LZ4_read32(matchPtr) == pattern) {
+                    int const back = lookBackLength ? LZ4HC_countBack(ip, matchPtr, iLowLimit, lowPrefixPtr) : 0;
+                    matchLength = MINMATCH + (int)LZ4_count(ip+MINMATCH, matchPtr+MINMATCH, iHighLimit);
+                    matchLength -= back;
+                    if (matchLength > longest) {
+                        longest = matchLength;
+                        *matchpos = matchPtr + back;
+                        *startpos = ip + back;
+            }   }   }
+        } else {   /* lowestMatchIndex <= matchIndex < dictLimit */
+            const BYTE* const matchPtr = dictBase + matchIndex;
+            if (LZ4_read32(matchPtr) == pattern) {
+                const BYTE* const dictStart = dictBase + hc4->lowLimit;
+                int back = 0;
+                const BYTE* vLimit = ip + (dictLimit - matchIndex);
+                if (vLimit > iHighLimit) vLimit = iHighLimit;
+                matchLength = (int)LZ4_count(ip+MINMATCH, matchPtr+MINMATCH, vLimit) + MINMATCH;
+                if ((ip+matchLength == vLimit) && (vLimit < iHighLimit))
+                    matchLength += LZ4_count(ip+matchLength, lowPrefixPtr, iHighLimit);
+                back = lookBackLength ? LZ4HC_countBack(ip, matchPtr, iLowLimit, dictStart) : 0;
+                matchLength -= back;
+                if (matchLength > longest) {
+                    longest = matchLength;
+                    *matchpos = base + matchIndex + back;   /* virtual pos, relative to ip, to retrieve offset */
+                    *startpos = ip + back;
+        }   }   }
+
+        if (chainSwap && matchLength==longest) {    /* better match => select a better chain */
+            assert(lookBackLength==0);   /* search forward only */
+            if (matchIndex + (U32)longest <= ipIndex) {
+                int const kTrigger = 4;
+                U32 distanceToNextMatch = 1;
+                int const end = longest - MINMATCH + 1;
+                int step = 1;
+                int accel = 1 << kTrigger;
+                int pos;
+                for (pos = 0; pos < end; pos += step) {
+                    U32 const candidateDist = DELTANEXTU16(chainTable, matchIndex + (U32)pos);
+                    step = (accel++ >> kTrigger);
+                    if (candidateDist > distanceToNextMatch) {
+                        distanceToNextMatch = candidateDist;
+                        matchChainPos = (U32)pos;
+                        accel = 1 << kTrigger;
+                    }
+                }
+                if (distanceToNextMatch > 1) {
+                    if (distanceToNextMatch > matchIndex) break;   /* avoid overflow */
+                    matchIndex -= distanceToNextMatch;
+                    continue;
+        }   }   }
+
+        {   U32 const distNextMatch = DELTANEXTU16(chainTable, matchIndex);
+            if (patternAnalysis && distNextMatch==1 && matchChainPos==0) {
+                U32 const matchCandidateIdx = matchIndex-1;
+                /* may be a repeated pattern */
+                if (repeat == rep_untested) {
+                    if ( ((pattern & 0xFFFF) == (pattern >> 16))
+                      &  ((pattern & 0xFF)   == (pattern >> 24)) ) {
+                        repeat = rep_confirmed;
+                        srcPatternLength = LZ4HC_countPattern(ip+sizeof(pattern), iHighLimit, pattern) + sizeof(pattern);
+                    } else {
+                        repeat = rep_not;
+                }   }
+                if ( (repeat == rep_confirmed) && (matchCandidateIdx >= lowestMatchIndex)
+                  && LZ4HC_protectDictEnd(dictLimit, matchCandidateIdx) ) {
+                    const int extDict = matchCandidateIdx < dictLimit;
+                    const BYTE* const matchPtr = (extDict ? dictBase : base) + matchCandidateIdx;
+                    if (LZ4_read32(matchPtr) == pattern) {  /* good candidate */
+                        const BYTE* const dictStart = dictBase + hc4->lowLimit;
+                        const BYTE* const iLimit = extDict ? dictBase + dictLimit : iHighLimit;
+                        size_t forwardPatternLength = LZ4HC_countPattern(matchPtr+sizeof(pattern), iLimit, pattern) + sizeof(pattern);
+                        if (extDict && matchPtr + forwardPatternLength == iLimit) {
+                            U32 const rotatedPattern = LZ4HC_rotatePattern(forwardPatternLength, pattern);
+                            forwardPatternLength += LZ4HC_countPattern(lowPrefixPtr, iHighLimit, rotatedPattern);
+                        }
+                        {   const BYTE* const lowestMatchPtr = extDict ? dictStart : lowPrefixPtr;
+                            size_t backLength = LZ4HC_reverseCountPattern(matchPtr, lowestMatchPtr, pattern);
+                            size_t currentSegmentLength;
+                            if (!extDict && matchPtr - backLength == lowPrefixPtr && hc4->lowLimit < dictLimit) {
+                                U32 const rotatedPattern = LZ4HC_rotatePattern((U32)(-(int)backLength), pattern);
+                                backLength += LZ4HC_reverseCountPattern(dictBase + dictLimit, dictStart, rotatedPattern);
+                            }
+                            /* Limit backLength not go further than lowestMatchIndex */
+                            backLength = matchCandidateIdx - MAX(matchCandidateIdx - (U32)backLength, lowestMatchIndex);
+                            assert(matchCandidateIdx - backLength >= lowestMatchIndex);
+                            currentSegmentLength = backLength + forwardPatternLength;
+                            /* Adjust to end of pattern if the source pattern fits, otherwise the beginning of the pattern */
+                            if ( (currentSegmentLength >= srcPatternLength)   /* current pattern segment large enough to contain full srcPatternLength */
+                              && (forwardPatternLength <= srcPatternLength) ) { /* haven't reached this position yet */
+                                U32 const newMatchIndex = matchCandidateIdx + (U32)forwardPatternLength - (U32)srcPatternLength;  /* best position, full pattern, might be followed by more match */
+                                if (LZ4HC_protectDictEnd(dictLimit, newMatchIndex))
+                                    matchIndex = newMatchIndex;
+                                else {
+                                    /* Can only happen if started in the prefix */
+                                    assert(newMatchIndex >= dictLimit - 3 && newMatchIndex < dictLimit && !extDict);
+                                    matchIndex = dictLimit;
+                                }
+                            } else {
+                                U32 const newMatchIndex = matchCandidateIdx - (U32)backLength;   /* farthest position in current segment, will find a match of length currentSegmentLength + maybe some back */
+                                if (!LZ4HC_protectDictEnd(dictLimit, newMatchIndex)) {
+                                    assert(newMatchIndex >= dictLimit - 3 && newMatchIndex < dictLimit && !extDict);
+                                    matchIndex = dictLimit;
+                                } else {
+                                    matchIndex = newMatchIndex;
+                                    if (lookBackLength==0) {  /* no back possible */
+                                        size_t const maxML = MIN(currentSegmentLength, srcPatternLength);
+                                        if ((size_t)longest < maxML) {
+                                            assert(base + matchIndex != ip);
+                                            if ((size_t)(ip - base) - matchIndex > LZ4_DISTANCE_MAX) break;
+                                            assert(maxML < 2 GB);
+                                            longest = (int)maxML;
+                                            *matchpos = base + matchIndex;   /* virtual pos, relative to ip, to retrieve offset */
+                                            *startpos = ip;
+                                        }
+                                        {   U32 const distToNextPattern = DELTANEXTU16(chainTable, matchIndex);
+                                            if (distToNextPattern > matchIndex) break;  /* avoid overflow */
+                                            matchIndex -= distToNextPattern;
+                        }   }   }   }   }
+                        continue;
+                }   }
+        }   }   /* PA optimization */
+
+        /* follow current chain */
+        matchIndex -= DELTANEXTU16(chainTable, matchIndex + matchChainPos);
+
+    }  /* while ((matchIndex>=lowestMatchIndex) && (nbAttempts)) */
+
+    if ( dict == usingDictCtxHc
+      && nbAttempts > 0
+      && ipIndex - lowestMatchIndex < LZ4_DISTANCE_MAX) {
+        size_t const dictEndOffset = (size_t)(dictCtx->end - dictCtx->base);
+        U32 dictMatchIndex = dictCtx->hashTable[LZ4HC_hashPtr(ip)];
+        assert(dictEndOffset <= 1 GB);
+        matchIndex = dictMatchIndex + lowestMatchIndex - (U32)dictEndOffset;
+        while (ipIndex - matchIndex <= LZ4_DISTANCE_MAX && nbAttempts--) {
+            const BYTE* const matchPtr = dictCtx->base + dictMatchIndex;
+
+            if (LZ4_read32(matchPtr) == pattern) {
+                int mlt;
+                int back = 0;
+                const BYTE* vLimit = ip + (dictEndOffset - dictMatchIndex);
+                if (vLimit > iHighLimit) vLimit = iHighLimit;
+                mlt = (int)LZ4_count(ip+MINMATCH, matchPtr+MINMATCH, vLimit) + MINMATCH;
+                back = lookBackLength ? LZ4HC_countBack(ip, matchPtr, iLowLimit, dictCtx->base + dictCtx->dictLimit) : 0;
+                mlt -= back;
+                if (mlt > longest) {
+                    longest = mlt;
+                    *matchpos = base + matchIndex + back;
+                    *startpos = ip + back;
+            }   }
+
+            {   U32 const nextOffset = DELTANEXTU16(dictCtx->chainTable, dictMatchIndex);
+                dictMatchIndex -= nextOffset;
+                matchIndex -= nextOffset;
+    }   }   }
+
+    return longest;
+}
+
+LZ4_FORCE_INLINE
+int LZ4HC_InsertAndFindBestMatch(LZ4HC_CCtx_internal* const hc4,   /* Index table will be updated */
+                                 const BYTE* const ip, const BYTE* const iLimit,
+                                 const BYTE** matchpos,
+                                 const int maxNbAttempts,
+                                 const int patternAnalysis,
+                                 const dictCtx_directive dict)
+{
+    const BYTE* uselessPtr = ip;
+    /* note : LZ4HC_InsertAndGetWiderMatch() is able to modify the starting position of a match (*startpos),
+     * but this won't be the case here, as we define iLowLimit==ip,
+     * so LZ4HC_InsertAndGetWiderMatch() won't be allowed to search past ip */
+    return LZ4HC_InsertAndGetWiderMatch(hc4, ip, ip, iLimit, MINMATCH-1, matchpos, &uselessPtr, maxNbAttempts, patternAnalysis, 0 /*chainSwap*/, dict, favorCompressionRatio);
+}
+
+/* LZ4HC_encodeSequence() :
+ * @return : 0 if ok,
+ *           1 if buffer issue detected */
+LZ4_FORCE_INLINE int LZ4HC_encodeSequence (
+    const BYTE** _ip,
+    BYTE** _op,
+    const BYTE** _anchor,
+    int matchLength,
+    const BYTE* const match,
+    limitedOutput_directive limit,
+    BYTE* oend)
+{
+#define ip      (*_ip)
+#define op      (*_op)
+#define anchor  (*_anchor)
+
+    size_t length;
+    BYTE* const token = op++;
+
+#if defined(LZ4_DEBUG) && (LZ4_DEBUG >= 6)
+    static const BYTE* start = NULL;
+    static U32 totalCost = 0;
+    U32 const pos = (start==NULL) ? 0 : (U32)(anchor - start);
+    U32 const ll = (U32)(ip - anchor);
+    U32 const llAdd = (ll>=15) ? ((ll-15) / 255) + 1 : 0;
+    U32 const mlAdd = (matchLength>=19) ? ((matchLength-19) / 255) + 1 : 0;
+    U32 const cost = 1 + llAdd + ll + 2 + mlAdd;
+    if (start==NULL) start = anchor;  /* only works for single segment */
+    /* g_debuglog_enable = (pos >= 2228) & (pos <= 2262); */
+    DEBUGLOG(6, "pos:%7u -- literals:%4u, match:%4i, offset:%5u, cost:%4u + %5u",
+                pos,
+                (U32)(ip - anchor), matchLength, (U32)(ip-match),
+                cost, totalCost);
+    totalCost += cost;
+#endif
+
+    /* Encode Literal length */
+    length = (size_t)(ip - anchor);
+    LZ4_STATIC_ASSERT(notLimited == 0);
+    /* Check output limit */
+    if (limit && ((op + (length / 255) + length + (2 + 1 + LASTLITERALS)) > oend)) {
+        DEBUGLOG(6, "Not enough room to write %i literals (%i bytes remaining)",
+                (int)length, (int)(oend - op));
+        return 1;
+    }
+    if (length >= RUN_MASK) {
+        size_t len = length - RUN_MASK;
+        *token = (RUN_MASK << ML_BITS);
+        for(; len >= 255 ; len -= 255) *op++ = 255;
+        *op++ = (BYTE)len;
+    } else {
+        *token = (BYTE)(length << ML_BITS);
+    }
+
+    /* Copy Literals */
+    LZ4_wildCopy8(op, anchor, op + length);
+    op += length;
+
+    /* Encode Offset */
+    assert( (ip - match) <= LZ4_DISTANCE_MAX );   /* note : consider providing offset as a value, rather than as a pointer difference */
+    LZ4_writeLE16(op, (U16)(ip - match)); op += 2;
+
+    /* Encode MatchLength */
+    assert(matchLength >= MINMATCH);
+    length = (size_t)matchLength - MINMATCH;
+    if (limit && (op + (length / 255) + (1 + LASTLITERALS) > oend)) {
+        DEBUGLOG(6, "Not enough room to write match length");
+        return 1;   /* Check output limit */
+    }
+    if (length >= ML_MASK) {
+        *token += ML_MASK;
+        length -= ML_MASK;
+        for(; length >= 510 ; length -= 510) { *op++ = 255; *op++ = 255; }
+        if (length >= 255) { length -= 255; *op++ = 255; }
+        *op++ = (BYTE)length;
+    } else {
+        *token += (BYTE)(length);
+    }
+
+    /* Prepare next loop */
+    ip += matchLength;
+    anchor = ip;
+
+    return 0;
+}
+#undef ip
+#undef op
+#undef anchor
+
+LZ4_FORCE_INLINE int LZ4HC_compress_hashChain (
+    LZ4HC_CCtx_internal* const ctx,
+    const char* const source,
+    char* const dest,
+    int* srcSizePtr,
+    int const maxOutputSize,
+    int maxNbAttempts,
+    const limitedOutput_directive limit,
+    const dictCtx_directive dict
+    )
+{
+    const int inputSize = *srcSizePtr;
+    const int patternAnalysis = (maxNbAttempts > 128);   /* levels 9+ */
+
+    const BYTE* ip = (const BYTE*) source;
+    const BYTE* anchor = ip;
+    const BYTE* const iend = ip + inputSize;
+    const BYTE* const mflimit = iend - MFLIMIT;
+    const BYTE* const matchlimit = (iend - LASTLITERALS);
+
+    BYTE* optr = (BYTE*) dest;
+    BYTE* op = (BYTE*) dest;
+    BYTE* oend = op + maxOutputSize;
+
+    int   ml0, ml, ml2, ml3;
+    const BYTE* start0;
+    const BYTE* ref0;
+    const BYTE* ref = NULL;
+    const BYTE* start2 = NULL;
+    const BYTE* ref2 = NULL;
+    const BYTE* start3 = NULL;
+    const BYTE* ref3 = NULL;
+
+    /* init */
+    *srcSizePtr = 0;
+    if (limit == fillOutput) oend -= LASTLITERALS;                  /* Hack for support LZ4 format restriction */
+    if (inputSize < LZ4_minLength) goto _last_literals;             /* Input too small, no compression (all literals) */
+
+    /* Main Loop */
+    while (ip <= mflimit) {
+        ml = LZ4HC_InsertAndFindBestMatch(ctx, ip, matchlimit, &ref, maxNbAttempts, patternAnalysis, dict);
+        if (ml encode ML1 */
+            optr = op;
+            if (LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml, ref, limit, oend)) goto _dest_overflow;
+            continue;
+        }
+
+        if (start0 < ip) {   /* first match was skipped at least once */
+            if (start2 < ip + ml0) {  /* squeezing ML1 between ML0(original ML1) and ML2 */
+                ip = start0; ref = ref0; ml = ml0;  /* restore initial ML1 */
+        }   }
+
+        /* Here, start0==ip */
+        if ((start2 - ip) < 3) {  /* First Match too small : removed */
+            ml = ml2;
+            ip = start2;
+            ref =ref2;
+            goto _Search2;
+        }
+
+_Search3:
+        /* At this stage, we have :
+        *  ml2 > ml1, and
+        *  ip1+3 <= ip2 (usually < ip1+ml1) */
+        if ((start2 - ip) < OPTIMAL_ML) {
+            int correction;
+            int new_ml = ml;
+            if (new_ml > OPTIMAL_ML) new_ml = OPTIMAL_ML;
+            if (ip+new_ml > start2 + ml2 - MINMATCH) new_ml = (int)(start2 - ip) + ml2 - MINMATCH;
+            correction = new_ml - (int)(start2 - ip);
+            if (correction > 0) {
+                start2 += correction;
+                ref2 += correction;
+                ml2 -= correction;
+            }
+        }
+        /* Now, we have start2 = ip+new_ml, with new_ml = min(ml, OPTIMAL_ML=18) */
+
+        if (start2 + ml2 <= mflimit) {
+            ml3 = LZ4HC_InsertAndGetWiderMatch(ctx,
+                            start2 + ml2 - 3, start2, matchlimit, ml2, &ref3, &start3,
+                            maxNbAttempts, patternAnalysis, 0, dict, favorCompressionRatio);
+        } else {
+            ml3 = ml2;
+        }
+
+        if (ml3 == ml2) {  /* No better match => encode ML1 and ML2 */
+            /* ip & ref are known; Now for ml */
+            if (start2 < ip+ml)  ml = (int)(start2 - ip);
+            /* Now, encode 2 sequences */
+            optr = op;
+            if (LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml, ref, limit, oend)) goto _dest_overflow;
+            ip = start2;
+            optr = op;
+            if (LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml2, ref2, limit, oend)) {
+                ml  = ml2;
+                ref = ref2;
+                goto _dest_overflow;
+            }
+            continue;
+        }
+
+        if (start3 < ip+ml+3) {  /* Not enough space for match 2 : remove it */
+            if (start3 >= (ip+ml)) {  /* can write Seq1 immediately ==> Seq2 is removed, so Seq3 becomes Seq1 */
+                if (start2 < ip+ml) {
+                    int correction = (int)(ip+ml - start2);
+                    start2 += correction;
+                    ref2 += correction;
+                    ml2 -= correction;
+                    if (ml2 < MINMATCH) {
+                        start2 = start3;
+                        ref2 = ref3;
+                        ml2 = ml3;
+                    }
+                }
+
+                optr = op;
+                if (LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml, ref, limit, oend)) goto _dest_overflow;
+                ip  = start3;
+                ref = ref3;
+                ml  = ml3;
+
+                start0 = start2;
+                ref0 = ref2;
+                ml0 = ml2;
+                goto _Search2;
+            }
+
+            start2 = start3;
+            ref2 = ref3;
+            ml2 = ml3;
+            goto _Search3;
+        }
+
+        /*
+        * OK, now we have 3 ascending matches;
+        * let's write the first one ML1.
+        * ip & ref are known; Now decide ml.
+        */
+        if (start2 < ip+ml) {
+            if ((start2 - ip) < OPTIMAL_ML) {
+                int correction;
+                if (ml > OPTIMAL_ML) ml = OPTIMAL_ML;
+                if (ip + ml > start2 + ml2 - MINMATCH) ml = (int)(start2 - ip) + ml2 - MINMATCH;
+                correction = ml - (int)(start2 - ip);
+                if (correction > 0) {
+                    start2 += correction;
+                    ref2 += correction;
+                    ml2 -= correction;
+                }
+            } else {
+                ml = (int)(start2 - ip);
+            }
+        }
+        optr = op;
+        if (LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml, ref, limit, oend)) goto _dest_overflow;
+
+        /* ML2 becomes ML1 */
+        ip = start2; ref = ref2; ml = ml2;
+
+        /* ML3 becomes ML2 */
+        start2 = start3; ref2 = ref3; ml2 = ml3;
+
+        /* let's find a new ML3 */
+        goto _Search3;
+    }
+
+_last_literals:
+    /* Encode Last Literals */
+    {   size_t lastRunSize = (size_t)(iend - anchor);  /* literals */
+        size_t llAdd = (lastRunSize + 255 - RUN_MASK) / 255;
+        size_t const totalSize = 1 + llAdd + lastRunSize;
+        if (limit == fillOutput) oend += LASTLITERALS;  /* restore correct value */
+        if (limit && (op + totalSize > oend)) {
+            if (limit == limitedOutput) return 0;
+            /* adapt lastRunSize to fill 'dest' */
+            lastRunSize  = (size_t)(oend - op) - 1 /*token*/;
+            llAdd = (lastRunSize + 256 - RUN_MASK) / 256;
+            lastRunSize -= llAdd;
+        }
+        DEBUGLOG(6, "Final literal run : %i literals", (int)lastRunSize);
+        ip = anchor + lastRunSize;  /* can be != iend if limit==fillOutput */
+
+        if (lastRunSize >= RUN_MASK) {
+            size_t accumulator = lastRunSize - RUN_MASK;
+            *op++ = (RUN_MASK << ML_BITS);
+            for(; accumulator >= 255 ; accumulator -= 255) *op++ = 255;
+            *op++ = (BYTE) accumulator;
+        } else {
+            *op++ = (BYTE)(lastRunSize << ML_BITS);
+        }
+        memcpy(op, anchor, lastRunSize);
+        op += lastRunSize;
+    }
+
+    /* End */
+    *srcSizePtr = (int) (((const char*)ip) - source);
+    return (int) (((char*)op)-dest);
+
+_dest_overflow:
+    if (limit == fillOutput) {
+        /* Assumption : ip, anchor, ml and ref must be set correctly */
+        size_t const ll = (size_t)(ip - anchor);
+        size_t const ll_addbytes = (ll + 240) / 255;
+        size_t const ll_totalCost = 1 + ll_addbytes + ll;
+        BYTE* const maxLitPos = oend - 3; /* 2 for offset, 1 for token */
+        DEBUGLOG(6, "Last sequence overflowing");
+        op = optr;  /* restore correct out pointer */
+        if (op + ll_totalCost <= maxLitPos) {
+            /* ll validated; now adjust match length */
+            size_t const bytesLeftForMl = (size_t)(maxLitPos - (op+ll_totalCost));
+            size_t const maxMlSize = MINMATCH + (ML_MASK-1) + (bytesLeftForMl * 255);
+            assert(maxMlSize < INT_MAX); assert(ml >= 0);
+            if ((size_t)ml > maxMlSize) ml = (int)maxMlSize;
+            if ((oend + LASTLITERALS) - (op + ll_totalCost + 2) - 1 + ml >= MFLIMIT) {
+                LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml, ref, notLimited, oend);
+        }   }
+        goto _last_literals;
+    }
+    /* compression failed */
+    return 0;
+}
+
+
+static int LZ4HC_compress_optimal( LZ4HC_CCtx_internal* ctx,
+    const char* const source, char* dst,
+    int* srcSizePtr, int dstCapacity,
+    int const nbSearches, size_t sufficient_len,
+    const limitedOutput_directive limit, int const fullUpdate,
+    const dictCtx_directive dict,
+    const HCfavor_e favorDecSpeed);
+
+
+LZ4_FORCE_INLINE int LZ4HC_compress_generic_internal (
+    LZ4HC_CCtx_internal* const ctx,
+    const char* const src,
+    char* const dst,
+    int* const srcSizePtr,
+    int const dstCapacity,
+    int cLevel,
+    const limitedOutput_directive limit,
+    const dictCtx_directive dict
+    )
+{
+    typedef enum { lz4hc, lz4opt } lz4hc_strat_e;
+    typedef struct {
+        lz4hc_strat_e strat;
+        int nbSearches;
+        U32 targetLength;
+    } cParams_t;
+    static const cParams_t clTable[LZ4HC_CLEVEL_MAX+1] = {
+        { lz4hc,     2, 16 },  /* 0, unused */
+        { lz4hc,     2, 16 },  /* 1, unused */
+        { lz4hc,     2, 16 },  /* 2, unused */
+        { lz4hc,     4, 16 },  /* 3 */
+        { lz4hc,     8, 16 },  /* 4 */
+        { lz4hc,    16, 16 },  /* 5 */
+        { lz4hc,    32, 16 },  /* 6 */
+        { lz4hc,    64, 16 },  /* 7 */
+        { lz4hc,   128, 16 },  /* 8 */
+        { lz4hc,   256, 16 },  /* 9 */
+        { lz4opt,   96, 64 },  /*10==LZ4HC_CLEVEL_OPT_MIN*/
+        { lz4opt,  512,128 },  /*11 */
+        { lz4opt,16384,LZ4_OPT_NUM },  /* 12==LZ4HC_CLEVEL_MAX */
+    };
+
+    DEBUGLOG(4, "LZ4HC_compress_generic(ctx=%p, src=%p, srcSize=%d, limit=%d)",
+                ctx, src, *srcSizePtr, limit);
+
+    if (limit == fillOutput && dstCapacity < 1) return 0;   /* Impossible to store anything */
+    if ((U32)*srcSizePtr > (U32)LZ4_MAX_INPUT_SIZE) return 0;    /* Unsupported input size (too large or negative) */
+
+    ctx->end += *srcSizePtr;
+    if (cLevel < 1) cLevel = LZ4HC_CLEVEL_DEFAULT;   /* note : convention is different from lz4frame, maybe something to review */
+    cLevel = MIN(LZ4HC_CLEVEL_MAX, cLevel);
+    {   cParams_t const cParam = clTable[cLevel];
+        HCfavor_e const favor = ctx->favorDecSpeed ? favorDecompressionSpeed : favorCompressionRatio;
+        int result;
+
+        if (cParam.strat == lz4hc) {
+            result = LZ4HC_compress_hashChain(ctx,
+                                src, dst, srcSizePtr, dstCapacity,
+                                cParam.nbSearches, limit, dict);
+        } else {
+            assert(cParam.strat == lz4opt);
+            result = LZ4HC_compress_optimal(ctx,
+                                src, dst, srcSizePtr, dstCapacity,
+                                cParam.nbSearches, cParam.targetLength, limit,
+                                cLevel == LZ4HC_CLEVEL_MAX,   /* ultra mode */
+                                dict, favor);
+        }
+        if (result <= 0) ctx->dirty = 1;
+        return result;
+    }
+}
+
+static void LZ4HC_setExternalDict(LZ4HC_CCtx_internal* ctxPtr, const BYTE* newBlock);
+
+static int
+LZ4HC_compress_generic_noDictCtx (
+        LZ4HC_CCtx_internal* const ctx,
+        const char* const src,
+        char* const dst,
+        int* const srcSizePtr,
+        int const dstCapacity,
+        int cLevel,
+        limitedOutput_directive limit
+        )
+{
+    assert(ctx->dictCtx == NULL);
+    return LZ4HC_compress_generic_internal(ctx, src, dst, srcSizePtr, dstCapacity, cLevel, limit, noDictCtx);
+}
+
+static int
+LZ4HC_compress_generic_dictCtx (
+        LZ4HC_CCtx_internal* const ctx,
+        const char* const src,
+        char* const dst,
+        int* const srcSizePtr,
+        int const dstCapacity,
+        int cLevel,
+        limitedOutput_directive limit
+        )
+{
+    const size_t position = (size_t)(ctx->end - ctx->base) - ctx->lowLimit;
+    assert(ctx->dictCtx != NULL);
+    if (position >= 64 KB) {
+        ctx->dictCtx = NULL;
+        return LZ4HC_compress_generic_noDictCtx(ctx, src, dst, srcSizePtr, dstCapacity, cLevel, limit);
+    } else if (position == 0 && *srcSizePtr > 4 KB) {
+        memcpy(ctx, ctx->dictCtx, sizeof(LZ4HC_CCtx_internal));
+        LZ4HC_setExternalDict(ctx, (const BYTE *)src);
+        ctx->compressionLevel = (short)cLevel;
+        return LZ4HC_compress_generic_noDictCtx(ctx, src, dst, srcSizePtr, dstCapacity, cLevel, limit);
+    } else {
+        return LZ4HC_compress_generic_internal(ctx, src, dst, srcSizePtr, dstCapacity, cLevel, limit, usingDictCtxHc);
+    }
+}
+
+static int
+LZ4HC_compress_generic (
+        LZ4HC_CCtx_internal* const ctx,
+        const char* const src,
+        char* const dst,
+        int* const srcSizePtr,
+        int const dstCapacity,
+        int cLevel,
+        limitedOutput_directive limit
+        )
+{
+    if (ctx->dictCtx == NULL) {
+        return LZ4HC_compress_generic_noDictCtx(ctx, src, dst, srcSizePtr, dstCapacity, cLevel, limit);
+    } else {
+        return LZ4HC_compress_generic_dictCtx(ctx, src, dst, srcSizePtr, dstCapacity, cLevel, limit);
+    }
+}
+
+
+int LZ4_sizeofStateHC(void) { return (int)sizeof(LZ4_streamHC_t); }
+
+static size_t LZ4_streamHC_t_alignment(void)
+{
+#if LZ4_ALIGN_TEST
+    typedef struct { char c; LZ4_streamHC_t t; } t_a;
+    return sizeof(t_a) - sizeof(LZ4_streamHC_t);
+#else
+    return 1;  /* effectively disabled */
+#endif
+}
+
+/* state is presumed correctly initialized,
+ * in which case its size and alignment have already been validate */
+int LZ4_compress_HC_extStateHC_fastReset (void* state, const char* src, char* dst, int srcSize, int dstCapacity, int compressionLevel)
+{
+    LZ4HC_CCtx_internal* const ctx = &((LZ4_streamHC_t*)state)->internal_donotuse;
+    if (!LZ4_isAligned(state, LZ4_streamHC_t_alignment())) return 0;
+    LZ4_resetStreamHC_fast((LZ4_streamHC_t*)state, compressionLevel);
+    LZ4HC_init_internal (ctx, (const BYTE*)src);
+    if (dstCapacity < LZ4_compressBound(srcSize))
+        return LZ4HC_compress_generic (ctx, src, dst, &srcSize, dstCapacity, compressionLevel, limitedOutput);
+    else
+        return LZ4HC_compress_generic (ctx, src, dst, &srcSize, dstCapacity, compressionLevel, notLimited);
+}
+
+int LZ4_compress_HC_extStateHC (void* state, const char* src, char* dst, int srcSize, int dstCapacity, int compressionLevel)
+{
+    LZ4_streamHC_t* const ctx = LZ4_initStreamHC(state, sizeof(*ctx));
+    if (ctx==NULL) return 0;   /* init failure */
+    return LZ4_compress_HC_extStateHC_fastReset(state, src, dst, srcSize, dstCapacity, compressionLevel);
+}
+
+int LZ4_compress_HC(const char* src, char* dst, int srcSize, int dstCapacity, int compressionLevel)
+{
+#if defined(LZ4HC_HEAPMODE) && LZ4HC_HEAPMODE==1
+    LZ4_streamHC_t* const statePtr = (LZ4_streamHC_t*)ALLOC(sizeof(LZ4_streamHC_t));
+#else
+    LZ4_streamHC_t state;
+    LZ4_streamHC_t* const statePtr = &state;
+#endif
+    int const cSize = LZ4_compress_HC_extStateHC(statePtr, src, dst, srcSize, dstCapacity, compressionLevel);
+#if defined(LZ4HC_HEAPMODE) && LZ4HC_HEAPMODE==1
+    FREEMEM(statePtr);
+#endif
+    return cSize;
+}
+
+/* state is presumed sized correctly (>= sizeof(LZ4_streamHC_t)) */
+int LZ4_compress_HC_destSize(void* state, const char* source, char* dest, int* sourceSizePtr, int targetDestSize, int cLevel)
+{
+    LZ4_streamHC_t* const ctx = LZ4_initStreamHC(state, sizeof(*ctx));
+    if (ctx==NULL) return 0;   /* init failure */
+    LZ4HC_init_internal(&ctx->internal_donotuse, (const BYTE*) source);
+    LZ4_setCompressionLevel(ctx, cLevel);
+    return LZ4HC_compress_generic(&ctx->internal_donotuse, source, dest, sourceSizePtr, targetDestSize, cLevel, fillOutput);
+}
+
+
+
+/**************************************
+*  Streaming Functions
+**************************************/
+/* allocation */
+LZ4_streamHC_t* LZ4_createStreamHC(void)
+{
+    LZ4_streamHC_t* const state =
+        (LZ4_streamHC_t*)ALLOC_AND_ZERO(sizeof(LZ4_streamHC_t));
+    if (state == NULL) return NULL;
+    LZ4_setCompressionLevel(state, LZ4HC_CLEVEL_DEFAULT);
+    return state;
+}
+
+int LZ4_freeStreamHC (LZ4_streamHC_t* LZ4_streamHCPtr)
+{
+    DEBUGLOG(4, "LZ4_freeStreamHC(%p)", LZ4_streamHCPtr);
+    if (!LZ4_streamHCPtr) return 0;  /* support free on NULL */
+    FREEMEM(LZ4_streamHCPtr);
+    return 0;
+}
+
+
+LZ4_streamHC_t* LZ4_initStreamHC (void* buffer, size_t size)
+{
+    LZ4_streamHC_t* const LZ4_streamHCPtr = (LZ4_streamHC_t*)buffer;
+    /* if compilation fails here, LZ4_STREAMHCSIZE must be increased */
+    LZ4_STATIC_ASSERT(sizeof(LZ4HC_CCtx_internal) <= LZ4_STREAMHCSIZE);
+    DEBUGLOG(4, "LZ4_initStreamHC(%p, %u)", buffer, (unsigned)size);
+    /* check conditions */
+    if (buffer == NULL) return NULL;
+    if (size < sizeof(LZ4_streamHC_t)) return NULL;
+    if (!LZ4_isAligned(buffer, LZ4_streamHC_t_alignment())) return NULL;
+    /* init */
+    { LZ4HC_CCtx_internal* const hcstate = &(LZ4_streamHCPtr->internal_donotuse);
+      MEM_INIT(hcstate, 0, sizeof(*hcstate)); }
+    LZ4_setCompressionLevel(LZ4_streamHCPtr, LZ4HC_CLEVEL_DEFAULT);
+    return LZ4_streamHCPtr;
+}
+
+/* just a stub */
+void LZ4_resetStreamHC (LZ4_streamHC_t* LZ4_streamHCPtr, int compressionLevel)
+{
+    LZ4_initStreamHC(LZ4_streamHCPtr, sizeof(*LZ4_streamHCPtr));
+    LZ4_setCompressionLevel(LZ4_streamHCPtr, compressionLevel);
+}
+
+void LZ4_resetStreamHC_fast (LZ4_streamHC_t* LZ4_streamHCPtr, int compressionLevel)
+{
+    DEBUGLOG(4, "LZ4_resetStreamHC_fast(%p, %d)", LZ4_streamHCPtr, compressionLevel);
+    if (LZ4_streamHCPtr->internal_donotuse.dirty) {
+        LZ4_initStreamHC(LZ4_streamHCPtr, sizeof(*LZ4_streamHCPtr));
+    } else {
+        /* preserve end - base : can trigger clearTable's threshold */
+        LZ4_streamHCPtr->internal_donotuse.end -= (uptrval)LZ4_streamHCPtr->internal_donotuse.base;
+        LZ4_streamHCPtr->internal_donotuse.base = NULL;
+        LZ4_streamHCPtr->internal_donotuse.dictCtx = NULL;
+    }
+    LZ4_setCompressionLevel(LZ4_streamHCPtr, compressionLevel);
+}
+
+void LZ4_setCompressionLevel(LZ4_streamHC_t* LZ4_streamHCPtr, int compressionLevel)
+{
+    DEBUGLOG(5, "LZ4_setCompressionLevel(%p, %d)", LZ4_streamHCPtr, compressionLevel);
+    if (compressionLevel < 1) compressionLevel = LZ4HC_CLEVEL_DEFAULT;
+    if (compressionLevel > LZ4HC_CLEVEL_MAX) compressionLevel = LZ4HC_CLEVEL_MAX;
+    LZ4_streamHCPtr->internal_donotuse.compressionLevel = (short)compressionLevel;
+}
+
+void LZ4_favorDecompressionSpeed(LZ4_streamHC_t* LZ4_streamHCPtr, int favor)
+{
+    LZ4_streamHCPtr->internal_donotuse.favorDecSpeed = (favor!=0);
+}
+
+/* LZ4_loadDictHC() :
+ * LZ4_streamHCPtr is presumed properly initialized */
+int LZ4_loadDictHC (LZ4_streamHC_t* LZ4_streamHCPtr,
+              const char* dictionary, int dictSize)
+{
+    LZ4HC_CCtx_internal* const ctxPtr = &LZ4_streamHCPtr->internal_donotuse;
+    DEBUGLOG(4, "LZ4_loadDictHC(ctx:%p, dict:%p, dictSize:%d)", LZ4_streamHCPtr, dictionary, dictSize);
+    assert(LZ4_streamHCPtr != NULL);
+    if (dictSize > 64 KB) {
+        dictionary += (size_t)dictSize - 64 KB;
+        dictSize = 64 KB;
+    }
+    /* need a full initialization, there are bad side-effects when using resetFast() */
+    {   int const cLevel = ctxPtr->compressionLevel;
+        LZ4_initStreamHC(LZ4_streamHCPtr, sizeof(*LZ4_streamHCPtr));
+        LZ4_setCompressionLevel(LZ4_streamHCPtr, cLevel);
+    }
+    LZ4HC_init_internal (ctxPtr, (const BYTE*)dictionary);
+    ctxPtr->end = (const BYTE*)dictionary + dictSize;
+    if (dictSize >= 4) LZ4HC_Insert (ctxPtr, ctxPtr->end-3);
+    return dictSize;
+}
+
+void LZ4_attach_HC_dictionary(LZ4_streamHC_t *working_stream, const LZ4_streamHC_t *dictionary_stream) {
+    working_stream->internal_donotuse.dictCtx = dictionary_stream != NULL ? &(dictionary_stream->internal_donotuse) : NULL;
+}
+
+/* compression */
+
+static void LZ4HC_setExternalDict(LZ4HC_CCtx_internal* ctxPtr, const BYTE* newBlock)
+{
+    DEBUGLOG(4, "LZ4HC_setExternalDict(%p, %p)", ctxPtr, newBlock);
+    if (ctxPtr->end >= ctxPtr->base + ctxPtr->dictLimit + 4)
+        LZ4HC_Insert (ctxPtr, ctxPtr->end-3);   /* Referencing remaining dictionary content */
+
+    /* Only one memory segment for extDict, so any previous extDict is lost at this stage */
+    ctxPtr->lowLimit  = ctxPtr->dictLimit;
+    ctxPtr->dictLimit = (U32)(ctxPtr->end - ctxPtr->base);
+    ctxPtr->dictBase  = ctxPtr->base;
+    ctxPtr->base = newBlock - ctxPtr->dictLimit;
+    ctxPtr->end  = newBlock;
+    ctxPtr->nextToUpdate = ctxPtr->dictLimit;   /* match referencing will resume from there */
+
+    /* cannot reference an extDict and a dictCtx at the same time */
+    ctxPtr->dictCtx = NULL;
+}
+
+static int
+LZ4_compressHC_continue_generic (LZ4_streamHC_t* LZ4_streamHCPtr,
+                                 const char* src, char* dst,
+                                 int* srcSizePtr, int dstCapacity,
+                                 limitedOutput_directive limit)
+{
+    LZ4HC_CCtx_internal* const ctxPtr = &LZ4_streamHCPtr->internal_donotuse;
+    DEBUGLOG(5, "LZ4_compressHC_continue_generic(ctx=%p, src=%p, srcSize=%d, limit=%d)",
+                LZ4_streamHCPtr, src, *srcSizePtr, limit);
+    assert(ctxPtr != NULL);
+    /* auto-init if forgotten */
+    if (ctxPtr->base == NULL) LZ4HC_init_internal (ctxPtr, (const BYTE*) src);
+
+    /* Check overflow */
+    if ((size_t)(ctxPtr->end - ctxPtr->base) > 2 GB) {
+        size_t dictSize = (size_t)(ctxPtr->end - ctxPtr->base) - ctxPtr->dictLimit;
+        if (dictSize > 64 KB) dictSize = 64 KB;
+        LZ4_loadDictHC(LZ4_streamHCPtr, (const char*)(ctxPtr->end) - dictSize, (int)dictSize);
+    }
+
+    /* Check if blocks follow each other */
+    if ((const BYTE*)src != ctxPtr->end)
+        LZ4HC_setExternalDict(ctxPtr, (const BYTE*)src);
+
+    /* Check overlapping input/dictionary space */
+    {   const BYTE* sourceEnd = (const BYTE*) src + *srcSizePtr;
+        const BYTE* const dictBegin = ctxPtr->dictBase + ctxPtr->lowLimit;
+        const BYTE* const dictEnd   = ctxPtr->dictBase + ctxPtr->dictLimit;
+        if ((sourceEnd > dictBegin) && ((const BYTE*)src < dictEnd)) {
+            if (sourceEnd > dictEnd) sourceEnd = dictEnd;
+            ctxPtr->lowLimit = (U32)(sourceEnd - ctxPtr->dictBase);
+            if (ctxPtr->dictLimit - ctxPtr->lowLimit < 4) ctxPtr->lowLimit = ctxPtr->dictLimit;
+    }   }
+
+    return LZ4HC_compress_generic (ctxPtr, src, dst, srcSizePtr, dstCapacity, ctxPtr->compressionLevel, limit);
+}
+
+int LZ4_compress_HC_continue (LZ4_streamHC_t* LZ4_streamHCPtr, const char* src, char* dst, int srcSize, int dstCapacity)
+{
+    if (dstCapacity < LZ4_compressBound(srcSize))
+        return LZ4_compressHC_continue_generic (LZ4_streamHCPtr, src, dst, &srcSize, dstCapacity, limitedOutput);
+    else
+        return LZ4_compressHC_continue_generic (LZ4_streamHCPtr, src, dst, &srcSize, dstCapacity, notLimited);
+}
+
+int LZ4_compress_HC_continue_destSize (LZ4_streamHC_t* LZ4_streamHCPtr, const char* src, char* dst, int* srcSizePtr, int targetDestSize)
+{
+    return LZ4_compressHC_continue_generic(LZ4_streamHCPtr, src, dst, srcSizePtr, targetDestSize, fillOutput);
+}
+
+
+
+/* LZ4_saveDictHC :
+ * save history content
+ * into a user-provided buffer
+ * which is then used to continue compression
+ */
+int LZ4_saveDictHC (LZ4_streamHC_t* LZ4_streamHCPtr, char* safeBuffer, int dictSize)
+{
+    LZ4HC_CCtx_internal* const streamPtr = &LZ4_streamHCPtr->internal_donotuse;
+    int const prefixSize = (int)(streamPtr->end - (streamPtr->base + streamPtr->dictLimit));
+    DEBUGLOG(5, "LZ4_saveDictHC(%p, %p, %d)", LZ4_streamHCPtr, safeBuffer, dictSize);
+    assert(prefixSize >= 0);
+    if (dictSize > 64 KB) dictSize = 64 KB;
+    if (dictSize < 4) dictSize = 0;
+    if (dictSize > prefixSize) dictSize = prefixSize;
+    if (safeBuffer == NULL) assert(dictSize == 0);
+    if (dictSize > 0)
+        memmove(safeBuffer, streamPtr->end - dictSize, dictSize);
+    {   U32 const endIndex = (U32)(streamPtr->end - streamPtr->base);
+        streamPtr->end = (const BYTE*)safeBuffer + dictSize;
+        streamPtr->base = streamPtr->end - endIndex;
+        streamPtr->dictLimit = endIndex - (U32)dictSize;
+        streamPtr->lowLimit = endIndex - (U32)dictSize;
+        if (streamPtr->nextToUpdate < streamPtr->dictLimit)
+            streamPtr->nextToUpdate = streamPtr->dictLimit;
+    }
+    return dictSize;
+}
+
+
+/***************************************************
+*  Deprecated Functions
+***************************************************/
+
+/* These functions currently generate deprecation warnings */
+
+/* Wrappers for deprecated compression functions */
+int LZ4_compressHC(const char* src, char* dst, int srcSize) { return LZ4_compress_HC (src, dst, srcSize, LZ4_compressBound(srcSize), 0); }
+int LZ4_compressHC_limitedOutput(const char* src, char* dst, int srcSize, int maxDstSize) { return LZ4_compress_HC(src, dst, srcSize, maxDstSize, 0); }
+int LZ4_compressHC2(const char* src, char* dst, int srcSize, int cLevel) { return LZ4_compress_HC (src, dst, srcSize, LZ4_compressBound(srcSize), cLevel); }
+int LZ4_compressHC2_limitedOutput(const char* src, char* dst, int srcSize, int maxDstSize, int cLevel) { return LZ4_compress_HC(src, dst, srcSize, maxDstSize, cLevel); }
+int LZ4_compressHC_withStateHC (void* state, const char* src, char* dst, int srcSize) { return LZ4_compress_HC_extStateHC (state, src, dst, srcSize, LZ4_compressBound(srcSize), 0); }
+int LZ4_compressHC_limitedOutput_withStateHC (void* state, const char* src, char* dst, int srcSize, int maxDstSize) { return LZ4_compress_HC_extStateHC (state, src, dst, srcSize, maxDstSize, 0); }
+int LZ4_compressHC2_withStateHC (void* state, const char* src, char* dst, int srcSize, int cLevel) { return LZ4_compress_HC_extStateHC(state, src, dst, srcSize, LZ4_compressBound(srcSize), cLevel); }
+int LZ4_compressHC2_limitedOutput_withStateHC (void* state, const char* src, char* dst, int srcSize, int maxDstSize, int cLevel) { return LZ4_compress_HC_extStateHC(state, src, dst, srcSize, maxDstSize, cLevel); }
+int LZ4_compressHC_continue (LZ4_streamHC_t* ctx, const char* src, char* dst, int srcSize) { return LZ4_compress_HC_continue (ctx, src, dst, srcSize, LZ4_compressBound(srcSize)); }
+int LZ4_compressHC_limitedOutput_continue (LZ4_streamHC_t* ctx, const char* src, char* dst, int srcSize, int maxDstSize) { return LZ4_compress_HC_continue (ctx, src, dst, srcSize, maxDstSize); }
+
+
+/* Deprecated streaming functions */
+int LZ4_sizeofStreamStateHC(void) { return LZ4_STREAMHCSIZE; }
+
+/* state is presumed correctly sized, aka >= sizeof(LZ4_streamHC_t)
+ * @return : 0 on success, !=0 if error */
+int LZ4_resetStreamStateHC(void* state, char* inputBuffer)
+{
+    LZ4_streamHC_t* const hc4 = LZ4_initStreamHC(state, sizeof(*hc4));
+    if (hc4 == NULL) return 1;   /* init failed */
+    LZ4HC_init_internal (&hc4->internal_donotuse, (const BYTE*)inputBuffer);
+    return 0;
+}
+
+void* LZ4_createHC (const char* inputBuffer)
+{
+    LZ4_streamHC_t* const hc4 = LZ4_createStreamHC();
+    if (hc4 == NULL) return NULL;   /* not enough memory */
+    LZ4HC_init_internal (&hc4->internal_donotuse, (const BYTE*)inputBuffer);
+    return hc4;
+}
+
+int LZ4_freeHC (void* LZ4HC_Data)
+{
+    if (!LZ4HC_Data) return 0;  /* support free on NULL */
+    FREEMEM(LZ4HC_Data);
+    return 0;
+}
+
+int LZ4_compressHC2_continue (void* LZ4HC_Data, const char* src, char* dst, int srcSize, int cLevel)
+{
+    return LZ4HC_compress_generic (&((LZ4_streamHC_t*)LZ4HC_Data)->internal_donotuse, src, dst, &srcSize, 0, cLevel, notLimited);
+}
+
+int LZ4_compressHC2_limitedOutput_continue (void* LZ4HC_Data, const char* src, char* dst, int srcSize, int dstCapacity, int cLevel)
+{
+    return LZ4HC_compress_generic (&((LZ4_streamHC_t*)LZ4HC_Data)->internal_donotuse, src, dst, &srcSize, dstCapacity, cLevel, limitedOutput);
+}
+
+char* LZ4_slideInputBufferHC(void* LZ4HC_Data)
+{
+    LZ4_streamHC_t *ctx = (LZ4_streamHC_t*)LZ4HC_Data;
+    const BYTE *bufferStart = ctx->internal_donotuse.base + ctx->internal_donotuse.lowLimit;
+    LZ4_resetStreamHC_fast(ctx, ctx->internal_donotuse.compressionLevel);
+    /* avoid const char * -> char * conversion warning :( */
+    return (char *)(uptrval)bufferStart;
+}
+
+
+/* ================================================
+ *  LZ4 Optimal parser (levels [LZ4HC_CLEVEL_OPT_MIN - LZ4HC_CLEVEL_MAX])
+ * ===============================================*/
+typedef struct {
+    int price;
+    int off;
+    int mlen;
+    int litlen;
+} LZ4HC_optimal_t;
+
+/* price in bytes */
+LZ4_FORCE_INLINE int LZ4HC_literalsPrice(int const litlen)
+{
+    int price = litlen;
+    assert(litlen >= 0);
+    if (litlen >= (int)RUN_MASK)
+        price += 1 + ((litlen-(int)RUN_MASK) / 255);
+    return price;
+}
+
+
+/* requires mlen >= MINMATCH */
+LZ4_FORCE_INLINE int LZ4HC_sequencePrice(int litlen, int mlen)
+{
+    int price = 1 + 2 ; /* token + 16-bit offset */
+    assert(litlen >= 0);
+    assert(mlen >= MINMATCH);
+
+    price += LZ4HC_literalsPrice(litlen);
+
+    if (mlen >= (int)(ML_MASK+MINMATCH))
+        price += 1 + ((mlen-(int)(ML_MASK+MINMATCH)) / 255);
+
+    return price;
+}
+
+
+typedef struct {
+    int off;
+    int len;
+} LZ4HC_match_t;
+
+LZ4_FORCE_INLINE LZ4HC_match_t
+LZ4HC_FindLongerMatch(LZ4HC_CCtx_internal* const ctx,
+                      const BYTE* ip, const BYTE* const iHighLimit,
+                      int minLen, int nbSearches,
+                      const dictCtx_directive dict,
+                      const HCfavor_e favorDecSpeed)
+{
+    LZ4HC_match_t match = { 0 , 0 };
+    const BYTE* matchPtr = NULL;
+    /* note : LZ4HC_InsertAndGetWiderMatch() is able to modify the starting position of a match (*startpos),
+     * but this won't be the case here, as we define iLowLimit==ip,
+     * so LZ4HC_InsertAndGetWiderMatch() won't be allowed to search past ip */
+    int matchLength = LZ4HC_InsertAndGetWiderMatch(ctx, ip, ip, iHighLimit, minLen, &matchPtr, &ip, nbSearches, 1 /*patternAnalysis*/, 1 /*chainSwap*/, dict, favorDecSpeed);
+    if (matchLength <= minLen) return match;
+    if (favorDecSpeed) {
+        if ((matchLength>18) & (matchLength<=36)) matchLength=18;   /* favor shortcut */
+    }
+    match.len = matchLength;
+    match.off = (int)(ip-matchPtr);
+    return match;
+}
+
+
+static int LZ4HC_compress_optimal ( LZ4HC_CCtx_internal* ctx,
+                                    const char* const source,
+                                    char* dst,
+                                    int* srcSizePtr,
+                                    int dstCapacity,
+                                    int const nbSearches,
+                                    size_t sufficient_len,
+                                    const limitedOutput_directive limit,
+                                    int const fullUpdate,
+                                    const dictCtx_directive dict,
+                                    const HCfavor_e favorDecSpeed)
+{
+    int retval = 0;
+#define TRAILING_LITERALS 3
+#ifdef LZ4HC_HEAPMODE
+    LZ4HC_optimal_t* const opt = (LZ4HC_optimal_t*)ALLOC(sizeof(LZ4HC_optimal_t) * (LZ4_OPT_NUM + TRAILING_LITERALS));
+#else
+    LZ4HC_optimal_t opt[LZ4_OPT_NUM + TRAILING_LITERALS];   /* ~64 KB, which is a bit large for stack... */
+#endif
+
+    const BYTE* ip = (const BYTE*) source;
+    const BYTE* anchor = ip;
+    const BYTE* const iend = ip + *srcSizePtr;
+    const BYTE* const mflimit = iend - MFLIMIT;
+    const BYTE* const matchlimit = iend - LASTLITERALS;
+    BYTE* op = (BYTE*) dst;
+    BYTE* opSaved = (BYTE*) dst;
+    BYTE* oend = op + dstCapacity;
+    int ovml = MINMATCH;  /* overflow - last sequence */
+    const BYTE* ovref = NULL;
+
+    /* init */
+#ifdef LZ4HC_HEAPMODE
+    if (opt == NULL) goto _return_label;
+#endif
+    DEBUGLOG(5, "LZ4HC_compress_optimal(dst=%p, dstCapa=%u)", dst, (unsigned)dstCapacity);
+    *srcSizePtr = 0;
+    if (limit == fillOutput) oend -= LASTLITERALS;   /* Hack for support LZ4 format restriction */
+    if (sufficient_len >= LZ4_OPT_NUM) sufficient_len = LZ4_OPT_NUM-1;
+
+    /* Main Loop */
+    while (ip <= mflimit) {
+         int const llen = (int)(ip - anchor);
+         int best_mlen, best_off;
+         int cur, last_match_pos = 0;
+
+         LZ4HC_match_t const firstMatch = LZ4HC_FindLongerMatch(ctx, ip, matchlimit, MINMATCH-1, nbSearches, dict, favorDecSpeed);
+         if (firstMatch.len==0) { ip++; continue; }
+
+         if ((size_t)firstMatch.len > sufficient_len) {
+             /* good enough solution : immediate encoding */
+             int const firstML = firstMatch.len;
+             const BYTE* const matchPos = ip - firstMatch.off;
+             opSaved = op;
+             if ( LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), firstML, matchPos, limit, oend) ) {  /* updates ip, op and anchor */
+                 ovml = firstML;
+                 ovref = matchPos;
+                 goto _dest_overflow;
+             }
+             continue;
+         }
+
+         /* set prices for first positions (literals) */
+         {   int rPos;
+             for (rPos = 0 ; rPos < MINMATCH ; rPos++) {
+                 int const cost = LZ4HC_literalsPrice(llen + rPos);
+                 opt[rPos].mlen = 1;
+                 opt[rPos].off = 0;
+                 opt[rPos].litlen = llen + rPos;
+                 opt[rPos].price = cost;
+                 DEBUGLOG(7, "rPos:%3i => price:%3i (litlen=%i) -- initial setup",
+                             rPos, cost, opt[rPos].litlen);
+         }   }
+         /* set prices using initial match */
+         {   int mlen = MINMATCH;
+             int const matchML = firstMatch.len;   /* necessarily < sufficient_len < LZ4_OPT_NUM */
+             int const offset = firstMatch.off;
+             assert(matchML < LZ4_OPT_NUM);
+             for ( ; mlen <= matchML ; mlen++) {
+                 int const cost = LZ4HC_sequencePrice(llen, mlen);
+                 opt[mlen].mlen = mlen;
+                 opt[mlen].off = offset;
+                 opt[mlen].litlen = llen;
+                 opt[mlen].price = cost;
+                 DEBUGLOG(7, "rPos:%3i => price:%3i (matchlen=%i) -- initial setup",
+                             mlen, cost, mlen);
+         }   }
+         last_match_pos = firstMatch.len;
+         {   int addLit;
+             for (addLit = 1; addLit <= TRAILING_LITERALS; addLit ++) {
+                 opt[last_match_pos+addLit].mlen = 1; /* literal */
+                 opt[last_match_pos+addLit].off = 0;
+                 opt[last_match_pos+addLit].litlen = addLit;
+                 opt[last_match_pos+addLit].price = opt[last_match_pos].price + LZ4HC_literalsPrice(addLit);
+                 DEBUGLOG(7, "rPos:%3i => price:%3i (litlen=%i) -- initial setup",
+                             last_match_pos+addLit, opt[last_match_pos+addLit].price, addLit);
+         }   }
+
+         /* check further positions */
+         for (cur = 1; cur < last_match_pos; cur++) {
+             const BYTE* const curPtr = ip + cur;
+             LZ4HC_match_t newMatch;
+
+             if (curPtr > mflimit) break;
+             DEBUGLOG(7, "rPos:%u[%u] vs [%u]%u",
+                     cur, opt[cur].price, opt[cur+1].price, cur+1);
+             if (fullUpdate) {
+                 /* not useful to search here if next position has same (or lower) cost */
+                 if ( (opt[cur+1].price <= opt[cur].price)
+                   /* in some cases, next position has same cost, but cost rises sharply after, so a small match would still be beneficial */
+                   && (opt[cur+MINMATCH].price < opt[cur].price + 3/*min seq price*/) )
+                     continue;
+             } else {
+                 /* not useful to search here if next position has same (or lower) cost */
+                 if (opt[cur+1].price <= opt[cur].price) continue;
+             }
+
+             DEBUGLOG(7, "search at rPos:%u", cur);
+             if (fullUpdate)
+                 newMatch = LZ4HC_FindLongerMatch(ctx, curPtr, matchlimit, MINMATCH-1, nbSearches, dict, favorDecSpeed);
+             else
+                 /* only test matches of minimum length; slightly faster, but misses a few bytes */
+                 newMatch = LZ4HC_FindLongerMatch(ctx, curPtr, matchlimit, last_match_pos - cur, nbSearches, dict, favorDecSpeed);
+             if (!newMatch.len) continue;
+
+             if ( ((size_t)newMatch.len > sufficient_len)
+               || (newMatch.len + cur >= LZ4_OPT_NUM) ) {
+                 /* immediate encoding */
+                 best_mlen = newMatch.len;
+                 best_off = newMatch.off;
+                 last_match_pos = cur + 1;
+                 goto encode;
+             }
+
+             /* before match : set price with literals at beginning */
+             {   int const baseLitlen = opt[cur].litlen;
+                 int litlen;
+                 for (litlen = 1; litlen < MINMATCH; litlen++) {
+                     int const price = opt[cur].price - LZ4HC_literalsPrice(baseLitlen) + LZ4HC_literalsPrice(baseLitlen+litlen);
+                     int const pos = cur + litlen;
+                     if (price < opt[pos].price) {
+                         opt[pos].mlen = 1; /* literal */
+                         opt[pos].off = 0;
+                         opt[pos].litlen = baseLitlen+litlen;
+                         opt[pos].price = price;
+                         DEBUGLOG(7, "rPos:%3i => price:%3i (litlen=%i)",
+                                     pos, price, opt[pos].litlen);
+             }   }   }
+
+             /* set prices using match at position = cur */
+             {   int const matchML = newMatch.len;
+                 int ml = MINMATCH;
+
+                 assert(cur + newMatch.len < LZ4_OPT_NUM);
+                 for ( ; ml <= matchML ; ml++) {
+                     int const pos = cur + ml;
+                     int const offset = newMatch.off;
+                     int price;
+                     int ll;
+                     DEBUGLOG(7, "testing price rPos %i (last_match_pos=%i)",
+                                 pos, last_match_pos);
+                     if (opt[cur].mlen == 1) {
+                         ll = opt[cur].litlen;
+                         price = ((cur > ll) ? opt[cur - ll].price : 0)
+                               + LZ4HC_sequencePrice(ll, ml);
+                     } else {
+                         ll = 0;
+                         price = opt[cur].price + LZ4HC_sequencePrice(0, ml);
+                     }
+
+                    assert((U32)favorDecSpeed <= 1);
+                     if (pos > last_match_pos+TRAILING_LITERALS
+                      || price <= opt[pos].price - (int)favorDecSpeed) {
+                         DEBUGLOG(7, "rPos:%3i => price:%3i (matchlen=%i)",
+                                     pos, price, ml);
+                         assert(pos < LZ4_OPT_NUM);
+                         if ( (ml == matchML)  /* last pos of last match */
+                           && (last_match_pos < pos) )
+                             last_match_pos = pos;
+                         opt[pos].mlen = ml;
+                         opt[pos].off = offset;
+                         opt[pos].litlen = ll;
+                         opt[pos].price = price;
+             }   }   }
+             /* complete following positions with literals */
+             {   int addLit;
+                 for (addLit = 1; addLit <= TRAILING_LITERALS; addLit ++) {
+                     opt[last_match_pos+addLit].mlen = 1; /* literal */
+                     opt[last_match_pos+addLit].off = 0;
+                     opt[last_match_pos+addLit].litlen = addLit;
+                     opt[last_match_pos+addLit].price = opt[last_match_pos].price + LZ4HC_literalsPrice(addLit);
+                     DEBUGLOG(7, "rPos:%3i => price:%3i (litlen=%i)", last_match_pos+addLit, opt[last_match_pos+addLit].price, addLit);
+             }   }
+         }  /* for (cur = 1; cur <= last_match_pos; cur++) */
+
+         assert(last_match_pos < LZ4_OPT_NUM + TRAILING_LITERALS);
+         best_mlen = opt[last_match_pos].mlen;
+         best_off = opt[last_match_pos].off;
+         cur = last_match_pos - best_mlen;
+
+encode: /* cur, last_match_pos, best_mlen, best_off must be set */
+         assert(cur < LZ4_OPT_NUM);
+         assert(last_match_pos >= 1);  /* == 1 when only one candidate */
+         DEBUGLOG(6, "reverse traversal, looking for shortest path (last_match_pos=%i)", last_match_pos);
+         {   int candidate_pos = cur;
+             int selected_matchLength = best_mlen;
+             int selected_offset = best_off;
+             while (1) {  /* from end to beginning */
+                 int const next_matchLength = opt[candidate_pos].mlen;  /* can be 1, means literal */
+                 int const next_offset = opt[candidate_pos].off;
+                 DEBUGLOG(7, "pos %i: sequence length %i", candidate_pos, selected_matchLength);
+                 opt[candidate_pos].mlen = selected_matchLength;
+                 opt[candidate_pos].off = selected_offset;
+                 selected_matchLength = next_matchLength;
+                 selected_offset = next_offset;
+                 if (next_matchLength > candidate_pos) break; /* last match elected, first match to encode */
+                 assert(next_matchLength > 0);  /* can be 1, means literal */
+                 candidate_pos -= next_matchLength;
+         }   }
+
+         /* encode all recorded sequences in order */
+         {   int rPos = 0;  /* relative position (to ip) */
+             while (rPos < last_match_pos) {
+                 int const ml = opt[rPos].mlen;
+                 int const offset = opt[rPos].off;
+                 if (ml == 1) { ip++; rPos++; continue; }  /* literal; note: can end up with several literals, in which case, skip them */
+                 rPos += ml;
+                 assert(ml >= MINMATCH);
+                 assert((offset >= 1) && (offset <= LZ4_DISTANCE_MAX));
+                 opSaved = op;
+                 if ( LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ml, ip - offset, limit, oend) ) {  /* updates ip, op and anchor */
+                     ovml = ml;
+                     ovref = ip - offset;
+                     goto _dest_overflow;
+         }   }   }
+     }  /* while (ip <= mflimit) */
+
+_last_literals:
+     /* Encode Last Literals */
+     {   size_t lastRunSize = (size_t)(iend - anchor);  /* literals */
+         size_t llAdd = (lastRunSize + 255 - RUN_MASK) / 255;
+         size_t const totalSize = 1 + llAdd + lastRunSize;
+         if (limit == fillOutput) oend += LASTLITERALS;  /* restore correct value */
+         if (limit && (op + totalSize > oend)) {
+             if (limit == limitedOutput) { /* Check output limit */
+                retval = 0;
+                goto _return_label;
+             }
+             /* adapt lastRunSize to fill 'dst' */
+             lastRunSize  = (size_t)(oend - op) - 1 /*token*/;
+             llAdd = (lastRunSize + 256 - RUN_MASK) / 256;
+             lastRunSize -= llAdd;
+         }
+         DEBUGLOG(6, "Final literal run : %i literals", (int)lastRunSize);
+         ip = anchor + lastRunSize; /* can be != iend if limit==fillOutput */
+
+         if (lastRunSize >= RUN_MASK) {
+             size_t accumulator = lastRunSize - RUN_MASK;
+             *op++ = (RUN_MASK << ML_BITS);
+             for(; accumulator >= 255 ; accumulator -= 255) *op++ = 255;
+             *op++ = (BYTE) accumulator;
+         } else {
+             *op++ = (BYTE)(lastRunSize << ML_BITS);
+         }
+         memcpy(op, anchor, lastRunSize);
+         op += lastRunSize;
+     }
+
+     /* End */
+     *srcSizePtr = (int) (((const char*)ip) - source);
+     retval = (int) ((char*)op-dst);
+     goto _return_label;
+
+_dest_overflow:
+if (limit == fillOutput) {
+     /* Assumption : ip, anchor, ovml and ovref must be set correctly */
+     size_t const ll = (size_t)(ip - anchor);
+     size_t const ll_addbytes = (ll + 240) / 255;
+     size_t const ll_totalCost = 1 + ll_addbytes + ll;
+     BYTE* const maxLitPos = oend - 3; /* 2 for offset, 1 for token */
+     DEBUGLOG(6, "Last sequence overflowing (only %i bytes remaining)", (int)(oend-1-opSaved));
+     op = opSaved;  /* restore correct out pointer */
+     if (op + ll_totalCost <= maxLitPos) {
+         /* ll validated; now adjust match length */
+         size_t const bytesLeftForMl = (size_t)(maxLitPos - (op+ll_totalCost));
+         size_t const maxMlSize = MINMATCH + (ML_MASK-1) + (bytesLeftForMl * 255);
+         assert(maxMlSize < INT_MAX); assert(ovml >= 0);
+         if ((size_t)ovml > maxMlSize) ovml = (int)maxMlSize;
+         if ((oend + LASTLITERALS) - (op + ll_totalCost + 2) - 1 + ovml >= MFLIMIT) {
+             DEBUGLOG(6, "Space to end : %i + ml (%i)", (int)((oend + LASTLITERALS) - (op + ll_totalCost + 2) - 1), ovml);
+             DEBUGLOG(6, "Before : ip = %p, anchor = %p", ip, anchor);
+             LZ4HC_encodeSequence(UPDATABLE(ip, op, anchor), ovml, ovref, notLimited, oend);
+             DEBUGLOG(6, "After : ip = %p, anchor = %p", ip, anchor);
+     }   }
+     goto _last_literals;
+}
+_return_label:
+#ifdef LZ4HC_HEAPMODE
+     FREEMEM(opt);
+#endif
+     return retval;
+}
diff --git a/lz4/lib/lz4hc.h b/lz4/lib/lz4hc.h
new file mode 100644
index 0000000..3d441fb
--- /dev/null
+++ b/lz4/lib/lz4hc.h
@@ -0,0 +1,413 @@
+/*
+   LZ4 HC - High Compression Mode of LZ4
+   Header File
+   Copyright (C) 2011-2017, Yann Collet.
+   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+   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.
+
+   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.
+
+   You can contact the author at :
+   - LZ4 source repository : https://github.com/lz4/lz4
+   - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+#ifndef LZ4_HC_H_19834876238432
+#define LZ4_HC_H_19834876238432
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+/* --- Dependency --- */
+/* note : lz4hc requires lz4.h/lz4.c for compilation */
+#include "lz4.h"   /* stddef, LZ4LIB_API, LZ4_DEPRECATED */
+
+
+/* --- Useful constants --- */
+#define LZ4HC_CLEVEL_MIN         3
+#define LZ4HC_CLEVEL_DEFAULT     9
+#define LZ4HC_CLEVEL_OPT_MIN    10
+#define LZ4HC_CLEVEL_MAX        12
+
+
+/*-************************************
+ *  Block Compression
+ **************************************/
+/*! LZ4_compress_HC() :
+ *  Compress data from `src` into `dst`, using the powerful but slower "HC" algorithm.
+ * `dst` must be already allocated.
+ *  Compression is guaranteed to succeed if `dstCapacity >= LZ4_compressBound(srcSize)` (see "lz4.h")
+ *  Max supported `srcSize` value is LZ4_MAX_INPUT_SIZE (see "lz4.h")
+ * `compressionLevel` : any value between 1 and LZ4HC_CLEVEL_MAX will work.
+ *                      Values > LZ4HC_CLEVEL_MAX behave the same as LZ4HC_CLEVEL_MAX.
+ * @return : the number of bytes written into 'dst'
+ *           or 0 if compression fails.
+ */
+LZ4LIB_API int LZ4_compress_HC (const char* src, char* dst, int srcSize, int dstCapacity, int compressionLevel);
+
+
+/* Note :
+ *   Decompression functions are provided within "lz4.h" (BSD license)
+ */
+
+
+/*! LZ4_compress_HC_extStateHC() :
+ *  Same as LZ4_compress_HC(), but using an externally allocated memory segment for `state`.
+ * `state` size is provided by LZ4_sizeofStateHC().
+ *  Memory segment must be aligned on 8-bytes boundaries (which a normal malloc() should do properly).
+ */
+LZ4LIB_API int LZ4_sizeofStateHC(void);
+LZ4LIB_API int LZ4_compress_HC_extStateHC(void* stateHC, const char* src, char* dst, int srcSize, int maxDstSize, int compressionLevel);
+
+
+/*! LZ4_compress_HC_destSize() : v1.9.0+
+ *  Will compress as much data as possible from `src`
+ *  to fit into `targetDstSize` budget.
+ *  Result is provided in 2 parts :
+ * @return : the number of bytes written into 'dst' (necessarily <= targetDstSize)
+ *           or 0 if compression fails.
+ * `srcSizePtr` : on success, *srcSizePtr is updated to indicate how much bytes were read from `src`
+ */
+LZ4LIB_API int LZ4_compress_HC_destSize(void* stateHC,
+                                  const char* src, char* dst,
+                                        int* srcSizePtr, int targetDstSize,
+                                        int compressionLevel);
+
+
+/*-************************************
+ *  Streaming Compression
+ *  Bufferless synchronous API
+ **************************************/
+ typedef union LZ4_streamHC_u LZ4_streamHC_t;   /* incomplete type (defined later) */
+
+/*! LZ4_createStreamHC() and LZ4_freeStreamHC() :
+ *  These functions create and release memory for LZ4 HC streaming state.
+ *  Newly created states are automatically initialized.
+ *  A same state can be used multiple times consecutively,
+ *  starting with LZ4_resetStreamHC_fast() to start a new stream of blocks.
+ */
+LZ4LIB_API LZ4_streamHC_t* LZ4_createStreamHC(void);
+LZ4LIB_API int             LZ4_freeStreamHC (LZ4_streamHC_t* streamHCPtr);
+
+/*
+  These functions compress data in successive blocks of any size,
+  using previous blocks as dictionary, to improve compression ratio.
+  One key assumption is that previous blocks (up to 64 KB) remain read-accessible while compressing next blocks.
+  There is an exception for ring buffers, which can be smaller than 64 KB.
+  Ring-buffer scenario is automatically detected and handled within LZ4_compress_HC_continue().
+
+  Before starting compression, state must be allocated and properly initialized.
+  LZ4_createStreamHC() does both, though compression level is set to LZ4HC_CLEVEL_DEFAULT.
+
+  Selecting the compression level can be done with LZ4_resetStreamHC_fast() (starts a new stream)
+  or LZ4_setCompressionLevel() (anytime, between blocks in the same stream) (experimental).
+  LZ4_resetStreamHC_fast() only works on states which have been properly initialized at least once,
+  which is automatically the case when state is created using LZ4_createStreamHC().
+
+  After reset, a first "fictional block" can be designated as initial dictionary,
+  using LZ4_loadDictHC() (Optional).
+
+  Invoke LZ4_compress_HC_continue() to compress each successive block.
+  The number of blocks is unlimited.
+  Previous input blocks, including initial dictionary when present,
+  must remain accessible and unmodified during compression.
+
+  It's allowed to update compression level anytime between blocks,
+  using LZ4_setCompressionLevel() (experimental).
+
+  'dst' buffer should be sized to handle worst case scenarios
+  (see LZ4_compressBound(), it ensures compression success).
+  In case of failure, the API does not guarantee recovery,
+  so the state _must_ be reset.
+  To ensure compression success
+  whenever `dst` buffer size cannot be made >= LZ4_compressBound(),
+  consider using LZ4_compress_HC_continue_destSize().
+
+  Whenever previous input blocks can't be preserved unmodified in-place during compression of next blocks,
+  it's possible to copy the last blocks into a more stable memory space, using LZ4_saveDictHC().
+  Return value of LZ4_saveDictHC() is the size of dictionary effectively saved into 'safeBuffer' (<= 64 KB)
+
+  After completing a streaming compression,
+  it's possible to start a new stream of blocks, using the same LZ4_streamHC_t state,
+  just by resetting it, using LZ4_resetStreamHC_fast().
+*/
+
+LZ4LIB_API void LZ4_resetStreamHC_fast(LZ4_streamHC_t* streamHCPtr, int compressionLevel);   /* v1.9.0+ */
+LZ4LIB_API int  LZ4_loadDictHC (LZ4_streamHC_t* streamHCPtr, const char* dictionary, int dictSize);
+
+LZ4LIB_API int LZ4_compress_HC_continue (LZ4_streamHC_t* streamHCPtr,
+                                   const char* src, char* dst,
+                                         int srcSize, int maxDstSize);
+
+/*! LZ4_compress_HC_continue_destSize() : v1.9.0+
+ *  Similar to LZ4_compress_HC_continue(),
+ *  but will read as much data as possible from `src`
+ *  to fit into `targetDstSize` budget.
+ *  Result is provided into 2 parts :
+ * @return : the number of bytes written into 'dst' (necessarily <= targetDstSize)
+ *           or 0 if compression fails.
+ * `srcSizePtr` : on success, *srcSizePtr will be updated to indicate how much bytes were read from `src`.
+ *           Note that this function may not consume the entire input.
+ */
+LZ4LIB_API int LZ4_compress_HC_continue_destSize(LZ4_streamHC_t* LZ4_streamHCPtr,
+                                           const char* src, char* dst,
+                                                 int* srcSizePtr, int targetDstSize);
+
+LZ4LIB_API int LZ4_saveDictHC (LZ4_streamHC_t* streamHCPtr, char* safeBuffer, int maxDictSize);
+
+
+
+/*^**********************************************
+ * !!!!!!   STATIC LINKING ONLY   !!!!!!
+ ***********************************************/
+
+/*-******************************************************************
+ * PRIVATE DEFINITIONS :
+ * Do not use these definitions directly.
+ * They are merely exposed to allow static allocation of `LZ4_streamHC_t`.
+ * Declare an `LZ4_streamHC_t` directly, rather than any type below.
+ * Even then, only do so in the context of static linking, as definitions may change between versions.
+ ********************************************************************/
+
+#define LZ4HC_DICTIONARY_LOGSIZE 16
+#define LZ4HC_MAXD (1<= LZ4HC_CLEVEL_OPT_MIN.
+ */
+LZ4LIB_STATIC_API void LZ4_favorDecompressionSpeed(
+    LZ4_streamHC_t* LZ4_streamHCPtr, int favor);
+
+/*! LZ4_resetStreamHC_fast() : v1.9.0+
+ *  When an LZ4_streamHC_t is known to be in a internally coherent state,
+ *  it can often be prepared for a new compression with almost no work, only
+ *  sometimes falling back to the full, expensive reset that is always required
+ *  when the stream is in an indeterminate state (i.e., the reset performed by
+ *  LZ4_resetStreamHC()).
+ *
+ *  LZ4_streamHCs are guaranteed to be in a valid state when:
+ *  - returned from LZ4_createStreamHC()
+ *  - reset by LZ4_resetStreamHC()
+ *  - memset(stream, 0, sizeof(LZ4_streamHC_t))
+ *  - the stream was in a valid state and was reset by LZ4_resetStreamHC_fast()
+ *  - the stream was in a valid state and was then used in any compression call
+ *    that returned success
+ *  - the stream was in an indeterminate state and was used in a compression
+ *    call that fully reset the state (LZ4_compress_HC_extStateHC()) and that
+ *    returned success
+ *
+ *  Note:
+ *  A stream that was last used in a compression call that returned an error
+ *  may be passed to this function. However, it will be fully reset, which will
+ *  clear any existing history and settings from the context.
+ */
+LZ4LIB_STATIC_API void LZ4_resetStreamHC_fast(
+    LZ4_streamHC_t* LZ4_streamHCPtr, int compressionLevel);
+
+/*! LZ4_compress_HC_extStateHC_fastReset() :
+ *  A variant of LZ4_compress_HC_extStateHC().
+ *
+ *  Using this variant avoids an expensive initialization step. It is only safe
+ *  to call if the state buffer is known to be correctly initialized already
+ *  (see above comment on LZ4_resetStreamHC_fast() for a definition of
+ *  "correctly initialized"). From a high level, the difference is that this
+ *  function initializes the provided state with a call to
+ *  LZ4_resetStreamHC_fast() while LZ4_compress_HC_extStateHC() starts with a
+ *  call to LZ4_resetStreamHC().
+ */
+LZ4LIB_STATIC_API int LZ4_compress_HC_extStateHC_fastReset (
+    void* state,
+    const char* src, char* dst,
+    int srcSize, int dstCapacity,
+    int compressionLevel);
+
+/*! LZ4_attach_HC_dictionary() :
+ *  This is an experimental API that allows for the efficient use of a
+ *  static dictionary many times.
+ *
+ *  Rather than re-loading the dictionary buffer into a working context before
+ *  each compression, or copying a pre-loaded dictionary's LZ4_streamHC_t into a
+ *  working LZ4_streamHC_t, this function introduces a no-copy setup mechanism,
+ *  in which the working stream references the dictionary stream in-place.
+ *
+ *  Several assumptions are made about the state of the dictionary stream.
+ *  Currently, only streams which have been prepared by LZ4_loadDictHC() should
+ *  be expected to work.
+ *
+ *  Alternatively, the provided dictionary stream pointer may be NULL, in which
+ *  case any existing dictionary stream is unset.
+ *
+ *  A dictionary should only be attached to a stream without any history (i.e.,
+ *  a stream that has just been reset).
+ *
+ *  The dictionary will remain attached to the working stream only for the
+ *  current stream session. Calls to LZ4_resetStreamHC(_fast) will remove the
+ *  dictionary context association from the working stream. The dictionary
+ *  stream (and source buffer) must remain in-place / accessible / unchanged
+ *  through the lifetime of the stream session.
+ */
+LZ4LIB_STATIC_API void LZ4_attach_HC_dictionary(
+          LZ4_streamHC_t *working_stream,
+    const LZ4_streamHC_t *dictionary_stream);
+
+#if defined (__cplusplus)
+}
+#endif
+
+#endif   /* LZ4_HC_SLO_098092834 */
+#endif   /* LZ4_HC_STATIC_LINKING_ONLY */
diff --git a/lz4/lib/xxhash.c b/lz4/lib/xxhash.c
new file mode 100644
index 0000000..ff28749
--- /dev/null
+++ b/lz4/lib/xxhash.c
@@ -0,0 +1,1030 @@
+/*
+*  xxHash - Fast Hash algorithm
+*  Copyright (C) 2012-2016, Yann Collet
+*
+*  BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+*
+*  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.
+*
+*  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.
+*
+*  You can contact the author at :
+*  - xxHash homepage: http://www.xxhash.com
+*  - xxHash source repository : https://github.com/Cyan4973/xxHash
+*/
+
+
+/* *************************************
+*  Tuning parameters
+***************************************/
+/*!XXH_FORCE_MEMORY_ACCESS :
+ * By default, access to unaligned memory is controlled by `memcpy()`, which is safe and portable.
+ * Unfortunately, on some target/compiler combinations, the generated assembly is sub-optimal.
+ * The below switch allow to select different access method for improved performance.
+ * Method 0 (default) : use `memcpy()`. Safe and portable.
+ * Method 1 : `__packed` statement. It depends on compiler extension (ie, not portable).
+ *            This method is safe if your compiler supports it, and *generally* as fast or faster than `memcpy`.
+ * Method 2 : direct access. This method doesn't depend on compiler but violate C standard.
+ *            It can generate buggy code on targets which do not support unaligned memory accesses.
+ *            But in some circumstances, it's the only known way to get the most performance (ie GCC + ARMv6)
+ * See http://stackoverflow.com/a/32095106/646947 for details.
+ * Prefer these methods in priority order (0 > 1 > 2)
+ */
+#ifndef XXH_FORCE_MEMORY_ACCESS   /* can be defined externally, on command line for example */
+#  if defined(__GNUC__) && ( defined(__ARM_ARCH_6__) || defined(__ARM_ARCH_6J__) \
+                        || defined(__ARM_ARCH_6K__) || defined(__ARM_ARCH_6Z__) \
+                        || defined(__ARM_ARCH_6ZK__) || defined(__ARM_ARCH_6T2__) )
+#    define XXH_FORCE_MEMORY_ACCESS 2
+#  elif (defined(__INTEL_COMPILER) && !defined(_WIN32)) || \
+  (defined(__GNUC__) && ( defined(__ARM_ARCH_7__) || defined(__ARM_ARCH_7A__) \
+                    || defined(__ARM_ARCH_7R__) || defined(__ARM_ARCH_7M__) \
+                    || defined(__ARM_ARCH_7S__) ))
+#    define XXH_FORCE_MEMORY_ACCESS 1
+#  endif
+#endif
+
+/*!XXH_ACCEPT_NULL_INPUT_POINTER :
+ * If input pointer is NULL, xxHash default behavior is to dereference it, triggering a segfault.
+ * When this macro is enabled, xxHash actively checks input for null pointer.
+ * It it is, result for null input pointers is the same as a null-length input.
+ */
+#ifndef XXH_ACCEPT_NULL_INPUT_POINTER   /* can be defined externally */
+#  define XXH_ACCEPT_NULL_INPUT_POINTER 0
+#endif
+
+/*!XXH_FORCE_NATIVE_FORMAT :
+ * By default, xxHash library provides endian-independent Hash values, based on little-endian convention.
+ * Results are therefore identical for little-endian and big-endian CPU.
+ * This comes at a performance cost for big-endian CPU, since some swapping is required to emulate little-endian format.
+ * Should endian-independence be of no importance for your application, you may set the #define below to 1,
+ * to improve speed for Big-endian CPU.
+ * This option has no impact on Little_Endian CPU.
+ */
+#ifndef XXH_FORCE_NATIVE_FORMAT   /* can be defined externally */
+#  define XXH_FORCE_NATIVE_FORMAT 0
+#endif
+
+/*!XXH_FORCE_ALIGN_CHECK :
+ * This is a minor performance trick, only useful with lots of very small keys.
+ * It means : check for aligned/unaligned input.
+ * The check costs one initial branch per hash;
+ * set it to 0 when the input is guaranteed to be aligned,
+ * or when alignment doesn't matter for performance.
+ */
+#ifndef XXH_FORCE_ALIGN_CHECK /* can be defined externally */
+#  if defined(__i386) || defined(_M_IX86) || defined(__x86_64__) || defined(_M_X64)
+#    define XXH_FORCE_ALIGN_CHECK 0
+#  else
+#    define XXH_FORCE_ALIGN_CHECK 1
+#  endif
+#endif
+
+
+/* *************************************
+*  Includes & Memory related functions
+***************************************/
+/*! Modify the local functions below should you wish to use some other memory routines
+*   for malloc(), free() */
+#include 
+static void* XXH_malloc(size_t s) { return malloc(s); }
+static void  XXH_free  (void* p)  { free(p); }
+/*! and for memcpy() */
+#include 
+static void* XXH_memcpy(void* dest, const void* src, size_t size) { return memcpy(dest,src,size); }
+
+#include    /* assert */
+
+#define XXH_STATIC_LINKING_ONLY
+#include "xxhash.h"
+
+
+/* *************************************
+*  Compiler Specific Options
+***************************************/
+#ifdef _MSC_VER    /* Visual Studio */
+#  pragma warning(disable : 4127)      /* disable: C4127: conditional expression is constant */
+#  define FORCE_INLINE static __forceinline
+#else
+#  if defined (__cplusplus) || defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L   /* C99 */
+#    ifdef __GNUC__
+#      define FORCE_INLINE static inline __attribute__((always_inline))
+#    else
+#      define FORCE_INLINE static inline
+#    endif
+#  else
+#    define FORCE_INLINE static
+#  endif /* __STDC_VERSION__ */
+#endif
+
+
+/* *************************************
+*  Basic Types
+***************************************/
+#ifndef MEM_MODULE
+# if !defined (__VMS) \
+  && (defined (__cplusplus) \
+  || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) )
+#   include 
+    typedef uint8_t  BYTE;
+    typedef uint16_t U16;
+    typedef uint32_t U32;
+# else
+    typedef unsigned char      BYTE;
+    typedef unsigned short     U16;
+    typedef unsigned int       U32;
+# endif
+#endif
+
+#if (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==2))
+
+/* Force direct memory access. Only works on CPU which support unaligned memory access in hardware */
+static U32 XXH_read32(const void* memPtr) { return *(const U32*) memPtr; }
+
+#elif (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==1))
+
+/* __pack instructions are safer, but compiler specific, hence potentially problematic for some compilers */
+/* currently only defined for gcc and icc */
+typedef union { U32 u32; } __attribute__((packed)) unalign;
+static U32 XXH_read32(const void* ptr) { return ((const unalign*)ptr)->u32; }
+
+#else
+
+/* portable and safe solution. Generally efficient.
+ * see : http://stackoverflow.com/a/32095106/646947
+ */
+static U32 XXH_read32(const void* memPtr)
+{
+    U32 val;
+    memcpy(&val, memPtr, sizeof(val));
+    return val;
+}
+
+#endif   /* XXH_FORCE_DIRECT_MEMORY_ACCESS */
+
+
+/* ****************************************
+*  Compiler-specific Functions and Macros
+******************************************/
+#define XXH_GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__)
+
+/* Note : although _rotl exists for minGW (GCC under windows), performance seems poor */
+#if defined(_MSC_VER)
+#  define XXH_rotl32(x,r) _rotl(x,r)
+#  define XXH_rotl64(x,r) _rotl64(x,r)
+#else
+#  define XXH_rotl32(x,r) ((x << r) | (x >> (32 - r)))
+#  define XXH_rotl64(x,r) ((x << r) | (x >> (64 - r)))
+#endif
+
+#if defined(_MSC_VER)     /* Visual Studio */
+#  define XXH_swap32 _byteswap_ulong
+#elif XXH_GCC_VERSION >= 403
+#  define XXH_swap32 __builtin_bswap32
+#else
+static U32 XXH_swap32 (U32 x)
+{
+    return  ((x << 24) & 0xff000000 ) |
+            ((x <<  8) & 0x00ff0000 ) |
+            ((x >>  8) & 0x0000ff00 ) |
+            ((x >> 24) & 0x000000ff );
+}
+#endif
+
+
+/* *************************************
+*  Architecture Macros
+***************************************/
+typedef enum { XXH_bigEndian=0, XXH_littleEndian=1 } XXH_endianess;
+
+/* XXH_CPU_LITTLE_ENDIAN can be defined externally, for example on the compiler command line */
+#ifndef XXH_CPU_LITTLE_ENDIAN
+static int XXH_isLittleEndian(void)
+{
+    const union { U32 u; BYTE c[4]; } one = { 1 };   /* don't use static : performance detrimental  */
+    return one.c[0];
+}
+#   define XXH_CPU_LITTLE_ENDIAN   XXH_isLittleEndian()
+#endif
+
+
+/* ***************************
+*  Memory reads
+*****************************/
+typedef enum { XXH_aligned, XXH_unaligned } XXH_alignment;
+
+FORCE_INLINE U32 XXH_readLE32_align(const void* ptr, XXH_endianess endian, XXH_alignment align)
+{
+    if (align==XXH_unaligned)
+        return endian==XXH_littleEndian ? XXH_read32(ptr) : XXH_swap32(XXH_read32(ptr));
+    else
+        return endian==XXH_littleEndian ? *(const U32*)ptr : XXH_swap32(*(const U32*)ptr);
+}
+
+FORCE_INLINE U32 XXH_readLE32(const void* ptr, XXH_endianess endian)
+{
+    return XXH_readLE32_align(ptr, endian, XXH_unaligned);
+}
+
+static U32 XXH_readBE32(const void* ptr)
+{
+    return XXH_CPU_LITTLE_ENDIAN ? XXH_swap32(XXH_read32(ptr)) : XXH_read32(ptr);
+}
+
+
+/* *************************************
+*  Macros
+***************************************/
+#define XXH_STATIC_ASSERT(c)  { enum { XXH_sa = 1/(int)(!!(c)) }; }  /* use after variable declarations */
+XXH_PUBLIC_API unsigned XXH_versionNumber (void) { return XXH_VERSION_NUMBER; }
+
+
+/* *******************************************************************
+*  32-bit hash functions
+*********************************************************************/
+static const U32 PRIME32_1 = 2654435761U;
+static const U32 PRIME32_2 = 2246822519U;
+static const U32 PRIME32_3 = 3266489917U;
+static const U32 PRIME32_4 =  668265263U;
+static const U32 PRIME32_5 =  374761393U;
+
+static U32 XXH32_round(U32 seed, U32 input)
+{
+    seed += input * PRIME32_2;
+    seed  = XXH_rotl32(seed, 13);
+    seed *= PRIME32_1;
+    return seed;
+}
+
+/* mix all bits */
+static U32 XXH32_avalanche(U32 h32)
+{
+    h32 ^= h32 >> 15;
+    h32 *= PRIME32_2;
+    h32 ^= h32 >> 13;
+    h32 *= PRIME32_3;
+    h32 ^= h32 >> 16;
+    return(h32);
+}
+
+#define XXH_get32bits(p) XXH_readLE32_align(p, endian, align)
+
+static U32
+XXH32_finalize(U32 h32, const void* ptr, size_t len,
+                XXH_endianess endian, XXH_alignment align)
+
+{
+    const BYTE* p = (const BYTE*)ptr;
+
+#define PROCESS1               \
+    h32 += (*p++) * PRIME32_5; \
+    h32 = XXH_rotl32(h32, 11) * PRIME32_1 ;
+
+#define PROCESS4                         \
+    h32 += XXH_get32bits(p) * PRIME32_3; \
+    p+=4;                                \
+    h32  = XXH_rotl32(h32, 17) * PRIME32_4 ;
+
+    switch(len&15)  /* or switch(bEnd - p) */
+    {
+      case 12:      PROCESS4;
+                    /* fallthrough */
+      case 8:       PROCESS4;
+                    /* fallthrough */
+      case 4:       PROCESS4;
+                    return XXH32_avalanche(h32);
+
+      case 13:      PROCESS4;
+                    /* fallthrough */
+      case 9:       PROCESS4;
+                    /* fallthrough */
+      case 5:       PROCESS4;
+                    PROCESS1;
+                    return XXH32_avalanche(h32);
+
+      case 14:      PROCESS4;
+                    /* fallthrough */
+      case 10:      PROCESS4;
+                    /* fallthrough */
+      case 6:       PROCESS4;
+                    PROCESS1;
+                    PROCESS1;
+                    return XXH32_avalanche(h32);
+
+      case 15:      PROCESS4;
+                    /* fallthrough */
+      case 11:      PROCESS4;
+                    /* fallthrough */
+      case 7:       PROCESS4;
+                    /* fallthrough */
+      case 3:       PROCESS1;
+                    /* fallthrough */
+      case 2:       PROCESS1;
+                    /* fallthrough */
+      case 1:       PROCESS1;
+                    /* fallthrough */
+      case 0:       return XXH32_avalanche(h32);
+    }
+    assert(0);
+    return h32;   /* reaching this point is deemed impossible */
+}
+
+
+FORCE_INLINE U32
+XXH32_endian_align(const void* input, size_t len, U32 seed,
+                    XXH_endianess endian, XXH_alignment align)
+{
+    const BYTE* p = (const BYTE*)input;
+    const BYTE* bEnd = p + len;
+    U32 h32;
+
+#if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1)
+    if (p==NULL) {
+        len=0;
+        bEnd=p=(const BYTE*)(size_t)16;
+    }
+#endif
+
+    if (len>=16) {
+        const BYTE* const limit = bEnd - 15;
+        U32 v1 = seed + PRIME32_1 + PRIME32_2;
+        U32 v2 = seed + PRIME32_2;
+        U32 v3 = seed + 0;
+        U32 v4 = seed - PRIME32_1;
+
+        do {
+            v1 = XXH32_round(v1, XXH_get32bits(p)); p+=4;
+            v2 = XXH32_round(v2, XXH_get32bits(p)); p+=4;
+            v3 = XXH32_round(v3, XXH_get32bits(p)); p+=4;
+            v4 = XXH32_round(v4, XXH_get32bits(p)); p+=4;
+        } while (p < limit);
+
+        h32 = XXH_rotl32(v1, 1)  + XXH_rotl32(v2, 7)
+            + XXH_rotl32(v3, 12) + XXH_rotl32(v4, 18);
+    } else {
+        h32  = seed + PRIME32_5;
+    }
+
+    h32 += (U32)len;
+
+    return XXH32_finalize(h32, p, len&15, endian, align);
+}
+
+
+XXH_PUBLIC_API unsigned int XXH32 (const void* input, size_t len, unsigned int seed)
+{
+#if 0
+    /* Simple version, good for code maintenance, but unfortunately slow for small inputs */
+    XXH32_state_t state;
+    XXH32_reset(&state, seed);
+    XXH32_update(&state, input, len);
+    return XXH32_digest(&state);
+#else
+    XXH_endianess endian_detected = (XXH_endianess)XXH_CPU_LITTLE_ENDIAN;
+
+    if (XXH_FORCE_ALIGN_CHECK) {
+        if ((((size_t)input) & 3) == 0) {   /* Input is 4-bytes aligned, leverage the speed benefit */
+            if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+                return XXH32_endian_align(input, len, seed, XXH_littleEndian, XXH_aligned);
+            else
+                return XXH32_endian_align(input, len, seed, XXH_bigEndian, XXH_aligned);
+    }   }
+
+    if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+        return XXH32_endian_align(input, len, seed, XXH_littleEndian, XXH_unaligned);
+    else
+        return XXH32_endian_align(input, len, seed, XXH_bigEndian, XXH_unaligned);
+#endif
+}
+
+
+
+/*======   Hash streaming   ======*/
+
+XXH_PUBLIC_API XXH32_state_t* XXH32_createState(void)
+{
+    return (XXH32_state_t*)XXH_malloc(sizeof(XXH32_state_t));
+}
+XXH_PUBLIC_API XXH_errorcode XXH32_freeState(XXH32_state_t* statePtr)
+{
+    XXH_free(statePtr);
+    return XXH_OK;
+}
+
+XXH_PUBLIC_API void XXH32_copyState(XXH32_state_t* dstState, const XXH32_state_t* srcState)
+{
+    memcpy(dstState, srcState, sizeof(*dstState));
+}
+
+XXH_PUBLIC_API XXH_errorcode XXH32_reset(XXH32_state_t* statePtr, unsigned int seed)
+{
+    XXH32_state_t state;   /* using a local state to memcpy() in order to avoid strict-aliasing warnings */
+    memset(&state, 0, sizeof(state));
+    state.v1 = seed + PRIME32_1 + PRIME32_2;
+    state.v2 = seed + PRIME32_2;
+    state.v3 = seed + 0;
+    state.v4 = seed - PRIME32_1;
+    /* do not write into reserved, planned to be removed in a future version */
+    memcpy(statePtr, &state, sizeof(state) - sizeof(state.reserved));
+    return XXH_OK;
+}
+
+
+FORCE_INLINE XXH_errorcode
+XXH32_update_endian(XXH32_state_t* state, const void* input, size_t len, XXH_endianess endian)
+{
+    if (input==NULL)
+#if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1)
+        return XXH_OK;
+#else
+        return XXH_ERROR;
+#endif
+
+    {   const BYTE* p = (const BYTE*)input;
+        const BYTE* const bEnd = p + len;
+
+        state->total_len_32 += (unsigned)len;
+        state->large_len |= (len>=16) | (state->total_len_32>=16);
+
+        if (state->memsize + len < 16)  {   /* fill in tmp buffer */
+            XXH_memcpy((BYTE*)(state->mem32) + state->memsize, input, len);
+            state->memsize += (unsigned)len;
+            return XXH_OK;
+        }
+
+        if (state->memsize) {   /* some data left from previous update */
+            XXH_memcpy((BYTE*)(state->mem32) + state->memsize, input, 16-state->memsize);
+            {   const U32* p32 = state->mem32;
+                state->v1 = XXH32_round(state->v1, XXH_readLE32(p32, endian)); p32++;
+                state->v2 = XXH32_round(state->v2, XXH_readLE32(p32, endian)); p32++;
+                state->v3 = XXH32_round(state->v3, XXH_readLE32(p32, endian)); p32++;
+                state->v4 = XXH32_round(state->v4, XXH_readLE32(p32, endian));
+            }
+            p += 16-state->memsize;
+            state->memsize = 0;
+        }
+
+        if (p <= bEnd-16) {
+            const BYTE* const limit = bEnd - 16;
+            U32 v1 = state->v1;
+            U32 v2 = state->v2;
+            U32 v3 = state->v3;
+            U32 v4 = state->v4;
+
+            do {
+                v1 = XXH32_round(v1, XXH_readLE32(p, endian)); p+=4;
+                v2 = XXH32_round(v2, XXH_readLE32(p, endian)); p+=4;
+                v3 = XXH32_round(v3, XXH_readLE32(p, endian)); p+=4;
+                v4 = XXH32_round(v4, XXH_readLE32(p, endian)); p+=4;
+            } while (p<=limit);
+
+            state->v1 = v1;
+            state->v2 = v2;
+            state->v3 = v3;
+            state->v4 = v4;
+        }
+
+        if (p < bEnd) {
+            XXH_memcpy(state->mem32, p, (size_t)(bEnd-p));
+            state->memsize = (unsigned)(bEnd-p);
+        }
+    }
+
+    return XXH_OK;
+}
+
+
+XXH_PUBLIC_API XXH_errorcode XXH32_update (XXH32_state_t* state_in, const void* input, size_t len)
+{
+    XXH_endianess endian_detected = (XXH_endianess)XXH_CPU_LITTLE_ENDIAN;
+
+    if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+        return XXH32_update_endian(state_in, input, len, XXH_littleEndian);
+    else
+        return XXH32_update_endian(state_in, input, len, XXH_bigEndian);
+}
+
+
+FORCE_INLINE U32
+XXH32_digest_endian (const XXH32_state_t* state, XXH_endianess endian)
+{
+    U32 h32;
+
+    if (state->large_len) {
+        h32 = XXH_rotl32(state->v1, 1)
+            + XXH_rotl32(state->v2, 7)
+            + XXH_rotl32(state->v3, 12)
+            + XXH_rotl32(state->v4, 18);
+    } else {
+        h32 = state->v3 /* == seed */ + PRIME32_5;
+    }
+
+    h32 += state->total_len_32;
+
+    return XXH32_finalize(h32, state->mem32, state->memsize, endian, XXH_aligned);
+}
+
+
+XXH_PUBLIC_API unsigned int XXH32_digest (const XXH32_state_t* state_in)
+{
+    XXH_endianess endian_detected = (XXH_endianess)XXH_CPU_LITTLE_ENDIAN;
+
+    if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+        return XXH32_digest_endian(state_in, XXH_littleEndian);
+    else
+        return XXH32_digest_endian(state_in, XXH_bigEndian);
+}
+
+
+/*======   Canonical representation   ======*/
+
+/*! Default XXH result types are basic unsigned 32 and 64 bits.
+*   The canonical representation follows human-readable write convention, aka big-endian (large digits first).
+*   These functions allow transformation of hash result into and from its canonical format.
+*   This way, hash values can be written into a file or buffer, remaining comparable across different systems.
+*/
+
+XXH_PUBLIC_API void XXH32_canonicalFromHash(XXH32_canonical_t* dst, XXH32_hash_t hash)
+{
+    XXH_STATIC_ASSERT(sizeof(XXH32_canonical_t) == sizeof(XXH32_hash_t));
+    if (XXH_CPU_LITTLE_ENDIAN) hash = XXH_swap32(hash);
+    memcpy(dst, &hash, sizeof(*dst));
+}
+
+XXH_PUBLIC_API XXH32_hash_t XXH32_hashFromCanonical(const XXH32_canonical_t* src)
+{
+    return XXH_readBE32(src);
+}
+
+
+#ifndef XXH_NO_LONG_LONG
+
+/* *******************************************************************
+*  64-bit hash functions
+*********************************************************************/
+
+/*======   Memory access   ======*/
+
+#ifndef MEM_MODULE
+# define MEM_MODULE
+# if !defined (__VMS) \
+  && (defined (__cplusplus) \
+  || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) )
+#   include 
+    typedef uint64_t U64;
+# else
+    /* if compiler doesn't support unsigned long long, replace by another 64-bit type */
+    typedef unsigned long long U64;
+# endif
+#endif
+
+
+#if (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==2))
+
+/* Force direct memory access. Only works on CPU which support unaligned memory access in hardware */
+static U64 XXH_read64(const void* memPtr) { return *(const U64*) memPtr; }
+
+#elif (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==1))
+
+/* __pack instructions are safer, but compiler specific, hence potentially problematic for some compilers */
+/* currently only defined for gcc and icc */
+typedef union { U32 u32; U64 u64; } __attribute__((packed)) unalign64;
+static U64 XXH_read64(const void* ptr) { return ((const unalign64*)ptr)->u64; }
+
+#else
+
+/* portable and safe solution. Generally efficient.
+ * see : http://stackoverflow.com/a/32095106/646947
+ */
+
+static U64 XXH_read64(const void* memPtr)
+{
+    U64 val;
+    memcpy(&val, memPtr, sizeof(val));
+    return val;
+}
+
+#endif   /* XXH_FORCE_DIRECT_MEMORY_ACCESS */
+
+#if defined(_MSC_VER)     /* Visual Studio */
+#  define XXH_swap64 _byteswap_uint64
+#elif XXH_GCC_VERSION >= 403
+#  define XXH_swap64 __builtin_bswap64
+#else
+static U64 XXH_swap64 (U64 x)
+{
+    return  ((x << 56) & 0xff00000000000000ULL) |
+            ((x << 40) & 0x00ff000000000000ULL) |
+            ((x << 24) & 0x0000ff0000000000ULL) |
+            ((x << 8)  & 0x000000ff00000000ULL) |
+            ((x >> 8)  & 0x00000000ff000000ULL) |
+            ((x >> 24) & 0x0000000000ff0000ULL) |
+            ((x >> 40) & 0x000000000000ff00ULL) |
+            ((x >> 56) & 0x00000000000000ffULL);
+}
+#endif
+
+FORCE_INLINE U64 XXH_readLE64_align(const void* ptr, XXH_endianess endian, XXH_alignment align)
+{
+    if (align==XXH_unaligned)
+        return endian==XXH_littleEndian ? XXH_read64(ptr) : XXH_swap64(XXH_read64(ptr));
+    else
+        return endian==XXH_littleEndian ? *(const U64*)ptr : XXH_swap64(*(const U64*)ptr);
+}
+
+FORCE_INLINE U64 XXH_readLE64(const void* ptr, XXH_endianess endian)
+{
+    return XXH_readLE64_align(ptr, endian, XXH_unaligned);
+}
+
+static U64 XXH_readBE64(const void* ptr)
+{
+    return XXH_CPU_LITTLE_ENDIAN ? XXH_swap64(XXH_read64(ptr)) : XXH_read64(ptr);
+}
+
+
+/*======   xxh64   ======*/
+
+static const U64 PRIME64_1 = 11400714785074694791ULL;
+static const U64 PRIME64_2 = 14029467366897019727ULL;
+static const U64 PRIME64_3 =  1609587929392839161ULL;
+static const U64 PRIME64_4 =  9650029242287828579ULL;
+static const U64 PRIME64_5 =  2870177450012600261ULL;
+
+static U64 XXH64_round(U64 acc, U64 input)
+{
+    acc += input * PRIME64_2;
+    acc  = XXH_rotl64(acc, 31);
+    acc *= PRIME64_1;
+    return acc;
+}
+
+static U64 XXH64_mergeRound(U64 acc, U64 val)
+{
+    val  = XXH64_round(0, val);
+    acc ^= val;
+    acc  = acc * PRIME64_1 + PRIME64_4;
+    return acc;
+}
+
+static U64 XXH64_avalanche(U64 h64)
+{
+    h64 ^= h64 >> 33;
+    h64 *= PRIME64_2;
+    h64 ^= h64 >> 29;
+    h64 *= PRIME64_3;
+    h64 ^= h64 >> 32;
+    return h64;
+}
+
+
+#define XXH_get64bits(p) XXH_readLE64_align(p, endian, align)
+
+static U64
+XXH64_finalize(U64 h64, const void* ptr, size_t len,
+               XXH_endianess endian, XXH_alignment align)
+{
+    const BYTE* p = (const BYTE*)ptr;
+
+#define PROCESS1_64            \
+    h64 ^= (*p++) * PRIME64_5; \
+    h64 = XXH_rotl64(h64, 11) * PRIME64_1;
+
+#define PROCESS4_64          \
+    h64 ^= (U64)(XXH_get32bits(p)) * PRIME64_1; \
+    p+=4;                    \
+    h64 = XXH_rotl64(h64, 23) * PRIME64_2 + PRIME64_3;
+
+#define PROCESS8_64 {        \
+    U64 const k1 = XXH64_round(0, XXH_get64bits(p)); \
+    p+=8;                    \
+    h64 ^= k1;               \
+    h64  = XXH_rotl64(h64,27) * PRIME64_1 + PRIME64_4; \
+}
+
+    switch(len&31) {
+      case 24: PROCESS8_64;
+                    /* fallthrough */
+      case 16: PROCESS8_64;
+                    /* fallthrough */
+      case  8: PROCESS8_64;
+               return XXH64_avalanche(h64);
+
+      case 28: PROCESS8_64;
+                    /* fallthrough */
+      case 20: PROCESS8_64;
+                    /* fallthrough */
+      case 12: PROCESS8_64;
+                    /* fallthrough */
+      case  4: PROCESS4_64;
+               return XXH64_avalanche(h64);
+
+      case 25: PROCESS8_64;
+                    /* fallthrough */
+      case 17: PROCESS8_64;
+                    /* fallthrough */
+      case  9: PROCESS8_64;
+               PROCESS1_64;
+               return XXH64_avalanche(h64);
+
+      case 29: PROCESS8_64;
+                    /* fallthrough */
+      case 21: PROCESS8_64;
+                    /* fallthrough */
+      case 13: PROCESS8_64;
+                    /* fallthrough */
+      case  5: PROCESS4_64;
+               PROCESS1_64;
+               return XXH64_avalanche(h64);
+
+      case 26: PROCESS8_64;
+                    /* fallthrough */
+      case 18: PROCESS8_64;
+                    /* fallthrough */
+      case 10: PROCESS8_64;
+               PROCESS1_64;
+               PROCESS1_64;
+               return XXH64_avalanche(h64);
+
+      case 30: PROCESS8_64;
+                    /* fallthrough */
+      case 22: PROCESS8_64;
+                    /* fallthrough */
+      case 14: PROCESS8_64;
+                    /* fallthrough */
+      case  6: PROCESS4_64;
+               PROCESS1_64;
+               PROCESS1_64;
+               return XXH64_avalanche(h64);
+
+      case 27: PROCESS8_64;
+                    /* fallthrough */
+      case 19: PROCESS8_64;
+                    /* fallthrough */
+      case 11: PROCESS8_64;
+               PROCESS1_64;
+               PROCESS1_64;
+               PROCESS1_64;
+               return XXH64_avalanche(h64);
+
+      case 31: PROCESS8_64;
+                    /* fallthrough */
+      case 23: PROCESS8_64;
+                    /* fallthrough */
+      case 15: PROCESS8_64;
+                    /* fallthrough */
+      case  7: PROCESS4_64;
+                    /* fallthrough */
+      case  3: PROCESS1_64;
+                    /* fallthrough */
+      case  2: PROCESS1_64;
+                    /* fallthrough */
+      case  1: PROCESS1_64;
+                    /* fallthrough */
+      case  0: return XXH64_avalanche(h64);
+    }
+
+    /* impossible to reach */
+    assert(0);
+    return 0;  /* unreachable, but some compilers complain without it */
+}
+
+FORCE_INLINE U64
+XXH64_endian_align(const void* input, size_t len, U64 seed,
+                XXH_endianess endian, XXH_alignment align)
+{
+    const BYTE* p = (const BYTE*)input;
+    const BYTE* bEnd = p + len;
+    U64 h64;
+
+#if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1)
+    if (p==NULL) {
+        len=0;
+        bEnd=p=(const BYTE*)(size_t)32;
+    }
+#endif
+
+    if (len>=32) {
+        const BYTE* const limit = bEnd - 32;
+        U64 v1 = seed + PRIME64_1 + PRIME64_2;
+        U64 v2 = seed + PRIME64_2;
+        U64 v3 = seed + 0;
+        U64 v4 = seed - PRIME64_1;
+
+        do {
+            v1 = XXH64_round(v1, XXH_get64bits(p)); p+=8;
+            v2 = XXH64_round(v2, XXH_get64bits(p)); p+=8;
+            v3 = XXH64_round(v3, XXH_get64bits(p)); p+=8;
+            v4 = XXH64_round(v4, XXH_get64bits(p)); p+=8;
+        } while (p<=limit);
+
+        h64 = XXH_rotl64(v1, 1) + XXH_rotl64(v2, 7) + XXH_rotl64(v3, 12) + XXH_rotl64(v4, 18);
+        h64 = XXH64_mergeRound(h64, v1);
+        h64 = XXH64_mergeRound(h64, v2);
+        h64 = XXH64_mergeRound(h64, v3);
+        h64 = XXH64_mergeRound(h64, v4);
+
+    } else {
+        h64  = seed + PRIME64_5;
+    }
+
+    h64 += (U64) len;
+
+    return XXH64_finalize(h64, p, len, endian, align);
+}
+
+
+XXH_PUBLIC_API unsigned long long XXH64 (const void* input, size_t len, unsigned long long seed)
+{
+#if 0
+    /* Simple version, good for code maintenance, but unfortunately slow for small inputs */
+    XXH64_state_t state;
+    XXH64_reset(&state, seed);
+    XXH64_update(&state, input, len);
+    return XXH64_digest(&state);
+#else
+    XXH_endianess endian_detected = (XXH_endianess)XXH_CPU_LITTLE_ENDIAN;
+
+    if (XXH_FORCE_ALIGN_CHECK) {
+        if ((((size_t)input) & 7)==0) {  /* Input is aligned, let's leverage the speed advantage */
+            if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+                return XXH64_endian_align(input, len, seed, XXH_littleEndian, XXH_aligned);
+            else
+                return XXH64_endian_align(input, len, seed, XXH_bigEndian, XXH_aligned);
+    }   }
+
+    if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+        return XXH64_endian_align(input, len, seed, XXH_littleEndian, XXH_unaligned);
+    else
+        return XXH64_endian_align(input, len, seed, XXH_bigEndian, XXH_unaligned);
+#endif
+}
+
+/*======   Hash Streaming   ======*/
+
+XXH_PUBLIC_API XXH64_state_t* XXH64_createState(void)
+{
+    return (XXH64_state_t*)XXH_malloc(sizeof(XXH64_state_t));
+}
+XXH_PUBLIC_API XXH_errorcode XXH64_freeState(XXH64_state_t* statePtr)
+{
+    XXH_free(statePtr);
+    return XXH_OK;
+}
+
+XXH_PUBLIC_API void XXH64_copyState(XXH64_state_t* dstState, const XXH64_state_t* srcState)
+{
+    memcpy(dstState, srcState, sizeof(*dstState));
+}
+
+XXH_PUBLIC_API XXH_errorcode XXH64_reset(XXH64_state_t* statePtr, unsigned long long seed)
+{
+    XXH64_state_t state;   /* using a local state to memcpy() in order to avoid strict-aliasing warnings */
+    memset(&state, 0, sizeof(state));
+    state.v1 = seed + PRIME64_1 + PRIME64_2;
+    state.v2 = seed + PRIME64_2;
+    state.v3 = seed + 0;
+    state.v4 = seed - PRIME64_1;
+     /* do not write into reserved, planned to be removed in a future version */
+    memcpy(statePtr, &state, sizeof(state) - sizeof(state.reserved));
+    return XXH_OK;
+}
+
+FORCE_INLINE XXH_errorcode
+XXH64_update_endian (XXH64_state_t* state, const void* input, size_t len, XXH_endianess endian)
+{
+    if (input==NULL)
+#if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1)
+        return XXH_OK;
+#else
+        return XXH_ERROR;
+#endif
+
+    {   const BYTE* p = (const BYTE*)input;
+        const BYTE* const bEnd = p + len;
+
+        state->total_len += len;
+
+        if (state->memsize + len < 32) {  /* fill in tmp buffer */
+            XXH_memcpy(((BYTE*)state->mem64) + state->memsize, input, len);
+            state->memsize += (U32)len;
+            return XXH_OK;
+        }
+
+        if (state->memsize) {   /* tmp buffer is full */
+            XXH_memcpy(((BYTE*)state->mem64) + state->memsize, input, 32-state->memsize);
+            state->v1 = XXH64_round(state->v1, XXH_readLE64(state->mem64+0, endian));
+            state->v2 = XXH64_round(state->v2, XXH_readLE64(state->mem64+1, endian));
+            state->v3 = XXH64_round(state->v3, XXH_readLE64(state->mem64+2, endian));
+            state->v4 = XXH64_round(state->v4, XXH_readLE64(state->mem64+3, endian));
+            p += 32-state->memsize;
+            state->memsize = 0;
+        }
+
+        if (p+32 <= bEnd) {
+            const BYTE* const limit = bEnd - 32;
+            U64 v1 = state->v1;
+            U64 v2 = state->v2;
+            U64 v3 = state->v3;
+            U64 v4 = state->v4;
+
+            do {
+                v1 = XXH64_round(v1, XXH_readLE64(p, endian)); p+=8;
+                v2 = XXH64_round(v2, XXH_readLE64(p, endian)); p+=8;
+                v3 = XXH64_round(v3, XXH_readLE64(p, endian)); p+=8;
+                v4 = XXH64_round(v4, XXH_readLE64(p, endian)); p+=8;
+            } while (p<=limit);
+
+            state->v1 = v1;
+            state->v2 = v2;
+            state->v3 = v3;
+            state->v4 = v4;
+        }
+
+        if (p < bEnd) {
+            XXH_memcpy(state->mem64, p, (size_t)(bEnd-p));
+            state->memsize = (unsigned)(bEnd-p);
+        }
+    }
+
+    return XXH_OK;
+}
+
+XXH_PUBLIC_API XXH_errorcode XXH64_update (XXH64_state_t* state_in, const void* input, size_t len)
+{
+    XXH_endianess endian_detected = (XXH_endianess)XXH_CPU_LITTLE_ENDIAN;
+
+    if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+        return XXH64_update_endian(state_in, input, len, XXH_littleEndian);
+    else
+        return XXH64_update_endian(state_in, input, len, XXH_bigEndian);
+}
+
+FORCE_INLINE U64 XXH64_digest_endian (const XXH64_state_t* state, XXH_endianess endian)
+{
+    U64 h64;
+
+    if (state->total_len >= 32) {
+        U64 const v1 = state->v1;
+        U64 const v2 = state->v2;
+        U64 const v3 = state->v3;
+        U64 const v4 = state->v4;
+
+        h64 = XXH_rotl64(v1, 1) + XXH_rotl64(v2, 7) + XXH_rotl64(v3, 12) + XXH_rotl64(v4, 18);
+        h64 = XXH64_mergeRound(h64, v1);
+        h64 = XXH64_mergeRound(h64, v2);
+        h64 = XXH64_mergeRound(h64, v3);
+        h64 = XXH64_mergeRound(h64, v4);
+    } else {
+        h64  = state->v3 /*seed*/ + PRIME64_5;
+    }
+
+    h64 += (U64) state->total_len;
+
+    return XXH64_finalize(h64, state->mem64, (size_t)state->total_len, endian, XXH_aligned);
+}
+
+XXH_PUBLIC_API unsigned long long XXH64_digest (const XXH64_state_t* state_in)
+{
+    XXH_endianess endian_detected = (XXH_endianess)XXH_CPU_LITTLE_ENDIAN;
+
+    if ((endian_detected==XXH_littleEndian) || XXH_FORCE_NATIVE_FORMAT)
+        return XXH64_digest_endian(state_in, XXH_littleEndian);
+    else
+        return XXH64_digest_endian(state_in, XXH_bigEndian);
+}
+
+
+/*====== Canonical representation   ======*/
+
+XXH_PUBLIC_API void XXH64_canonicalFromHash(XXH64_canonical_t* dst, XXH64_hash_t hash)
+{
+    XXH_STATIC_ASSERT(sizeof(XXH64_canonical_t) == sizeof(XXH64_hash_t));
+    if (XXH_CPU_LITTLE_ENDIAN) hash = XXH_swap64(hash);
+    memcpy(dst, &hash, sizeof(*dst));
+}
+
+XXH_PUBLIC_API XXH64_hash_t XXH64_hashFromCanonical(const XXH64_canonical_t* src)
+{
+    return XXH_readBE64(src);
+}
+
+#endif  /* XXH_NO_LONG_LONG */
diff --git a/lz4/lib/xxhash.h b/lz4/lib/xxhash.h
new file mode 100644
index 0000000..d6bad94
--- /dev/null
+++ b/lz4/lib/xxhash.h
@@ -0,0 +1,328 @@
+/*
+   xxHash - Extremely Fast Hash algorithm
+   Header File
+   Copyright (C) 2012-2016, Yann Collet.
+
+   BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php)
+
+   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.
+
+   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.
+
+   You can contact the author at :
+   - xxHash source repository : https://github.com/Cyan4973/xxHash
+*/
+
+/* Notice extracted from xxHash homepage :
+
+xxHash is an extremely fast Hash algorithm, running at RAM speed limits.
+It also successfully passes all tests from the SMHasher suite.
+
+Comparison (single thread, Windows Seven 32 bits, using SMHasher on a Core 2 Duo @3GHz)
+
+Name            Speed       Q.Score   Author
+xxHash          5.4 GB/s     10
+CrapWow         3.2 GB/s      2       Andrew
+MumurHash 3a    2.7 GB/s     10       Austin Appleby
+SpookyHash      2.0 GB/s     10       Bob Jenkins
+SBox            1.4 GB/s      9       Bret Mulvey
+Lookup3         1.2 GB/s      9       Bob Jenkins
+SuperFastHash   1.2 GB/s      1       Paul Hsieh
+CityHash64      1.05 GB/s    10       Pike & Alakuijala
+FNV             0.55 GB/s     5       Fowler, Noll, Vo
+CRC32           0.43 GB/s     9
+MD5-32          0.33 GB/s    10       Ronald L. Rivest
+SHA1-32         0.28 GB/s    10
+
+Q.Score is a measure of quality of the hash function.
+It depends on successfully passing SMHasher test set.
+10 is a perfect score.
+
+A 64-bit version, named XXH64, is available since r35.
+It offers much better speed, but for 64-bit applications only.
+Name     Speed on 64 bits    Speed on 32 bits
+XXH64       13.8 GB/s            1.9 GB/s
+XXH32        6.8 GB/s            6.0 GB/s
+*/
+
+#ifndef XXHASH_H_5627135585666179
+#define XXHASH_H_5627135585666179 1
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+
+/* ****************************
+*  Definitions
+******************************/
+#include    /* size_t */
+typedef enum { XXH_OK=0, XXH_ERROR } XXH_errorcode;
+
+
+/* ****************************
+ *  API modifier
+ ******************************/
+/** XXH_INLINE_ALL (and XXH_PRIVATE_API)
+ *  This is useful to include xxhash functions in `static` mode
+ *  in order to inline them, and remove their symbol from the public list.
+ *  Inlining can offer dramatic performance improvement on small keys.
+ *  Methodology :
+ *     #define XXH_INLINE_ALL
+ *     #include "xxhash.h"
+ * `xxhash.c` is automatically included.
+ *  It's not useful to compile and link it as a separate module.
+ */
+#if defined(XXH_INLINE_ALL) || defined(XXH_PRIVATE_API)
+#  ifndef XXH_STATIC_LINKING_ONLY
+#    define XXH_STATIC_LINKING_ONLY
+#  endif
+#  if defined(__GNUC__)
+#    define XXH_PUBLIC_API static __inline __attribute__((unused))
+#  elif defined (__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */)
+#    define XXH_PUBLIC_API static inline
+#  elif defined(_MSC_VER)
+#    define XXH_PUBLIC_API static __inline
+#  else
+     /* this version may generate warnings for unused static functions */
+#    define XXH_PUBLIC_API static
+#  endif
+#else
+#  define XXH_PUBLIC_API   /* do nothing */
+#endif /* XXH_INLINE_ALL || XXH_PRIVATE_API */
+
+/*! XXH_NAMESPACE, aka Namespace Emulation :
+ *
+ * If you want to include _and expose_ xxHash functions from within your own library,
+ * but also want to avoid symbol collisions with other libraries which may also include xxHash,
+ *
+ * you can use XXH_NAMESPACE, to automatically prefix any public symbol from xxhash library
+ * with the value of XXH_NAMESPACE (therefore, avoid NULL and numeric values).
+ *
+ * Note that no change is required within the calling program as long as it includes `xxhash.h` :
+ * regular symbol name will be automatically translated by this header.
+ */
+#ifdef XXH_NAMESPACE
+#  define XXH_CAT(A,B) A##B
+#  define XXH_NAME2(A,B) XXH_CAT(A,B)
+#  define XXH_versionNumber XXH_NAME2(XXH_NAMESPACE, XXH_versionNumber)
+#  define XXH32 XXH_NAME2(XXH_NAMESPACE, XXH32)
+#  define XXH32_createState XXH_NAME2(XXH_NAMESPACE, XXH32_createState)
+#  define XXH32_freeState XXH_NAME2(XXH_NAMESPACE, XXH32_freeState)
+#  define XXH32_reset XXH_NAME2(XXH_NAMESPACE, XXH32_reset)
+#  define XXH32_update XXH_NAME2(XXH_NAMESPACE, XXH32_update)
+#  define XXH32_digest XXH_NAME2(XXH_NAMESPACE, XXH32_digest)
+#  define XXH32_copyState XXH_NAME2(XXH_NAMESPACE, XXH32_copyState)
+#  define XXH32_canonicalFromHash XXH_NAME2(XXH_NAMESPACE, XXH32_canonicalFromHash)
+#  define XXH32_hashFromCanonical XXH_NAME2(XXH_NAMESPACE, XXH32_hashFromCanonical)
+#  define XXH64 XXH_NAME2(XXH_NAMESPACE, XXH64)
+#  define XXH64_createState XXH_NAME2(XXH_NAMESPACE, XXH64_createState)
+#  define XXH64_freeState XXH_NAME2(XXH_NAMESPACE, XXH64_freeState)
+#  define XXH64_reset XXH_NAME2(XXH_NAMESPACE, XXH64_reset)
+#  define XXH64_update XXH_NAME2(XXH_NAMESPACE, XXH64_update)
+#  define XXH64_digest XXH_NAME2(XXH_NAMESPACE, XXH64_digest)
+#  define XXH64_copyState XXH_NAME2(XXH_NAMESPACE, XXH64_copyState)
+#  define XXH64_canonicalFromHash XXH_NAME2(XXH_NAMESPACE, XXH64_canonicalFromHash)
+#  define XXH64_hashFromCanonical XXH_NAME2(XXH_NAMESPACE, XXH64_hashFromCanonical)
+#endif
+
+
+/* *************************************
+*  Version
+***************************************/
+#define XXH_VERSION_MAJOR    0
+#define XXH_VERSION_MINOR    6
+#define XXH_VERSION_RELEASE  5
+#define XXH_VERSION_NUMBER  (XXH_VERSION_MAJOR *100*100 + XXH_VERSION_MINOR *100 + XXH_VERSION_RELEASE)
+XXH_PUBLIC_API unsigned XXH_versionNumber (void);
+
+
+/*-**********************************************************************
+*  32-bit hash
+************************************************************************/
+typedef unsigned int XXH32_hash_t;
+
+/*! XXH32() :
+    Calculate the 32-bit hash of sequence "length" bytes stored at memory address "input".
+    The memory between input & input+length must be valid (allocated and read-accessible).
+    "seed" can be used to alter the result predictably.
+    Speed on Core 2 Duo @ 3 GHz (single thread, SMHasher benchmark) : 5.4 GB/s */
+XXH_PUBLIC_API XXH32_hash_t XXH32 (const void* input, size_t length, unsigned int seed);
+
+/*======   Streaming   ======*/
+typedef struct XXH32_state_s XXH32_state_t;   /* incomplete type */
+XXH_PUBLIC_API XXH32_state_t* XXH32_createState(void);
+XXH_PUBLIC_API XXH_errorcode  XXH32_freeState(XXH32_state_t* statePtr);
+XXH_PUBLIC_API void XXH32_copyState(XXH32_state_t* dst_state, const XXH32_state_t* src_state);
+
+XXH_PUBLIC_API XXH_errorcode XXH32_reset  (XXH32_state_t* statePtr, unsigned int seed);
+XXH_PUBLIC_API XXH_errorcode XXH32_update (XXH32_state_t* statePtr, const void* input, size_t length);
+XXH_PUBLIC_API XXH32_hash_t  XXH32_digest (const XXH32_state_t* statePtr);
+
+/*
+ * Streaming functions generate the xxHash of an input provided in multiple segments.
+ * Note that, for small input, they are slower than single-call functions, due to state management.
+ * For small inputs, prefer `XXH32()` and `XXH64()`, which are better optimized.
+ *
+ * XXH state must first be allocated, using XXH*_createState() .
+ *
+ * Start a new hash by initializing state with a seed, using XXH*_reset().
+ *
+ * Then, feed the hash state by calling XXH*_update() as many times as necessary.
+ * The function returns an error code, with 0 meaning OK, and any other value meaning there is an error.
+ *
+ * Finally, a hash value can be produced anytime, by using XXH*_digest().
+ * This function returns the nn-bits hash as an int or long long.
+ *
+ * It's still possible to continue inserting input into the hash state after a digest,
+ * and generate some new hashes later on, by calling again XXH*_digest().
+ *
+ * When done, free XXH state space if it was allocated dynamically.
+ */
+
+/*======   Canonical representation   ======*/
+
+typedef struct { unsigned char digest[4]; } XXH32_canonical_t;
+XXH_PUBLIC_API void XXH32_canonicalFromHash(XXH32_canonical_t* dst, XXH32_hash_t hash);
+XXH_PUBLIC_API XXH32_hash_t XXH32_hashFromCanonical(const XXH32_canonical_t* src);
+
+/* Default result type for XXH functions are primitive unsigned 32 and 64 bits.
+ * The canonical representation uses human-readable write convention, aka big-endian (large digits first).
+ * These functions allow transformation of hash result into and from its canonical format.
+ * This way, hash values can be written into a file / memory, and remain comparable on different systems and programs.
+ */
+
+
+#ifndef XXH_NO_LONG_LONG
+/*-**********************************************************************
+*  64-bit hash
+************************************************************************/
+typedef unsigned long long XXH64_hash_t;
+
+/*! XXH64() :
+    Calculate the 64-bit hash of sequence of length "len" stored at memory address "input".
+    "seed" can be used to alter the result predictably.
+    This function runs faster on 64-bit systems, but slower on 32-bit systems (see benchmark).
+*/
+XXH_PUBLIC_API XXH64_hash_t XXH64 (const void* input, size_t length, unsigned long long seed);
+
+/*======   Streaming   ======*/
+typedef struct XXH64_state_s XXH64_state_t;   /* incomplete type */
+XXH_PUBLIC_API XXH64_state_t* XXH64_createState(void);
+XXH_PUBLIC_API XXH_errorcode  XXH64_freeState(XXH64_state_t* statePtr);
+XXH_PUBLIC_API void XXH64_copyState(XXH64_state_t* dst_state, const XXH64_state_t* src_state);
+
+XXH_PUBLIC_API XXH_errorcode XXH64_reset  (XXH64_state_t* statePtr, unsigned long long seed);
+XXH_PUBLIC_API XXH_errorcode XXH64_update (XXH64_state_t* statePtr, const void* input, size_t length);
+XXH_PUBLIC_API XXH64_hash_t  XXH64_digest (const XXH64_state_t* statePtr);
+
+/*======   Canonical representation   ======*/
+typedef struct { unsigned char digest[8]; } XXH64_canonical_t;
+XXH_PUBLIC_API void XXH64_canonicalFromHash(XXH64_canonical_t* dst, XXH64_hash_t hash);
+XXH_PUBLIC_API XXH64_hash_t XXH64_hashFromCanonical(const XXH64_canonical_t* src);
+#endif  /* XXH_NO_LONG_LONG */
+
+
+
+#ifdef XXH_STATIC_LINKING_ONLY
+
+/* ================================================================================================
+   This section contains declarations which are not guaranteed to remain stable.
+   They may change in future versions, becoming incompatible with a different version of the library.
+   These declarations should only be used with static linking.
+   Never use them in association with dynamic linking !
+=================================================================================================== */
+
+/* These definitions are only present to allow
+ * static allocation of XXH state, on stack or in a struct for example.
+ * Never **ever** use members directly. */
+
+#if !defined (__VMS) \
+  && (defined (__cplusplus) \
+  || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) )
+#   include 
+
+struct XXH32_state_s {
+   uint32_t total_len_32;
+   uint32_t large_len;
+   uint32_t v1;
+   uint32_t v2;
+   uint32_t v3;
+   uint32_t v4;
+   uint32_t mem32[4];
+   uint32_t memsize;
+   uint32_t reserved;   /* never read nor write, might be removed in a future version */
+};   /* typedef'd to XXH32_state_t */
+
+struct XXH64_state_s {
+   uint64_t total_len;
+   uint64_t v1;
+   uint64_t v2;
+   uint64_t v3;
+   uint64_t v4;
+   uint64_t mem64[4];
+   uint32_t memsize;
+   uint32_t reserved[2];          /* never read nor write, might be removed in a future version */
+};   /* typedef'd to XXH64_state_t */
+
+# else
+
+struct XXH32_state_s {
+   unsigned total_len_32;
+   unsigned large_len;
+   unsigned v1;
+   unsigned v2;
+   unsigned v3;
+   unsigned v4;
+   unsigned mem32[4];
+   unsigned memsize;
+   unsigned reserved;   /* never read nor write, might be removed in a future version */
+};   /* typedef'd to XXH32_state_t */
+
+#   ifndef XXH_NO_LONG_LONG  /* remove 64-bit support */
+struct XXH64_state_s {
+   unsigned long long total_len;
+   unsigned long long v1;
+   unsigned long long v2;
+   unsigned long long v3;
+   unsigned long long v4;
+   unsigned long long mem64[4];
+   unsigned memsize;
+   unsigned reserved[2];     /* never read nor write, might be removed in a future version */
+};   /* typedef'd to XXH64_state_t */
+#    endif
+
+# endif
+
+
+#if defined(XXH_INLINE_ALL) || defined(XXH_PRIVATE_API)
+#  include "xxhash.c"   /* include xxhash function bodies as `static`, for inlining */
+#endif
+
+#endif /* XXH_STATIC_LINKING_ONLY */
+
+
+#if defined (__cplusplus)
+}
+#endif
+
+#endif /* XXHASH_H_5627135585666179 */
diff --git a/lz4/ossfuzz/Makefile b/lz4/ossfuzz/Makefile
new file mode 100644
index 0000000..2ec1675
--- /dev/null
+++ b/lz4/ossfuzz/Makefile
@@ -0,0 +1,78 @@
+# ##########################################################################
+# LZ4 oss fuzzer - Makefile
+#
+# GPL v2 License
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# You can contact the author at :
+#  - LZ4 homepage : http://www.lz4.org
+#  - LZ4 source repository : https://github.com/lz4/lz4
+# ##########################################################################
+# compress_fuzzer : OSS Fuzz test tool
+# decompress_fuzzer : OSS Fuzz test tool
+# ##########################################################################
+
+LZ4DIR  := ../lib
+LIB_FUZZING_ENGINE ?=
+
+DEBUGLEVEL?= 1
+DEBUGFLAGS = -g -DLZ4_DEBUG=$(DEBUGLEVEL)
+
+LZ4_CFLAGS  = $(CFLAGS) $(DEBUGFLAGS) $(MOREFLAGS)
+LZ4_CXXFLAGS = $(CXXFLAGS) $(DEBUGFLAGS) $(MOREFLAGS)
+LZ4_CPPFLAGS = $(CPPFLAGS) -I$(LZ4DIR) -DXXH_NAMESPACE=LZ4_ \
+               -DFUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+
+FUZZERS := \
+	compress_fuzzer \
+	decompress_fuzzer \
+	round_trip_fuzzer \
+	round_trip_stream_fuzzer \
+	compress_hc_fuzzer \
+	round_trip_hc_fuzzer \
+	compress_frame_fuzzer \
+	round_trip_frame_fuzzer \
+	decompress_frame_fuzzer
+
+.PHONY: all
+all: $(FUZZERS)
+
+# Include a rule to build the static library if calling this target
+# directly.
+$(LZ4DIR)/liblz4.a:
+	$(MAKE) -C $(LZ4DIR) CFLAGS="$(LZ4_CFLAGS)" liblz4.a
+
+%.o: %.c
+	$(CC) -c $(LZ4_CFLAGS) $(LZ4_CPPFLAGS) $< -o $@
+
+# Generic rule for generating fuzzers
+ifeq ($(LIB_FUZZING_ENGINE),)
+  LIB_FUZZING_DEPS := standaloneengine.o
+else
+  LIB_FUZZING_DEPS :=
+endif
+%_fuzzer: %_fuzzer.o lz4_helpers.o fuzz_data_producer.o $(LZ4DIR)/liblz4.a $(LIB_FUZZING_DEPS)
+	$(CXX) $(LZ4_CXXFLAGS) $(LZ4_CPPFLAGS) $(LDFLAGS) $(LIB_FUZZING_ENGINE) $^ -o $@$(EXT)
+
+%_fuzzer_clean:
+	$(RM) $*_fuzzer $*_fuzzer.o standaloneengine.o
+
+.PHONY: clean
+clean: compress_fuzzer_clean decompress_fuzzer_clean \
+	compress_frame_fuzzer_clean compress_hc_fuzzer_clean \
+	decompress_frame_fuzzer_clean round_trip_frame_fuzzer_clean \
+	round_trip_fuzzer_clean round_trip_hc_fuzzer_clean round_trip_stream_fuzzer_clean
+	$(MAKE) -C $(LZ4DIR) clean
diff --git a/lz4/ossfuzz/compress_frame_fuzzer.c b/lz4/ossfuzz/compress_frame_fuzzer.c
new file mode 100644
index 0000000..568ae14
--- /dev/null
+++ b/lz4/ossfuzz/compress_frame_fuzzer.c
@@ -0,0 +1,48 @@
+/**
+ * This fuzz target attempts to compress the fuzzed data with the simple
+ * compression function with an output buffer that may be too small to
+ * ensure that the compressor never crashes.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "lz4.h"
+#include "lz4frame.h"
+#include "lz4_helpers.h"
+#include "fuzz_data_producer.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    LZ4F_preferences_t const prefs = FUZZ_dataProducer_preferences(producer);
+    size_t const dstCapacitySeed = FUZZ_dataProducer_retrieve32(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const compressBound = LZ4F_compressFrameBound(size, &prefs);
+    size_t const dstCapacity = FUZZ_getRange_from_uint32(dstCapacitySeed, 0, compressBound);
+
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const rt = (char*)malloc(size);
+
+    FUZZ_ASSERT(dst!=NULL);
+    FUZZ_ASSERT(rt!=NULL);
+
+    /* If compression succeeds it must round trip correctly. */
+    size_t const dstSize =
+            LZ4F_compressFrame(dst, dstCapacity, data, size, &prefs);
+    if (!LZ4F_isError(dstSize)) {
+        size_t const rtSize = FUZZ_decompressFrame(rt, size, dst, dstSize);
+        FUZZ_ASSERT_MSG(rtSize == size, "Incorrect regenerated size");
+        FUZZ_ASSERT_MSG(!memcmp(data, rt, size), "Corruption!");
+    }
+
+    free(dst);
+    free(rt);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/compress_fuzzer.c b/lz4/ossfuzz/compress_fuzzer.c
new file mode 100644
index 0000000..edc8aad
--- /dev/null
+++ b/lz4/ossfuzz/compress_fuzzer.c
@@ -0,0 +1,58 @@
+/**
+ * This fuzz target attempts to compress the fuzzed data with the simple
+ * compression function with an output buffer that may be too small to
+ * ensure that the compressor never crashes.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "fuzz_data_producer.h"
+#include "lz4.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    size_t const dstCapacitySeed = FUZZ_dataProducer_retrieve32(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const compressBound = LZ4_compressBound(size);
+    size_t const dstCapacity = FUZZ_getRange_from_uint32(dstCapacitySeed, 0, compressBound);
+
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const rt = (char*)malloc(size);
+
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(rt);
+
+    /* If compression succeeds it must round trip correctly. */
+    {
+        int const dstSize = LZ4_compress_default((const char*)data, dst,
+                                                 size, dstCapacity);
+        if (dstSize > 0) {
+            int const rtSize = LZ4_decompress_safe(dst, rt, dstSize, size);
+            FUZZ_ASSERT_MSG(rtSize == size, "Incorrect regenerated size");
+            FUZZ_ASSERT_MSG(!memcmp(data, rt, size), "Corruption!");
+        }
+    }
+
+    if (dstCapacity > 0) {
+        /* Compression succeeds and must round trip correctly. */
+        int compressedSize = size;
+        int const dstSize = LZ4_compress_destSize((const char*)data, dst,
+                                                  &compressedSize, dstCapacity);
+        FUZZ_ASSERT(dstSize > 0);
+        int const rtSize = LZ4_decompress_safe(dst, rt, dstSize, size);
+        FUZZ_ASSERT_MSG(rtSize == compressedSize, "Incorrect regenerated size");
+        FUZZ_ASSERT_MSG(!memcmp(data, rt, compressedSize), "Corruption!");
+    }
+
+    free(dst);
+    free(rt);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/compress_hc_fuzzer.c b/lz4/ossfuzz/compress_hc_fuzzer.c
new file mode 100644
index 0000000..7d8e45a
--- /dev/null
+++ b/lz4/ossfuzz/compress_hc_fuzzer.c
@@ -0,0 +1,64 @@
+/**
+ * This fuzz target attempts to compress the fuzzed data with the simple
+ * compression function with an output buffer that may be too small to
+ * ensure that the compressor never crashes.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "fuzz_data_producer.h"
+#include "lz4.h"
+#include "lz4hc.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    size_t const dstCapacitySeed = FUZZ_dataProducer_retrieve32(producer);
+    size_t const levelSeed = FUZZ_dataProducer_retrieve32(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const dstCapacity = FUZZ_getRange_from_uint32(dstCapacitySeed, 0, size);
+    int const level = FUZZ_getRange_from_uint32(levelSeed, LZ4HC_CLEVEL_MIN, LZ4HC_CLEVEL_MAX);
+
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const rt = (char*)malloc(size);
+
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(rt);
+
+    /* If compression succeeds it must round trip correctly. */
+    {
+        int const dstSize = LZ4_compress_HC((const char*)data, dst, size,
+                                            dstCapacity, level);
+        if (dstSize > 0) {
+            int const rtSize = LZ4_decompress_safe(dst, rt, dstSize, size);
+            FUZZ_ASSERT_MSG(rtSize == size, "Incorrect regenerated size");
+            FUZZ_ASSERT_MSG(!memcmp(data, rt, size), "Corruption!");
+        }
+    }
+
+    if (dstCapacity > 0) {
+        /* Compression succeeds and must round trip correctly. */
+        void* state = malloc(LZ4_sizeofStateHC());
+        FUZZ_ASSERT(state);
+        int compressedSize = size;
+        int const dstSize = LZ4_compress_HC_destSize(state, (const char*)data,
+                                                     dst, &compressedSize,
+                                                     dstCapacity, level);
+        FUZZ_ASSERT(dstSize > 0);
+        int const rtSize = LZ4_decompress_safe(dst, rt, dstSize, size);
+        FUZZ_ASSERT_MSG(rtSize == compressedSize, "Incorrect regenerated size");
+        FUZZ_ASSERT_MSG(!memcmp(data, rt, compressedSize), "Corruption!");
+        free(state);
+    }
+
+    free(dst);
+    free(rt);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/decompress_frame_fuzzer.c b/lz4/ossfuzz/decompress_frame_fuzzer.c
new file mode 100644
index 0000000..0fcbb16
--- /dev/null
+++ b/lz4/ossfuzz/decompress_frame_fuzzer.c
@@ -0,0 +1,75 @@
+/**
+ * This fuzz target attempts to decompress the fuzzed data with the simple
+ * decompression function to ensure the decompressor never crashes.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "fuzz_data_producer.h"
+#include "lz4.h"
+#define LZ4F_STATIC_LINKING_ONLY
+#include "lz4frame.h"
+#include "lz4_helpers.h"
+
+static void decompress(LZ4F_dctx* dctx, void* dst, size_t dstCapacity,
+                       const void* src, size_t srcSize,
+                       const void* dict, size_t dictSize,
+                       const LZ4F_decompressOptions_t* opts)
+{
+    LZ4F_resetDecompressionContext(dctx);
+    if (dictSize == 0)
+        LZ4F_decompress(dctx, dst, &dstCapacity, src, &srcSize, opts);
+    else
+        LZ4F_decompress_usingDict(dctx, dst, &dstCapacity, src, &srcSize,
+                                  dict, dictSize, opts);
+}
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    size_t const dstCapacitySeed = FUZZ_dataProducer_retrieve32(producer);
+    size_t const dictSizeSeed = FUZZ_dataProducer_retrieve32(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const dstCapacity = FUZZ_getRange_from_uint32(
+      dstCapacitySeed, 0, 4 * size);
+    size_t const largeDictSize = 64 * 1024;
+    size_t const dictSize = FUZZ_getRange_from_uint32(
+      dictSizeSeed, 0, largeDictSize);
+
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const dict = (char*)malloc(dictSize);
+    LZ4F_decompressOptions_t opts;
+    LZ4F_dctx* dctx;
+    LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION);
+
+    FUZZ_ASSERT(dctx);
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(dict);
+
+    /* Prepare the dictionary. The data doesn't matter for decompression. */
+    memset(dict, 0, dictSize);
+
+
+    /* Decompress using multiple configurations. */
+    memset(&opts, 0, sizeof(opts));
+    opts.stableDst = 0;
+    decompress(dctx, dst, dstCapacity, data, size, NULL, 0, &opts);
+    opts.stableDst = 1;
+    decompress(dctx, dst, dstCapacity, data, size, NULL, 0, &opts);
+    opts.stableDst = 0;
+    decompress(dctx, dst, dstCapacity, data, size, dict, dictSize, &opts);
+    opts.stableDst = 1;
+    decompress(dctx, dst, dstCapacity, data, size, dict, dictSize, &opts);
+
+    LZ4F_freeDecompressionContext(dctx);
+    free(dst);
+    free(dict);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/decompress_fuzzer.c b/lz4/ossfuzz/decompress_fuzzer.c
new file mode 100644
index 0000000..6f48e30
--- /dev/null
+++ b/lz4/ossfuzz/decompress_fuzzer.c
@@ -0,0 +1,62 @@
+/**
+ * This fuzz target attempts to decompress the fuzzed data with the simple
+ * decompression function to ensure the decompressor never crashes.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "fuzz_data_producer.h"
+#include "lz4.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    size_t const dstCapacitySeed = FUZZ_dataProducer_retrieve32(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const dstCapacity = FUZZ_getRange_from_uint32(dstCapacitySeed, 0, 4 * size);
+    size_t const smallDictSize = size + 1;
+    size_t const largeDictSize = 64 * 1024 - 1;
+    size_t const dictSize = MAX(smallDictSize, largeDictSize);
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const dict = (char*)malloc(dictSize + size);
+    char* const largeDict = dict;
+    char* const dataAfterDict = dict + dictSize;
+    char* const smallDict = dataAfterDict - smallDictSize;
+
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(dict);
+
+    /* Prepare the dictionary. The data doesn't matter for decompression. */
+    memset(dict, 0, dictSize);
+    memcpy(dataAfterDict, data, size);
+
+    /* Decompress using each possible dictionary configuration. */
+    /* No dictionary. */
+    LZ4_decompress_safe_usingDict((char const*)data, dst, size,
+                                  dstCapacity, NULL, 0);
+    /* Small external dictonary. */
+    LZ4_decompress_safe_usingDict((char const*)data, dst, size,
+                                  dstCapacity, smallDict, smallDictSize);
+    /* Large external dictionary. */
+    LZ4_decompress_safe_usingDict((char const*)data, dst, size,
+                                  dstCapacity, largeDict, largeDictSize);
+    /* Small prefix. */
+    LZ4_decompress_safe_usingDict((char const*)dataAfterDict, dst, size,
+                                  dstCapacity, smallDict, smallDictSize);
+    /* Large prefix. */
+    LZ4_decompress_safe_usingDict((char const*)data, dst, size,
+                                  dstCapacity, largeDict, largeDictSize);
+    /* Partial decompression. */
+    LZ4_decompress_safe_partial((char const*)data, dst, size,
+                                dstCapacity, dstCapacity);
+    free(dst);
+    free(dict);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/fuzz.h b/lz4/ossfuzz/fuzz.h
new file mode 100644
index 0000000..eefac63
--- /dev/null
+++ b/lz4/ossfuzz/fuzz.h
@@ -0,0 +1,48 @@
+/**
+ * Fuzz target interface.
+ * Fuzz targets have some common parameters passed as macros during compilation.
+ * Check the documentation for each individual fuzzer for more parameters.
+ *
+ * @param FUZZ_RNG_SEED_SIZE:
+ *        The number of bytes of the source to look at when constructing a seed
+ *        for the deterministic RNG. These bytes are discarded before passing
+ *        the data to lz4 functions. Every fuzzer initializes the RNG exactly
+ *        once before doing anything else, even if it is unused.
+ *        Default: 4.
+ * @param LZ4_DEBUG:
+ *        This is a parameter for the lz4 library. Defining `LZ4_DEBUG=1`
+ *        enables assert() statements in the lz4 library. Higher levels enable
+ *        logging, so aren't recommended. Defining `LZ4_DEBUG=1` is
+ *        recommended.
+ * @param LZ4_FORCE_MEMORY_ACCESS:
+ *        This flag controls how the zstd library accesses unaligned memory.
+ *        It can be undefined, or 0 through 2. If it is undefined, it selects
+ *        the method to use based on the compiler. If testing with UBSAN set
+ *        MEM_FORCE_MEMORY_ACCESS=0 to use the standard compliant method.
+ * @param FUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION
+ *        This is the canonical flag to enable deterministic builds for fuzzing.
+ *        Changes to zstd for fuzzing are gated behind this define.
+ *        It is recommended to define this when building zstd for fuzzing.
+ */
+
+#ifndef FUZZ_H
+#define FUZZ_H
+
+#ifndef FUZZ_RNG_SEED_SIZE
+#  define FUZZ_RNG_SEED_SIZE 4
+#endif
+
+#include 
+#include 
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+int LLVMFuzzerTestOneInput(const uint8_t *src, size_t size);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/lz4/ossfuzz/fuzz_data_producer.c b/lz4/ossfuzz/fuzz_data_producer.c
new file mode 100644
index 0000000..670fbf5
--- /dev/null
+++ b/lz4/ossfuzz/fuzz_data_producer.c
@@ -0,0 +1,77 @@
+#include "fuzz_data_producer.h"
+
+struct FUZZ_dataProducer_s{
+  const uint8_t *data;
+  size_t size;
+};
+
+FUZZ_dataProducer_t* FUZZ_dataProducer_create(const uint8_t* data, size_t size) {
+  FUZZ_dataProducer_t* const producer = malloc(sizeof(FUZZ_dataProducer_t));
+
+  FUZZ_ASSERT(producer != NULL);
+
+  producer->data = data;
+  producer->size = size;
+  return producer;
+}
+
+void FUZZ_dataProducer_free(FUZZ_dataProducer_t *producer) { free(producer); }
+
+uint32_t FUZZ_dataProducer_retrieve32(FUZZ_dataProducer_t *producer) {
+    const uint8_t* data = producer->data;
+    const size_t size = producer->size;
+    if (size == 0) {
+        return 0;
+    } else if (size < 4) {
+        producer->size -= 1;
+        return (uint32_t)data[size - 1];
+    } else {
+        producer->size -= 4;
+        return *(data + size - 4);
+    }
+}
+
+uint32_t FUZZ_getRange_from_uint32(uint32_t seed, uint32_t min, uint32_t max)
+{
+    uint32_t range = max - min;
+    if (range == 0xffffffff) {
+      return seed;
+    }
+    return min + seed % (range + 1);
+}
+
+uint32_t FUZZ_dataProducer_range32(FUZZ_dataProducer_t* producer,
+    uint32_t min, uint32_t max)
+{
+    size_t const seed = FUZZ_dataProducer_retrieve32(producer);
+    return FUZZ_getRange_from_uint32(seed, min, max);
+}
+
+LZ4F_frameInfo_t FUZZ_dataProducer_frameInfo(FUZZ_dataProducer_t* producer)
+{
+    LZ4F_frameInfo_t info = LZ4F_INIT_FRAMEINFO;
+    info.blockSizeID = FUZZ_dataProducer_range32(producer, LZ4F_max64KB - 1, LZ4F_max4MB);
+    if (info.blockSizeID < LZ4F_max64KB) {
+        info.blockSizeID = LZ4F_default;
+    }
+    info.blockMode = FUZZ_dataProducer_range32(producer, LZ4F_blockLinked, LZ4F_blockIndependent);
+    info.contentChecksumFlag = FUZZ_dataProducer_range32(producer, LZ4F_noContentChecksum,
+                                           LZ4F_contentChecksumEnabled);
+    info.blockChecksumFlag = FUZZ_dataProducer_range32(producer, LZ4F_noBlockChecksum,
+                                         LZ4F_blockChecksumEnabled);
+    return info;
+}
+
+LZ4F_preferences_t FUZZ_dataProducer_preferences(FUZZ_dataProducer_t* producer)
+{
+    LZ4F_preferences_t prefs = LZ4F_INIT_PREFERENCES;
+    prefs.frameInfo = FUZZ_dataProducer_frameInfo(producer);
+    prefs.compressionLevel = FUZZ_dataProducer_range32(producer, 0, LZ4HC_CLEVEL_MAX + 3) - 3;
+    prefs.autoFlush = FUZZ_dataProducer_range32(producer, 0, 1);
+    prefs.favorDecSpeed = FUZZ_dataProducer_range32(producer, 0, 1);
+    return prefs;
+}
+
+size_t FUZZ_dataProducer_remainingBytes(FUZZ_dataProducer_t *producer){
+  return producer->size;
+}
diff --git a/lz4/ossfuzz/fuzz_data_producer.h b/lz4/ossfuzz/fuzz_data_producer.h
new file mode 100644
index 0000000..b96dcba
--- /dev/null
+++ b/lz4/ossfuzz/fuzz_data_producer.h
@@ -0,0 +1,36 @@
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "lz4frame.h"
+#include "lz4hc.h"
+
+/* Struct used for maintaining the state of the data */
+typedef struct FUZZ_dataProducer_s FUZZ_dataProducer_t;
+
+/* Returns a data producer state struct. Use for producer initialization. */
+FUZZ_dataProducer_t *FUZZ_dataProducer_create(const uint8_t *data, size_t size);
+
+/* Frees the data producer */
+void FUZZ_dataProducer_free(FUZZ_dataProducer_t *producer);
+
+/* Returns 32 bits from the end of data */
+uint32_t FUZZ_dataProducer_retrieve32(FUZZ_dataProducer_t *producer);
+
+/* Returns value between [min, max] */
+uint32_t FUZZ_getRange_from_uint32(uint32_t seed, uint32_t min, uint32_t max);
+
+/* Combination of above two functions for non adaptive use cases. ie where size is not involved */
+uint32_t FUZZ_dataProducer_range32(FUZZ_dataProducer_t *producer, uint32_t min,
+                                  uint32_t max);
+
+/* Returns lz4 preferences */
+LZ4F_preferences_t FUZZ_dataProducer_preferences(FUZZ_dataProducer_t* producer);
+
+/* Returns lz4 frame info */
+LZ4F_frameInfo_t FUZZ_dataProducer_frameInfo(FUZZ_dataProducer_t* producer);
+
+/* Returns the size of the remaining bytes of data in the producer */
+size_t FUZZ_dataProducer_remainingBytes(FUZZ_dataProducer_t *producer);
diff --git a/lz4/ossfuzz/fuzz_helpers.h b/lz4/ossfuzz/fuzz_helpers.h
new file mode 100644
index 0000000..c4a8645
--- /dev/null
+++ b/lz4/ossfuzz/fuzz_helpers.h
@@ -0,0 +1,94 @@
+/*
+ * Copyright (c) 2016-present, Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under both the BSD-style license (found in the
+ * LICENSE file in the root directory of this source tree) and the GPLv2 (found
+ * in the COPYING file in the root directory of this source tree).
+ */
+
+/**
+ * Helper functions for fuzzing.
+ */
+
+#ifndef FUZZ_HELPERS_H
+#define FUZZ_HELPERS_H
+
+#include "fuzz.h"
+#include "xxhash.h"
+#include 
+#include 
+#include 
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define LZ4_COMMONDEFS_ONLY
+#ifndef LZ4_SRC_INCLUDED
+#include "lz4.c"   /* LZ4_count, constants, mem */
+#endif
+
+#define MIN(a,b)   ( (a) < (b) ? (a) : (b) )
+#define MAX(a,b)   ( (a) > (b) ? (a) : (b) )
+
+#define FUZZ_QUOTE_IMPL(str) #str
+#define FUZZ_QUOTE(str) FUZZ_QUOTE_IMPL(str)
+
+/**
+ * Asserts for fuzzing that are always enabled.
+ */
+#define FUZZ_ASSERT_MSG(cond, msg)                                             \
+  ((cond) ? (void)0                                                            \
+          : (fprintf(stderr, "%s: %u: Assertion: `%s' failed. %s\n", __FILE__, \
+                     __LINE__, FUZZ_QUOTE(cond), (msg)),                       \
+             abort()))
+#define FUZZ_ASSERT(cond) FUZZ_ASSERT_MSG((cond), "");
+
+#if defined(__GNUC__)
+#define FUZZ_STATIC static __inline __attribute__((unused))
+#elif defined(__cplusplus) ||                                                  \
+    (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */)
+#define FUZZ_STATIC static inline
+#elif defined(_MSC_VER)
+#define FUZZ_STATIC static __inline
+#else
+#define FUZZ_STATIC static
+#endif
+
+/**
+ * Deterministically constructs a seed based on the fuzz input.
+ * Consumes up to the first FUZZ_RNG_SEED_SIZE bytes of the input.
+ */
+FUZZ_STATIC uint32_t FUZZ_seed(uint8_t const **src, size_t* size) {
+    uint8_t const *data = *src;
+    size_t const toHash = MIN(FUZZ_RNG_SEED_SIZE, *size);
+    *size -= toHash;
+    *src += toHash;
+    return XXH32(data, toHash, 0);
+}
+
+#define FUZZ_rotl32(x, r) (((x) << (r)) | ((x) >> (32 - (r))))
+
+FUZZ_STATIC uint32_t FUZZ_rand(uint32_t *state) {
+    static const uint32_t prime1 = 2654435761U;
+    static const uint32_t prime2 = 2246822519U;
+    uint32_t rand32 = *state;
+    rand32 *= prime1;
+    rand32 += prime2;
+    rand32 = FUZZ_rotl32(rand32, 13);
+    *state = rand32;
+    return rand32 >> 5;
+}
+
+/* Returns a random numer in the range [min, max]. */
+FUZZ_STATIC uint32_t FUZZ_rand32(uint32_t *state, uint32_t min, uint32_t max) {
+    uint32_t random = FUZZ_rand(state);
+    return min + (random % (max - min + 1));
+}
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/lz4/ossfuzz/lz4_helpers.c b/lz4/ossfuzz/lz4_helpers.c
new file mode 100644
index 0000000..9471630
--- /dev/null
+++ b/lz4/ossfuzz/lz4_helpers.c
@@ -0,0 +1,51 @@
+#include "fuzz_helpers.h"
+#include "lz4_helpers.h"
+#include "lz4hc.h"
+
+LZ4F_frameInfo_t FUZZ_randomFrameInfo(uint32_t* seed)
+{
+    LZ4F_frameInfo_t info = LZ4F_INIT_FRAMEINFO;
+    info.blockSizeID = FUZZ_rand32(seed, LZ4F_max64KB - 1, LZ4F_max4MB);
+    if (info.blockSizeID < LZ4F_max64KB) {
+        info.blockSizeID = LZ4F_default;
+    }
+    info.blockMode = FUZZ_rand32(seed, LZ4F_blockLinked, LZ4F_blockIndependent);
+    info.contentChecksumFlag = FUZZ_rand32(seed, LZ4F_noContentChecksum,
+                                           LZ4F_contentChecksumEnabled);
+    info.blockChecksumFlag = FUZZ_rand32(seed, LZ4F_noBlockChecksum,
+                                         LZ4F_blockChecksumEnabled);
+    return info;
+}
+
+LZ4F_preferences_t FUZZ_randomPreferences(uint32_t* seed)
+{
+    LZ4F_preferences_t prefs = LZ4F_INIT_PREFERENCES;
+    prefs.frameInfo = FUZZ_randomFrameInfo(seed);
+    prefs.compressionLevel = FUZZ_rand32(seed, 0, LZ4HC_CLEVEL_MAX + 3) - 3;
+    prefs.autoFlush = FUZZ_rand32(seed, 0, 1);
+    prefs.favorDecSpeed = FUZZ_rand32(seed, 0, 1);
+    return prefs;
+}
+
+size_t FUZZ_decompressFrame(void* dst, const size_t dstCapacity,
+                            const void* src, const size_t srcSize)
+{
+    LZ4F_decompressOptions_t opts;
+    memset(&opts, 0, sizeof(opts));
+    opts.stableDst = 1;
+    LZ4F_dctx* dctx;
+    LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION);
+    FUZZ_ASSERT(dctx);
+
+    size_t dstSize = dstCapacity;
+    size_t srcConsumed = srcSize;
+    size_t const rc =
+            LZ4F_decompress(dctx, dst, &dstSize, src, &srcConsumed, &opts);
+    FUZZ_ASSERT(!LZ4F_isError(rc));
+    FUZZ_ASSERT(rc == 0);
+    FUZZ_ASSERT(srcConsumed == srcSize);
+
+    LZ4F_freeDecompressionContext(dctx);
+
+    return dstSize;
+}
diff --git a/lz4/ossfuzz/lz4_helpers.h b/lz4/ossfuzz/lz4_helpers.h
new file mode 100644
index 0000000..c99fb01
--- /dev/null
+++ b/lz4/ossfuzz/lz4_helpers.h
@@ -0,0 +1,13 @@
+#ifndef LZ4_HELPERS
+#define LZ4_HELPERS
+
+#include "lz4frame.h"
+
+LZ4F_frameInfo_t FUZZ_randomFrameInfo(uint32_t* seed);
+
+LZ4F_preferences_t FUZZ_randomPreferences(uint32_t* seed);
+
+size_t FUZZ_decompressFrame(void* dst, const size_t dstCapacity,
+                            const void* src, const size_t srcSize);
+
+#endif /* LZ4_HELPERS */
diff --git a/lz4/ossfuzz/ossfuzz.sh b/lz4/ossfuzz/ossfuzz.sh
new file mode 100755
index 0000000..9782286
--- /dev/null
+++ b/lz4/ossfuzz/ossfuzz.sh
@@ -0,0 +1,23 @@
+#!/bin/bash -eu
+
+# This script is called by the oss-fuzz main project when compiling the fuzz
+# targets. This script is regression tested by travisoss.sh.
+
+# Save off the current folder as the build root.
+export BUILD_ROOT=$PWD
+
+echo "CC: $CC"
+echo "CXX: $CXX"
+echo "LIB_FUZZING_ENGINE: $LIB_FUZZING_ENGINE"
+echo "CFLAGS: $CFLAGS"
+echo "CXXFLAGS: $CXXFLAGS"
+echo "OUT: $OUT"
+
+export MAKEFLAGS+="-j$(nproc)"
+
+pushd ossfuzz
+make V=1 all
+popd
+
+# Copy the fuzzers to the target directory.
+cp -v ossfuzz/*_fuzzer $OUT/
diff --git a/lz4/ossfuzz/round_trip_frame_fuzzer.c b/lz4/ossfuzz/round_trip_frame_fuzzer.c
new file mode 100644
index 0000000..149542d
--- /dev/null
+++ b/lz4/ossfuzz/round_trip_frame_fuzzer.c
@@ -0,0 +1,43 @@
+/**
+ * This fuzz target performs a lz4 round-trip test (compress & decompress),
+ * compares the result with the original, and calls abort() on corruption.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "lz4.h"
+#include "lz4frame.h"
+#include "lz4_helpers.h"
+#include "fuzz_data_producer.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t* producer = FUZZ_dataProducer_create(data, size);
+    LZ4F_preferences_t const prefs = FUZZ_dataProducer_preferences(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const dstCapacity = LZ4F_compressFrameBound(LZ4_compressBound(size), &prefs);
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const rt = (char*)malloc(FUZZ_dataProducer_remainingBytes(producer));
+
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(rt);
+
+    /* Compression must succeed and round trip correctly. */
+    size_t const dstSize =
+            LZ4F_compressFrame(dst, dstCapacity, data, size, &prefs);
+    FUZZ_ASSERT(!LZ4F_isError(dstSize));
+    size_t const rtSize = FUZZ_decompressFrame(rt, size, dst, dstSize);
+    FUZZ_ASSERT_MSG(rtSize == size, "Incorrect regenerated size");
+    FUZZ_ASSERT_MSG(!memcmp(data, rt, size), "Corruption!");
+
+    free(dst);
+    free(rt);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/round_trip_fuzzer.c b/lz4/ossfuzz/round_trip_fuzzer.c
new file mode 100644
index 0000000..6307058
--- /dev/null
+++ b/lz4/ossfuzz/round_trip_fuzzer.c
@@ -0,0 +1,57 @@
+/**
+ * This fuzz target performs a lz4 round-trip test (compress & decompress),
+ * compares the result with the original, and calls abort() on corruption.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "lz4.h"
+#include "fuzz_data_producer.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    size_t const partialCapacitySeed = FUZZ_dataProducer_retrieve32(producer);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const partialCapacity = FUZZ_getRange_from_uint32(partialCapacitySeed, 0, size);
+    size_t const dstCapacity = LZ4_compressBound(size);
+
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const rt = (char*)malloc(size);
+
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(rt);
+
+    /* Compression must succeed and round trip correctly. */
+    int const dstSize = LZ4_compress_default((const char*)data, dst,
+                                             size, dstCapacity);
+    FUZZ_ASSERT(dstSize > 0);
+
+    int const rtSize = LZ4_decompress_safe(dst, rt, dstSize, size);
+    FUZZ_ASSERT_MSG(rtSize == size, "Incorrect size");
+    FUZZ_ASSERT_MSG(!memcmp(data, rt, size), "Corruption!");
+
+    /* Partial decompression must succeed. */
+    {
+        char* const partial = (char*)malloc(partialCapacity);
+        FUZZ_ASSERT(partial);
+        int const partialSize = LZ4_decompress_safe_partial(
+                dst, partial, dstSize, partialCapacity, partialCapacity);
+        FUZZ_ASSERT(partialSize >= 0);
+        FUZZ_ASSERT_MSG(partialSize == partialCapacity, "Incorrect size");
+        FUZZ_ASSERT_MSG(!memcmp(data, partial, partialSize), "Corruption!");
+        free(partial);
+    }
+
+
+    free(dst);
+    free(rt);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/round_trip_hc_fuzzer.c b/lz4/ossfuzz/round_trip_hc_fuzzer.c
new file mode 100644
index 0000000..7d03ee2
--- /dev/null
+++ b/lz4/ossfuzz/round_trip_hc_fuzzer.c
@@ -0,0 +1,44 @@
+/**
+ * This fuzz target performs a lz4 round-trip test (compress & decompress),
+ * compares the result with the original, and calls abort() on corruption.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#include "fuzz_data_producer.h"
+#include "lz4.h"
+#include "lz4hc.h"
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    FUZZ_dataProducer_t *producer = FUZZ_dataProducer_create(data, size);
+    int const level = FUZZ_dataProducer_range32(producer,
+        LZ4HC_CLEVEL_MIN, LZ4HC_CLEVEL_MAX);
+    size = FUZZ_dataProducer_remainingBytes(producer);
+
+    size_t const dstCapacity = LZ4_compressBound(size);
+    char* const dst = (char*)malloc(dstCapacity);
+    char* const rt = (char*)malloc(size);
+
+    FUZZ_ASSERT(dst);
+    FUZZ_ASSERT(rt);
+
+    /* Compression must succeed and round trip correctly. */
+    int const dstSize = LZ4_compress_HC((const char*)data, dst, size,
+                                        dstCapacity, level);
+    FUZZ_ASSERT(dstSize > 0);
+
+    int const rtSize = LZ4_decompress_safe(dst, rt, dstSize, size);
+    FUZZ_ASSERT_MSG(rtSize == size, "Incorrect size");
+    FUZZ_ASSERT_MSG(!memcmp(data, rt, size), "Corruption!");
+
+    free(dst);
+    free(rt);
+    FUZZ_dataProducer_free(producer);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/round_trip_stream_fuzzer.c b/lz4/ossfuzz/round_trip_stream_fuzzer.c
new file mode 100644
index 0000000..abfcd2d
--- /dev/null
+++ b/lz4/ossfuzz/round_trip_stream_fuzzer.c
@@ -0,0 +1,302 @@
+/**
+ * This fuzz target performs a lz4 streaming round-trip test
+ * (compress & decompress), compares the result with the original, and calls
+ * abort() on corruption.
+ */
+
+#include 
+#include 
+#include 
+#include 
+
+#include "fuzz_helpers.h"
+#define LZ4_STATIC_LINKING_ONLY
+#include "lz4.h"
+#define LZ4_HC_STATIC_LINKING_ONLY
+#include "lz4hc.h"
+
+typedef struct {
+  char const* buf;
+  size_t size;
+  size_t pos;
+} const_cursor_t;
+
+typedef struct {
+  char* buf;
+  size_t size;
+  size_t pos;
+} cursor_t;
+
+typedef struct {
+  LZ4_stream_t* cstream;
+  LZ4_streamHC_t* cstreamHC;
+  LZ4_streamDecode_t* dstream;
+  const_cursor_t data;
+  cursor_t compressed;
+  cursor_t roundTrip;
+  uint32_t seed;
+  int level;
+} state_t;
+
+cursor_t cursor_create(size_t size)
+{
+  cursor_t cursor;
+  cursor.buf = (char*)malloc(size);
+  cursor.size = size;
+  cursor.pos = 0;
+  FUZZ_ASSERT(cursor.buf);
+  return cursor;
+}
+
+typedef void (*round_trip_t)(state_t* state);
+
+void cursor_free(cursor_t cursor)
+{
+    free(cursor.buf);
+}
+
+state_t state_create(char const* data, size_t size, uint32_t seed)
+{
+    state_t state;
+
+    state.seed = seed;
+
+    state.data.buf = (char const*)data;
+    state.data.size = size;
+    state.data.pos = 0;
+
+    /* Extra margin because we are streaming. */
+    state.compressed = cursor_create(1024 + 2 * LZ4_compressBound(size));
+    state.roundTrip = cursor_create(size);
+
+    state.cstream = LZ4_createStream();
+    FUZZ_ASSERT(state.cstream);
+    state.cstreamHC = LZ4_createStreamHC();
+    FUZZ_ASSERT(state.cstream);
+    state.dstream = LZ4_createStreamDecode();
+    FUZZ_ASSERT(state.dstream);
+
+    return state;
+}
+
+void state_free(state_t state)
+{
+    cursor_free(state.compressed);
+    cursor_free(state.roundTrip);
+    LZ4_freeStream(state.cstream);
+    LZ4_freeStreamHC(state.cstreamHC);
+    LZ4_freeStreamDecode(state.dstream);
+}
+
+static void state_reset(state_t* state, uint32_t seed)
+{
+    state->level = FUZZ_rand32(&seed, LZ4HC_CLEVEL_MIN, LZ4HC_CLEVEL_MAX);
+    LZ4_resetStream_fast(state->cstream);
+    LZ4_resetStreamHC_fast(state->cstreamHC, state->level);
+    LZ4_setStreamDecode(state->dstream, NULL, 0);
+    state->data.pos = 0;
+    state->compressed.pos = 0;
+    state->roundTrip.pos = 0;
+    state->seed = seed;
+}
+
+static void state_decompress(state_t* state, char const* src, int srcSize)
+{
+    char* dst = state->roundTrip.buf + state->roundTrip.pos;
+    int const dstCapacity = state->roundTrip.size - state->roundTrip.pos;
+    int const dSize = LZ4_decompress_safe_continue(state->dstream, src, dst,
+                                                   srcSize, dstCapacity);
+    FUZZ_ASSERT(dSize >= 0);
+    state->roundTrip.pos += dSize;
+}
+
+static void state_checkRoundTrip(state_t const* state)
+{
+    char const* data = state->data.buf;
+    size_t const size = state->data.size;
+    FUZZ_ASSERT_MSG(size == state->roundTrip.pos, "Incorrect size!");
+    FUZZ_ASSERT_MSG(!memcmp(data, state->roundTrip.buf, size), "Corruption!");
+}
+
+/**
+ * Picks a dictionary size and trims the dictionary off of the data.
+ * We copy the dictionary to the roundTrip so our validation passes.
+ */
+static size_t state_trimDict(state_t* state)
+{
+    /* 64 KB is the max dict size, allow slightly beyond that to test trim. */
+    uint32_t maxDictSize = MIN(70 * 1024, state->data.size);
+    size_t const dictSize = FUZZ_rand32(&state->seed, 0, maxDictSize);
+    DEBUGLOG(2, "dictSize = %zu", dictSize);
+    FUZZ_ASSERT(state->data.pos == 0);
+    FUZZ_ASSERT(state->roundTrip.pos == 0);
+    memcpy(state->roundTrip.buf, state->data.buf, dictSize);
+    state->data.pos += dictSize;
+    state->roundTrip.pos += dictSize;
+    return dictSize;
+}
+
+static void state_prefixRoundTrip(state_t* state)
+{
+    while (state->data.pos != state->data.size) {
+        char const* src = state->data.buf + state->data.pos;
+        char* dst = state->compressed.buf + state->compressed.pos;
+        int const srcRemaining = state->data.size - state->data.pos;
+        int const srcSize = FUZZ_rand32(&state->seed, 0, srcRemaining);
+        int const dstCapacity = state->compressed.size - state->compressed.pos;
+        int const cSize = LZ4_compress_fast_continue(state->cstream, src, dst,
+                                                     srcSize, dstCapacity, 0);
+        FUZZ_ASSERT(cSize > 0);
+        state->data.pos += srcSize;
+        state->compressed.pos += cSize;
+        state_decompress(state, dst, cSize);
+    }
+}
+
+static void state_extDictRoundTrip(state_t* state)
+{
+    int i = 0;
+    cursor_t data2 = cursor_create(state->data.size);
+    memcpy(data2.buf, state->data.buf, state->data.size);
+    while (state->data.pos != state->data.size) {
+        char const* data = (i++ & 1) ? state->data.buf : data2.buf;
+        char const* src = data + state->data.pos;
+        char* dst = state->compressed.buf + state->compressed.pos;
+        int const srcRemaining = state->data.size - state->data.pos;
+        int const srcSize = FUZZ_rand32(&state->seed, 0, srcRemaining);
+        int const dstCapacity = state->compressed.size - state->compressed.pos;
+        int const cSize = LZ4_compress_fast_continue(state->cstream, src, dst,
+                                                     srcSize, dstCapacity, 0);
+        FUZZ_ASSERT(cSize > 0);
+        state->data.pos += srcSize;
+        state->compressed.pos += cSize;
+        state_decompress(state, dst, cSize);
+    }
+    cursor_free(data2);
+}
+
+static void state_randomRoundTrip(state_t* state, round_trip_t rt0,
+                                  round_trip_t rt1)
+{
+    if (FUZZ_rand32(&state->seed, 0, 1)) {
+      rt0(state);
+    } else {
+      rt1(state);
+    }
+}
+
+static void state_loadDictRoundTrip(state_t* state)
+{
+    char const* dict = state->data.buf;
+    size_t const dictSize = state_trimDict(state);
+    LZ4_loadDict(state->cstream, dict, dictSize);
+    LZ4_setStreamDecode(state->dstream, dict, dictSize);
+    state_randomRoundTrip(state, state_prefixRoundTrip, state_extDictRoundTrip);
+}
+
+static void state_attachDictRoundTrip(state_t* state)
+{
+    char const* dict = state->data.buf;
+    size_t const dictSize = state_trimDict(state);
+    LZ4_stream_t* dictStream = LZ4_createStream();
+    LZ4_loadDict(dictStream, dict, dictSize);
+    LZ4_attach_dictionary(state->cstream, dictStream);
+    LZ4_setStreamDecode(state->dstream, dict, dictSize);
+    state_randomRoundTrip(state, state_prefixRoundTrip, state_extDictRoundTrip);
+    LZ4_freeStream(dictStream);
+}
+
+static void state_prefixHCRoundTrip(state_t* state)
+{
+    while (state->data.pos != state->data.size) {
+        char const* src = state->data.buf + state->data.pos;
+        char* dst = state->compressed.buf + state->compressed.pos;
+        int const srcRemaining = state->data.size - state->data.pos;
+        int const srcSize = FUZZ_rand32(&state->seed, 0, srcRemaining);
+        int const dstCapacity = state->compressed.size - state->compressed.pos;
+        int const cSize = LZ4_compress_HC_continue(state->cstreamHC, src, dst,
+                                                   srcSize, dstCapacity);
+        FUZZ_ASSERT(cSize > 0);
+        state->data.pos += srcSize;
+        state->compressed.pos += cSize;
+        state_decompress(state, dst, cSize);
+    }
+}
+
+static void state_extDictHCRoundTrip(state_t* state)
+{
+    int i = 0;
+    cursor_t data2 = cursor_create(state->data.size);
+    DEBUGLOG(2, "extDictHC");
+    memcpy(data2.buf, state->data.buf, state->data.size);
+    while (state->data.pos != state->data.size) {
+        char const* data = (i++ & 1) ? state->data.buf : data2.buf;
+        char const* src = data + state->data.pos;
+        char* dst = state->compressed.buf + state->compressed.pos;
+        int const srcRemaining = state->data.size - state->data.pos;
+        int const srcSize = FUZZ_rand32(&state->seed, 0, srcRemaining);
+        int const dstCapacity = state->compressed.size - state->compressed.pos;
+        int const cSize = LZ4_compress_HC_continue(state->cstreamHC, src, dst,
+                                                   srcSize, dstCapacity);
+        FUZZ_ASSERT(cSize > 0);
+        DEBUGLOG(2, "srcSize = %d", srcSize);
+        state->data.pos += srcSize;
+        state->compressed.pos += cSize;
+        state_decompress(state, dst, cSize);
+    }
+    cursor_free(data2);
+}
+
+static void state_loadDictHCRoundTrip(state_t* state)
+{
+    char const* dict = state->data.buf;
+    size_t const dictSize = state_trimDict(state);
+    LZ4_loadDictHC(state->cstreamHC, dict, dictSize);
+    LZ4_setStreamDecode(state->dstream, dict, dictSize);
+    state_randomRoundTrip(state, state_prefixHCRoundTrip,
+                          state_extDictHCRoundTrip);
+}
+
+static void state_attachDictHCRoundTrip(state_t* state)
+{
+    char const* dict = state->data.buf;
+    size_t const dictSize = state_trimDict(state);
+    LZ4_streamHC_t* dictStream = LZ4_createStreamHC();
+    LZ4_setCompressionLevel(dictStream, state->level);
+    LZ4_loadDictHC(dictStream, dict, dictSize);
+    LZ4_attach_HC_dictionary(state->cstreamHC, dictStream);
+    LZ4_setStreamDecode(state->dstream, dict, dictSize);
+    state_randomRoundTrip(state, state_prefixHCRoundTrip,
+                          state_extDictHCRoundTrip);
+    LZ4_freeStreamHC(dictStream);
+}
+
+round_trip_t roundTrips[] = {
+  &state_prefixRoundTrip,
+  &state_extDictRoundTrip,
+  &state_loadDictRoundTrip,
+  &state_attachDictRoundTrip,
+  &state_prefixHCRoundTrip,
+  &state_extDictHCRoundTrip,
+  &state_loadDictHCRoundTrip,
+  &state_attachDictHCRoundTrip,
+};
+
+int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size)
+{
+    uint32_t seed = FUZZ_seed(&data, &size);
+    state_t state = state_create((char const*)data, size, seed);
+    const int n = sizeof(roundTrips) / sizeof(round_trip_t);
+    int i;
+
+    for (i = 0; i < n; ++i) {
+        DEBUGLOG(2, "Round trip %d", i);
+        state_reset(&state, seed);
+        roundTrips[i](&state);
+        state_checkRoundTrip(&state);
+    }
+
+    state_free(state);
+
+    return 0;
+}
diff --git a/lz4/ossfuzz/standaloneengine.c b/lz4/ossfuzz/standaloneengine.c
new file mode 100644
index 0000000..6afeffd
--- /dev/null
+++ b/lz4/ossfuzz/standaloneengine.c
@@ -0,0 +1,74 @@
+#include 
+#include 
+#include 
+
+#include "fuzz.h"
+
+/**
+ * Main procedure for standalone fuzzing engine.
+ *
+ * Reads filenames from the argument array. For each filename, read the file
+ * into memory and then call the fuzzing interface with the data.
+ */
+int main(int argc, char **argv)
+{
+  int ii;
+  for(ii = 1; ii < argc; ii++)
+  {
+    FILE *infile;
+    printf("[%s] ", argv[ii]);
+
+    /* Try and open the file. */
+    infile = fopen(argv[ii], "rb");
+    if(infile)
+    {
+      uint8_t *buffer = NULL;
+      size_t buffer_len;
+
+      printf("Opened.. ");
+
+      /* Get the length of the file. */
+      fseek(infile, 0L, SEEK_END);
+      buffer_len = ftell(infile);
+
+      /* Reset the file indicator to the beginning of the file. */
+      fseek(infile, 0L, SEEK_SET);
+
+      /* Allocate a buffer for the file contents. */
+      buffer = (uint8_t *)calloc(buffer_len, sizeof(uint8_t));
+      if(buffer)
+      {
+        /* Read all the text from the file into the buffer. */
+        fread(buffer, sizeof(uint8_t), buffer_len, infile);
+        printf("Read %zu bytes, fuzzing.. ", buffer_len);
+
+        /* Call the fuzzer with the data. */
+        LLVMFuzzerTestOneInput(buffer, buffer_len);
+
+        printf("complete !!");
+
+        /* Free the buffer as it's no longer needed. */
+        free(buffer);
+        buffer = NULL;
+      }
+      else
+      {
+        fprintf(stderr,
+                "[%s] Failed to allocate %zu bytes \n",
+                argv[ii],
+                buffer_len);
+      }
+
+      /* Close the file as it's no longer needed. */
+      fclose(infile);
+      infile = NULL;
+    }
+    else
+    {
+      /* Failed to open the file. Maybe wrong name or wrong permissions? */
+      fprintf(stderr, "[%s] Open failed. \n", argv[ii]);
+    }
+
+    printf("\n");
+  }
+}
diff --git a/lz4/ossfuzz/travisoss.sh b/lz4/ossfuzz/travisoss.sh
new file mode 100755
index 0000000..eae9a80
--- /dev/null
+++ b/lz4/ossfuzz/travisoss.sh
@@ -0,0 +1,26 @@
+#!/bin/bash
+
+set -ex
+
+# Clone the oss-fuzz repository
+git clone https://github.com/google/oss-fuzz.git /tmp/ossfuzz
+
+if [[ ! -d /tmp/ossfuzz/projects/lz4 ]]
+then
+    echo "Could not find the lz4 project in ossfuzz"
+    exit 1
+fi
+
+# Modify the oss-fuzz Dockerfile so that we're checking out the current branch on travis.
+if [ "x${TRAVIS_PULL_REQUEST}" = "xfalse" ]
+then
+    sed -i "s@https://github.com/lz4/lz4.git@-b ${TRAVIS_BRANCH} https://github.com/lz4/lz4.git@" /tmp/ossfuzz/projects/lz4/Dockerfile
+else
+    sed -i "s@https://github.com/lz4/lz4.git@-b ${TRAVIS_PULL_REQUEST_BRANCH} https://github.com/${TRAVIS_PULL_REQUEST_SLUG}.git@" /tmp/ossfuzz/projects/lz4/Dockerfile
+fi
+
+# Try and build the fuzzers
+pushd /tmp/ossfuzz
+python infra/helper.py build_image --pull lz4
+python infra/helper.py build_fuzzers lz4
+popd
diff --git a/lz4/programs/.gitignore b/lz4/programs/.gitignore
new file mode 100644
index 0000000..9ffadd9
--- /dev/null
+++ b/lz4/programs/.gitignore
@@ -0,0 +1,21 @@
+# local binary (Makefile)
+lz4
+unlz4
+lz4cat
+lz4c
+lz4c32
+lz4-wlib
+datagen
+frametest
+frametest32
+fullbench
+fullbench32
+fuzzer
+fuzzer32
+*.exe
+
+# tests files
+tmp*
+
+# artefacts
+*.dSYM
diff --git a/lz4/programs/COPYING b/lz4/programs/COPYING
new file mode 100644
index 0000000..d159169
--- /dev/null
+++ b/lz4/programs/COPYING
@@ -0,0 +1,339 @@
+                    GNU GENERAL PUBLIC LICENSE
+                       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+                            NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    
+    Copyright (C)   
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  , 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.
diff --git a/lz4/programs/Makefile b/lz4/programs/Makefile
new file mode 100644
index 0000000..c1053f6
--- /dev/null
+++ b/lz4/programs/Makefile
@@ -0,0 +1,187 @@
+# ##########################################################################
+# LZ4 programs - Makefile
+# Copyright (C) Yann Collet 2011-2017
+#
+# This Makefile is validated for Linux, macOS, *BSD, Hurd, Solaris, MSYS2 targets
+#
+# GPL v2 License
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# You can contact the author at :
+#  - LZ4 homepage : http://www.lz4.org
+#  - LZ4 source repository : https://github.com/lz4/lz4
+# ##########################################################################
+# lz4 : Command Line Utility, supporting gzip-like arguments
+# lz4c  : CLU, supporting also legacy lz4demo arguments
+# lz4c32: Same as lz4c, but forced to compile in 32-bits mode
+# ##########################################################################
+
+# Version numbers
+LZ4DIR   := ../lib
+LIBVER_SRC := $(LZ4DIR)/lz4.h
+LIBVER_MAJOR_SCRIPT:=`sed -n '/define LZ4_VERSION_MAJOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < $(LIBVER_SRC)`
+LIBVER_MINOR_SCRIPT:=`sed -n '/define LZ4_VERSION_MINOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < $(LIBVER_SRC)`
+LIBVER_PATCH_SCRIPT:=`sed -n '/define LZ4_VERSION_RELEASE/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < $(LIBVER_SRC)`
+LIBVER_SCRIPT:= $(LIBVER_MAJOR_SCRIPT).$(LIBVER_MINOR_SCRIPT).$(LIBVER_PATCH_SCRIPT)
+LIBVER_MAJOR := $(shell echo $(LIBVER_MAJOR_SCRIPT))
+LIBVER_MINOR := $(shell echo $(LIBVER_MINOR_SCRIPT))
+LIBVER_PATCH := $(shell echo $(LIBVER_PATCH_SCRIPT))
+LIBVER   := $(shell echo $(LIBVER_SCRIPT))
+
+LIBFILES  = $(wildcard $(LZ4DIR)/*.c)
+SRCFILES  = $(sort $(LIBFILES) $(wildcard *.c))
+OBJFILES  = $(SRCFILES:.c=.o)
+
+CPPFLAGS += -I$(LZ4DIR) -DXXH_NAMESPACE=LZ4_
+CFLAGS   ?= -O3
+DEBUGFLAGS= -Wall -Wextra -Wundef -Wcast-qual -Wcast-align -Wshadow \
+            -Wswitch-enum -Wdeclaration-after-statement -Wstrict-prototypes \
+            -Wpointer-arith -Wstrict-aliasing=1
+CFLAGS   += $(DEBUGFLAGS) $(MOREFLAGS)
+FLAGS     = $(CFLAGS) $(CPPFLAGS) $(LDFLAGS)
+
+LZ4_VERSION=$(LIBVER)
+MD2ROFF   = ronn
+MD2ROFF_FLAGS = --roff --warnings --manual="User Commands" --organization="lz4 $(LZ4_VERSION)"
+
+include ../Makefile.inc
+
+default: lz4-release
+
+all: lz4 lz4c
+
+all32: CFLAGS+=-m32
+all32: all
+
+ifeq ($(WINBASED),yes)
+lz4-exe.rc: lz4-exe.rc.in
+	@echo creating executable resource
+	$(Q)sed -e 's|@PROGNAME@|lz4|' \
+         -e 's|@LIBVER_MAJOR@|$(LIBVER_MAJOR)|g' \
+         -e 's|@LIBVER_MINOR@|$(LIBVER_MINOR)|g' \
+         -e 's|@LIBVER_PATCH@|$(LIBVER_PATCH)|g' \
+         -e 's|@EXT@|$(EXT)|g' \
+          $< >$@
+
+lz4-exe.o: lz4-exe.rc
+	$(WINDRES) -i lz4-exe.rc -o lz4-exe.o
+
+lz4: $(OBJFILES) lz4-exe.o
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+else
+lz4: $(OBJFILES)
+	$(CC) $(FLAGS) $(OBJFILES) -o $@$(EXT) $(LDLIBS)
+endif
+
+.PHONY: lz4-release
+lz4-release: DEBUGFLAGS=
+lz4-release: lz4
+
+lz4-wlib: LIBFILES =
+lz4-wlib: SRCFILES+= $(LZ4DIR)/xxhash.c  # benchmark unit needs XXH64()
+lz4-wlib: LDFLAGS += -L $(LZ4DIR)
+lz4-wlib: LDLIBS   = -llz4
+lz4-wlib: liblz4 $(OBJFILES)
+	@echo WARNING: $@ must link to an extended variant of the dynamic library which also exposes unstable symbols
+	$(CC) $(FLAGS) $(OBJFILES) -o $@$(EXT) $(LDLIBS)
+
+.PHONY:liblz4
+liblz4:
+	CPPFLAGS="-DLZ4F_PUBLISH_STATIC_FUNCTIONS -DLZ4_PUBLISH_STATIC_FUNCTIONS" $(MAKE) -C $(LZ4DIR) liblz4
+
+lz4c: lz4
+	$(LN_SF) lz4$(EXT) lz4c$(EXT)
+
+lz4c32: CFLAGS += -m32
+lz4c32 : $(SRCFILES)
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+lz4.1: lz4.1.md $(LIBVER_SRC)
+	cat $< | $(MD2ROFF) $(MD2ROFF_FLAGS) | sed -n '/^\.\\\".*/!p' > $@
+
+man: lz4.1
+
+clean-man:
+	$(RM) lz4.1
+
+preview-man: clean-man man
+	man ./lz4.1
+
+clean:
+ifeq ($(WINBASED),yes)
+	$(Q)$(RM) *.rc
+endif
+	@$(MAKE) -C $(LZ4DIR) $@ > $(VOID)
+	@$(RM) core *.o *.test tmp* \
+           lz4$(EXT) lz4c$(EXT) lz4c32$(EXT) lz4-wlib$(EXT) \
+           unlz4$(EXT) lz4cat$(EXT)
+	@echo Cleaning completed
+
+
+#-----------------------------------------------------------------------------
+# make install is validated only for Linux, OSX, BSD, Hurd and Solaris targets
+#-----------------------------------------------------------------------------
+ifeq ($(POSIX_ENV),Yes)
+
+unlz4: lz4
+	$(LN_SF) lz4$(EXT) unlz4$(EXT)
+
+lz4cat: lz4
+	$(LN_SF) lz4$(EXT) lz4cat$(EXT)
+
+DESTDIR     ?=
+# directory variables : GNU conventions prefer lowercase
+# see https://www.gnu.org/prep/standards/html_node/Makefile-Conventions.html
+# support both lower and uppercase (BSD), use lowercase in script
+PREFIX      ?= /usr/local
+prefix      ?= $(PREFIX)
+EXEC_PREFIX ?= $(prefix)
+exec_prefix ?= $(EXEC_PREFIX)
+BINDIR      ?= $(exec_prefix)/bin
+bindir      ?= $(BINDIR)
+DATAROOTDIR ?= $(prefix)/share
+datarootdir ?= $(DATAROOTDIR)
+MANDIR      ?= $(datarootdir)/man
+mandir      ?= $(MANDIR)
+MAN1DIR     ?= $(mandir)/man1
+man1dir     ?= $(MAN1DIR)
+
+install: lz4
+	@echo Installing binaries
+	@$(INSTALL_DIR) $(DESTDIR)$(bindir)/ $(DESTDIR)$(man1dir)/
+	@$(INSTALL_PROGRAM) lz4$(EXT) $(DESTDIR)$(bindir)/lz4$(EXT)
+	@$(LN_S) lz4$(EXT) $(DESTDIR)$(bindir)/lz4c$(EXT)
+	@$(LN_S) lz4$(EXT) $(DESTDIR)$(bindir)/lz4cat$(EXT)
+	@$(LN_S) lz4$(EXT) $(DESTDIR)$(bindir)/unlz4$(EXT)
+	@echo Installing man pages
+	@$(INSTALL_DATA) lz4.1 $(DESTDIR)$(man1dir)/lz4.1
+	@$(LN_SF) lz4.1 $(DESTDIR)$(man1dir)/lz4c.1
+	@$(LN_SF) lz4.1 $(DESTDIR)$(man1dir)/lz4cat.1
+	@$(LN_SF) lz4.1 $(DESTDIR)$(man1dir)/unlz4.1
+	@echo lz4 installation completed
+
+uninstall:
+	@$(RM) $(DESTDIR)$(bindir)/lz4cat$(EXT)
+	@$(RM) $(DESTDIR)$(bindir)/unlz4$(EXT)
+	@$(RM) $(DESTDIR)$(bindir)/lz4$(EXT)
+	@$(RM) $(DESTDIR)$(bindir)/lz4c$(EXT)
+	@$(RM) $(DESTDIR)$(man1dir)/lz4.1
+	@$(RM) $(DESTDIR)$(man1dir)/lz4c.1
+	@$(RM) $(DESTDIR)$(man1dir)/lz4cat.1
+	@$(RM) $(DESTDIR)$(man1dir)/unlz4.1
+	@echo lz4 programs successfully uninstalled
+
+endif
diff --git a/lz4/programs/README.md b/lz4/programs/README.md
new file mode 100644
index 0000000..c1995af
--- /dev/null
+++ b/lz4/programs/README.md
@@ -0,0 +1,84 @@
+Command Line Interface for LZ4 library
+============================================
+
+### Build
+The Command Line Interface (CLI) can be generated
+using the `make` command without any additional parameters.
+
+The `Makefile` script supports all [standard conventions](https://www.gnu.org/prep/standards/html_node/Makefile-Conventions.html),
+including standard targets (`all`, `install`, `clean`, etc.)
+and standard variables (`CC`, `CFLAGS`, `CPPFLAGS`, etc.).
+
+For advanced use cases, there are targets to different variations of the CLI:
+- `lz4` : default CLI, with a command line syntax close to gzip
+- `lz4c` : Same as `lz4` with additional support legacy lz4 commands (incompatible with gzip)
+- `lz4c32` : Same as `lz4c`, but forced to compile in 32-bits mode
+
+The CLI generates and decodes [LZ4-compressed frames](../doc/lz4_Frame_format.md).
+
+
+#### Aggregation of parameters
+CLI supports aggregation of parameters i.e. `-b1`, `-e18`, and `-i1` can be joined into `-b1e18i1`.
+
+
+#### Benchmark in Command Line Interface
+CLI includes in-memory compression benchmark module for lz4.
+The benchmark is conducted using a given filename.
+The file is read into memory.
+It makes benchmark more precise as it eliminates I/O overhead.
+
+The benchmark measures ratio, compressed size, compression and decompression speed.
+One can select compression levels starting from `-b` and ending with `-e`.
+The `-i` parameter selects a number of seconds used for each of tested levels.
+
+
+
+#### Usage of Command Line Interface
+The full list of commands can be obtained with `-h` or `-H` parameter:
+```
+Usage :
+      lz4 [arg] [input] [output]
+
+input   : a filename
+          with no FILE, or when FILE is - or stdin, read standard input
+Arguments :
+ -1     : Fast compression (default)
+ -9     : High compression
+ -d     : decompression (default for .lz4 extension)
+ -z     : force compression
+ -D FILE: use FILE as dictionary
+ -f     : overwrite output without prompting
+ -k     : preserve source files(s)  (default)
+--rm    : remove source file(s) after successful de/compression
+ -h/-H  : display help/long help and exit
+
+Advanced arguments :
+ -V     : display Version number and exit
+ -v     : verbose mode
+ -q     : suppress warnings; specify twice to suppress errors too
+ -c     : force write to standard output, even if it is the console
+ -t     : test compressed file integrity
+ -m     : multiple input files (implies automatic output filenames)
+ -r     : operate recursively on directories (sets also -m)
+ -l     : compress using Legacy format (Linux kernel compression)
+ -B#    : cut file into blocks of size # bytes [32+]
+                     or predefined block size [4-7] (default: 7)
+ -BD    : Block dependency (improve compression ratio)
+ -BX    : enable block checksum (default:disabled)
+--no-frame-crc : disable stream checksum (default:enabled)
+--content-size : compressed frame includes original size (default:not present)
+--[no-]sparse  : sparse mode (default:enabled on file, disabled on stdout)
+--favor-decSpeed: compressed files decompress faster, but are less compressed
+--fast[=#]: switch to ultra fast compression level (default: 1)
+
+Benchmark arguments :
+ -b#    : benchmark file(s), using # compression level (default : 1)
+ -e#    : test all compression levels from -bX to # (default : 1)
+ -i#    : minimum evaluation time in seconds (default : 3s)```
+```
+
+#### License
+
+All files in this directory are licensed under GPL-v2.
+See [COPYING](COPYING) for details.
+The text of the license is also included at the top of each source file.
diff --git a/lz4/programs/bench.c b/lz4/programs/bench.c
new file mode 100644
index 0000000..3357d14
--- /dev/null
+++ b/lz4/programs/bench.c
@@ -0,0 +1,746 @@
+/*
+    bench.c - Demo program to benchmark open-source compression algorithms
+    Copyright (C) Yann Collet 2012-2016
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+    - LZ4 homepage : http://www.lz4.org
+    - LZ4 source repository : https://github.com/lz4/lz4
+*/
+
+
+/*-************************************
+*  Compiler options
+**************************************/
+#ifdef _MSC_VER    /* Visual Studio */
+#  pragma warning(disable : 4127)    /* disable: C4127: conditional expression is constant */
+#endif
+
+
+/* *************************************
+*  Includes
+***************************************/
+#include "platform.h"    /* Compiler options */
+#include "util.h"        /* UTIL_GetFileSize, UTIL_sleep */
+#include       /* malloc, free */
+#include       /* memset */
+#include        /* fprintf, fopen, ftello */
+#include         /* clock_t, clock, CLOCKS_PER_SEC */
+#include       /* assert */
+
+#include "datagen.h"     /* RDG_genBuffer */
+#include "xxhash.h"
+#include "bench.h"
+
+#define LZ4_STATIC_LINKING_ONLY
+#include "lz4.h"
+#define LZ4_HC_STATIC_LINKING_ONLY
+#include "lz4hc.h"
+
+
+/* *************************************
+*  Compression parameters and functions
+***************************************/
+
+struct compressionParameters
+{
+    int cLevel;
+    const char* dictBuf;
+    int dictSize;
+
+    LZ4_stream_t* LZ4_stream;
+    LZ4_stream_t* LZ4_dictStream;
+    LZ4_streamHC_t* LZ4_streamHC;
+    LZ4_streamHC_t* LZ4_dictStreamHC;
+
+    void (*initFunction)(
+        struct compressionParameters* pThis);
+    void (*resetFunction)(
+        const struct compressionParameters* pThis);
+    int (*blockFunction)(
+        const struct compressionParameters* pThis,
+        const char* src, char* dst, int srcSize, int dstSize);
+    void (*cleanupFunction)(
+        const struct compressionParameters* pThis);
+};
+
+static void LZ4_compressInitNoStream(
+    struct compressionParameters* pThis)
+{
+    pThis->LZ4_stream = NULL;
+    pThis->LZ4_dictStream = NULL;
+    pThis->LZ4_streamHC = NULL;
+    pThis->LZ4_dictStreamHC = NULL;
+}
+
+static void LZ4_compressInitStream(
+    struct compressionParameters* pThis)
+{
+    pThis->LZ4_stream = LZ4_createStream();
+    pThis->LZ4_dictStream = LZ4_createStream();
+    pThis->LZ4_streamHC = NULL;
+    pThis->LZ4_dictStreamHC = NULL;
+    LZ4_loadDict(pThis->LZ4_dictStream, pThis->dictBuf, pThis->dictSize);
+}
+
+static void LZ4_compressInitStreamHC(
+    struct compressionParameters* pThis)
+{
+    pThis->LZ4_stream = NULL;
+    pThis->LZ4_dictStream = NULL;
+    pThis->LZ4_streamHC = LZ4_createStreamHC();
+    pThis->LZ4_dictStreamHC = LZ4_createStreamHC();
+    LZ4_loadDictHC(pThis->LZ4_dictStreamHC, pThis->dictBuf, pThis->dictSize);
+}
+
+static void LZ4_compressResetNoStream(
+    const struct compressionParameters* pThis)
+{
+    (void)pThis;
+}
+
+static void LZ4_compressResetStream(
+    const struct compressionParameters* pThis)
+{
+    LZ4_resetStream_fast(pThis->LZ4_stream);
+    LZ4_attach_dictionary(pThis->LZ4_stream, pThis->LZ4_dictStream);
+}
+
+static void LZ4_compressResetStreamHC(
+    const struct compressionParameters* pThis)
+{
+    LZ4_resetStreamHC_fast(pThis->LZ4_streamHC, pThis->cLevel);
+    LZ4_attach_HC_dictionary(pThis->LZ4_streamHC, pThis->LZ4_dictStreamHC);
+}
+
+static int LZ4_compressBlockNoStream(
+    const struct compressionParameters* pThis,
+    const char* src, char* dst,
+    int srcSize, int dstSize)
+{
+    int const acceleration = (pThis->cLevel < 0) ? -pThis->cLevel + 1 : 1;
+    return LZ4_compress_fast(src, dst, srcSize, dstSize, acceleration);
+}
+
+static int LZ4_compressBlockNoStreamHC(
+    const struct compressionParameters* pThis,
+    const char* src, char* dst,
+    int srcSize, int dstSize)
+{
+    return LZ4_compress_HC(src, dst, srcSize, dstSize, pThis->cLevel);
+}
+
+static int LZ4_compressBlockStream(
+    const struct compressionParameters* pThis,
+    const char* src, char* dst,
+    int srcSize, int dstSize)
+{
+    int const acceleration = (pThis->cLevel < 0) ? -pThis->cLevel + 1 : 1;
+    return LZ4_compress_fast_continue(pThis->LZ4_stream, src, dst, srcSize, dstSize, acceleration);
+}
+
+static int LZ4_compressBlockStreamHC(
+    const struct compressionParameters* pThis,
+    const char* src, char* dst,
+    int srcSize, int dstSize)
+{
+    return LZ4_compress_HC_continue(pThis->LZ4_streamHC, src, dst, srcSize, dstSize);
+}
+
+static void LZ4_compressCleanupNoStream(
+    const struct compressionParameters* pThis)
+{
+    (void)pThis;
+}
+
+static void LZ4_compressCleanupStream(
+    const struct compressionParameters* pThis)
+{
+    LZ4_freeStream(pThis->LZ4_stream);
+    LZ4_freeStream(pThis->LZ4_dictStream);
+}
+
+static void LZ4_compressCleanupStreamHC(
+    const struct compressionParameters* pThis)
+{
+    LZ4_freeStreamHC(pThis->LZ4_streamHC);
+    LZ4_freeStreamHC(pThis->LZ4_dictStreamHC);
+}
+
+static void LZ4_buildCompressionParameters(
+    struct compressionParameters* pParams,
+    int cLevel, const char* dictBuf, int dictSize)
+{
+    pParams->cLevel = cLevel;
+    pParams->dictBuf = dictBuf;
+    pParams->dictSize = dictSize;
+
+    if (dictSize) {
+        if (cLevel < LZ4HC_CLEVEL_MIN) {
+            pParams->initFunction = LZ4_compressInitStream;
+            pParams->resetFunction = LZ4_compressResetStream;
+            pParams->blockFunction = LZ4_compressBlockStream;
+            pParams->cleanupFunction = LZ4_compressCleanupStream;
+        } else {
+            pParams->initFunction = LZ4_compressInitStreamHC;
+            pParams->resetFunction = LZ4_compressResetStreamHC;
+            pParams->blockFunction = LZ4_compressBlockStreamHC;
+            pParams->cleanupFunction = LZ4_compressCleanupStreamHC;
+        }
+    } else {
+        pParams->initFunction = LZ4_compressInitNoStream;
+        pParams->resetFunction = LZ4_compressResetNoStream;
+        pParams->cleanupFunction = LZ4_compressCleanupNoStream;
+
+        if (cLevel < LZ4HC_CLEVEL_MIN) {
+            pParams->blockFunction = LZ4_compressBlockNoStream;
+        } else {
+            pParams->blockFunction = LZ4_compressBlockNoStreamHC;
+        }
+    }
+}
+
+#define LZ4_isError(errcode) (errcode==0)
+
+
+/* *************************************
+*  Constants
+***************************************/
+#ifndef LZ4_GIT_COMMIT_STRING
+#  define LZ4_GIT_COMMIT_STRING ""
+#else
+#  define LZ4_GIT_COMMIT_STRING LZ4_EXPAND_AND_QUOTE(LZ4_GIT_COMMIT)
+#endif
+
+#define NBSECONDS             3
+#define TIMELOOP_MICROSEC     1*1000000ULL /* 1 second */
+#define TIMELOOP_NANOSEC      1*1000000000ULL /* 1 second */
+#define ACTIVEPERIOD_MICROSEC 70*1000000ULL /* 70 seconds */
+#define COOLPERIOD_SEC        10
+#define DECOMP_MULT           1 /* test decompression DECOMP_MULT times longer than compression */
+
+#define KB *(1 <<10)
+#define MB *(1 <<20)
+#define GB *(1U<<30)
+
+#define LZ4_MAX_DICT_SIZE (64 KB)
+
+static const size_t maxMemory = (sizeof(size_t)==4)  ?  (2 GB - 64 MB) : (size_t)(1ULL << ((sizeof(size_t)*8)-31));
+
+static U32 g_compressibilityDefault = 50;
+
+
+/* *************************************
+*  console display
+***************************************/
+#define DISPLAY(...)         fprintf(stderr, __VA_ARGS__)
+#define DISPLAYLEVEL(l, ...) if (g_displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+static U32 g_displayLevel = 2;   /* 0 : no display;   1: errors;   2 : + result + interaction + warnings;   3 : + progression;   4 : + information */
+
+#define DISPLAYUPDATE(l, ...) if (g_displayLevel>=l) { \
+            if ((clock() - g_time > refreshRate) || (g_displayLevel>=4)) \
+            { g_time = clock(); DISPLAY(__VA_ARGS__); \
+            if (g_displayLevel>=4) fflush(stdout); } }
+static const clock_t refreshRate = CLOCKS_PER_SEC * 15 / 100;
+static clock_t g_time = 0;
+
+
+/* *************************************
+*  Exceptions
+***************************************/
+#ifndef DEBUG
+#  define DEBUG 0
+#endif
+#define DEBUGOUTPUT(...) if (DEBUG) DISPLAY(__VA_ARGS__);
+#define EXM_THROW(error, ...)                                             \
+{                                                                         \
+    DEBUGOUTPUT("Error defined at %s, line %i : \n", __FILE__, __LINE__); \
+    DISPLAYLEVEL(1, "Error %i : ", error);                                \
+    DISPLAYLEVEL(1, __VA_ARGS__);                                         \
+    DISPLAYLEVEL(1, "\n");                                                \
+    exit(error);                                                          \
+}
+
+
+/* *************************************
+*  Benchmark Parameters
+***************************************/
+static U32 g_nbSeconds = NBSECONDS;
+static size_t g_blockSize = 0;
+int g_additionalParam = 0;
+int g_benchSeparately = 0;
+
+void BMK_setNotificationLevel(unsigned level) { g_displayLevel=level; }
+
+void BMK_setAdditionalParam(int additionalParam) { g_additionalParam=additionalParam; }
+
+void BMK_setNbSeconds(unsigned nbSeconds)
+{
+    g_nbSeconds = nbSeconds;
+    DISPLAYLEVEL(3, "- test >= %u seconds per compression / decompression -\n", g_nbSeconds);
+}
+
+void BMK_setBlockSize(size_t blockSize) { g_blockSize = blockSize; }
+
+void BMK_setBenchSeparately(int separate) { g_benchSeparately = (separate!=0); }
+
+
+/* ********************************************************
+*  Bench functions
+**********************************************************/
+typedef struct {
+    const char* srcPtr;
+    size_t srcSize;
+    char*  cPtr;
+    size_t cRoom;
+    size_t cSize;
+    char*  resPtr;
+    size_t resSize;
+} blockParam_t;
+
+#define MIN(a,b) ((a)<(b) ? (a) : (b))
+#define MAX(a,b) ((a)>(b) ? (a) : (b))
+
+static int BMK_benchMem(const void* srcBuffer, size_t srcSize,
+                        const char* displayName, int cLevel,
+                        const size_t* fileSizes, U32 nbFiles,
+                        const char* dictBuf, int dictSize)
+{
+    size_t const blockSize = (g_blockSize>=32 ? g_blockSize : srcSize) + (!srcSize) /* avoid div by 0 */ ;
+    U32 const maxNbBlocks = (U32) ((srcSize + (blockSize-1)) / blockSize) + nbFiles;
+    blockParam_t* const blockTable = (blockParam_t*) malloc(maxNbBlocks * sizeof(blockParam_t));
+    size_t const maxCompressedSize = LZ4_compressBound((int)srcSize) + (maxNbBlocks * 1024);   /* add some room for safety */
+    void* const compressedBuffer = malloc(maxCompressedSize);
+    void* const resultBuffer = malloc(srcSize);
+    U32 nbBlocks;
+    struct compressionParameters compP;
+
+    /* checks */
+    if (!compressedBuffer || !resultBuffer || !blockTable)
+        EXM_THROW(31, "allocation error : not enough memory");
+
+    if (strlen(displayName)>17) displayName += strlen(displayName)-17;   /* can only display 17 characters */
+
+    /* init */
+    LZ4_buildCompressionParameters(&compP, cLevel, dictBuf, dictSize);
+    compP.initFunction(&compP);
+
+    /* Init blockTable data */
+    {   const char* srcPtr = (const char*)srcBuffer;
+        char* cPtr = (char*)compressedBuffer;
+        char* resPtr = (char*)resultBuffer;
+        U32 fileNb;
+        for (nbBlocks=0, fileNb=0; fileNb ACTIVEPERIOD_MICROSEC) {
+                DISPLAYLEVEL(2, "\rcooling down ...    \r");
+                UTIL_sleep(COOLPERIOD_SEC);
+                coolTime = UTIL_getTime();
+            }
+
+            /* Compression */
+            DISPLAYLEVEL(2, "%2s-%-17.17s :%10u ->\r", marks[markNb], displayName, (U32)srcSize);
+            if (!cCompleted) memset(compressedBuffer, 0xE5, maxCompressedSize);  /* warm up and erase result buffer */
+
+            UTIL_sleepMilli(1);  /* give processor time to other processes */
+            UTIL_waitForNextTick();
+
+            if (!cCompleted) {   /* still some time to do compression tests */
+                UTIL_time_t const clockStart = UTIL_getTime();
+                U32 nbLoops;
+                for (nbLoops=0; nbLoops < nbCompressionLoops; nbLoops++) {
+                    U32 blockNb;
+                    compP.resetFunction(&compP);
+                    for (blockNb=0; blockNb 0) {
+                        if (clockSpan < fastestC * nbCompressionLoops)
+                            fastestC = clockSpan / nbCompressionLoops;
+                        assert(fastestC > 0);
+                        nbCompressionLoops = (U32)(TIMELOOP_NANOSEC / fastestC) + 1;  /* aim for ~1sec */
+                    } else {
+                        assert(nbCompressionLoops < 40000000);   /* avoid overflow */
+                        nbCompressionLoops *= 100;
+                    }
+                    totalCTime += clockSpan;
+                    cCompleted = totalCTime>maxTime;
+            }   }
+
+            cSize = 0;
+            { U32 blockNb; for (blockNb=0; blockNb%10u (%5.3f),%6.1f MB/s\r",
+                    marks[markNb], displayName, (U32)srcSize, (U32)cSize, ratio,
+                    ((double)srcSize / fastestC) * 1000 );
+
+            (void)fastestD; (void)crcOrig;   /*  unused when decompression disabled */
+#if 1
+            /* Decompression */
+            if (!dCompleted) memset(resultBuffer, 0xD6, srcSize);  /* warm result buffer */
+
+            UTIL_sleepMilli(5); /* give processor time to other processes */
+            UTIL_waitForNextTick();
+
+            if (!dCompleted) {
+                UTIL_time_t const clockStart = UTIL_getTime();
+                U32 nbLoops;
+                for (nbLoops=0; nbLoops < nbDecodeLoops; nbLoops++) {
+                    U32 blockNb;
+                    for (blockNb=0; blockNb 0) {
+                        if (clockSpan < fastestD * nbDecodeLoops)
+                            fastestD = clockSpan / nbDecodeLoops;
+                        assert(fastestD > 0);
+                        nbDecodeLoops = (U32)(TIMELOOP_NANOSEC / fastestD) + 1;  /* aim for ~1sec */
+                    } else {
+                        assert(nbDecodeLoops < 40000000);   /* avoid overflow */
+                        nbDecodeLoops *= 100;
+                    }
+                    totalDTime += clockSpan;
+                    dCompleted = totalDTime > (DECOMP_MULT*maxTime);
+            }   }
+
+            markNb = (markNb+1) % NB_MARKS;
+            DISPLAYLEVEL(2, "%2s-%-17.17s :%10u ->%10u (%5.3f),%6.1f MB/s ,%6.1f MB/s\r",
+                    marks[markNb], displayName, (U32)srcSize, (U32)cSize, ratio,
+                    ((double)srcSize / fastestC) * 1000,
+                    ((double)srcSize / fastestD) * 1000);
+
+            /* CRC Checking */
+            {   U64 const crcCheck = XXH64(resultBuffer, srcSize, 0);
+                if (crcOrig!=crcCheck) {
+                    size_t u;
+                    DISPLAY("\n!!! WARNING !!! %17s : Invalid Checksum : %x != %x   \n", displayName, (unsigned)crcOrig, (unsigned)crcCheck);
+                    for (u=0; u u) break;
+                                bacc += blockTable[segNb].srcSize;
+                            }
+                            pos = (U32)(u - bacc);
+                            bNb = pos / (128 KB);
+                            DISPLAY("(block %u, sub %u, pos %u) \n", segNb, bNb, pos);
+                            break;
+                        }
+                        if (u==srcSize-1) {  /* should never happen */
+                            DISPLAY("no difference detected\n");
+                    }   }
+                    break;
+            }   }   /* CRC Checking */
+#endif
+        }   /* for (testNb = 1; testNb <= (g_nbSeconds + !g_nbSeconds); testNb++) */
+
+        if (g_displayLevel == 1) {
+            double const cSpeed = ((double)srcSize / fastestC) * 1000;
+            double const dSpeed = ((double)srcSize / fastestD) * 1000;
+            if (g_additionalParam)
+                DISPLAY("-%-3i%11i (%5.3f) %6.2f MB/s %6.1f MB/s  %s (param=%d)\n", cLevel, (int)cSize, ratio, cSpeed, dSpeed, displayName, g_additionalParam);
+            else
+                DISPLAY("-%-3i%11i (%5.3f) %6.2f MB/s %6.1f MB/s  %s\n", cLevel, (int)cSize, ratio, cSpeed, dSpeed, displayName);
+        }
+        DISPLAYLEVEL(2, "%2i#\n", cLevel);
+    }   /* Bench */
+
+    /* clean up */
+    compP.cleanupFunction(&compP);
+    free(blockTable);
+    free(compressedBuffer);
+    free(resultBuffer);
+    return 0;
+}
+
+
+static size_t BMK_findMaxMem(U64 requiredMem)
+{
+    size_t step = 64 MB;
+    BYTE* testmem=NULL;
+
+    requiredMem = (((requiredMem >> 26) + 1) << 26);
+    requiredMem += 2*step;
+    if (requiredMem > maxMemory) requiredMem = maxMemory;
+
+    while (!testmem) {
+        if (requiredMem > step) requiredMem -= step;
+        else requiredMem >>= 1;
+        testmem = (BYTE*) malloc ((size_t)requiredMem);
+    }
+    free (testmem);
+
+    /* keep some space available */
+    if (requiredMem > step) requiredMem -= step;
+    else requiredMem >>= 1;
+
+    return (size_t)requiredMem;
+}
+
+
+static void BMK_benchCLevel(void* srcBuffer, size_t benchedSize,
+                            const char* displayName, int cLevel, int cLevelLast,
+                            const size_t* fileSizes, unsigned nbFiles,
+                            const char* dictBuf, int dictSize)
+{
+    int l;
+
+    const char* pch = strrchr(displayName, '\\'); /* Windows */
+    if (!pch) pch = strrchr(displayName, '/'); /* Linux */
+    if (pch) displayName = pch+1;
+
+    SET_REALTIME_PRIORITY;
+
+    if (g_displayLevel == 1 && !g_additionalParam)
+        DISPLAY("bench %s %s: input %u bytes, %u seconds, %u KB blocks\n", LZ4_VERSION_STRING, LZ4_GIT_COMMIT_STRING, (U32)benchedSize, g_nbSeconds, (U32)(g_blockSize>>10));
+
+    if (cLevelLast < cLevel) cLevelLast = cLevel;
+
+    for (l=cLevel; l <= cLevelLast; l++) {
+        BMK_benchMem(srcBuffer, benchedSize,
+                     displayName, l,
+                     fileSizes, nbFiles,
+                     dictBuf, dictSize);
+    }
+}
+
+
+/*! BMK_loadFiles() :
+    Loads `buffer` with content of files listed within `fileNamesTable`.
+    At most, fills `buffer` entirely */
+static void BMK_loadFiles(void* buffer, size_t bufferSize,
+                          size_t* fileSizes,
+                          const char** fileNamesTable, unsigned nbFiles)
+{
+    size_t pos = 0, totalSize = 0;
+    unsigned n;
+    for (n=0; n bufferSize-pos) { /* buffer too small - stop after this file */
+            fileSize = bufferSize-pos;
+            nbFiles=n;
+        }
+        { size_t const readSize = fread(((char*)buffer)+pos, 1, (size_t)fileSize, f);
+          if (readSize != (size_t)fileSize) EXM_THROW(11, "could not read %s", fileNamesTable[n]);
+          pos += readSize; }
+        fileSizes[n] = (size_t)fileSize;
+        totalSize += (size_t)fileSize;
+        fclose(f);
+    }
+
+    if (totalSize == 0) EXM_THROW(12, "no data to bench");
+}
+
+static void BMK_benchFileTable(const char** fileNamesTable, unsigned nbFiles,
+                               int cLevel, int cLevelLast,
+                               const char* dictBuf, int dictSize)
+{
+    void* srcBuffer;
+    size_t benchedSize;
+    size_t* fileSizes = (size_t*)malloc(nbFiles * sizeof(size_t));
+    U64 const totalSizeToLoad = UTIL_getTotalFileSize(fileNamesTable, nbFiles);
+    char mfName[20] = {0};
+
+    if (!fileSizes) EXM_THROW(12, "not enough memory for fileSizes");
+
+    /* Memory allocation & restrictions */
+    benchedSize = BMK_findMaxMem(totalSizeToLoad * 3) / 3;
+    if (benchedSize==0) EXM_THROW(12, "not enough memory");
+    if ((U64)benchedSize > totalSizeToLoad) benchedSize = (size_t)totalSizeToLoad;
+    if (benchedSize > LZ4_MAX_INPUT_SIZE) {
+        benchedSize = LZ4_MAX_INPUT_SIZE;
+        DISPLAY("File(s) bigger than LZ4's max input size; testing %u MB only...\n", (U32)(benchedSize >> 20));
+    } else {
+        if (benchedSize < totalSizeToLoad)
+            DISPLAY("Not enough memory; testing %u MB only...\n", (U32)(benchedSize >> 20));
+    }
+    srcBuffer = malloc(benchedSize + !benchedSize);   /* avoid alloc of zero */
+    if (!srcBuffer) EXM_THROW(12, "not enough memory");
+
+    /* Load input buffer */
+    BMK_loadFiles(srcBuffer, benchedSize, fileSizes, fileNamesTable, nbFiles);
+
+    /* Bench */
+    snprintf (mfName, sizeof(mfName), " %u files", nbFiles);
+    {   const char* displayName = (nbFiles > 1) ? mfName : fileNamesTable[0];
+        BMK_benchCLevel(srcBuffer, benchedSize,
+                        displayName, cLevel, cLevelLast,
+                        fileSizes, nbFiles,
+                        dictBuf, dictSize);
+    }
+
+    /* clean up */
+    free(srcBuffer);
+    free(fileSizes);
+}
+
+
+static void BMK_syntheticTest(int cLevel, int cLevelLast, double compressibility,
+                              const char* dictBuf, int dictSize)
+{
+    char name[20] = {0};
+    size_t benchedSize = 10000000;
+    void* const srcBuffer = malloc(benchedSize);
+
+    /* Memory allocation */
+    if (!srcBuffer) EXM_THROW(21, "not enough memory");
+
+    /* Fill input buffer */
+    RDG_genBuffer(srcBuffer, benchedSize, compressibility, 0.0, 0);
+
+    /* Bench */
+    snprintf (name, sizeof(name), "Synthetic %2u%%", (unsigned)(compressibility*100));
+    BMK_benchCLevel(srcBuffer, benchedSize, name, cLevel, cLevelLast, &benchedSize, 1, dictBuf, dictSize);
+
+    /* clean up */
+    free(srcBuffer);
+}
+
+
+int BMK_benchFilesSeparately(const char** fileNamesTable, unsigned nbFiles,
+                   int cLevel, int cLevelLast,
+                   const char* dictBuf, int dictSize)
+{
+    unsigned fileNb;
+    if (cLevel > LZ4HC_CLEVEL_MAX) cLevel = LZ4HC_CLEVEL_MAX;
+    if (cLevelLast > LZ4HC_CLEVEL_MAX) cLevelLast = LZ4HC_CLEVEL_MAX;
+    if (cLevelLast < cLevel) cLevelLast = cLevel;
+    if (cLevelLast > cLevel) DISPLAYLEVEL(2, "Benchmarking levels from %d to %d\n", cLevel, cLevelLast);
+
+    for (fileNb=0; fileNb LZ4HC_CLEVEL_MAX) cLevel = LZ4HC_CLEVEL_MAX;
+    if (cLevelLast > LZ4HC_CLEVEL_MAX) cLevelLast = LZ4HC_CLEVEL_MAX;
+    if (cLevelLast < cLevel) cLevelLast = cLevel;
+    if (cLevelLast > cLevel) DISPLAYLEVEL(2, "Benchmarking levels from %d to %d\n", cLevel, cLevelLast);
+
+    if (dictFileName) {
+        FILE* dictFile = NULL;
+        U64 dictFileSize = UTIL_getFileSize(dictFileName);
+        if (!dictFileSize) EXM_THROW(25, "Dictionary error : could not stat dictionary file");
+
+        dictFile = fopen(dictFileName, "rb");
+        if (!dictFile) EXM_THROW(25, "Dictionary error : could not open dictionary file");
+
+        if (dictFileSize > LZ4_MAX_DICT_SIZE) {
+            dictSize = LZ4_MAX_DICT_SIZE;
+            if (UTIL_fseek(dictFile, dictFileSize - dictSize, SEEK_SET))
+                EXM_THROW(25, "Dictionary error : could not seek dictionary file");
+        } else {
+            dictSize = (int)dictFileSize;
+        }
+
+        dictBuf = (char *)malloc(dictSize);
+        if (!dictBuf) EXM_THROW(25, "Allocation error : not enough memory");
+
+        if (fread(dictBuf, 1, dictSize, dictFile) != (size_t)dictSize)
+            EXM_THROW(25, "Dictionary error : could not read dictionary file");
+
+        fclose(dictFile);
+    }
+
+    if (nbFiles == 0)
+        BMK_syntheticTest(cLevel, cLevelLast, compressibility, dictBuf, dictSize);
+    else {
+        if (g_benchSeparately)
+            BMK_benchFilesSeparately(fileNamesTable, nbFiles, cLevel, cLevelLast, dictBuf, dictSize);
+        else
+            BMK_benchFileTable(fileNamesTable, nbFiles, cLevel, cLevelLast, dictBuf, dictSize);
+    }
+
+    free(dictBuf);
+    return 0;
+}
diff --git a/lz4/programs/bench.h b/lz4/programs/bench.h
new file mode 100644
index 0000000..22ebf60
--- /dev/null
+++ b/lz4/programs/bench.h
@@ -0,0 +1,39 @@
+/*
+    bench.h - Demo program to benchmark open-source compression algorithm
+    Copyright (C) Yann Collet 2012-2016
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+    - LZ4 source repository : https://github.com/lz4/lz4
+    - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+#ifndef BENCH_H_125623623633
+#define BENCH_H_125623623633
+
+#include 
+
+int BMK_benchFiles(const char** fileNamesTable, unsigned nbFiles,
+                   int cLevel, int cLevelLast,
+                   const char* dictFileName);
+
+/* Set Parameters */
+void BMK_setNbSeconds(unsigned nbLoops);
+void BMK_setBlockSize(size_t blockSize);
+void BMK_setAdditionalParam(int additionalParam);
+void BMK_setNotificationLevel(unsigned level);
+void BMK_setBenchSeparately(int separate);
+
+#endif   /* BENCH_H_125623623633 */
diff --git a/lz4/programs/datagen.c b/lz4/programs/datagen.c
new file mode 100644
index 0000000..24a2da2
--- /dev/null
+++ b/lz4/programs/datagen.c
@@ -0,0 +1,189 @@
+/*
+    datagen.c - compressible data generator test tool
+    Copyright (C) Yann Collet 2012-2016
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+   - LZ4 source repository : https://github.com/lz4/lz4
+   - Public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+
+/**************************************
+*  Includes
+**************************************/
+#include "platform.h"  /* Compiler options, SET_BINARY_MODE */
+#include "util.h"      /* U32 */
+#include     /* malloc */
+#include      /* FILE, fwrite */
+#include     /* memcpy */
+#include 
+
+
+/**************************************
+*  Constants
+**************************************/
+#define KB *(1 <<10)
+
+#define PRIME1   2654435761U
+#define PRIME2   2246822519U
+
+
+/**************************************
+*  Local types
+**************************************/
+#define LTLOG 13
+#define LTSIZE (1<> (32 - r)))
+static unsigned int RDG_rand(U32* src)
+{
+    U32 rand32 = *src;
+    rand32 *= PRIME1;
+    rand32 ^= PRIME2;
+    rand32  = RDG_rotl32(rand32, 13);
+    *src = rand32;
+    return rand32;
+}
+
+
+static void RDG_fillLiteralDistrib(litDistribTable lt, double ld)
+{
+    BYTE const firstChar = ld <= 0.0 ? 0 : '(';
+    BYTE const lastChar  = ld <= 0.0 ? 255 : '}';
+    BYTE character = ld <= 0.0 ? 0 : '0';
+    U32 u = 0;
+
+    while (u lastChar) character = firstChar;
+    }
+}
+
+
+static BYTE RDG_genChar(U32* seed, const litDistribTable lt)
+{
+    U32 id = RDG_rand(seed) & LTMASK;
+    return (lt[id]);
+}
+
+
+#define RDG_DICTSIZE    (32 KB)
+#define RDG_RAND15BITS  ((RDG_rand(seed) >> 3) & 32767)
+#define RDG_RANDLENGTH  ( ((RDG_rand(seed) >> 7) & 7) ? (RDG_rand(seed) & 15) : (RDG_rand(seed) & 511) + 15)
+void RDG_genBlock(void* buffer, size_t buffSize, size_t prefixSize, double matchProba, litDistribTable lt, unsigned* seedPtr)
+{
+    BYTE* buffPtr = (BYTE*)buffer;
+    const U32 matchProba32 = (U32)(32768 * matchProba);
+    size_t pos = prefixSize;
+    U32* seed = seedPtr;
+
+    /* special case */
+    while (matchProba >= 1.0) {
+        size_t size0 = RDG_rand(seed) & 3;
+        size0  = (size_t)1 << (16 + size0 * 2);
+        size0 += RDG_rand(seed) & (size0-1);   /* because size0 is power of 2*/
+        if (buffSize < pos + size0) {
+            memset(buffPtr+pos, 0, buffSize-pos);
+            return;
+        }
+        memset(buffPtr+pos, 0, size0);
+        pos += size0;
+        buffPtr[pos-1] = RDG_genChar(seed, lt);
+    }
+
+    /* init */
+    if (pos==0) {
+        buffPtr[0] = RDG_genChar(seed, lt);
+        pos=1;
+    }
+
+    /* Generate compressible data */
+    while (pos < buffSize) {
+        /* Select : Literal (char) or Match (within 32K) */
+        if (RDG_RAND15BITS < matchProba32) {
+            /* Copy (within 32K) */
+            size_t match;
+            size_t d;
+            int length = RDG_RANDLENGTH + 4;
+            U32 offset = RDG_RAND15BITS + 1;
+            if (offset > pos) offset = (U32)pos;
+            match = pos - offset;
+            d = pos + length;
+            if (d > buffSize) d = buffSize;
+            while (pos < d) buffPtr[pos++] = buffPtr[match++];
+        } else {
+            /* Literal (noise) */
+            size_t d;
+            size_t length = RDG_RANDLENGTH;
+            d = pos + length;
+            if (d > buffSize) d = buffSize;
+            while (pos < d) buffPtr[pos++] = RDG_genChar(seed, lt);
+        }
+    }
+}
+
+
+void RDG_genBuffer(void* buffer, size_t size, double matchProba, double litProba, unsigned seed)
+{
+    litDistribTable lt;
+    if (litProba==0.0) litProba = matchProba / 4.5;
+    RDG_fillLiteralDistrib(lt, litProba);
+    RDG_genBlock(buffer, size, 0, matchProba, lt, &seed);
+}
+
+
+#define RDG_BLOCKSIZE (128 KB)
+void RDG_genOut(unsigned long long size, double matchProba, double litProba, unsigned seed)
+{
+    BYTE buff[RDG_DICTSIZE + RDG_BLOCKSIZE];
+    U64 total = 0;
+    size_t genBlockSize = RDG_BLOCKSIZE;
+    litDistribTable lt;
+
+    /* init */
+    if (litProba==0.0) litProba = matchProba / 4.5;
+    RDG_fillLiteralDistrib(lt, litProba);
+    SET_BINARY_MODE(stdout);
+
+    /* Generate dict */
+    RDG_genBlock(buff, RDG_DICTSIZE, 0, matchProba, lt, &seed);
+
+    /* Generate compressible data */
+    while (total < size) {
+        RDG_genBlock(buff, RDG_DICTSIZE+RDG_BLOCKSIZE, RDG_DICTSIZE, matchProba, lt, &seed);
+        if (size-total < RDG_BLOCKSIZE) genBlockSize = (size_t)(size-total);
+        total += genBlockSize;
+        fwrite(buff, 1, genBlockSize, stdout);  /* should check potential write error */
+        /* update dict */
+        memcpy(buff, buff + RDG_BLOCKSIZE, RDG_DICTSIZE);
+    }
+}
diff --git a/lz4/programs/datagen.h b/lz4/programs/datagen.h
new file mode 100644
index 0000000..91c5b02
--- /dev/null
+++ b/lz4/programs/datagen.h
@@ -0,0 +1,40 @@
+/*
+    datagen.h - compressible data generator header
+    Copyright (C) Yann Collet 2012-2016
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+   - LZ4 source repository : https://github.com/lz4/lz4
+   - Public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+
+
+#include    /* size_t */
+
+void RDG_genOut(unsigned long long size, double matchProba, double litProba, unsigned seed);
+void RDG_genBuffer(void* buffer, size_t size, double matchProba, double litProba, unsigned seed);
+/* RDG_genOut
+   Generate 'size' bytes of compressible data into stdout.
+   Compressibility can be controlled using 'matchProba'.
+   'LitProba' is optional, and affect variability of bytes. If litProba==0.0, default value is used.
+   Generated data can be selected using 'seed'.
+   If (matchProba, litProba and seed) are equal, the function always generate the same content.
+
+   RDG_genBuffer
+   Same as RDG_genOut, but generate data into provided buffer
+*/
diff --git a/lz4/programs/lz4-exe.rc.in b/lz4/programs/lz4-exe.rc.in
new file mode 100644
index 0000000..7b81030
--- /dev/null
+++ b/lz4/programs/lz4-exe.rc.in
@@ -0,0 +1,27 @@
+1 VERSIONINFO
+FILEVERSION       @LIBVER_MAJOR@,@LIBVER_MINOR@,@LIBVER_PATCH@,0
+PRODUCTVERSION    @LIBVER_MAJOR@,@LIBVER_MINOR@,@LIBVER_PATCH@,0
+FILEFLAGSMASK 0
+FILEOS 0x40000
+FILETYPE 1
+{
+    BLOCK "StringFileInfo"
+    {
+        BLOCK "040904B0"
+        {
+            VALUE "CompanyName", "Yann Collet"
+            VALUE "FileDescription", "Extremely fast compression"
+            VALUE "FileVersion", "@LIBVER_MAJOR@.@LIBVER_MINOR@.@LIBVER_PATCH@.0"
+            VALUE "InternalName", "@PROGNAME@"
+            VALUE "LegalCopyright", "Copyright (C) 2013-2016, Yann Collet"
+            VALUE "OriginalFilename", "@PROGNAME@.@EXT@"
+            VALUE "ProductName", "LZ4"
+            VALUE "ProductVersion", "@LIBVER_MAJOR@.@LIBVER_MINOR@.@LIBVER_PATCH@.0"
+        }
+    }
+    BLOCK "VarFileInfo"
+    {
+        VALUE "Translation", 0x0409, 1200
+    }
+}
+
diff --git a/lz4/programs/lz4.1 b/lz4/programs/lz4.1
new file mode 100644
index 0000000..d758ed5
--- /dev/null
+++ b/lz4/programs/lz4.1
@@ -0,0 +1,241 @@
+.
+.TH "LZ4" "1" "July 2019" "lz4 1.9.2" "User Commands"
+.
+.SH "NAME"
+\fBlz4\fR \- lz4, unlz4, lz4cat \- Compress or decompress \.lz4 files
+.
+.SH "SYNOPSIS"
+\fBlz4\fR [\fIOPTIONS\fR] [\-|INPUT\-FILE] \fIOUTPUT\-FILE\fR
+.
+.P
+\fBunlz4\fR is equivalent to \fBlz4 \-d\fR
+.
+.P
+\fBlz4cat\fR is equivalent to \fBlz4 \-dcfm\fR
+.
+.P
+When writing scripts that need to decompress files, it is recommended to always use the name \fBlz4\fR with appropriate arguments (\fBlz4 \-d\fR or \fBlz4 \-dc\fR) instead of the names \fBunlz4\fR and \fBlz4cat\fR\.
+.
+.SH "DESCRIPTION"
+\fBlz4\fR is an extremely fast lossless compression algorithm, based on \fBbyte\-aligned LZ77\fR family of compression scheme\. \fBlz4\fR offers compression speeds of 400 MB/s per core, linearly scalable with multi\-core CPUs\. It features an extremely fast decoder, with speed in multiple GB/s per core, typically reaching RAM speed limit on multi\-core systems\. The native file format is the \fB\.lz4\fR format\.
+.
+.SS "Difference between lz4 and gzip"
+\fBlz4\fR supports a command line syntax similar \fIbut not identical\fR to \fBgzip(1)\fR\. Differences are :
+.
+.IP "\(bu" 4
+\fBlz4\fR compresses a single file by default (see \fB\-m\fR for multiple files)
+.
+.IP "\(bu" 4
+\fBlz4 file1 file2\fR means : compress file1 \fIinto\fR file2
+.
+.IP "\(bu" 4
+\fBlz4 file\.lz4\fR will default to decompression (use \fB\-z\fR to force compression)
+.
+.IP "\(bu" 4
+\fBlz4\fR preserves original files
+.
+.IP "\(bu" 4
+\fBlz4\fR shows real\-time notification statistics during compression or decompression of a single file (use \fB\-q\fR to silence them)
+.
+.IP "\(bu" 4
+When no destination is specified, result is sent on implicit output, which depends on \fBstdout\fR status\. When \fBstdout\fR \fIis Not the console\fR, it becomes the implicit output\. Otherwise, if \fBstdout\fR is the console, the implicit output is \fBfilename\.lz4\fR\.
+.
+.IP "\(bu" 4
+It is considered bad practice to rely on implicit output in scripts\. because the script\'s environment may change\. Always use explicit output in scripts\. \fB\-c\fR ensures that output will be \fBstdout\fR\. Conversely, providing a destination name, or using \fB\-m\fR ensures that the output will be either the specified name, or \fBfilename\.lz4\fR respectively\.
+.
+.IP "" 0
+.
+.P
+Default behaviors can be modified by opt\-in commands, detailed below\.
+.
+.IP "\(bu" 4
+\fBlz4 \-m\fR makes it possible to provide multiple input filenames, which will be compressed into files using suffix \fB\.lz4\fR\. Progress notifications become disabled by default (use \fB\-v\fR to enable them)\. This mode has a behavior which more closely mimics \fBgzip\fR command line, with the main remaining difference being that source files are preserved by default\.
+.
+.IP "\(bu" 4
+Similarly, \fBlz4 \-m \-d\fR can decompress multiple \fB*\.lz4\fR files\.
+.
+.IP "\(bu" 4
+It\'s possible to opt\-in to erase source files on successful compression or decompression, using \fB\-\-rm\fR command\.
+.
+.IP "\(bu" 4
+Consequently, \fBlz4 \-m \-\-rm\fR behaves the same as \fBgzip\fR\.
+.
+.IP "" 0
+.
+.SS "Concatenation of \.lz4 files"
+It is possible to concatenate \fB\.lz4\fR files as is\. \fBlz4\fR will decompress such files as if they were a single \fB\.lz4\fR file\. For example:
+.
+.IP "" 4
+.
+.nf
+
+lz4 file1  > foo\.lz4
+lz4 file2 >> foo\.lz4
+.
+.fi
+.
+.IP "" 0
+.
+.P
+Then \fBlz4cat foo\.lz4\fR is equivalent to \fBcat file1 file2\fR\.
+.
+.SH "OPTIONS"
+.
+.SS "Short commands concatenation"
+In some cases, some options can be expressed using short command \fB\-x\fR or long command \fB\-\-long\-word\fR\. Short commands can be concatenated together\. For example, \fB\-d \-c\fR is equivalent to \fB\-dc\fR\. Long commands cannot be concatenated\. They must be clearly separated by a space\.
+.
+.SS "Multiple commands"
+When multiple contradictory commands are issued on a same command line, only the latest one will be applied\.
+.
+.SS "Operation mode"
+.
+.TP
+\fB\-z\fR \fB\-\-compress\fR
+Compress\. This is the default operation mode when no operation mode option is specified, no other operation mode is implied from the command name (for example, \fBunlz4\fR implies \fB\-\-decompress\fR), nor from the input file name (for example, a file extension \fB\.lz4\fR implies \fB\-\-decompress\fR by default)\. \fB\-z\fR can also be used to force compression of an already compressed \fB\.lz4\fR file\.
+.
+.TP
+\fB\-d\fR \fB\-\-decompress\fR \fB\-\-uncompress\fR
+Decompress\. \fB\-\-decompress\fR is also the default operation when the input filename has an \fB\.lz4\fR extension\.
+.
+.TP
+\fB\-t\fR \fB\-\-test\fR
+Test the integrity of compressed \fB\.lz4\fR files\. The decompressed data is discarded\. No files are created nor removed\.
+.
+.TP
+\fB\-b#\fR
+Benchmark mode, using \fB#\fR compression level\.
+.
+.TP
+\fB\-\-list\fR
+List information about \.lz4 files\. note : current implementation is limited to single\-frame \.lz4 files\.
+.
+.SS "Operation modifiers"
+.
+.TP
+\fB\-#\fR
+Compression level, with # being any value from 1 to 12\. Higher values trade compression speed for compression ratio\. Values above 12 are considered the same as 12\. Recommended values are 1 for fast compression (default), and 9 for high compression\. Speed/compression trade\-off will vary depending on data to compress\. Decompression speed remains fast at all settings\.
+.
+.TP
+\fB\-\-fast[=#]\fR
+Switch to ultra\-fast compression levels\. The higher the value, the faster the compression speed, at the cost of some compression ratio\. If \fB=#\fR is not present, it defaults to \fB1\fR\. This setting overrides compression level if one was set previously\. Similarly, if a compression level is set after \fB\-\-fast\fR, it overrides it\.
+.
+.TP
+\fB\-\-best\fR
+Set highest compression level\. Same as -12\.
+.
+.TP
+\fB\-\-favor\-decSpeed\fR
+Generate compressed data optimized for decompression speed\. Compressed data will be larger as a consequence (typically by ~0\.5%), while decompression speed will be improved by 5\-20%, depending on use cases\. This option only works in combination with very high compression levels (>=10)\.
+.
+.TP
+\fB\-D dictionaryName\fR
+Compress, decompress or benchmark using dictionary \fIdictionaryName\fR\. Compression and decompression must use the same dictionary to be compatible\. Using a different dictionary during decompression will either abort due to decompression error, or generate a checksum error\.
+.
+.TP
+\fB\-f\fR \fB\-\-[no\-]force\fR
+This option has several effects:
+.
+.IP
+If the target file already exists, overwrite it without prompting\.
+.
+.IP
+When used with \fB\-\-decompress\fR and \fBlz4\fR cannot recognize the type of the source file, copy the source file as is to standard output\. This allows \fBlz4cat \-\-force\fR to be used like \fBcat (1)\fR for files that have not been compressed with \fBlz4\fR\.
+.
+.TP
+\fB\-c\fR \fB\-\-stdout\fR \fB\-\-to\-stdout\fR
+Force write to standard output, even if it is the console\.
+.
+.TP
+\fB\-m\fR \fB\-\-multiple\fR
+Multiple input files\. Compressed file names will be appended a \fB\.lz4\fR suffix\. This mode also reduces notification level\. Can also be used to list multiple files\. \fBlz4 \-m\fR has a behavior equivalent to \fBgzip \-k\fR (it preserves source files by default)\.
+.
+.TP
+\fB\-r\fR
+operate recursively on directories\. This mode also sets \fB\-m\fR (multiple input files)\.
+.
+.TP
+\fB\-B#\fR
+Block size [4\-7](default : 7)
+.
+.br
+\fB\-B4\fR= 64KB ; \fB\-B5\fR= 256KB ; \fB\-B6\fR= 1MB ; \fB\-B7\fR= 4MB
+.
+.TP
+\fB\-BI\fR
+Produce independent blocks (default)
+.
+.TP
+\fB\-BD\fR
+Blocks depend on predecessors (improves compression ratio, more noticeable on small blocks)
+.
+.TP
+\fB\-\-[no\-]frame\-crc\fR
+Select frame checksum (default:enabled)
+.
+.TP
+\fB\-\-[no\-]content\-size\fR
+Header includes original size (default:not present)
+.
+.br
+Note : this option can only be activated when the original size can be determined, hence for a file\. It won\'t work with unknown source size, such as stdin or pipe\.
+.
+.TP
+\fB\-\-[no\-]sparse\fR
+Sparse mode support (default:enabled on file, disabled on stdout)
+.
+.TP
+\fB\-l\fR
+Use Legacy format (typically for Linux Kernel compression)
+.
+.br
+Note : \fB\-l\fR is not compatible with \fB\-m\fR (\fB\-\-multiple\fR) nor \fB\-r\fR
+.
+.SS "Other options"
+.
+.TP
+\fB\-v\fR \fB\-\-verbose\fR
+Verbose mode
+.
+.TP
+\fB\-q\fR \fB\-\-quiet\fR
+Suppress warnings and real\-time statistics; specify twice to suppress errors too
+.
+.TP
+\fB\-h\fR \fB\-H\fR \fB\-\-help\fR
+Display help/long help and exit
+.
+.TP
+\fB\-V\fR \fB\-\-version\fR
+Display Version number and exit
+.
+.TP
+\fB\-k\fR \fB\-\-keep\fR
+Preserve source files (default behavior)
+.
+.TP
+\fB\-\-rm\fR
+Delete source files on successful compression or decompression
+.
+.TP
+\fB\-\-\fR
+Treat all subsequent arguments as files
+.
+.SS "Benchmark mode"
+.
+.TP
+\fB\-b#\fR
+Benchmark file(s), using # compression level
+.
+.TP
+\fB\-e#\fR
+Benchmark multiple compression levels, from b# to e# (included)
+.
+.TP
+\fB\-i#\fR
+Minimum evaluation time in seconds [1\-9] (default : 3)
+.
+.SH "BUGS"
+Report bugs at: https://github\.com/lz4/lz4/issues
+.
+.SH "AUTHOR"
+Yann Collet
diff --git a/lz4/programs/lz4.1.md b/lz4/programs/lz4.1.md
new file mode 100644
index 0000000..56c0053
--- /dev/null
+++ b/lz4/programs/lz4.1.md
@@ -0,0 +1,250 @@
+lz4(1) -- lz4, unlz4, lz4cat - Compress or decompress .lz4 files
+================================================================
+
+SYNOPSIS
+--------
+
+`lz4` [*OPTIONS*] [-|INPUT-FILE] 
+
+`unlz4` is equivalent to `lz4 -d`
+
+`lz4cat` is equivalent to `lz4 -dcfm`
+
+When writing scripts that need to decompress files,
+it is recommended to always use the name `lz4` with appropriate arguments
+(`lz4 -d` or `lz4 -dc`) instead of the names `unlz4` and `lz4cat`.
+
+
+DESCRIPTION
+-----------
+
+`lz4` is an extremely fast lossless compression algorithm,
+based on **byte-aligned LZ77** family of compression scheme.
+`lz4` offers compression speeds of 400 MB/s per core, linearly scalable with
+multi-core CPUs.
+It features an extremely fast decoder, with speed in multiple GB/s per core,
+typically reaching RAM speed limit on multi-core systems.
+The native file format is the `.lz4` format.
+
+### Difference between lz4 and gzip
+
+`lz4` supports a command line syntax similar _but not identical_ to `gzip(1)`.
+Differences are :
+
+  * `lz4` compresses a single file by default (see `-m` for multiple files)
+  * `lz4 file1 file2` means : compress file1 _into_ file2
+  * `lz4 file.lz4` will default to decompression (use `-z` to force compression)
+  * `lz4` preserves original files
+  * `lz4` shows real-time notification statistics
+     during compression or decompression of a single file
+     (use `-q` to silence them)
+  * When no destination is specified, result is sent on implicit output,
+    which depends on `stdout` status.
+    When `stdout` _is Not the console_, it becomes the implicit output.
+    Otherwise, if `stdout` is the console, the implicit output is `filename.lz4`.
+  * It is considered bad practice to rely on implicit output in scripts.
+    because the script's environment may change.
+    Always use explicit output in scripts.
+    `-c` ensures that output will be `stdout`.
+    Conversely, providing a destination name, or using `-m`
+    ensures that the output will be either the specified name, or `filename.lz4` respectively.
+
+Default behaviors can be modified by opt-in commands, detailed below.
+
+  * `lz4 -m` makes it possible to provide multiple input filenames,
+    which will be compressed into files using suffix `.lz4`.
+    Progress notifications become disabled by default (use `-v` to enable them).
+    This mode has a behavior which more closely mimics `gzip` command line,
+    with the main remaining difference being that source files are preserved by default.
+  * Similarly, `lz4 -m -d` can decompress multiple `*.lz4` files.
+  * It's possible to opt-in to erase source files
+    on successful compression or decompression, using `--rm` command.
+  * Consequently, `lz4 -m --rm` behaves the same as `gzip`.
+
+### Concatenation of .lz4 files
+
+It is possible to concatenate `.lz4` files as is.
+`lz4` will decompress such files as if they were a single `.lz4` file.
+For example:
+
+    lz4 file1  > foo.lz4
+    lz4 file2 >> foo.lz4
+
+Then `lz4cat foo.lz4` is equivalent to `cat file1 file2`.
+
+OPTIONS
+-------
+
+### Short commands concatenation
+
+In some cases, some options can be expressed using short command `-x`
+or long command `--long-word`.
+Short commands can be concatenated together.
+For example, `-d -c` is equivalent to `-dc`.
+Long commands cannot be concatenated. They must be clearly separated by a space.
+
+### Multiple commands
+
+When multiple contradictory commands are issued on a same command line,
+only the latest one will be applied.
+
+### Operation mode
+
+* `-z` `--compress`:
+  Compress.
+  This is the default operation mode when no operation mode option is
+  specified, no other operation mode is implied from the command name
+  (for example, `unlz4` implies `--decompress`),
+  nor from the input file name
+  (for example, a file extension `.lz4` implies  `--decompress` by default).
+  `-z` can also be used to force compression of an already compressed
+  `.lz4` file.
+
+* `-d` `--decompress` `--uncompress`:
+  Decompress.
+  `--decompress` is also the default operation when the input filename has an
+  `.lz4` extension.
+
+* `-t` `--test`:
+  Test the integrity of compressed `.lz4` files.
+  The decompressed data is discarded.
+  No files are created nor removed.
+
+* `-b#`:
+  Benchmark mode, using `#` compression level.
+
+* `--list`:
+  List information about .lz4 files.
+  note : current implementation is limited to single-frame .lz4 files.
+
+### Operation modifiers
+
+* `-#`:
+  Compression level, with # being any value from 1 to 12.
+  Higher values trade compression speed for compression ratio.
+  Values above 12 are considered the same as 12.
+  Recommended values are 1 for fast compression (default),
+  and 9 for high compression.
+  Speed/compression trade-off will vary depending on data to compress.
+  Decompression speed remains fast at all settings.
+
+* `--fast[=#]`:
+  Switch to ultra-fast compression levels.
+  The higher the value, the faster the compression speed, at the cost of some compression ratio.
+  If `=#` is not present, it defaults to `1`.
+  This setting overrides compression level if one was set previously.
+  Similarly, if a compression level is set after `--fast`, it overrides it.
+
+* `--best`:
+  Set highest compression level. Same as -12.
+
+* `--favor-decSpeed`:
+  Generate compressed data optimized for decompression speed.
+  Compressed data will be larger as a consequence (typically by ~0.5%),
+  while decompression speed will be improved by 5-20%, depending on use cases.
+  This option only works in combination with very high compression levels (>=10).
+
+* `-D dictionaryName`:
+  Compress, decompress or benchmark using dictionary _dictionaryName_.
+  Compression and decompression must use the same dictionary to be compatible.
+  Using a different dictionary during decompression will either
+  abort due to decompression error, or generate a checksum error.
+
+* `-f` `--[no-]force`:
+  This option has several effects:
+
+  If the target file already exists, overwrite it without prompting.
+
+  When used with `--decompress` and `lz4` cannot recognize the type of
+  the source file, copy the source file as is to standard output.
+  This allows `lz4cat --force` to be used like `cat (1)` for files
+  that have not been compressed with `lz4`.
+
+* `-c` `--stdout` `--to-stdout`:
+  Force write to standard output, even if it is the console.
+
+* `-m` `--multiple`:
+  Multiple input files.
+  Compressed file names will be appended a `.lz4` suffix.
+  This mode also reduces notification level.
+  Can also be used to list multiple files.
+  `lz4 -m` has a behavior equivalent to `gzip -k`
+  (it preserves source files by default).
+
+* `-r` :
+  operate recursively on directories.
+  This mode also sets `-m` (multiple input files).
+
+* `-B#`:
+  Block size \[4-7\](default : 7)
    
+  `-B4`= 64KB ; `-B5`= 256KB ; `-B6`= 1MB ; `-B7`= 4MB
+
+* `-BI`:
+  Produce independent blocks (default)
+
+* `-BD`:
+  Blocks depend on predecessors (improves compression ratio, more noticeable on small blocks)
+
+* `--[no-]frame-crc`:
+  Select frame checksum (default:enabled)
+
+* `--[no-]content-size`:
+  Header includes original size (default:not present)
    
+  Note : this option can only be activated when the original size can be
+  determined, hence for a file. It won't work with unknown source size,
+  such as stdin or pipe.
+
+* `--[no-]sparse`:
+  Sparse mode support (default:enabled on file, disabled on stdout)
+
+* `-l`:
+  Use Legacy format (typically for Linux Kernel compression)
    
+  Note : `-l` is not compatible with `-m` (`--multiple`) nor `-r`
+
+### Other options
+
+* `-v` `--verbose`:
+  Verbose mode
+
+* `-q` `--quiet`:
+  Suppress warnings and real-time statistics;
+  specify twice to suppress errors too
+
+* `-h` `-H` `--help`:
+  Display help/long help and exit
+
+* `-V` `--version`:
+  Display Version number and exit
+
+* `-k` `--keep`:
+  Preserve source files (default behavior)
+
+* `--rm` :
+  Delete source files on successful compression or decompression
+
+* `--` :
+  Treat all subsequent arguments as files
+
+
+### Benchmark mode
+
+* `-b#`:
+  Benchmark file(s), using # compression level
+
+* `-e#`:
+  Benchmark multiple compression levels, from b# to e# (included)
+
+* `-i#`:
+  Minimum evaluation time in seconds \[1-9\] (default : 3)
+
+
+BUGS
+----
+
+Report bugs at: https://github.com/lz4/lz4/issues
+
+
+AUTHOR
+------
+
+Yann Collet
diff --git a/lz4/programs/lz4cli.c b/lz4/programs/lz4cli.c
new file mode 100644
index 0000000..523b8a8
--- /dev/null
+++ b/lz4/programs/lz4cli.c
@@ -0,0 +1,788 @@
+/*
+  LZ4cli - LZ4 Command Line Interface
+  Copyright (C) Yann Collet 2011-2016
+
+  GPL v2 License
+
+  This program is free software; you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or
+  (at your option) any later version.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License along
+  with this program; if not, write to the Free Software Foundation, Inc.,
+  51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+  You can contact the author at :
+  - LZ4 source repository : https://github.com/lz4/lz4
+  - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+/*
+  Note : this is stand-alone program.
+  It is not part of LZ4 compression library, it is a user program of the LZ4 library.
+  The license of LZ4 library is BSD.
+  The license of xxHash library is BSD.
+  The license of this compression CLI program is GPLv2.
+*/
+
+
+/****************************
+*  Includes
+*****************************/
+#include "platform.h" /* Compiler options, IS_CONSOLE */
+#include "util.h"     /* UTIL_HAS_CREATEFILELIST, UTIL_createFileList */
+#include     /* fprintf, getchar */
+#include    /* exit, calloc, free */
+#include    /* strcmp, strlen */
+#include "bench.h"    /* BMK_benchFile, BMK_SetNbIterations, BMK_SetBlocksize, BMK_SetPause */
+#include "lz4io.h"    /* LZ4IO_compressFilename, LZ4IO_decompressFilename, LZ4IO_compressMultipleFilenames */
+#include "lz4hc.h"    /* LZ4HC_CLEVEL_MAX */
+#include "lz4.h"      /* LZ4_VERSION_STRING */
+
+
+/*****************************
+*  Constants
+******************************/
+#define COMPRESSOR_NAME "LZ4 command line interface"
+#define AUTHOR "Yann Collet"
+#define WELCOME_MESSAGE "*** %s %i-bits v%s, by %s ***\n", COMPRESSOR_NAME, (int)(sizeof(void*)*8), LZ4_versionString(), AUTHOR
+#define LZ4_EXTENSION ".lz4"
+#define LZ4CAT "lz4cat"
+#define UNLZ4 "unlz4"
+#define LZ4_LEGACY "lz4c"
+static int g_lz4c_legacy_commands = 0;
+
+#define KB *(1U<<10)
+#define MB *(1U<<20)
+#define GB *(1U<<30)
+
+#define LZ4_BLOCKSIZEID_DEFAULT 7
+
+
+/*-************************************
+*  Macros
+***************************************/
+#define DISPLAYOUT(...)        fprintf(stdout, __VA_ARGS__)
+#define DISPLAY(...)           fprintf(stderr, __VA_ARGS__)
+#define DISPLAYLEVEL(l, ...)   if (displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+static unsigned displayLevel = 2;   /* 0 : no display ; 1: errors only ; 2 : downgradable normal ; 3 : non-downgradable normal; 4 : + information */
+
+
+/*-************************************
+*  Exceptions
+***************************************/
+#define DEBUG 0
+#define DEBUGOUTPUT(...) if (DEBUG) DISPLAY(__VA_ARGS__);
+#define EXM_THROW(error, ...)                                             \
+{                                                                         \
+    DEBUGOUTPUT("Error defined at %s, line %i : \n", __FILE__, __LINE__); \
+    DISPLAYLEVEL(1, "Error %i : ", error);                                \
+    DISPLAYLEVEL(1, __VA_ARGS__);                                         \
+    DISPLAYLEVEL(1, "\n");                                                \
+    exit(error);                                                          \
+}
+
+
+/*-************************************
+*  Version modifiers
+***************************************/
+#define DEFAULT_COMPRESSOR   LZ4IO_compressFilename
+#define DEFAULT_DECOMPRESSOR LZ4IO_decompressFilename
+int LZ4IO_compressFilename_Legacy(const char* input_filename, const char* output_filename, int compressionlevel, const LZ4IO_prefs_t* prefs);   /* hidden function */
+int LZ4IO_compressMultipleFilenames_Legacy(
+                            const char** inFileNamesTable, int ifntSize,
+                            const char* suffix,
+                            int compressionLevel, const LZ4IO_prefs_t* prefs);
+
+/*-***************************
+*  Functions
+*****************************/
+static int usage(const char* exeName)
+{
+    DISPLAY( "Usage : \n");
+    DISPLAY( "      %s [arg] [input] [output] \n", exeName);
+    DISPLAY( "\n");
+    DISPLAY( "input   : a filename \n");
+    DISPLAY( "          with no FILE, or when FILE is - or %s, read standard input\n", stdinmark);
+    DISPLAY( "Arguments : \n");
+    DISPLAY( " -1     : Fast compression (default) \n");
+    DISPLAY( " -9     : High compression \n");
+    DISPLAY( " -d     : decompression (default for %s extension)\n", LZ4_EXTENSION);
+    DISPLAY( " -z     : force compression \n");
+    DISPLAY( " -D FILE: use FILE as dictionary \n");
+    DISPLAY( " -f     : overwrite output without prompting \n");
+    DISPLAY( " -k     : preserve source files(s)  (default) \n");
+    DISPLAY( "--rm    : remove source file(s) after successful de/compression \n");
+    DISPLAY( " -h/-H  : display help/long help and exit \n");
+    return 0;
+}
+
+static int usage_advanced(const char* exeName)
+{
+    DISPLAY(WELCOME_MESSAGE);
+    usage(exeName);
+    DISPLAY( "\n");
+    DISPLAY( "Advanced arguments :\n");
+    DISPLAY( " -V     : display Version number and exit \n");
+    DISPLAY( " -v     : verbose mode \n");
+    DISPLAY( " -q     : suppress warnings; specify twice to suppress errors too\n");
+    DISPLAY( " -c     : force write to standard output, even if it is the console\n");
+    DISPLAY( " -t     : test compressed file integrity\n");
+    DISPLAY( " -m     : multiple input files (implies automatic output filenames)\n");
+#ifdef UTIL_HAS_CREATEFILELIST
+    DISPLAY( " -r     : operate recursively on directories (sets also -m) \n");
+#endif
+    DISPLAY( " -l     : compress using Legacy format (Linux kernel compression)\n");
+    DISPLAY( " -B#    : cut file into blocks of size # bytes [32+] \n");
+    DISPLAY( "                     or predefined block size [4-7] (default: 7) \n");
+    DISPLAY( " -BI    : Block Independence (default) \n");
+    DISPLAY( " -BD    : Block dependency (improves compression ratio) \n");
+    DISPLAY( " -BX    : enable block checksum (default:disabled) \n");
+    DISPLAY( "--no-frame-crc : disable stream checksum (default:enabled) \n");
+    DISPLAY( "--content-size : compressed frame includes original size (default:not present)\n");
+    DISPLAY( "--list FILE : lists information about .lz4 files (useful for files compressed with --content-size flag)\n");
+    DISPLAY( "--[no-]sparse  : sparse mode (default:enabled on file, disabled on stdout)\n");
+    DISPLAY( "--favor-decSpeed: compressed files decompress faster, but are less compressed \n");
+    DISPLAY( "--fast[=#]: switch to ultra fast compression level (default: %i)\n", 1);
+    DISPLAY( "--best  : same as -%d\n", LZ4HC_CLEVEL_MAX);
+    DISPLAY( "Benchmark arguments : \n");
+    DISPLAY( " -b#    : benchmark file(s), using # compression level (default : 1) \n");
+    DISPLAY( " -e#    : test all compression levels from -bX to # (default : 1)\n");
+    DISPLAY( " -i#    : minimum evaluation time in seconds (default : 3s) \n");
+    if (g_lz4c_legacy_commands) {
+        DISPLAY( "Legacy arguments : \n");
+        DISPLAY( " -c0    : fast compression \n");
+        DISPLAY( " -c1    : high compression \n");
+        DISPLAY( " -c2,-hc: very high compression \n");
+        DISPLAY( " -y     : overwrite output without prompting \n");
+    }
+    return 0;
+}
+
+static int usage_longhelp(const char* exeName)
+{
+    usage_advanced(exeName);
+    DISPLAY( "\n");
+    DISPLAY( "****************************\n");
+    DISPLAY( "***** Advanced comment *****\n");
+    DISPLAY( "****************************\n");
+    DISPLAY( "\n");
+    DISPLAY( "Which values can [output] have ? \n");
+    DISPLAY( "---------------------------------\n");
+    DISPLAY( "[output] : a filename \n");
+    DISPLAY( "          '%s', or '-' for standard output (pipe mode)\n", stdoutmark);
+    DISPLAY( "          '%s' to discard output (test mode) \n", NULL_OUTPUT);
+    DISPLAY( "[output] can be left empty. In this case, it receives the following value :\n");
+    DISPLAY( "          - if stdout is not the console, then [output] = stdout \n");
+    DISPLAY( "          - if stdout is console : \n");
+    DISPLAY( "               + for compression, output to filename%s \n", LZ4_EXTENSION);
+    DISPLAY( "               + for decompression, output to filename without '%s'\n", LZ4_EXTENSION);
+    DISPLAY( "                    > if input filename has no '%s' extension : error \n", LZ4_EXTENSION);
+    DISPLAY( "\n");
+    DISPLAY( "Compression levels : \n");
+    DISPLAY( "---------------------\n");
+    DISPLAY( "-0 ... -2  => Fast compression, all identicals\n");
+    DISPLAY( "-3 ... -%d => High compression; higher number == more compression but slower\n", LZ4HC_CLEVEL_MAX);
+    DISPLAY( "\n");
+    DISPLAY( "stdin, stdout and the console : \n");
+    DISPLAY( "--------------------------------\n");
+    DISPLAY( "To protect the console from binary flooding (bad argument mistake)\n");
+    DISPLAY( "%s will refuse to read from console, or write to console \n", exeName);
+    DISPLAY( "except if '-c' command is specified, to force output to console \n");
+    DISPLAY( "\n");
+    DISPLAY( "Simple example :\n");
+    DISPLAY( "----------------\n");
+    DISPLAY( "1 : compress 'filename' fast, using default output name 'filename.lz4'\n");
+    DISPLAY( "          %s filename\n", exeName);
+    DISPLAY( "\n");
+    DISPLAY( "Short arguments can be aggregated. For example :\n");
+    DISPLAY( "----------------------------------\n");
+    DISPLAY( "2 : compress 'filename' in high compression mode, overwrite output if exists\n");
+    DISPLAY( "          %s -9 -f filename \n", exeName);
+    DISPLAY( "    is equivalent to :\n");
+    DISPLAY( "          %s -9f filename \n", exeName);
+    DISPLAY( "\n");
+    DISPLAY( "%s can be used in 'pure pipe mode'. For example :\n", exeName);
+    DISPLAY( "-------------------------------------\n");
+    DISPLAY( "3 : compress data stream from 'generator', send result to 'consumer'\n");
+    DISPLAY( "          generator | %s | consumer \n", exeName);
+    if (g_lz4c_legacy_commands) {
+        DISPLAY( "\n");
+        DISPLAY( "***** Warning  ***** \n");
+        DISPLAY( "Legacy arguments take precedence. Therefore : \n");
+        DISPLAY( "--------------------------------- \n");
+        DISPLAY( "          %s -hc filename \n", exeName);
+        DISPLAY( "means 'compress filename in high compression mode' \n");
+        DISPLAY( "It is not equivalent to : \n");
+        DISPLAY( "          %s -h -c filename \n", exeName);
+        DISPLAY( "which displays help text and exits \n");
+    }
+    return 0;
+}
+
+static int badusage(const char* exeName)
+{
+    DISPLAYLEVEL(1, "Incorrect parameters\n");
+    if (displayLevel >= 1) usage(exeName);
+    exit(1);
+}
+
+
+static void waitEnter(void)
+{
+    DISPLAY("Press enter to continue...\n");
+    (void)getchar();
+}
+
+static const char* lastNameFromPath(const char* path)
+{
+    const char* name = path;
+    if (strrchr(name, '/')) name = strrchr(name, '/') + 1;
+    if (strrchr(name, '\\')) name = strrchr(name, '\\') + 1; /* windows */
+    return name;
+}
+
+/*! exeNameMatch() :
+    @return : a non-zero value if exeName matches test, excluding the extension
+   */
+static int exeNameMatch(const char* exeName, const char* test)
+{
+    return !strncmp(exeName, test, strlen(test)) &&
+        (exeName[strlen(test)] == '\0' || exeName[strlen(test)] == '.');
+}
+
+/*! readU32FromChar() :
+ * @return : unsigned integer value read from input in `char` format
+ *  allows and interprets K, KB, KiB, M, MB and MiB suffix.
+ *  Will also modify `*stringPtr`, advancing it to position where it stopped reading.
+ *  Note : function result can overflow if digit string > MAX_UINT */
+static unsigned readU32FromChar(const char** stringPtr)
+{
+    unsigned result = 0;
+    while ((**stringPtr >='0') && (**stringPtr <='9')) {
+        result *= 10;
+        result += (unsigned)(**stringPtr - '0');
+        (*stringPtr)++ ;
+    }
+    if ((**stringPtr=='K') || (**stringPtr=='M')) {
+        result <<= 10;
+        if (**stringPtr=='M') result <<= 10;
+        (*stringPtr)++ ;
+        if (**stringPtr=='i') (*stringPtr)++;
+        if (**stringPtr=='B') (*stringPtr)++;
+    }
+    return result;
+}
+
+/** longCommandWArg() :
+ *  check if *stringPtr is the same as longCommand.
+ *  If yes, @return 1 and advances *stringPtr to the position which immediately follows longCommand.
+ * @return 0 and doesn't modify *stringPtr otherwise.
+ */
+static int longCommandWArg(const char** stringPtr, const char* longCommand)
+{
+    size_t const comSize = strlen(longCommand);
+    int const result = !strncmp(*stringPtr, longCommand, comSize);
+    if (result) *stringPtr += comSize;
+    return result;
+}
+
+typedef enum { om_auto, om_compress, om_decompress, om_test, om_bench, om_list } operationMode_e;
+
+/** determineOpMode() :
+ *  auto-determine operation mode, based on input filename extension
+ *  @return `om_decompress` if input filename has .lz4 extension and `om_compress` otherwise.
+ */
+static operationMode_e determineOpMode(const char* inputFilename)
+{
+    size_t const inSize  = strlen(inputFilename);
+    size_t const extSize = strlen(LZ4_EXTENSION);
+    size_t const extStart= (inSize > extSize) ? inSize-extSize : 0;
+    if (!strcmp(inputFilename+extStart, LZ4_EXTENSION)) return om_decompress;
+    else return om_compress;
+}
+
+int main(int argc, const char** argv)
+{
+    int i,
+        cLevel=1,
+        cLevelLast=-10000,
+        legacy_format=0,
+        forceStdout=0,
+        main_pause=0,
+        multiple_inputs=0,
+        all_arguments_are_files=0,
+        operationResult=0;
+    operationMode_e mode = om_auto;
+    const char* input_filename = NULL;
+    const char* output_filename= NULL;
+    const char* dictionary_filename = NULL;
+    char* dynNameSpace = NULL;
+    const char** inFileNames = (const char**)calloc((size_t)argc, sizeof(char*));
+    unsigned ifnIdx=0;
+    LZ4IO_prefs_t* const prefs = LZ4IO_defaultPreferences();
+    const char nullOutput[] = NULL_OUTPUT;
+    const char extension[] = LZ4_EXTENSION;
+    size_t blockSize = LZ4IO_setBlockSizeID(prefs, LZ4_BLOCKSIZEID_DEFAULT);
+    const char* const exeName = lastNameFromPath(argv[0]);
+#ifdef UTIL_HAS_CREATEFILELIST
+    const char** extendedFileList = NULL;
+    char* fileNamesBuf = NULL;
+    unsigned fileNamesNb, recursive=0;
+#endif
+
+    /* Init */
+    if (inFileNames==NULL) {
+        DISPLAY("Allocation error : not enough memory \n");
+        return 1;
+    }
+    inFileNames[0] = stdinmark;
+    LZ4IO_setOverwrite(prefs, 0);
+
+    /* predefined behaviors, based on binary/link name */
+    if (exeNameMatch(exeName, LZ4CAT)) {
+        mode = om_decompress;
+        LZ4IO_setOverwrite(prefs, 1);
+        LZ4IO_setPassThrough(prefs, 1);
+        LZ4IO_setRemoveSrcFile(prefs, 0);
+        forceStdout=1;
+        output_filename=stdoutmark;
+        displayLevel=1;
+        multiple_inputs=1;
+    }
+    if (exeNameMatch(exeName, UNLZ4)) { mode = om_decompress; }
+    if (exeNameMatch(exeName, LZ4_LEGACY)) { g_lz4c_legacy_commands=1; }
+
+    /* command switches */
+    for(i=1; i='0') && (*argument<='9')) {
+                    cLevel = (int)readU32FromChar(&argument);
+                    argument--;
+                    continue;
+                }
+
+
+                switch(argument[0])
+                {
+                    /* Display help */
+                case 'V': DISPLAYOUT(WELCOME_MESSAGE); goto _cleanup;   /* Version */
+                case 'h': usage_advanced(exeName); goto _cleanup;
+                case 'H': usage_longhelp(exeName); goto _cleanup;
+
+                case 'e':
+                    argument++;
+                    cLevelLast = (int)readU32FromChar(&argument);
+                    argument--;
+                    break;
+
+                    /* Compression (default) */
+                case 'z': mode = om_compress; break;
+
+                case 'D':
+                    if (argument[1] == '\0') {
+                        /* path is next arg */
+                        if (i + 1 == argc) {
+                            /* there is no next arg */
+                            badusage(exeName);
+                        }
+                        dictionary_filename = argv[++i];
+                    } else {
+                        /* path follows immediately */
+                        dictionary_filename = argument + 1;
+                    }
+                    /* skip to end of argument so that we jump to parsing next argument */
+                    argument += strlen(argument) - 1;
+                    break;
+
+                    /* Use Legacy format (ex : Linux kernel compression) */
+                case 'l': legacy_format = 1; blockSize = 8 MB; break;
+
+                    /* Decoding */
+                case 'd': mode = om_decompress; break;
+
+                    /* Force stdout, even if stdout==console */
+                case 'c':
+                  forceStdout=1;
+                  output_filename=stdoutmark;
+                  LZ4IO_setPassThrough(prefs, 1);
+                  break;
+
+                    /* Test integrity */
+                case 't': mode = om_test; break;
+
+                    /* Overwrite */
+                case 'f': LZ4IO_setOverwrite(prefs, 1); break;
+
+                    /* Verbose mode */
+                case 'v': displayLevel++; break;
+
+                    /* Quiet mode */
+                case 'q': if (displayLevel) displayLevel--; break;
+
+                    /* keep source file (default anyway, so useless) (for xz/lzma compatibility) */
+                case 'k': LZ4IO_setRemoveSrcFile(prefs, 0); break;
+
+                    /* Modify Block Properties */
+                case 'B':
+                    while (argument[1]!=0) {
+                        int exitBlockProperties=0;
+                        switch(argument[1])
+                        {
+                        case 'D': LZ4IO_setBlockMode(prefs, LZ4IO_blockLinked); argument++; break;
+                        case 'I': LZ4IO_setBlockMode(prefs, LZ4IO_blockIndependent); argument++; break;
+                        case 'X': LZ4IO_setBlockChecksumMode(prefs, 1); argument ++; break;   /* disabled by default */
+                        default :
+                            if (argument[1] < '0' || argument[1] > '9') {
+                                exitBlockProperties=1;
+                                break;
+                            } else {
+                                unsigned B;
+                                argument++;
+                                B = readU32FromChar(&argument);
+                                argument--;
+                                if (B < 4) badusage(exeName);
+                                if (B <= 7) {
+                                    blockSize = LZ4IO_setBlockSizeID(prefs, B);
+                                    BMK_setBlockSize(blockSize);
+                                    DISPLAYLEVEL(2, "using blocks of size %u KB \n", (U32)(blockSize>>10));
+                                } else {
+                                    if (B < 32) badusage(exeName);
+                                    blockSize = LZ4IO_setBlockSize(prefs, B);
+                                    BMK_setBlockSize(blockSize);
+                                    if (blockSize >= 1024) {
+                                        DISPLAYLEVEL(2, "using blocks of size %u KB \n", (U32)(blockSize>>10));
+                                    } else {
+                                        DISPLAYLEVEL(2, "using blocks of size %u bytes \n", (U32)(blockSize));
+                                    }
+                                }
+                                break;
+                            }
+                        }
+                        if (exitBlockProperties) break;
+                    }
+                    break;
+
+                    /* Benchmark */
+                case 'b': mode = om_bench; multiple_inputs=1;
+                    break;
+
+                    /* hidden command : benchmark files, but do not fuse result */
+                case 'S': BMK_setBenchSeparately(1);
+                    break;
+
+#ifdef UTIL_HAS_CREATEFILELIST
+                    /* recursive */
+                case 'r': recursive=1;
+#endif
+                    /* fall-through */
+                    /* Treat non-option args as input files.  See https://code.google.com/p/lz4/issues/detail?id=151 */
+                case 'm': multiple_inputs=1;
+                    break;
+
+                    /* Modify Nb Seconds (benchmark only) */
+                case 'i':
+                    {   unsigned iters;
+                        argument++;
+                        iters = readU32FromChar(&argument);
+                        argument--;
+                        BMK_setNotificationLevel(displayLevel);
+                        BMK_setNbSeconds(iters);   /* notification if displayLevel >= 3 */
+                    }
+                    break;
+
+                    /* Pause at the end (hidden option) */
+                case 'p': main_pause=1; break;
+
+                    /* Unrecognised command */
+                default : badusage(exeName);
+                }
+            }
+            continue;
+        }
+
+        /* Store in *inFileNames[] if -m is used. */
+        if (multiple_inputs) { inFileNames[ifnIdx++]=argument; continue; }
+
+        /* Store first non-option arg in input_filename to preserve original cli logic. */
+        if (!input_filename) { input_filename=argument; continue; }
+
+        /* Second non-option arg in output_filename to preserve original cli logic. */
+        if (!output_filename) {
+            output_filename=argument;
+            if (!strcmp (output_filename, nullOutput)) output_filename = nulmark;
+            continue;
+        }
+
+        /* 3rd non-option arg should not exist */
+        DISPLAYLEVEL(1, "Warning : %s won't be used ! Do you want multiple input files (-m) ? \n", argument);
+    }
+
+    DISPLAYLEVEL(3, WELCOME_MESSAGE);
+#ifdef _POSIX_C_SOURCE
+    DISPLAYLEVEL(4, "_POSIX_C_SOURCE defined: %ldL\n", (long) _POSIX_C_SOURCE);
+#endif
+#ifdef _POSIX_VERSION
+    DISPLAYLEVEL(4, "_POSIX_VERSION defined: %ldL\n", (long) _POSIX_VERSION);
+#endif
+#ifdef PLATFORM_POSIX_VERSION
+    DISPLAYLEVEL(4, "PLATFORM_POSIX_VERSION defined: %ldL\n", (long) PLATFORM_POSIX_VERSION);
+#endif
+#ifdef _FILE_OFFSET_BITS
+    DISPLAYLEVEL(4, "_FILE_OFFSET_BITS defined: %ldL\n", (long) _FILE_OFFSET_BITS);
+#endif
+    if ((mode == om_compress) || (mode == om_bench))
+        DISPLAYLEVEL(4, "Blocks size : %u KB\n", (U32)(blockSize>>10));
+
+    if (multiple_inputs) {
+        input_filename = inFileNames[0];
+#ifdef UTIL_HAS_CREATEFILELIST
+        if (recursive) {  /* at this stage, filenameTable is a list of paths, which can contain both files and directories */
+            extendedFileList = UTIL_createFileList(inFileNames, ifnIdx, &fileNamesBuf, &fileNamesNb);
+            if (extendedFileList) {
+                unsigned u;
+                for (u=0; u try to select one automatically (when possible) */
+    while ((!output_filename) && (multiple_inputs==0)) {
+        if (!IS_CONSOLE(stdout) && mode != om_list) {
+            /* Default to stdout whenever stdout is not the console.
+             * Note : this policy may change in the future, therefore don't rely on it !
+             * To ensure `stdout` is explicitly selected, use `-c` command flag.
+             * Conversely, to ensure output will not become `stdout`, use `-m` command flag */
+            DISPLAYLEVEL(1, "Warning : using stdout as default output. Do not rely on this behavior: use explicit `-c` instead ! \n");
+            output_filename=stdoutmark;
+            break;
+        }
+        if (mode == om_auto) {  /* auto-determine compression or decompression, based on file extension */
+            mode = determineOpMode(input_filename);
+        }
+        if (mode == om_compress) {   /* compression to file */
+            size_t const l = strlen(input_filename);
+            dynNameSpace = (char*)calloc(1,l+5);
+            if (dynNameSpace==NULL) { perror(exeName); exit(1); }
+            strcpy(dynNameSpace, input_filename);
+            strcat(dynNameSpace, LZ4_EXTENSION);
+            output_filename = dynNameSpace;
+            DISPLAYLEVEL(2, "Compressed filename will be : %s \n", output_filename);
+            break;
+        }
+        if (mode == om_decompress) {/* decompression to file (automatic name will work only if input filename has correct format extension) */
+            size_t outl;
+            size_t const inl = strlen(input_filename);
+            dynNameSpace = (char*)calloc(1,inl+1);
+            if (dynNameSpace==NULL) { perror(exeName); exit(1); }
+            strcpy(dynNameSpace, input_filename);
+            outl = inl;
+            if (inl>4)
+                while ((outl >= inl-4) && (input_filename[outl] ==  extension[outl-inl+4])) dynNameSpace[outl--]=0;
+            if (outl != inl-5) { DISPLAYLEVEL(1, "Cannot determine an output filename\n"); badusage(exeName); }
+            output_filename = dynNameSpace;
+            DISPLAYLEVEL(2, "Decoding file %s \n", output_filename);
+        }
+        break;
+    }
+
+    if (mode == om_list){
+        /* Exit if trying to read from stdin as this isn't supported in this mode */
+        if(!strcmp(input_filename, stdinmark)){
+            DISPLAYLEVEL(1, "refusing to read from standard input in --list mode\n");
+            exit(1);
+        }
+        if(!multiple_inputs){
+            inFileNames[ifnIdx++] = input_filename;
+        }
+    }
+    else{
+        if (multiple_inputs==0) assert(output_filename);
+    }
+    /* when multiple_inputs==1, output_filename may simply be useless,
+     * however, output_filename must be !NULL for next strcmp() tests */
+    if (!output_filename) output_filename = "*\\dummy^!//";
+
+    /* Check if output is defined as console; trigger an error in this case */
+    if (!strcmp(output_filename,stdoutmark) && IS_CONSOLE(stdout) && !forceStdout) {
+        DISPLAYLEVEL(1, "refusing to write to console without -c \n");
+        exit(1);
+    }
+    /* Downgrade notification level in stdout and multiple file mode */
+    if (!strcmp(output_filename,stdoutmark) && (displayLevel==2)) displayLevel=1;
+    if ((multiple_inputs) && (displayLevel==2)) displayLevel=1;
+
+    /* Auto-determine compression or decompression, based on file extension */
+    if (mode == om_auto) {
+        mode = determineOpMode(input_filename);
+    }
+
+    /* IO Stream/File */
+    LZ4IO_setNotificationLevel((int)displayLevel);
+    if (ifnIdx == 0) multiple_inputs = 0;
+    if (mode == om_decompress) {
+        if (multiple_inputs) {
+            const char* const dec_extension = !strcmp(output_filename,stdoutmark) ? stdoutmark : LZ4_EXTENSION;
+            assert(ifnIdx <= INT_MAX);
+            operationResult = LZ4IO_decompressMultipleFilenames(inFileNames, (int)ifnIdx, dec_extension, prefs);
+        } else {
+            operationResult = DEFAULT_DECOMPRESSOR(input_filename, output_filename, prefs);
+        }
+    } else if (mode == om_list){
+        operationResult = LZ4IO_displayCompressedFilesInfo(inFileNames, ifnIdx);
+    } else {   /* compression is default action */
+        if (legacy_format) {
+            DISPLAYLEVEL(3, "! Generating LZ4 Legacy format (deprecated) ! \n");
+            if(multiple_inputs){
+                const char* const leg_extension = !strcmp(output_filename,stdoutmark) ? stdoutmark : LZ4_EXTENSION;
+                LZ4IO_compressMultipleFilenames_Legacy(inFileNames, (int)ifnIdx, leg_extension, cLevel, prefs);
+            } else {
+                LZ4IO_compressFilename_Legacy(input_filename, output_filename, cLevel, prefs);
+            }
+        } else {
+            if (multiple_inputs) {
+                const char* const comp_extension = !strcmp(output_filename,stdoutmark) ? stdoutmark : LZ4_EXTENSION;
+                assert(ifnIdx <= INT_MAX);
+                operationResult = LZ4IO_compressMultipleFilenames(inFileNames, (int)ifnIdx, comp_extension, cLevel, prefs);
+            } else {
+                operationResult = DEFAULT_COMPRESSOR(input_filename, output_filename, cLevel, prefs);
+    }   }   }
+
+_cleanup:
+    if (main_pause) waitEnter();
+    free(dynNameSpace);
+#ifdef UTIL_HAS_CREATEFILELIST
+    if (extendedFileList) {
+        UTIL_freeFileList(extendedFileList, fileNamesBuf);
+        inFileNames = NULL;
+    }
+#endif
+    LZ4IO_freePreferences(prefs);
+    free((void*)inFileNames);
+    return operationResult;
+}
diff --git a/lz4/programs/lz4io.c b/lz4/programs/lz4io.c
new file mode 100644
index 0000000..a274798
--- /dev/null
+++ b/lz4/programs/lz4io.c
@@ -0,0 +1,1677 @@
+/*
+  LZ4io.c - LZ4 File/Stream Interface
+  Copyright (C) Yann Collet 2011-2017
+
+  GPL v2 License
+
+  This program is free software; you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or
+  (at your option) any later version.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License along
+  with this program; if not, write to the Free Software Foundation, Inc.,
+  51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+  You can contact the author at :
+  - LZ4 source repository : https://github.com/lz4/lz4
+  - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+/*
+  Note : this is stand-alone program.
+  It is not part of LZ4 compression library, it is a user code of the LZ4 library.
+  - The license of LZ4 library is BSD.
+  - The license of xxHash library is BSD.
+  - The license of this source file is GPLv2.
+*/
+
+
+/*-************************************
+*  Compiler options
+**************************************/
+#ifdef _MSC_VER    /* Visual Studio */
+#  pragma warning(disable : 4127)    /* disable: C4127: conditional expression is constant */
+#endif
+#if defined(__MINGW32__) && !defined(_POSIX_SOURCE)
+#  define _POSIX_SOURCE 1          /* disable %llu warnings with MinGW on Windows */
+#endif
+
+
+/*****************************
+*  Includes
+*****************************/
+#include "platform.h"  /* Large File Support, SET_BINARY_MODE, SET_SPARSE_FILE_MODE, PLATFORM_POSIX_VERSION, __64BIT__ */
+#include "util.h"      /* UTIL_getFileStat, UTIL_setFileStat */
+#include      /* fprintf, fopen, fread, stdin, stdout, fflush, getchar */
+#include     /* malloc, free */
+#include     /* strerror, strcmp, strlen */
+#include       /* clock */
+#include  /* stat64 */
+#include   /* stat64 */
+#include "lz4.h"       /* still required for legacy format */
+#include "lz4hc.h"     /* still required for legacy format */
+#define LZ4F_STATIC_LINKING_ONLY
+#include "lz4frame.h"
+#include "lz4io.h"
+
+
+/*****************************
+*  Constants
+*****************************/
+#define KB *(1 <<10)
+#define MB *(1 <<20)
+#define GB *(1U<<30)
+
+#define _1BIT  0x01
+#define _2BITS 0x03
+#define _3BITS 0x07
+#define _4BITS 0x0F
+#define _8BITS 0xFF
+
+#define MAGICNUMBER_SIZE    4
+#define LZ4IO_MAGICNUMBER   0x184D2204
+#define LZ4IO_SKIPPABLE0    0x184D2A50
+#define LZ4IO_SKIPPABLEMASK 0xFFFFFFF0
+#define LEGACY_MAGICNUMBER  0x184C2102
+
+#define CACHELINE 64
+#define LEGACY_BLOCKSIZE   (8 MB)
+#define MIN_STREAM_BUFSIZE (192 KB)
+#define LZ4IO_BLOCKSIZEID_DEFAULT 7
+#define LZ4_MAX_DICT_SIZE (64 KB)
+
+
+/**************************************
+*  Macros
+**************************************/
+#define DISPLAY(...)         fprintf(stderr, __VA_ARGS__)
+#define DISPLAYOUT(...)      fprintf(stdout, __VA_ARGS__)
+#define DISPLAYLEVEL(l, ...) if (g_displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+static int g_displayLevel = 0;   /* 0 : no display  ; 1: errors  ; 2 : + result + interaction + warnings ; 3 : + progression; 4 : + information */
+
+#define DISPLAYUPDATE(l, ...) if (g_displayLevel>=l) { \
+            if ( ((clock() - g_time) > refreshRate)    \
+              || (g_displayLevel>=4) ) {               \
+                g_time = clock();                      \
+                DISPLAY(__VA_ARGS__);                  \
+                if (g_displayLevel>=4) fflush(stderr); \
+        }   }
+static const clock_t refreshRate = CLOCKS_PER_SEC / 6;
+static clock_t g_time = 0;
+#define LZ4IO_STATIC_ASSERT(c)   { enum { LZ4IO_static_assert = 1/(int)(!!(c)) }; }   /* use after variable declarations */
+
+
+/**************************************
+*  Local Parameters
+**************************************/
+
+struct LZ4IO_prefs_s {
+    int passThrough;
+    int overwrite;
+    int testMode;
+    int blockSizeId;
+    size_t blockSize;
+    int blockChecksum;
+    int streamChecksum;
+    int blockIndependence;
+    int sparseFileSupport;
+    int contentSizeFlag;
+    int useDictionary;
+    unsigned favorDecSpeed;
+    const char* dictionaryFilename;
+    int removeSrcFile;
+};
+
+/**************************************
+*  Exceptions
+***************************************/
+#ifndef DEBUG
+#  define DEBUG 0
+#endif
+#define DEBUGOUTPUT(...) if (DEBUG) DISPLAY(__VA_ARGS__);
+#define EXM_THROW(error, ...)                                             \
+{                                                                         \
+    DEBUGOUTPUT("Error defined at %s, line %i : \n", __FILE__, __LINE__); \
+    DISPLAYLEVEL(1, "Error %i : ", error);                                \
+    DISPLAYLEVEL(1, __VA_ARGS__);                                         \
+    DISPLAYLEVEL(1, " \n");                                               \
+    exit(error);                                                          \
+}
+
+
+/**************************************
+*  Version modifiers
+**************************************/
+#define EXTENDED_ARGUMENTS
+#define EXTENDED_HELP
+#define EXTENDED_FORMAT
+#define DEFAULT_DECOMPRESSOR LZ4IO_decompressLZ4F
+
+
+/* ************************************************** */
+/* ****************** Parameters ******************** */
+/* ************************************************** */
+
+LZ4IO_prefs_t* LZ4IO_defaultPreferences(void)
+{
+    LZ4IO_prefs_t* const ret = (LZ4IO_prefs_t*)malloc(sizeof(*ret));
+    if (!ret) EXM_THROW(21, "Allocation error : not enough memory");
+    ret->passThrough = 0;
+    ret->overwrite = 1;
+    ret->testMode = 0;
+    ret->blockSizeId = LZ4IO_BLOCKSIZEID_DEFAULT;
+    ret->blockSize = 0;
+    ret->blockChecksum = 0;
+    ret->streamChecksum = 1;
+    ret->blockIndependence = 1;
+    ret->sparseFileSupport = 1;
+    ret->contentSizeFlag = 0;
+    ret->useDictionary = 0;
+    ret->favorDecSpeed = 0;
+    ret->dictionaryFilename = NULL;
+    ret->removeSrcFile = 0;
+    return ret;
+}
+
+void LZ4IO_freePreferences(LZ4IO_prefs_t* prefs)
+{
+    free(prefs);
+}
+
+
+int LZ4IO_setDictionaryFilename(LZ4IO_prefs_t* const prefs, const char* dictionaryFilename)
+{
+    prefs->dictionaryFilename = dictionaryFilename;
+    prefs->useDictionary = dictionaryFilename != NULL;
+    return prefs->useDictionary;
+}
+
+/* Default setting : passThrough = 0; return : passThrough mode (0/1) */
+int LZ4IO_setPassThrough(LZ4IO_prefs_t* const prefs, int yes)
+{
+   prefs->passThrough = (yes!=0);
+   return prefs->passThrough;
+}
+
+
+/* Default setting : overwrite = 1; return : overwrite mode (0/1) */
+int LZ4IO_setOverwrite(LZ4IO_prefs_t* const prefs, int yes)
+{
+   prefs->overwrite = (yes!=0);
+   return prefs->overwrite;
+}
+
+/* Default setting : testMode = 0; return : testMode (0/1) */
+int LZ4IO_setTestMode(LZ4IO_prefs_t* const prefs, int yes)
+{
+   prefs->testMode = (yes!=0);
+   return prefs->testMode;
+}
+
+/* blockSizeID : valid values : 4-5-6-7 */
+size_t LZ4IO_setBlockSizeID(LZ4IO_prefs_t* const prefs, unsigned bsid)
+{
+    static const size_t blockSizeTable[] = { 64 KB, 256 KB, 1 MB, 4 MB };
+    static const unsigned minBlockSizeID = 4;
+    static const unsigned maxBlockSizeID = 7;
+    if ((bsid < minBlockSizeID) || (bsid > maxBlockSizeID)) return 0;
+    prefs->blockSizeId = (int)bsid;
+    prefs->blockSize = blockSizeTable[(unsigned)prefs->blockSizeId-minBlockSizeID];
+    return prefs->blockSize;
+}
+
+size_t LZ4IO_setBlockSize(LZ4IO_prefs_t* const prefs, size_t blockSize)
+{
+    static const size_t minBlockSize = 32;
+    static const size_t maxBlockSize = 4 MB;
+    unsigned bsid = 0;
+    if (blockSize < minBlockSize) blockSize = minBlockSize;
+    if (blockSize > maxBlockSize) blockSize = maxBlockSize;
+    prefs->blockSize = blockSize;
+    blockSize--;
+    /* find which of { 64k, 256k, 1MB, 4MB } is closest to blockSize */
+    while (blockSize >>= 2)
+        bsid++;
+    if (bsid < 7) bsid = 7;
+    prefs->blockSizeId = (int)(bsid-3);
+    return prefs->blockSize;
+}
+
+/* Default setting : 1 == independent blocks */
+int LZ4IO_setBlockMode(LZ4IO_prefs_t* const prefs, LZ4IO_blockMode_t blockMode)
+{
+    prefs->blockIndependence = (blockMode == LZ4IO_blockIndependent);
+    return prefs->blockIndependence;
+}
+
+/* Default setting : 0 == no block checksum */
+int LZ4IO_setBlockChecksumMode(LZ4IO_prefs_t* const prefs, int enable)
+{
+    prefs->blockChecksum = (enable != 0);
+    return prefs->blockChecksum;
+}
+
+/* Default setting : 1 == checksum enabled */
+int LZ4IO_setStreamChecksumMode(LZ4IO_prefs_t* const prefs, int enable)
+{
+    prefs->streamChecksum = (enable != 0);
+    return prefs->streamChecksum;
+}
+
+/* Default setting : 0 (no notification) */
+int LZ4IO_setNotificationLevel(int level)
+{
+    g_displayLevel = level;
+    return g_displayLevel;
+}
+
+/* Default setting : 1 (auto: enabled on file, disabled on stdout) */
+int LZ4IO_setSparseFile(LZ4IO_prefs_t* const prefs, int enable)
+{
+    prefs->sparseFileSupport = 2*(enable!=0);  /* 2==force enable */
+    return prefs->sparseFileSupport;
+}
+
+/* Default setting : 0 (disabled) */
+int LZ4IO_setContentSize(LZ4IO_prefs_t* const prefs, int enable)
+{
+    prefs->contentSizeFlag = (enable!=0);
+    return prefs->contentSizeFlag;
+}
+
+/* Default setting : 0 (disabled) */
+void LZ4IO_favorDecSpeed(LZ4IO_prefs_t* const prefs, int favor)
+{
+    prefs->favorDecSpeed = (favor!=0);
+}
+
+void LZ4IO_setRemoveSrcFile(LZ4IO_prefs_t* const prefs, unsigned flag)
+{
+  prefs->removeSrcFile = (flag>0);
+}
+
+
+
+/* ************************************************************************ **
+** ********************** LZ4 File / Pipe compression ********************* **
+** ************************************************************************ */
+
+static int LZ4IO_isSkippableMagicNumber(unsigned int magic) {
+    return (magic & LZ4IO_SKIPPABLEMASK) == LZ4IO_SKIPPABLE0;
+}
+
+
+/** LZ4IO_openSrcFile() :
+ * condition : `srcFileName` must be non-NULL.
+ * @result : FILE* to `dstFileName`, or NULL if it fails */
+static FILE* LZ4IO_openSrcFile(const char* srcFileName)
+{
+    FILE* f;
+
+    if (!strcmp (srcFileName, stdinmark)) {
+        DISPLAYLEVEL(4,"Using stdin for input\n");
+        f = stdin;
+        SET_BINARY_MODE(stdin);
+    } else {
+        f = fopen(srcFileName, "rb");
+        if ( f==NULL ) DISPLAYLEVEL(1, "%s: %s \n", srcFileName, strerror(errno));
+    }
+
+    return f;
+}
+
+/** FIO_openDstFile() :
+ *  prefs is writable, because sparseFileSupport might be updated.
+ *  condition : `dstFileName` must be non-NULL.
+ * @result : FILE* to `dstFileName`, or NULL if it fails */
+static FILE* LZ4IO_openDstFile(const char* dstFileName, const LZ4IO_prefs_t* const prefs)
+{
+    FILE* f;
+    assert(dstFileName != NULL);
+
+    if (!strcmp (dstFileName, stdoutmark)) {
+        DISPLAYLEVEL(4, "Using stdout for output \n");
+        f = stdout;
+        SET_BINARY_MODE(stdout);
+        if (prefs->sparseFileSupport==1) {
+            DISPLAYLEVEL(4, "Sparse File Support automatically disabled on stdout ;"
+                            " to force-enable it, add --sparse command \n");
+        }
+    } else {
+        if (!prefs->overwrite && strcmp (dstFileName, nulmark)) {  /* Check if destination file already exists */
+            FILE* const testf = fopen( dstFileName, "rb" );
+            if (testf != NULL) {  /* dest exists, prompt for overwrite authorization */
+                fclose(testf);
+                if (g_displayLevel <= 1) {  /* No interaction possible */
+                    DISPLAY("%s already exists; not overwritten  \n", dstFileName);
+                    return NULL;
+                }
+                DISPLAY("%s already exists; do you wish to overwrite (y/N) ? ", dstFileName);
+                {   int ch = getchar();
+                    if ((ch!='Y') && (ch!='y')) {
+                        DISPLAY("    not overwritten  \n");
+                        return NULL;
+                    }
+                    while ((ch!=EOF) && (ch!='\n')) ch = getchar();  /* flush rest of input line */
+        }   }   }
+        f = fopen( dstFileName, "wb" );
+        if (f==NULL) DISPLAYLEVEL(1, "%s: %s\n", dstFileName, strerror(errno));
+    }
+
+    /* sparse file */
+    {   int const sparseMode = (prefs->sparseFileSupport - (f==stdout)) > 0;
+        if (f && sparseMode) { SET_SPARSE_FILE_MODE(f); }
+    }
+
+    return f;
+}
+
+
+
+/***************************************
+*   Legacy Compression
+***************************************/
+
+/* unoptimized version; solves endianess & alignment issues */
+static void LZ4IO_writeLE32 (void* p, unsigned value32)
+{
+    unsigned char* const dstPtr = (unsigned char*)p;
+    dstPtr[0] = (unsigned char)value32;
+    dstPtr[1] = (unsigned char)(value32 >> 8);
+    dstPtr[2] = (unsigned char)(value32 >> 16);
+    dstPtr[3] = (unsigned char)(value32 >> 24);
+}
+
+static int LZ4IO_LZ4_compress(const char* src, char* dst, int srcSize, int dstSize, int cLevel)
+{
+    (void)cLevel;
+    return LZ4_compress_fast(src, dst, srcSize, dstSize, 1);
+}
+
+/* LZ4IO_compressFilename_Legacy :
+ * This function is intentionally "hidden" (not published in .h)
+ * It generates compressed streams using the old 'legacy' format */
+int LZ4IO_compressFilename_Legacy(const char* input_filename, const char* output_filename,
+                                  int compressionlevel, const LZ4IO_prefs_t* prefs)
+{
+    typedef int (*compress_f)(const char* src, char* dst, int srcSize, int dstSize, int cLevel);
+    compress_f const compressionFunction = (compressionlevel < 3) ? LZ4IO_LZ4_compress : LZ4_compress_HC;
+    unsigned long long filesize = 0;
+    unsigned long long compressedfilesize = MAGICNUMBER_SIZE;
+    char* in_buff;
+    char* out_buff;
+    const int outBuffSize = LZ4_compressBound(LEGACY_BLOCKSIZE);
+    FILE* const finput = LZ4IO_openSrcFile(input_filename);
+    FILE* foutput;
+    clock_t clockEnd;
+
+    /* Init */
+    clock_t const clockStart = clock();
+    if (finput == NULL)
+        EXM_THROW(20, "%s : open file error ", input_filename);
+
+    foutput = LZ4IO_openDstFile(output_filename, prefs);
+    if (foutput == NULL) {
+        fclose(finput);
+        EXM_THROW(20, "%s : open file error ", input_filename);
+    }
+
+    /* Allocate Memory */
+    in_buff = (char*)malloc(LEGACY_BLOCKSIZE);
+    out_buff = (char*)malloc((size_t)outBuffSize + 4);
+    if (!in_buff || !out_buff)
+        EXM_THROW(21, "Allocation error : not enough memory");
+
+    /* Write Archive Header */
+    LZ4IO_writeLE32(out_buff, LEGACY_MAGICNUMBER);
+    if (fwrite(out_buff, 1, MAGICNUMBER_SIZE, foutput) != MAGICNUMBER_SIZE)
+        EXM_THROW(22, "Write error : cannot write header");
+
+    /* Main Loop */
+    while (1) {
+        int outSize;
+        /* Read Block */
+        size_t const inSize = fread(in_buff, (size_t)1, (size_t)LEGACY_BLOCKSIZE, finput);
+        if (inSize == 0) break;
+        assert(inSize <= LEGACY_BLOCKSIZE);
+        filesize += inSize;
+
+        /* Compress Block */
+        outSize = compressionFunction(in_buff, out_buff+4, (int)inSize, outBuffSize, compressionlevel);
+        assert(outSize >= 0);
+        compressedfilesize += (unsigned long long)outSize+4;
+        DISPLAYUPDATE(2, "\rRead : %i MB  ==> %.2f%%   ",
+                (int)(filesize>>20), (double)compressedfilesize/filesize*100);
+
+        /* Write Block */
+        assert(outSize > 0);
+        assert(outSize < outBuffSize);
+        LZ4IO_writeLE32(out_buff, (unsigned)outSize);
+        if (fwrite(out_buff, 1, (size_t)outSize+4, foutput) != (size_t)(outSize+4)) {
+            EXM_THROW(24, "Write error : cannot write compressed block");
+    }   }
+    if (ferror(finput)) EXM_THROW(25, "Error while reading %s ", input_filename);
+
+    /* Status */
+    clockEnd = clock();
+    if (clockEnd==clockStart) clockEnd+=1;  /* avoid division by zero (speed) */
+    filesize += !filesize;   /* avoid division by zero (ratio) */
+    DISPLAYLEVEL(2, "\r%79s\r", "");   /* blank line */
+    DISPLAYLEVEL(2,"Compressed %llu bytes into %llu bytes ==> %.2f%%\n",
+        filesize, compressedfilesize, (double)compressedfilesize / filesize * 100);
+    {   double const seconds = (double)(clockEnd - clockStart) / CLOCKS_PER_SEC;
+        DISPLAYLEVEL(4,"Done in %.2f s ==> %.2f MB/s\n", seconds,
+                        (double)filesize / seconds / 1024 / 1024);
+    }
+
+    /* Close & Free */
+    free(in_buff);
+    free(out_buff);
+    fclose(finput);
+    if (strcmp(output_filename,stdoutmark)) fclose(foutput);   /* do not close stdout */
+
+    return 0;
+}
+
+#define FNSPACE 30
+/* LZ4IO_compressMultipleFilenames_Legacy :
+ * This function is intentionally "hidden" (not published in .h)
+ * It generates multiple compressed streams using the old 'legacy' format */
+int LZ4IO_compressMultipleFilenames_Legacy(
+                            const char** inFileNamesTable, int ifntSize,
+                            const char* suffix,
+                            int compressionLevel, const LZ4IO_prefs_t* prefs)
+{
+    int i;
+    int missed_files = 0;
+    char* dstFileName = (char*)malloc(FNSPACE);
+    size_t ofnSize = FNSPACE;
+    const size_t suffixSize = strlen(suffix);
+
+    if (dstFileName == NULL) return ifntSize;   /* not enough memory */
+
+    /* loop on each file */
+    for (i=0; i0);
+
+    if (dictLen > LZ4_MAX_DICT_SIZE) {
+        dictLen = LZ4_MAX_DICT_SIZE;
+    }
+
+    *dictSize = dictLen;
+
+    dictStart = (circularBufSize + dictEnd - dictLen) % circularBufSize;
+
+    if (dictStart == 0) {
+        /* We're in the simple case where the dict starts at the beginning of our circular buffer. */
+        dictBuf = circularBuf;
+        circularBuf = NULL;
+    } else {
+        /* Otherwise, we will alloc a new buffer and copy our dict into that. */
+        dictBuf = (char *)malloc(dictLen ? dictLen : 1);
+        if (!dictBuf) EXM_THROW(25, "Allocation error : not enough memory");
+
+        memcpy(dictBuf, circularBuf + dictStart, circularBufSize - dictStart);
+        memcpy(dictBuf + circularBufSize - dictStart, circularBuf, dictLen - (circularBufSize - dictStart));
+    }
+
+    fclose(dictFile);
+    free(circularBuf);
+
+    return dictBuf;
+}
+
+static LZ4F_CDict* LZ4IO_createCDict(const LZ4IO_prefs_t* const prefs)
+{
+    size_t dictionarySize;
+    void* dictionaryBuffer;
+    LZ4F_CDict* cdict;
+    if (!prefs->useDictionary) return NULL;
+    dictionaryBuffer = LZ4IO_createDict(&dictionarySize, prefs->dictionaryFilename);
+    if (!dictionaryBuffer) EXM_THROW(25, "Dictionary error : could not create dictionary");
+    cdict = LZ4F_createCDict(dictionaryBuffer, dictionarySize);
+    free(dictionaryBuffer);
+    return cdict;
+}
+
+static cRess_t LZ4IO_createCResources(const LZ4IO_prefs_t* const prefs)
+{
+    const size_t blockSize = prefs->blockSize;
+    cRess_t ress;
+
+    LZ4F_errorCode_t const errorCode = LZ4F_createCompressionContext(&(ress.ctx), LZ4F_VERSION);
+    if (LZ4F_isError(errorCode)) EXM_THROW(30, "Allocation error : can't create LZ4F context : %s", LZ4F_getErrorName(errorCode));
+
+    /* Allocate Memory */
+    ress.srcBuffer = malloc(blockSize);
+    ress.srcBufferSize = blockSize;
+    ress.dstBufferSize = LZ4F_compressFrameBound(blockSize, NULL);   /* cover worst case */
+    ress.dstBuffer = malloc(ress.dstBufferSize);
+    if (!ress.srcBuffer || !ress.dstBuffer) EXM_THROW(31, "Allocation error : not enough memory");
+
+    ress.cdict = LZ4IO_createCDict(prefs);
+
+    return ress;
+}
+
+static void LZ4IO_freeCResources(cRess_t ress)
+{
+    free(ress.srcBuffer);
+    free(ress.dstBuffer);
+
+    LZ4F_freeCDict(ress.cdict);
+    ress.cdict = NULL;
+
+    { LZ4F_errorCode_t const errorCode = LZ4F_freeCompressionContext(ress.ctx);
+      if (LZ4F_isError(errorCode)) EXM_THROW(38, "Error : can't free LZ4F context resource : %s", LZ4F_getErrorName(errorCode)); }
+}
+
+/*
+ * LZ4IO_compressFilename_extRess()
+ * result : 0 : compression completed correctly
+ *          1 : missing or pb opening srcFileName
+ */
+static int
+LZ4IO_compressFilename_extRess(cRess_t ress,
+                               const char* srcFileName, const char* dstFileName,
+                               int compressionLevel, const LZ4IO_prefs_t* const io_prefs)
+{
+    unsigned long long filesize = 0;
+    unsigned long long compressedfilesize = 0;
+    FILE* dstFile;
+    void* const srcBuffer = ress.srcBuffer;
+    void* const dstBuffer = ress.dstBuffer;
+    const size_t dstBufferSize = ress.dstBufferSize;
+    const size_t blockSize = io_prefs->blockSize;
+    size_t readSize;
+    LZ4F_compressionContext_t ctx = ress.ctx;   /* just a pointer */
+    LZ4F_preferences_t prefs;
+
+    /* Init */
+    FILE* const srcFile = LZ4IO_openSrcFile(srcFileName);
+    if (srcFile == NULL) return 1;
+    dstFile = LZ4IO_openDstFile(dstFileName, io_prefs);
+    if (dstFile == NULL) { fclose(srcFile); return 1; }
+    memset(&prefs, 0, sizeof(prefs));
+
+    /* Set compression parameters */
+    prefs.autoFlush = 1;
+    prefs.compressionLevel = compressionLevel;
+    prefs.frameInfo.blockMode = (LZ4F_blockMode_t)io_prefs->blockIndependence;
+    prefs.frameInfo.blockSizeID = (LZ4F_blockSizeID_t)io_prefs->blockSizeId;
+    prefs.frameInfo.blockChecksumFlag = (LZ4F_blockChecksum_t)io_prefs->blockChecksum;
+    prefs.frameInfo.contentChecksumFlag = (LZ4F_contentChecksum_t)io_prefs->streamChecksum;
+    prefs.favorDecSpeed = io_prefs->favorDecSpeed;
+    if (io_prefs->contentSizeFlag) {
+      U64 const fileSize = UTIL_getOpenFileSize(srcFile);
+      prefs.frameInfo.contentSize = fileSize;   /* == 0 if input == stdin */
+      if (fileSize==0)
+          DISPLAYLEVEL(3, "Warning : cannot determine input content size \n");
+    }
+
+    /* read first block */
+    readSize  = fread(srcBuffer, (size_t)1, blockSize, srcFile);
+    if (ferror(srcFile)) EXM_THROW(30, "Error reading %s ", srcFileName);
+    filesize += readSize;
+
+    /* single-block file */
+    if (readSize < blockSize) {
+        /* Compress in single pass */
+        size_t const cSize = LZ4F_compressFrame_usingCDict(ctx, dstBuffer, dstBufferSize, srcBuffer, readSize, ress.cdict, &prefs);
+        if (LZ4F_isError(cSize))
+            EXM_THROW(31, "Compression failed : %s", LZ4F_getErrorName(cSize));
+        compressedfilesize = cSize;
+        DISPLAYUPDATE(2, "\rRead : %u MB   ==> %.2f%%   ",
+                      (unsigned)(filesize>>20), (double)compressedfilesize/(filesize+!filesize)*100);   /* avoid division by zero */
+
+        /* Write Block */
+        if (fwrite(dstBuffer, 1, cSize, dstFile) != cSize) {
+            EXM_THROW(32, "Write error : failed writing single-block compressed frame");
+    }   }
+
+    else
+
+    /* multiple-blocks file */
+    {
+        /* Write Frame Header */
+        size_t const headerSize = LZ4F_compressBegin_usingCDict(ctx, dstBuffer, dstBufferSize, ress.cdict, &prefs);
+        if (LZ4F_isError(headerSize)) EXM_THROW(33, "File header generation failed : %s", LZ4F_getErrorName(headerSize));
+        if (fwrite(dstBuffer, 1, headerSize, dstFile) != headerSize)
+            EXM_THROW(34, "Write error : cannot write header");
+        compressedfilesize += headerSize;
+
+        /* Main Loop - one block at a time */
+        while (readSize>0) {
+            size_t const outSize = LZ4F_compressUpdate(ctx, dstBuffer, dstBufferSize, srcBuffer, readSize, NULL);
+            if (LZ4F_isError(outSize))
+                EXM_THROW(35, "Compression failed : %s", LZ4F_getErrorName(outSize));
+            compressedfilesize += outSize;
+            DISPLAYUPDATE(2, "\rRead : %u MB   ==> %.2f%%   ",
+                        (unsigned)(filesize>>20), (double)compressedfilesize/filesize*100);
+
+            /* Write Block */
+            if (fwrite(dstBuffer, 1, outSize, dstFile) != outSize)
+                EXM_THROW(36, "Write error : cannot write compressed block");
+
+            /* Read next block */
+            readSize  = fread(srcBuffer, (size_t)1, (size_t)blockSize, srcFile);
+            filesize += readSize;
+        }
+        if (ferror(srcFile)) EXM_THROW(37, "Error reading %s ", srcFileName);
+
+        /* End of Frame mark */
+        {   size_t const endSize = LZ4F_compressEnd(ctx, dstBuffer, dstBufferSize, NULL);
+            if (LZ4F_isError(endSize))
+                EXM_THROW(38, "End of frame error : %s", LZ4F_getErrorName(endSize));
+            if (fwrite(dstBuffer, 1, endSize, dstFile) != endSize)
+                EXM_THROW(39, "Write error : cannot write end of frame");
+            compressedfilesize += endSize;
+    }   }
+
+    /* Release file handlers */
+    fclose (srcFile);
+    if (strcmp(dstFileName,stdoutmark)) fclose (dstFile);  /* do not close stdout */
+
+    /* Copy owner, file permissions and modification time */
+    {   stat_t statbuf;
+        if (strcmp (srcFileName, stdinmark)
+         && strcmp (dstFileName, stdoutmark)
+         && strcmp (dstFileName, nulmark)
+         && UTIL_getFileStat(srcFileName, &statbuf)) {
+            UTIL_setFileStat(dstFileName, &statbuf);
+    }   }
+
+    if (io_prefs->removeSrcFile) {  /* remove source file : --rm */
+        if (remove(srcFileName))
+            EXM_THROW(40, "Remove error : %s: %s", srcFileName, strerror(errno));
+    }
+
+    /* Final Status */
+    DISPLAYLEVEL(2, "\r%79s\r", "");
+    DISPLAYLEVEL(2, "Compressed %llu bytes into %llu bytes ==> %.2f%%\n",
+                    filesize, compressedfilesize,
+                    (double)compressedfilesize / (filesize + !filesize /* avoid division by zero */ ) * 100);
+
+    return 0;
+}
+
+
+int LZ4IO_compressFilename(const char* srcFileName, const char* dstFileName, int compressionLevel, const LZ4IO_prefs_t* prefs)
+{
+    UTIL_time_t const timeStart = UTIL_getTime();
+    clock_t const cpuStart = clock();
+    cRess_t const ress = LZ4IO_createCResources(prefs);
+
+    int const result = LZ4IO_compressFilename_extRess(ress, srcFileName, dstFileName, compressionLevel, prefs);
+
+    /* Free resources */
+    LZ4IO_freeCResources(ress);
+
+    /* Final Status */
+    {   clock_t const cpuEnd = clock();
+        double const cpuLoad_s = (double)(cpuEnd - cpuStart) / CLOCKS_PER_SEC;
+        U64 const timeLength_ns = UTIL_clockSpanNano(timeStart);
+        double const timeLength_s = (double)timeLength_ns / 1000000000;
+        DISPLAYLEVEL(4, "Completed in %.2f sec  (cpu load : %.0f%%)\n",
+                        timeLength_s, (cpuLoad_s / timeLength_s) * 100);
+    }
+
+    return result;
+}
+
+
+int LZ4IO_compressMultipleFilenames(
+                              const char** inFileNamesTable, int ifntSize,
+                              const char* suffix,
+                              int compressionLevel,
+                              const LZ4IO_prefs_t* prefs)
+{
+    int i;
+    int missed_files = 0;
+    char* dstFileName = (char*)malloc(FNSPACE);
+    size_t ofnSize = FNSPACE;
+    const size_t suffixSize = strlen(suffix);
+    cRess_t ress;
+
+    if (dstFileName == NULL) return ifntSize;   /* not enough memory */
+    ress = LZ4IO_createCResources(prefs);
+
+    /* loop on each file */
+    for (i=0; i= 4 */
+static unsigned LZ4IO_readLE32 (const void* s)
+{
+    const unsigned char* const srcPtr = (const unsigned char*)s;
+    unsigned value32 = srcPtr[0];
+    value32 += (unsigned)srcPtr[1] <<  8;
+    value32 += (unsigned)srcPtr[2] << 16;
+    value32 += (unsigned)srcPtr[3] << 24;
+    return value32;
+}
+
+
+static unsigned
+LZ4IO_fwriteSparse(FILE* file,
+                   const void* buffer, size_t bufferSize,
+                   int sparseFileSupport,
+                   unsigned storedSkips)
+{
+    const size_t sizeT = sizeof(size_t);
+    const size_t maskT = sizeT -1 ;
+    const size_t* const bufferT = (const size_t*)buffer;   /* Buffer is supposed malloc'ed, hence aligned on size_t */
+    const size_t* ptrT = bufferT;
+    size_t bufferSizeT = bufferSize / sizeT;
+    const size_t* const bufferTEnd = bufferT + bufferSizeT;
+    const size_t segmentSizeT = (32 KB) / sizeT;
+    int const sparseMode = (sparseFileSupport - (file==stdout)) > 0;
+
+    if (!sparseMode) {  /* normal write */
+        size_t const sizeCheck = fwrite(buffer, 1, bufferSize, file);
+        if (sizeCheck != bufferSize) EXM_THROW(70, "Write error : cannot write decoded block");
+        return 0;
+    }
+
+    /* avoid int overflow */
+    if (storedSkips > 1 GB) {
+        int const seekResult = UTIL_fseek(file, 1 GB, SEEK_CUR);
+        if (seekResult != 0) EXM_THROW(71, "1 GB skip error (sparse file support)");
+        storedSkips -= 1 GB;
+    }
+
+    while (ptrT < bufferTEnd) {
+        size_t seg0SizeT = segmentSizeT;
+        size_t nb0T;
+
+        /* count leading zeros */
+        if (seg0SizeT > bufferSizeT) seg0SizeT = bufferSizeT;
+        bufferSizeT -= seg0SizeT;
+        for (nb0T=0; (nb0T < seg0SizeT) && (ptrT[nb0T] == 0); nb0T++) ;
+        storedSkips += (unsigned)(nb0T * sizeT);
+
+        if (nb0T != seg0SizeT) {   /* not all 0s */
+            errno = 0;
+            {   int const seekResult = UTIL_fseek(file, storedSkips, SEEK_CUR);
+                if (seekResult) EXM_THROW(72, "Sparse skip error(%d): %s ; try --no-sparse", (int)errno, strerror(errno));
+            }
+            storedSkips = 0;
+            seg0SizeT -= nb0T;
+            ptrT += nb0T;
+            {   size_t const sizeCheck = fwrite(ptrT, sizeT, seg0SizeT, file);
+                if (sizeCheck != seg0SizeT) EXM_THROW(73, "Write error : cannot write decoded block");
+        }   }
+        ptrT += seg0SizeT;
+    }
+
+    if (bufferSize & maskT) {  /* size not multiple of sizeT : implies end of block */
+        const char* const restStart = (const char*)bufferTEnd;
+        const char* restPtr = restStart;
+        size_t const restSize =  bufferSize & maskT;
+        const char* const restEnd = restStart + restSize;
+        for (; (restPtr < restEnd) && (*restPtr == 0); restPtr++) ;
+        storedSkips += (unsigned) (restPtr - restStart);
+        if (restPtr != restEnd) {
+            int const seekResult = UTIL_fseek(file, storedSkips, SEEK_CUR);
+            if (seekResult) EXM_THROW(74, "Sparse skip error ; try --no-sparse");
+            storedSkips = 0;
+            {   size_t const sizeCheck = fwrite(restPtr, 1, (size_t)(restEnd - restPtr), file);
+                if (sizeCheck != (size_t)(restEnd - restPtr)) EXM_THROW(75, "Write error : cannot write decoded end of block");
+        }   }
+    }
+
+    return storedSkips;
+}
+
+static void LZ4IO_fwriteSparseEnd(FILE* file, unsigned storedSkips)
+{
+    if (storedSkips>0) {   /* implies sparseFileSupport>0 */
+        const char lastZeroByte[1] = { 0 };
+        if (UTIL_fseek(file, storedSkips-1, SEEK_CUR) != 0)
+            EXM_THROW(69, "Final skip error (sparse file)\n");
+        if (fwrite(lastZeroByte, 1, 1, file) != 1)
+            EXM_THROW(69, "Write error : cannot write last zero\n");
+    }
+}
+
+
+static unsigned g_magicRead = 0;   /* out-parameter of LZ4IO_decodeLegacyStream() */
+static unsigned long long LZ4IO_decodeLegacyStream(FILE* finput, FILE* foutput, const LZ4IO_prefs_t* prefs)
+{
+    unsigned long long streamSize = 0;
+    unsigned storedSkips = 0;
+
+    /* Allocate Memory */
+    char* const in_buff  = (char*)malloc((size_t)LZ4_compressBound(LEGACY_BLOCKSIZE));
+    char* const out_buff = (char*)malloc(LEGACY_BLOCKSIZE);
+    if (!in_buff || !out_buff) EXM_THROW(51, "Allocation error : not enough memory");
+
+    /* Main Loop */
+    while (1) {
+        unsigned int blockSize;
+
+        /* Block Size */
+        {   size_t const sizeCheck = fread(in_buff, 1, 4, finput);
+            if (sizeCheck == 0) break;                   /* Nothing to read : file read is completed */
+            if (sizeCheck != 4) EXM_THROW(52, "Read error : cannot access block size "); }
+            blockSize = LZ4IO_readLE32(in_buff);       /* Convert to Little Endian */
+            if (blockSize > LZ4_COMPRESSBOUND(LEGACY_BLOCKSIZE)) {
+            /* Cannot read next block : maybe new stream ? */
+            g_magicRead = blockSize;
+            break;
+        }
+
+        /* Read Block */
+        { size_t const sizeCheck = fread(in_buff, 1, blockSize, finput);
+          if (sizeCheck!=blockSize) EXM_THROW(52, "Read error : cannot access compressed block !"); }
+
+        /* Decode Block */
+        {   int const decodeSize = LZ4_decompress_safe(in_buff, out_buff, (int)blockSize, LEGACY_BLOCKSIZE);
+            if (decodeSize < 0) EXM_THROW(53, "Decoding Failed ! Corrupted input detected !");
+            streamSize += (unsigned long long)decodeSize;
+            /* Write Block */
+            storedSkips = LZ4IO_fwriteSparse(foutput, out_buff, (size_t)decodeSize, prefs->sparseFileSupport, storedSkips); /* success or die */
+    }   }
+    if (ferror(finput)) EXM_THROW(54, "Read error : ferror");
+
+    LZ4IO_fwriteSparseEnd(foutput, storedSkips);
+
+    /* Free */
+    free(in_buff);
+    free(out_buff);
+
+    return streamSize;
+}
+
+
+
+typedef struct {
+    void*  srcBuffer;
+    size_t srcBufferSize;
+    void*  dstBuffer;
+    size_t dstBufferSize;
+    FILE*  dstFile;
+    LZ4F_decompressionContext_t dCtx;
+    void*  dictBuffer;
+    size_t dictBufferSize;
+} dRess_t;
+
+static void LZ4IO_loadDDict(dRess_t* ress, const LZ4IO_prefs_t* const prefs)
+{
+    if (!prefs->useDictionary) {
+        ress->dictBuffer = NULL;
+        ress->dictBufferSize = 0;
+        return;
+    }
+
+    ress->dictBuffer = LZ4IO_createDict(&ress->dictBufferSize, prefs->dictionaryFilename);
+    if (!ress->dictBuffer) EXM_THROW(25, "Dictionary error : could not create dictionary");
+}
+
+static const size_t LZ4IO_dBufferSize = 64 KB;
+static dRess_t LZ4IO_createDResources(const LZ4IO_prefs_t* const prefs)
+{
+    dRess_t ress;
+
+    /* init */
+    LZ4F_errorCode_t const errorCode = LZ4F_createDecompressionContext(&ress.dCtx, LZ4F_VERSION);
+    if (LZ4F_isError(errorCode)) EXM_THROW(60, "Can't create LZ4F context : %s", LZ4F_getErrorName(errorCode));
+
+    /* Allocate Memory */
+    ress.srcBufferSize = LZ4IO_dBufferSize;
+    ress.srcBuffer = malloc(ress.srcBufferSize);
+    ress.dstBufferSize = LZ4IO_dBufferSize;
+    ress.dstBuffer = malloc(ress.dstBufferSize);
+    if (!ress.srcBuffer || !ress.dstBuffer) EXM_THROW(61, "Allocation error : not enough memory");
+
+    LZ4IO_loadDDict(&ress, prefs);
+
+    ress.dstFile = NULL;
+    return ress;
+}
+
+static void LZ4IO_freeDResources(dRess_t ress)
+{
+    LZ4F_errorCode_t errorCode = LZ4F_freeDecompressionContext(ress.dCtx);
+    if (LZ4F_isError(errorCode)) EXM_THROW(69, "Error : can't free LZ4F context resource : %s", LZ4F_getErrorName(errorCode));
+    free(ress.srcBuffer);
+    free(ress.dstBuffer);
+    free(ress.dictBuffer);
+}
+
+
+static unsigned long long
+LZ4IO_decompressLZ4F(dRess_t ress,
+                     FILE* const srcFile, FILE* const dstFile,
+                     const LZ4IO_prefs_t* const prefs)
+{
+    unsigned long long filesize = 0;
+    LZ4F_errorCode_t nextToLoad;
+    unsigned storedSkips = 0;
+
+    /* Init feed with magic number (already consumed from FILE* sFile) */
+    {   size_t inSize = MAGICNUMBER_SIZE;
+        size_t outSize= 0;
+        LZ4IO_writeLE32(ress.srcBuffer, LZ4IO_MAGICNUMBER);
+        nextToLoad = LZ4F_decompress_usingDict(ress.dCtx, ress.dstBuffer, &outSize, ress.srcBuffer, &inSize, ress.dictBuffer, ress.dictBufferSize, NULL);
+        if (LZ4F_isError(nextToLoad)) EXM_THROW(62, "Header error : %s", LZ4F_getErrorName(nextToLoad));
+    }
+
+    /* Main Loop */
+    for (;nextToLoad;) {
+        size_t readSize;
+        size_t pos = 0;
+        size_t decodedBytes = ress.dstBufferSize;
+
+        /* Read input */
+        if (nextToLoad > ress.srcBufferSize) nextToLoad = ress.srcBufferSize;
+        readSize = fread(ress.srcBuffer, 1, nextToLoad, srcFile);
+        if (!readSize) break;   /* reached end of file or stream */
+
+        while ((pos < readSize) || (decodedBytes == ress.dstBufferSize)) {  /* still to read, or still to flush */
+            /* Decode Input (at least partially) */
+            size_t remaining = readSize - pos;
+            decodedBytes = ress.dstBufferSize;
+            nextToLoad = LZ4F_decompress_usingDict(ress.dCtx, ress.dstBuffer, &decodedBytes, (char*)(ress.srcBuffer)+pos, &remaining, ress.dictBuffer, ress.dictBufferSize, NULL);
+            if (LZ4F_isError(nextToLoad)) EXM_THROW(66, "Decompression error : %s", LZ4F_getErrorName(nextToLoad));
+            pos += remaining;
+
+            /* Write Block */
+            if (decodedBytes) {
+                if (!prefs->testMode)
+                    storedSkips = LZ4IO_fwriteSparse(dstFile, ress.dstBuffer, decodedBytes, prefs->sparseFileSupport, storedSkips);
+                filesize += decodedBytes;
+                DISPLAYUPDATE(2, "\rDecompressed : %u MB  ", (unsigned)(filesize>>20));
+            }
+
+            if (!nextToLoad) break;
+        }
+    }
+    /* can be out because readSize == 0, which could be an fread() error */
+    if (ferror(srcFile)) EXM_THROW(67, "Read error");
+
+    if (!prefs->testMode) LZ4IO_fwriteSparseEnd(dstFile, storedSkips);
+    if (nextToLoad!=0) EXM_THROW(68, "Unfinished stream");
+
+    return filesize;
+}
+
+
+/* LZ4IO_passThrough:
+ * just output the same content as input, no decoding.
+ * This is a capability of zcat, and by extension lz4cat
+ * MNstore : contain the first MAGICNUMBER_SIZE bytes already read from finput
+ */
+#define PTSIZE  (64 KB)
+#define PTSIZET (PTSIZE / sizeof(size_t))
+static unsigned long long
+LZ4IO_passThrough(FILE* finput, FILE* foutput,
+                  unsigned char MNstore[MAGICNUMBER_SIZE],
+                  int sparseFileSupport)
+{
+	size_t buffer[PTSIZET];
+    size_t readBytes = 1;
+    unsigned long long total = MAGICNUMBER_SIZE;
+    unsigned storedSkips = 0;
+
+    if (fwrite(MNstore, 1, MAGICNUMBER_SIZE, foutput) != MAGICNUMBER_SIZE) {
+        EXM_THROW(50, "Pass-through write error");
+    }
+    while (readBytes) {
+        readBytes = fread(buffer, 1, sizeof(buffer), finput);
+        total += readBytes;
+        storedSkips = LZ4IO_fwriteSparse(foutput, buffer, readBytes, sparseFileSupport, storedSkips);
+    }
+    if (ferror(finput)) EXM_THROW(51, "Read Error");
+
+    LZ4IO_fwriteSparseEnd(foutput, storedSkips);
+    return total;
+}
+
+
+/** Safely handle cases when (unsigned)offset > LONG_MAX */
+static int fseek_u32(FILE *fp, unsigned offset, int where)
+{
+    const unsigned stepMax = 1U << 30;
+    int errorNb = 0;
+
+    if (where != SEEK_CUR) return -1;  /* Only allows SEEK_CUR */
+    while (offset > 0) {
+        unsigned s = offset;
+        if (s > stepMax) s = stepMax;
+        errorNb = UTIL_fseek(fp, (long) s, SEEK_CUR);
+        if (errorNb != 0) break;
+        offset -= s;
+    }
+    return errorNb;
+}
+
+#define ENDOFSTREAM ((unsigned long long)-1)
+static unsigned long long
+selectDecoder(dRess_t ress,
+              FILE* finput, FILE* foutput,
+              const LZ4IO_prefs_t* const prefs)
+{
+    unsigned char MNstore[MAGICNUMBER_SIZE];
+    unsigned magicNumber;
+    static unsigned nbFrames = 0;
+
+    /* init */
+    nbFrames++;
+
+    /* Check Archive Header */
+    if (g_magicRead) {  /* magic number already read from finput (see legacy frame)*/
+        magicNumber = g_magicRead;
+        g_magicRead = 0;
+    } else {
+        size_t const nbReadBytes = fread(MNstore, 1, MAGICNUMBER_SIZE, finput);
+        if (nbReadBytes==0) { nbFrames = 0; return ENDOFSTREAM; }   /* EOF */
+        if (nbReadBytes != MAGICNUMBER_SIZE)
+          EXM_THROW(40, "Unrecognized header : Magic Number unreadable");
+        magicNumber = LZ4IO_readLE32(MNstore);   /* Little Endian format */
+    }
+    if (LZ4IO_isSkippableMagicNumber(magicNumber))
+        magicNumber = LZ4IO_SKIPPABLE0;   /* fold skippable magic numbers */
+
+    switch(magicNumber)
+    {
+    case LZ4IO_MAGICNUMBER:
+        return LZ4IO_decompressLZ4F(ress, finput, foutput, prefs);
+    case LEGACY_MAGICNUMBER:
+        DISPLAYLEVEL(4, "Detected : Legacy format \n");
+        return LZ4IO_decodeLegacyStream(finput, foutput, prefs);
+    case LZ4IO_SKIPPABLE0:
+        DISPLAYLEVEL(4, "Skipping detected skippable area \n");
+        {   size_t const nbReadBytes = fread(MNstore, 1, 4, finput);
+            if (nbReadBytes != 4)
+                EXM_THROW(42, "Stream error : skippable size unreadable");
+        }
+        {   unsigned const size = LZ4IO_readLE32(MNstore);
+            int const errorNb = fseek_u32(finput, size, SEEK_CUR);
+            if (errorNb != 0)
+                EXM_THROW(43, "Stream error : cannot skip skippable area");
+        }
+        return 0;
+    EXTENDED_FORMAT;  /* macro extension for custom formats */
+    default:
+        if (nbFrames == 1) {  /* just started */
+            /* Wrong magic number at the beginning of 1st stream */
+            if (!prefs->testMode && prefs->overwrite && prefs->passThrough) {
+                nbFrames = 0;
+                return LZ4IO_passThrough(finput, foutput, MNstore, prefs->sparseFileSupport);
+            }
+            EXM_THROW(44,"Unrecognized header : file cannot be decoded");
+        }
+        {   long int const position = ftell(finput);  /* only works for files < 2 GB */
+            DISPLAYLEVEL(2, "Stream followed by undecodable data ");
+            if (position != -1L)
+                DISPLAYLEVEL(2, "at position %i ", (int)position);
+            DISPLAYLEVEL(2, "\n");
+        }
+        return ENDOFSTREAM;
+    }
+}
+
+
+static int
+LZ4IO_decompressSrcFile(dRess_t ress,
+                        const char* input_filename, const char* output_filename,
+                        const LZ4IO_prefs_t* const prefs)
+{
+    FILE* const foutput = ress.dstFile;
+    unsigned long long filesize = 0;
+
+    /* Init */
+    FILE* const finput = LZ4IO_openSrcFile(input_filename);
+    if (finput==NULL) return 1;
+    assert(foutput != NULL);
+
+    /* Loop over multiple streams */
+    for ( ; ; ) {  /* endless loop, see break condition */
+        unsigned long long const decodedSize =
+                        selectDecoder(ress, finput, foutput, prefs);
+        if (decodedSize == ENDOFSTREAM) break;
+        filesize += decodedSize;
+    }
+
+    /* Close input */
+    fclose(finput);
+    if (prefs->removeSrcFile) {  /* --rm */
+        if (remove(input_filename))
+            EXM_THROW(45, "Remove error : %s: %s", input_filename, strerror(errno));
+    }
+
+    /* Final Status */
+    DISPLAYLEVEL(2, "\r%79s\r", "");
+    DISPLAYLEVEL(2, "%-20.20s : decoded %llu bytes \n", input_filename, filesize);
+    (void)output_filename;
+
+    return 0;
+}
+
+
+static int
+LZ4IO_decompressDstFile(dRess_t ress,
+                        const char* input_filename, const char* output_filename,
+                        const LZ4IO_prefs_t* const prefs)
+{
+    stat_t statbuf;
+    int stat_result = 0;
+    FILE* const foutput = LZ4IO_openDstFile(output_filename, prefs);
+    if (foutput==NULL) return 1;   /* failure */
+
+    if ( strcmp(input_filename, stdinmark)
+      && UTIL_getFileStat(input_filename, &statbuf))
+        stat_result = 1;
+
+    ress.dstFile = foutput;
+    LZ4IO_decompressSrcFile(ress, input_filename, output_filename, prefs);
+
+    fclose(foutput);
+
+    /* Copy owner, file permissions and modification time */
+    if ( stat_result != 0
+      && strcmp (output_filename, stdoutmark)
+      && strcmp (output_filename, nulmark)) {
+        UTIL_setFileStat(output_filename, &statbuf);
+        /* should return value be read ? or is silent fail good enough ? */
+    }
+
+    return 0;
+}
+
+
+int LZ4IO_decompressFilename(const char* input_filename, const char* output_filename, const LZ4IO_prefs_t* prefs)
+{
+    dRess_t const ress = LZ4IO_createDResources(prefs);
+    clock_t const start = clock();
+
+    int const missingFiles = LZ4IO_decompressDstFile(ress, input_filename, output_filename, prefs);
+
+    clock_t const end = clock();
+    double const seconds = (double)(end - start) / CLOCKS_PER_SEC;
+    DISPLAYLEVEL(4, "Done in %.2f sec  \n", seconds);
+
+    LZ4IO_freeDResources(ress);
+    return missingFiles;
+}
+
+
+int LZ4IO_decompressMultipleFilenames(
+                            const char** inFileNamesTable, int ifntSize,
+                            const char* suffix,
+                            const LZ4IO_prefs_t* prefs)
+{
+    int i;
+    int skippedFiles = 0;
+    int missingFiles = 0;
+    char* outFileName = (char*)malloc(FNSPACE);
+    size_t ofnSize = FNSPACE;
+    size_t const suffixSize = strlen(suffix);
+    dRess_t ress = LZ4IO_createDResources(prefs);
+
+    if (outFileName==NULL) EXM_THROW(70, "Memory allocation error");
+    ress.dstFile = LZ4IO_openDstFile(stdoutmark, prefs);
+
+    for (i=0; i= 4); assert(sizeID <= 7);
+    buffer[1] = (char)(sizeID + '0');
+    buffer[2] = (blockMode == LZ4F_blockIndependent) ? 'I' : 'D';
+    buffer[3] = 0;
+    return buffer;
+}
+
+/* buffer : must be valid memory area of at least 10 bytes */
+static const char* LZ4IO_toHuman(long double size, char *buf)
+{
+    const char units[] = {"\0KMGTPEZY"};
+    size_t i = 0;
+    for (; size >= 1024; i++) size /= 1024;
+    sprintf(buf, "%.2Lf%c", size, units[i]);
+    return buf;
+}
+
+/* Get filename without path prefix */
+static const char* LZ4IO_baseName(const char* input_filename)
+{
+    const char* b = strrchr(input_filename, '/');
+    if (!b) b = strrchr(input_filename, '\\');
+    if (!b) return input_filename;
+    return b + 1;
+}
+
+/* Report frame/s information (--list) in verbose mode (-v).
+ * Will populate file info with fileName and frameSummary where applicable.
+ * - TODO :
+ *  + report nb of blocks, hence max. possible decompressed size (when not reported in header)
+ */
+static LZ4IO_infoResult
+LZ4IO_getCompressedFileInfo(LZ4IO_cFileInfo_t* cfinfo, const char* input_filename)
+{
+    LZ4IO_infoResult result = LZ4IO_format_not_known;  /* default result (error) */
+    unsigned char buffer[LZ4F_HEADER_SIZE_MAX];
+    FILE* const finput = LZ4IO_openSrcFile(input_filename);
+
+    if (finput == NULL) return LZ4IO_not_a_file;
+    cfinfo->fileSize = UTIL_getOpenFileSize(finput);
+
+    while (!feof(finput)) {
+        LZ4IO_frameInfo_t frameInfo = LZ4IO_INIT_FRAMEINFO;
+        unsigned magicNumber;
+        /* Get MagicNumber */
+        {   size_t const nbReadBytes = fread(buffer, 1, MAGICNUMBER_SIZE, finput);
+            if (nbReadBytes == 0) { break; } /* EOF */
+            result = LZ4IO_format_not_known;  /* default result (error) */
+            if (nbReadBytes != MAGICNUMBER_SIZE) {
+                EXM_THROW(40, "Unrecognized header : Magic Number unreadable");
+        }   }
+        magicNumber = LZ4IO_readLE32(buffer);   /* Little Endian format */
+        if (LZ4IO_isSkippableMagicNumber(magicNumber))
+            magicNumber = LZ4IO_SKIPPABLE0;   /* fold skippable magic numbers */
+
+        switch (magicNumber) {
+        case LZ4IO_MAGICNUMBER:
+            if (cfinfo->frameSummary.frameType != lz4Frame) cfinfo->eqFrameTypes = 0;
+            /* Get frame info */
+            {   const size_t readBytes = fread(buffer + MAGICNUMBER_SIZE, 1, LZ4F_HEADER_SIZE_MIN - MAGICNUMBER_SIZE, finput);
+                if (!readBytes || ferror(finput)) EXM_THROW(71, "Error reading %s", input_filename);
+            }
+            {   size_t hSize = LZ4F_headerSize(&buffer, LZ4F_HEADER_SIZE_MIN);
+                if (LZ4F_isError(hSize)) break;
+                if (hSize > (LZ4F_HEADER_SIZE_MIN + MAGICNUMBER_SIZE)) {
+                    /* We've already read LZ4F_HEADER_SIZE_MIN so read any extra until hSize*/
+                    const size_t readBytes = fread(buffer + LZ4F_HEADER_SIZE_MIN, 1, hSize - LZ4F_HEADER_SIZE_MIN, finput);
+                    if (!readBytes || ferror(finput)) EXM_THROW(72, "Error reading %s", input_filename);
+                }
+                /* Create decompression context */
+                {   LZ4F_dctx* dctx;
+                    if ( LZ4F_isError(LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION)) ) break;
+                    {   unsigned const frameInfoError = LZ4F_isError(LZ4F_getFrameInfo(dctx, &frameInfo.lz4FrameInfo, buffer, &hSize));
+                        LZ4F_freeDecompressionContext(dctx);
+                        if (frameInfoError) break;
+                        if ((cfinfo->frameSummary.lz4FrameInfo.blockSizeID != frameInfo.lz4FrameInfo.blockSizeID ||
+                                cfinfo->frameSummary.lz4FrameInfo.blockMode != frameInfo.lz4FrameInfo.blockMode)
+                                && cfinfo->frameCount != 0)
+                            cfinfo->eqBlockTypes = 0;
+                        {   const unsigned long long totalBlocksSize = LZ4IO_skipBlocksData(finput,
+                                    frameInfo.lz4FrameInfo.blockChecksumFlag,
+                                    frameInfo.lz4FrameInfo.contentChecksumFlag);
+                            if (totalBlocksSize) {
+                                char bTypeBuffer[5];
+                                LZ4IO_blockTypeID(frameInfo.lz4FrameInfo.blockSizeID, frameInfo.lz4FrameInfo.blockMode, bTypeBuffer);
+                                DISPLAYLEVEL(3, "    %6llu %14s %5s %8s",
+                                             cfinfo->frameCount + 1,
+                                             LZ4IO_frameTypeNames[frameInfo.frameType],
+                                             bTypeBuffer,
+                                             frameInfo.lz4FrameInfo.contentChecksumFlag ? "XXH32" : "-");
+                                if (frameInfo.lz4FrameInfo.contentSize) {
+                                    {   double const ratio = (double)(totalBlocksSize + hSize) / frameInfo.lz4FrameInfo.contentSize * 100;
+                                        DISPLAYLEVEL(3, " %20llu %20llu %9.2f%%\n",
+                                                     totalBlocksSize + hSize,
+                                                     frameInfo.lz4FrameInfo.contentSize,
+                                                     ratio);
+                                    }
+                                    /* Now we've consumed frameInfo we can use it to store the total contentSize */
+                                    frameInfo.lz4FrameInfo.contentSize += cfinfo->frameSummary.lz4FrameInfo.contentSize;
+                                }
+                                else {
+                                    DISPLAYLEVEL(3, " %20llu %20s %9s \n", totalBlocksSize + hSize, "-", "-");
+                                    cfinfo->allContentSize = 0;
+                                }
+                                result = LZ4IO_LZ4F_OK;
+            }   }   }   }   }
+            break;
+        case LEGACY_MAGICNUMBER:
+            frameInfo.frameType = legacyFrame;
+            if (cfinfo->frameSummary.frameType != legacyFrame && cfinfo->frameCount != 0) cfinfo->eqFrameTypes = 0;
+            cfinfo->eqBlockTypes = 0;
+            cfinfo->allContentSize = 0;
+            {   const unsigned long long totalBlocksSize = LZ4IO_skipLegacyBlocksData(finput);
+                if (totalBlocksSize) {
+                    DISPLAYLEVEL(3, "    %6llu %14s %5s %8s %20llu %20s %9s\n",
+                                 cfinfo->frameCount + 1,
+                                 LZ4IO_frameTypeNames[frameInfo.frameType],
+                                 "-", "-",
+                                 totalBlocksSize + 4,
+                                 "-", "-");
+                    result = LZ4IO_LZ4F_OK;
+            }   }
+            break;
+        case LZ4IO_SKIPPABLE0:
+            frameInfo.frameType = skippableFrame;
+            if (cfinfo->frameSummary.frameType != skippableFrame && cfinfo->frameCount != 0) cfinfo->eqFrameTypes = 0;
+            cfinfo->eqBlockTypes = 0;
+            cfinfo->allContentSize = 0;
+            {   size_t const nbReadBytes = fread(buffer, 1, 4, finput);
+                if (nbReadBytes != 4)
+                    EXM_THROW(42, "Stream error : skippable size unreadable");
+            }
+            {   unsigned const size = LZ4IO_readLE32(buffer);
+                int const errorNb = fseek_u32(finput, size, SEEK_CUR);
+                if (errorNb != 0)
+                    EXM_THROW(43, "Stream error : cannot skip skippable area");
+                DISPLAYLEVEL(3, "    %6llu %14s %5s %8s %20u %20s %9s\n",
+                             cfinfo->frameCount + 1,
+                             "SkippableFrame",
+                             "-", "-", size + 8, "-", "-");
+
+                result = LZ4IO_LZ4F_OK;
+            }
+            break;
+        default:
+            {   long int const position = ftell(finput);  /* only works for files < 2 GB */
+                DISPLAYLEVEL(3, "Stream followed by undecodable data ");
+                if (position != -1L)
+                    DISPLAYLEVEL(3, "at position %i ", (int)position);
+                DISPLAYLEVEL(3, "\n");
+            }
+        break;
+        }
+        if (result != LZ4IO_LZ4F_OK) break;
+        cfinfo->frameSummary = frameInfo;
+        cfinfo->frameCount++;
+    }  /* while (!feof(finput)) */
+    fclose(finput);
+    return result;
+}
+
+
+int LZ4IO_displayCompressedFilesInfo(const char** inFileNames, size_t ifnIdx)
+{
+    int result = 0;
+    size_t idx = 0;
+    if (g_displayLevel < 3) {
+        DISPLAYOUT("%10s %14s %5s %11s %13s %9s   %s\n",
+                "Frames", "Type", "Block", "Compressed", "Uncompressed", "Ratio", "Filename");
+    }
+    for (; idx < ifnIdx; idx++) {
+        /* Get file info */
+        LZ4IO_cFileInfo_t cfinfo = LZ4IO_INIT_CFILEINFO;
+        cfinfo.fileName = LZ4IO_baseName(inFileNames[idx]);
+        if (!UTIL_isRegFile(inFileNames[idx])) {
+            DISPLAYLEVEL(1, "lz4: %s is not a regular file \n", inFileNames[idx]);
+            return 0;
+        }
+        DISPLAYLEVEL(3, "%s(%llu/%llu)\n", cfinfo.fileName, (unsigned long long)idx + 1, (unsigned  long long)ifnIdx);
+        DISPLAYLEVEL(3, "    %6s %14s %5s %8s %20s %20s %9s\n",
+                     "Frame", "Type", "Block", "Checksum", "Compressed", "Uncompressed", "Ratio")
+        {   LZ4IO_infoResult const op_result = LZ4IO_getCompressedFileInfo(&cfinfo, inFileNames[idx]);
+            if (op_result != LZ4IO_LZ4F_OK) {
+                assert(op_result == LZ4IO_format_not_known);
+                DISPLAYLEVEL(1, "lz4: %s: File format not recognized \n", inFileNames[idx]);
+                return 0;
+        }   }
+        DISPLAYLEVEL(3, "\n");
+        if (g_displayLevel < 3) {
+            /* Display Summary */
+            {   char buffers[3][10];
+                DISPLAYOUT("%10llu %14s %5s %11s %13s ",
+                        cfinfo.frameCount,
+                        cfinfo.eqFrameTypes ? LZ4IO_frameTypeNames[cfinfo.frameSummary.frameType] : "-" ,
+                        cfinfo.eqBlockTypes ? LZ4IO_blockTypeID(cfinfo.frameSummary.lz4FrameInfo.blockSizeID,
+                                                                cfinfo.frameSummary.lz4FrameInfo.blockMode, buffers[0]) : "-",
+                        LZ4IO_toHuman((long double)cfinfo.fileSize, buffers[1]),
+                        cfinfo.allContentSize ? LZ4IO_toHuman((long double)cfinfo.frameSummary.lz4FrameInfo.contentSize, buffers[2]) : "-");
+                if (cfinfo.allContentSize) {
+                    double const ratio = (double)cfinfo.fileSize / cfinfo.frameSummary.lz4FrameInfo.contentSize * 100;
+                    DISPLAYOUT("%9.2f%%  %s \n", ratio, cfinfo.fileName);
+                } else {
+                    DISPLAYOUT("%9s   %s\n",
+                            "-",
+                            cfinfo.fileName);
+        }   }   }  /* if (g_displayLevel < 3) */
+    }  /* for (; idx < ifnIdx; idx++) */
+
+    return result;
+}
diff --git a/lz4/programs/lz4io.h b/lz4/programs/lz4io.h
new file mode 100644
index 0000000..d6d7eee
--- /dev/null
+++ b/lz4/programs/lz4io.h
@@ -0,0 +1,134 @@
+/*
+  LZ4io.h - LZ4 File/Stream Interface
+  Copyright (C) Yann Collet 2011-2016
+  GPL v2 License
+
+  This program is free software; you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or
+  (at your option) any later version.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License along
+  with this program; if not, write to the Free Software Foundation, Inc.,
+  51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+  You can contact the author at :
+  - LZ4 source repository : https://github.com/lz4/lz4
+  - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+/*
+  Note : this is stand-alone program.
+  It is not part of LZ4 compression library, it is a user code of the LZ4 library.
+  - The license of LZ4 library is BSD.
+  - The license of xxHash library is BSD.
+  - The license of this source file is GPLv2.
+*/
+
+#ifndef LZ4IO_H_237902873
+#define LZ4IO_H_237902873
+
+/*---   Dependency   ---*/
+#include    /* size_t */
+
+
+/* ************************************************** */
+/* Special input/output values                        */
+/* ************************************************** */
+#define stdinmark  "stdin"
+#define stdoutmark "stdout"
+#define NULL_OUTPUT "null"
+#ifdef _WIN32
+#define nulmark "nul"
+#else
+#define nulmark "/dev/null"
+#endif
+
+/* ************************************************** */
+/* ****************** Type Definitions ************** */
+/* ************************************************** */
+
+typedef struct LZ4IO_prefs_s LZ4IO_prefs_t;
+
+LZ4IO_prefs_t* LZ4IO_defaultPreferences(void);
+void LZ4IO_freePreferences(LZ4IO_prefs_t* prefs);
+
+/* Size in bytes of a legacy block header in little-endian format */
+#define LZIO_LEGACY_BLOCK_HEADER_SIZE 4
+
+/* ************************************************** */
+/* ****************** Functions ********************* */
+/* ************************************************** */
+
+/* if output_filename == stdoutmark, writes to stdout */
+int LZ4IO_compressFilename(const char* input_filename, const char* output_filename, int compressionlevel, const LZ4IO_prefs_t* prefs);
+int LZ4IO_decompressFilename(const char* input_filename, const char* output_filename, const LZ4IO_prefs_t* prefs);
+
+/* if suffix == stdoutmark, writes to stdout */
+int LZ4IO_compressMultipleFilenames(const char** inFileNamesTable, int ifntSize, const char* suffix, int compressionlevel, const LZ4IO_prefs_t* prefs);
+int LZ4IO_decompressMultipleFilenames(const char** inFileNamesTable, int ifntSize, const char* suffix, const LZ4IO_prefs_t* prefs);
+
+
+/* ************************************************** */
+/* ****************** Parameters ******************** */
+/* ************************************************** */
+
+int LZ4IO_setDictionaryFilename(LZ4IO_prefs_t* const prefs, const char* dictionaryFilename);
+
+/* Default setting : passThrough = 0;
+   return : passThrough mode (0/1) */
+int LZ4IO_setPassThrough(LZ4IO_prefs_t* const prefs, int yes);
+
+/* Default setting : overwrite = 1;
+   return : overwrite mode (0/1) */
+int LZ4IO_setOverwrite(LZ4IO_prefs_t* const prefs, int yes);
+
+/* Default setting : testMode = 0;
+   return : testMode (0/1) */
+int LZ4IO_setTestMode(LZ4IO_prefs_t* const prefs, int yes);
+
+/* blockSizeID : valid values : 4-5-6-7
+   return : 0 if error, blockSize if OK */
+size_t LZ4IO_setBlockSizeID(LZ4IO_prefs_t* const prefs, unsigned blockSizeID);
+
+/* blockSize : valid values : 32 -> 4MB
+   return : 0 if error, actual blocksize if OK */
+size_t LZ4IO_setBlockSize(LZ4IO_prefs_t* const prefs, size_t blockSize);
+
+/* Default setting : independent blocks */
+typedef enum { LZ4IO_blockLinked=0, LZ4IO_blockIndependent} LZ4IO_blockMode_t;
+int LZ4IO_setBlockMode(LZ4IO_prefs_t* const prefs, LZ4IO_blockMode_t blockMode);
+
+/* Default setting : no block checksum */
+int LZ4IO_setBlockChecksumMode(LZ4IO_prefs_t* const prefs, int xxhash);
+
+/* Default setting : stream checksum enabled */
+int LZ4IO_setStreamChecksumMode(LZ4IO_prefs_t* const prefs, int xxhash);
+
+/* Default setting : 0 (no notification) */
+int LZ4IO_setNotificationLevel(int level);
+
+/* Default setting : 0 (disabled) */
+int LZ4IO_setSparseFile(LZ4IO_prefs_t* const prefs, int enable);
+
+/* Default setting : 0 == no content size present in frame header */
+int LZ4IO_setContentSize(LZ4IO_prefs_t* const prefs, int enable);
+
+/* Default setting : 0 == src file preserved */
+void LZ4IO_setRemoveSrcFile(LZ4IO_prefs_t* const prefs, unsigned flag);
+
+/* Default setting : 0 == favor compression ratio
+ * Note : 1 only works for high compression levels (10+) */
+void LZ4IO_favorDecSpeed(LZ4IO_prefs_t* const prefs, int favor);
+
+
+/* implement --list
+ * @return 0 on success, 1 on error */
+int LZ4IO_displayCompressedFilesInfo(const char** inFileNames, size_t ifnIdx);
+
+
+#endif  /* LZ4IO_H_237902873 */
diff --git a/lz4/programs/platform.h b/lz4/programs/platform.h
new file mode 100644
index 0000000..ab8300d
--- /dev/null
+++ b/lz4/programs/platform.h
@@ -0,0 +1,155 @@
+/*
+    platform.h - compiler and OS detection
+    Copyright (C) 2016-present, Przemyslaw Skibinski, Yann Collet
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+*/
+
+#ifndef PLATFORM_H_MODULE
+#define PLATFORM_H_MODULE
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+
+
+/* **************************************
+*  Compiler Options
+****************************************/
+#if defined(_MSC_VER)
+#  define _CRT_SECURE_NO_WARNINGS    /* Disable Visual Studio warning messages for fopen, strncpy, strerror */
+#  if (_MSC_VER <= 1800)             /* (1800 = Visual Studio 2013) */
+#    define _CRT_SECURE_NO_DEPRECATE /* VS2005 - must be declared before  and  */
+#    define snprintf sprintf_s       /* snprintf unsupported by Visual <= 2013 */
+#  endif
+#endif
+
+
+/* **************************************
+*  Detect 64-bit OS
+*  http://nadeausoftware.com/articles/2012/02/c_c_tip_how_detect_processor_type_using_compiler_predefined_macros
+****************************************/
+#if defined __ia64 || defined _M_IA64                                                                               /* Intel Itanium */ \
+  || defined __powerpc64__ || defined __ppc64__ || defined __PPC64__                                                /* POWER 64-bit */  \
+  || (defined __sparc && (defined __sparcv9 || defined __sparc_v9__ || defined __arch64__)) || defined __sparc64__  /* SPARC 64-bit */  \
+  || defined __x86_64__s || defined _M_X64                                                                          /* x86 64-bit */    \
+  || defined __arm64__ || defined __aarch64__ || defined __ARM64_ARCH_8__                                           /* ARM 64-bit */    \
+  || (defined __mips  && (__mips == 64 || __mips == 4 || __mips == 3))                                              /* MIPS 64-bit */   \
+  || defined _LP64 || defined __LP64__ /* NetBSD, OpenBSD */ || defined __64BIT__ /* AIX */ || defined _ADDR64 /* Cray */               \
+  || (defined __SIZEOF_POINTER__ && __SIZEOF_POINTER__ == 8) /* gcc */
+#  if !defined(__64BIT__)
+#    define __64BIT__  1
+#  endif
+#endif
+
+
+/* *********************************************************
+*  Turn on Large Files support (>4GB) for 32-bit Linux/Unix
+***********************************************************/
+#if !defined(__64BIT__) || defined(__MINGW32__)       /* No point defining Large file for 64 bit but MinGW-w64 requires it */
+#  if !defined(_FILE_OFFSET_BITS)
+#    define _FILE_OFFSET_BITS 64                      /* turn off_t into a 64-bit type for ftello, fseeko */
+#  endif
+#  if !defined(_LARGEFILE_SOURCE)                     /* obsolete macro, replaced with _FILE_OFFSET_BITS */
+#    define _LARGEFILE_SOURCE 1                       /* Large File Support extension (LFS) - fseeko, ftello */
+#  endif
+#  if defined(_AIX) || defined(__hpux)
+#    define _LARGE_FILES                              /* Large file support on 32-bits AIX and HP-UX */
+#  endif
+#endif
+
+
+/* ************************************************************
+*  Detect POSIX version
+*  PLATFORM_POSIX_VERSION = -1 for non-Unix e.g. Windows
+*  PLATFORM_POSIX_VERSION = 0 for Unix-like non-POSIX
+*  PLATFORM_POSIX_VERSION >= 1 is equal to found _POSIX_VERSION
+************************************************************** */
+#if !defined(_WIN32) && (defined(__unix__) || defined(__unix) || (defined(__APPLE__) && defined(__MACH__)) /* UNIX-like OS */ \
+   || defined(__midipix__) || defined(__VMS))
+#  if (defined(__APPLE__) && defined(__MACH__)) || defined(__SVR4) || defined(_AIX) || defined(__hpux) /* POSIX.1–2001 (SUSv3) conformant */ \
+     || defined(__DragonFly__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)  || defined(__MidnightBSD__) /* BSD distros */ \
+     || defined(__HAIKU__)
+#    define PLATFORM_POSIX_VERSION 200112L
+#  else
+#    if defined(__linux__) || defined(__linux)
+#      ifndef _POSIX_C_SOURCE
+#        define _POSIX_C_SOURCE 200809L  /* use feature test macro */
+#      endif
+#    endif
+#    include   /* declares _POSIX_VERSION */
+#    if defined(_POSIX_VERSION)  /* POSIX compliant */
+#      define PLATFORM_POSIX_VERSION _POSIX_VERSION
+#    else
+#      define PLATFORM_POSIX_VERSION 0
+#    endif
+#  endif
+#endif
+#if !defined(PLATFORM_POSIX_VERSION)
+#  define PLATFORM_POSIX_VERSION -1
+#endif
+
+
+/*-*********************************************
+*  Detect if isatty() and fileno() are available
+*********************************************** */
+#if (defined(__linux__) && (PLATFORM_POSIX_VERSION >= 1)) || (PLATFORM_POSIX_VERSION >= 200112L) || defined(__DJGPP__)
+#  include    /* isatty */
+#  define IS_CONSOLE(stdStream) isatty(fileno(stdStream))
+#elif defined(MSDOS) || defined(OS2) || defined(__CYGWIN__)
+#  include        /* _isatty */
+#  define IS_CONSOLE(stdStream) _isatty(_fileno(stdStream))
+#elif defined(WIN32) || defined(_WIN32)
+#  include       /* _isatty */
+#  include  /* DeviceIoControl, HANDLE, FSCTL_SET_SPARSE */
+#  include    /* FILE */
+static __inline int IS_CONSOLE(FILE* stdStream)
+{
+    DWORD dummy;
+    return _isatty(_fileno(stdStream)) && GetConsoleMode((HANDLE)_get_osfhandle(_fileno(stdStream)), &dummy);
+}
+#else
+#  define IS_CONSOLE(stdStream) 0
+#endif
+
+
+/******************************
+*  OS-specific Includes
+***************************** */
+#if defined(MSDOS) || defined(OS2) || defined(WIN32) || defined(_WIN32)
+#  include    /* _O_BINARY */
+#  include       /* _setmode, _fileno, _get_osfhandle */
+#  if !defined(__DJGPP__)
+#    include  /* DeviceIoControl, HANDLE, FSCTL_SET_SPARSE */
+#    include  /* FSCTL_SET_SPARSE */
+#    define SET_BINARY_MODE(file) { int unused=_setmode(_fileno(file), _O_BINARY); (void)unused; }
+#    define SET_SPARSE_FILE_MODE(file) { DWORD dw; DeviceIoControl((HANDLE) _get_osfhandle(_fileno(file)), FSCTL_SET_SPARSE, 0, 0, 0, 0, &dw, 0); }
+#  else
+#    define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY)
+#    define SET_SPARSE_FILE_MODE(file)
+#  endif
+#else
+#  define SET_BINARY_MODE(file)
+#  define SET_SPARSE_FILE_MODE(file)
+#endif
+
+
+
+#if defined (__cplusplus)
+}
+#endif
+
+#endif /* PLATFORM_H_MODULE */
diff --git a/lz4/programs/util.h b/lz4/programs/util.h
new file mode 100644
index 0000000..733c1ca
--- /dev/null
+++ b/lz4/programs/util.h
@@ -0,0 +1,650 @@
+/*
+    util.h - utility functions
+    Copyright (C) 2016-present, Przemyslaw Skibinski, Yann Collet
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+*/
+
+#ifndef UTIL_H_MODULE
+#define UTIL_H_MODULE
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+
+
+/*-****************************************
+*  Dependencies
+******************************************/
+#include "platform.h"     /* PLATFORM_POSIX_VERSION */
+#include        /* size_t, ptrdiff_t */
+#include        /* malloc */
+#include        /* strlen, strncpy */
+#include         /* fprintf, fileno */
+#include 
+#include     /* stat, utime */
+#include      /* stat */
+#if defined(_WIN32)
+#  include   /* utime */
+#  include          /* _chmod */
+#else
+#  include      /* chown, stat */
+# if PLATFORM_POSIX_VERSION < 200809L
+#  include       /* utime */
+# else
+#  include       /* AT_FDCWD */
+#  include    /* for utimensat */
+# endif
+#endif
+#include          /* time */
+#include        /* INT_MAX */
+#include 
+
+
+
+/*-**************************************************************
+*  Basic Types
+*****************************************************************/
+#if !defined (__VMS) && (defined (__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) )
+# include 
+  typedef  uint8_t BYTE;
+  typedef uint16_t U16;
+  typedef  int16_t S16;
+  typedef uint32_t U32;
+  typedef  int32_t S32;
+  typedef uint64_t U64;
+  typedef  int64_t S64;
+#else
+  typedef unsigned char       BYTE;
+  typedef unsigned short      U16;
+  typedef   signed short      S16;
+  typedef unsigned int        U32;
+  typedef   signed int        S32;
+  typedef unsigned long long  U64;
+  typedef   signed long long  S64;
+#endif
+
+
+/* ************************************************************
+* Avoid fseek()'s 2GiB barrier with MSVC, MacOS, *BSD, MinGW
+***************************************************************/
+#if defined(_MSC_VER) && (_MSC_VER >= 1400)
+#   define UTIL_fseek _fseeki64
+#elif !defined(__64BIT__) && (PLATFORM_POSIX_VERSION >= 200112L) /* No point defining Large file for 64 bit */
+#  define UTIL_fseek fseeko
+#elif defined(__MINGW32__) && defined(__MSVCRT__) && !defined(__STRICT_ANSI__) && !defined(__NO_MINGW_LFS)
+#   define UTIL_fseek fseeko64
+#else
+#   define UTIL_fseek fseek
+#endif
+
+
+/*-****************************************
+*  Sleep functions: Windows - Posix - others
+******************************************/
+#if defined(_WIN32)
+#  include 
+#  define SET_REALTIME_PRIORITY SetPriorityClass(GetCurrentProcess(), REALTIME_PRIORITY_CLASS)
+#  define UTIL_sleep(s) Sleep(1000*s)
+#  define UTIL_sleepMilli(milli) Sleep(milli)
+#elif PLATFORM_POSIX_VERSION >= 0 /* Unix-like operating system */
+#  include 
+#  include  /* setpriority */
+#  include          /* clock_t, nanosleep, clock, CLOCKS_PER_SEC */
+#  if defined(PRIO_PROCESS)
+#    define SET_REALTIME_PRIORITY setpriority(PRIO_PROCESS, 0, -20)
+#  else
+#    define SET_REALTIME_PRIORITY /* disabled */
+#  endif
+#  define UTIL_sleep(s) sleep(s)
+#  if (defined(__linux__) && (PLATFORM_POSIX_VERSION >= 199309L)) || (PLATFORM_POSIX_VERSION >= 200112L)  /* nanosleep requires POSIX.1-2001 */
+#      define UTIL_sleepMilli(milli) { struct timespec t; t.tv_sec=0; t.tv_nsec=milli*1000000ULL; nanosleep(&t, NULL); }
+#  else
+#      define UTIL_sleepMilli(milli) /* disabled */
+#  endif
+#else
+#  define SET_REALTIME_PRIORITY      /* disabled */
+#  define UTIL_sleep(s)          /* disabled */
+#  define UTIL_sleepMilli(milli) /* disabled */
+#endif
+
+
+/*-****************************************
+*  stat() functions
+******************************************/
+#if defined(_MSC_VER)
+#  define UTIL_TYPE_stat __stat64
+#  define UTIL_stat _stat64
+#  define UTIL_fstat _fstat64
+#  define UTIL_STAT_MODE_ISREG(st_mode) ((st_mode) & S_IFREG)
+#elif   defined(__MINGW32__) && defined (__MSVCRT__)
+#  define UTIL_TYPE_stat _stati64
+#  define UTIL_stat _stati64
+#  define UTIL_fstat _fstati64
+#  define UTIL_STAT_MODE_ISREG(st_mode) ((st_mode) & S_IFREG)
+#else
+#  define UTIL_TYPE_stat stat
+#  define UTIL_stat stat
+#  define UTIL_fstat fstat
+#  define UTIL_STAT_MODE_ISREG(st_mode) (S_ISREG(st_mode))
+#endif
+
+
+/*-****************************************
+*  fileno() function
+******************************************/
+#if defined(_MSC_VER)
+#  define UTIL_fileno _fileno
+#else
+#  define UTIL_fileno fileno
+#endif
+
+/* *************************************
+*  Constants
+***************************************/
+#define LIST_SIZE_INCREASE   (8*1024)
+
+
+/*-****************************************
+*  Compiler specifics
+******************************************/
+#if defined(__INTEL_COMPILER)
+#  pragma warning(disable : 177)    /* disable: message #177: function was declared but never referenced, useful with UTIL_STATIC */
+#endif
+#if defined(__GNUC__)
+#  define UTIL_STATIC static __attribute__((unused))
+#elif defined (__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */)
+#  define UTIL_STATIC static inline
+#elif defined(_MSC_VER)
+#  define UTIL_STATIC static __inline
+#else
+#  define UTIL_STATIC static  /* this version may generate warnings for unused static functions; disable the relevant warning */
+#endif
+
+
+/*-****************************************
+*  Time functions
+******************************************/
+#if defined(_WIN32)   /* Windows */
+
+    typedef LARGE_INTEGER UTIL_time_t;
+    UTIL_STATIC UTIL_time_t UTIL_getTime(void) { UTIL_time_t x; QueryPerformanceCounter(&x); return x; }
+    UTIL_STATIC U64 UTIL_getSpanTimeMicro(UTIL_time_t clockStart, UTIL_time_t clockEnd)
+    {
+        static LARGE_INTEGER ticksPerSecond;
+        static int init = 0;
+        if (!init) {
+            if (!QueryPerformanceFrequency(&ticksPerSecond))
+                fprintf(stderr, "ERROR: QueryPerformanceFrequency() failure\n");
+            init = 1;
+        }
+        return 1000000ULL*(clockEnd.QuadPart - clockStart.QuadPart)/ticksPerSecond.QuadPart;
+    }
+    UTIL_STATIC U64 UTIL_getSpanTimeNano(UTIL_time_t clockStart, UTIL_time_t clockEnd)
+    {
+        static LARGE_INTEGER ticksPerSecond;
+        static int init = 0;
+        if (!init) {
+            if (!QueryPerformanceFrequency(&ticksPerSecond))
+                fprintf(stderr, "ERROR: QueryPerformanceFrequency() failure\n");
+            init = 1;
+        }
+        return 1000000000ULL*(clockEnd.QuadPart - clockStart.QuadPart)/ticksPerSecond.QuadPart;
+    }
+
+#elif defined(__APPLE__) && defined(__MACH__)
+
+    #include 
+    typedef U64 UTIL_time_t;
+    UTIL_STATIC UTIL_time_t UTIL_getTime(void) { return mach_absolute_time(); }
+    UTIL_STATIC U64 UTIL_getSpanTimeMicro(UTIL_time_t clockStart, UTIL_time_t clockEnd)
+    {
+        static mach_timebase_info_data_t rate;
+        static int init = 0;
+        if (!init) {
+            mach_timebase_info(&rate);
+            init = 1;
+        }
+        return (((clockEnd - clockStart) * (U64)rate.numer) / ((U64)rate.denom)) / 1000ULL;
+    }
+    UTIL_STATIC U64 UTIL_getSpanTimeNano(UTIL_time_t clockStart, UTIL_time_t clockEnd)
+    {
+        static mach_timebase_info_data_t rate;
+        static int init = 0;
+        if (!init) {
+            mach_timebase_info(&rate);
+            init = 1;
+        }
+        return ((clockEnd - clockStart) * (U64)rate.numer) / ((U64)rate.denom);
+    }
+
+#elif (PLATFORM_POSIX_VERSION >= 200112L) && (defined __UCLIBC__ || (defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 17) || __GLIBC__ > 2) ) )
+
+    #include 
+    typedef struct timespec UTIL_time_t;
+    UTIL_STATIC UTIL_time_t UTIL_getTime(void)
+    {
+        UTIL_time_t now;
+        if (clock_gettime(CLOCK_MONOTONIC, &now))
+            fprintf(stderr, "ERROR: Failed to get time\n");   /* we could also exit() */
+        return now;
+    }
+    UTIL_STATIC UTIL_time_t UTIL_getSpanTime(UTIL_time_t begin, UTIL_time_t end)
+    {
+        UTIL_time_t diff;
+        if (end.tv_nsec < begin.tv_nsec) {
+            diff.tv_sec = (end.tv_sec - 1) - begin.tv_sec;
+            diff.tv_nsec = (end.tv_nsec + 1000000000ULL) - begin.tv_nsec;
+        } else {
+            diff.tv_sec = end.tv_sec - begin.tv_sec;
+            diff.tv_nsec = end.tv_nsec - begin.tv_nsec;
+        }
+        return diff;
+    }
+    UTIL_STATIC U64 UTIL_getSpanTimeMicro(UTIL_time_t begin, UTIL_time_t end)
+    {
+        UTIL_time_t const diff = UTIL_getSpanTime(begin, end);
+        U64 micro = 0;
+        micro += 1000000ULL * diff.tv_sec;
+        micro += diff.tv_nsec / 1000ULL;
+        return micro;
+    }
+    UTIL_STATIC U64 UTIL_getSpanTimeNano(UTIL_time_t begin, UTIL_time_t end)
+    {
+        UTIL_time_t const diff = UTIL_getSpanTime(begin, end);
+        U64 nano = 0;
+        nano += 1000000000ULL * diff.tv_sec;
+        nano += diff.tv_nsec;
+        return nano;
+    }
+
+#else   /* relies on standard C (note : clock_t measurements can be wrong when using multi-threading) */
+
+    typedef clock_t UTIL_time_t;
+    UTIL_STATIC UTIL_time_t UTIL_getTime(void) { return clock(); }
+    UTIL_STATIC U64 UTIL_getSpanTimeMicro(UTIL_time_t clockStart, UTIL_time_t clockEnd) { return 1000000ULL * (clockEnd - clockStart) / CLOCKS_PER_SEC; }
+    UTIL_STATIC U64 UTIL_getSpanTimeNano(UTIL_time_t clockStart, UTIL_time_t clockEnd) { return 1000000000ULL * (clockEnd - clockStart) / CLOCKS_PER_SEC; }
+#endif
+
+
+/* returns time span in microseconds */
+UTIL_STATIC U64 UTIL_clockSpanMicro(UTIL_time_t clockStart)
+{
+    UTIL_time_t const clockEnd = UTIL_getTime();
+    return UTIL_getSpanTimeMicro(clockStart, clockEnd);
+}
+
+/* returns time span in nanoseconds */
+UTIL_STATIC U64 UTIL_clockSpanNano(UTIL_time_t clockStart)
+{
+    UTIL_time_t const clockEnd = UTIL_getTime();
+    return UTIL_getSpanTimeNano(clockStart, clockEnd);
+}
+
+UTIL_STATIC void UTIL_waitForNextTick(void)
+{
+    UTIL_time_t const clockStart = UTIL_getTime();
+    UTIL_time_t clockEnd;
+    do {
+        clockEnd = UTIL_getTime();
+    } while (UTIL_getSpanTimeNano(clockStart, clockEnd) == 0);
+}
+
+
+
+/*-****************************************
+*  File functions
+******************************************/
+#if defined(_MSC_VER)
+    #define chmod _chmod
+    typedef struct __stat64 stat_t;
+#else
+    typedef struct stat stat_t;
+#endif
+
+
+UTIL_STATIC int UTIL_isRegFile(const char* infilename);
+
+
+UTIL_STATIC int UTIL_setFileStat(const char *filename, stat_t *statbuf)
+{
+    int res = 0;
+
+    if (!UTIL_isRegFile(filename))
+        return -1;
+
+    {
+#if defined(_WIN32) || (PLATFORM_POSIX_VERSION < 200809L)
+        struct utimbuf timebuf;
+        timebuf.actime = time(NULL);
+        timebuf.modtime = statbuf->st_mtime;
+        res += utime(filename, &timebuf);  /* set access and modification times */
+#else
+        struct timespec timebuf[2] = {};
+        timebuf[0].tv_nsec = UTIME_NOW;
+        timebuf[1].tv_sec = statbuf->st_mtime;
+        res += utimensat(AT_FDCWD, filename, timebuf, 0);  /* set access and modification times */
+#endif
+    }
+
+#if !defined(_WIN32)
+    res += chown(filename, statbuf->st_uid, statbuf->st_gid);  /* Copy ownership */
+#endif
+
+    res += chmod(filename, statbuf->st_mode & 07777);  /* Copy file permissions */
+
+    errno = 0;
+    return -res; /* number of errors is returned */
+}
+
+
+UTIL_STATIC int UTIL_getFileStat(const char* infilename, stat_t *statbuf)
+{
+    int r;
+#if defined(_MSC_VER)
+    r = _stat64(infilename, statbuf);
+    if (r || !(statbuf->st_mode & S_IFREG)) return 0;   /* No good... */
+#else
+    r = stat(infilename, statbuf);
+    if (r || !S_ISREG(statbuf->st_mode)) return 0;   /* No good... */
+#endif
+    return 1;
+}
+
+
+UTIL_STATIC int UTIL_isRegFile(const char* infilename)
+{
+    stat_t statbuf;
+    return UTIL_getFileStat(infilename, &statbuf); /* Only need to know whether it is a regular file */
+}
+
+
+UTIL_STATIC U32 UTIL_isDirectory(const char* infilename)
+{
+    int r;
+    stat_t statbuf;
+#if defined(_MSC_VER)
+    r = _stat64(infilename, &statbuf);
+    if (!r && (statbuf.st_mode & _S_IFDIR)) return 1;
+#else
+    r = stat(infilename, &statbuf);
+    if (!r && S_ISDIR(statbuf.st_mode)) return 1;
+#endif
+    return 0;
+}
+
+
+UTIL_STATIC U64 UTIL_getOpenFileSize(FILE* file)
+{
+    int r;
+    int fd;
+    struct UTIL_TYPE_stat statbuf;
+
+    fd = UTIL_fileno(file);
+    if (fd < 0) {
+        perror("fileno");
+        exit(1);
+    }
+    r = UTIL_fstat(fd, &statbuf);
+    if (r || !UTIL_STAT_MODE_ISREG(statbuf.st_mode)) return 0;   /* No good... */
+    return (U64)statbuf.st_size;
+}
+
+
+UTIL_STATIC U64 UTIL_getFileSize(const char* infilename)
+{
+    int r;
+    struct UTIL_TYPE_stat statbuf;
+
+    r = UTIL_stat(infilename, &statbuf);
+    if (r || !UTIL_STAT_MODE_ISREG(statbuf.st_mode)) return 0;   /* No good... */
+    return (U64)statbuf.st_size;
+}
+
+
+UTIL_STATIC U64 UTIL_getTotalFileSize(const char** fileNamesTable, unsigned nbFiles)
+{
+    U64 total = 0;
+    unsigned n;
+    for (n=0; n= *bufEnd) {
+                ptrdiff_t newListSize = (*bufEnd - *bufStart) + LIST_SIZE_INCREASE;
+                *bufStart = (char*)UTIL_realloc(*bufStart, newListSize);
+                *bufEnd = *bufStart + newListSize;
+                if (*bufStart == NULL) { free(path); FindClose(hFile); return 0; }
+            }
+            if (*bufStart + *pos + pathLength < *bufEnd) {
+                strncpy(*bufStart + *pos, path, *bufEnd - (*bufStart + *pos));
+                *pos += pathLength + 1;
+                nbFiles++;
+            }
+        }
+        free(path);
+    } while (FindNextFileA(hFile, &cFile));
+
+    FindClose(hFile);
+    assert(nbFiles < INT_MAX);
+    return (int)nbFiles;
+}
+
+#elif defined(__linux__) || (PLATFORM_POSIX_VERSION >= 200112L)  /* opendir, readdir require POSIX.1-2001 */
+#  define UTIL_HAS_CREATEFILELIST
+#  include        /* opendir, readdir */
+#  include        /* strerror, memcpy */
+
+UTIL_STATIC int UTIL_prepareFileList(const char* dirName, char** bufStart, size_t* pos, char** bufEnd)
+{
+    DIR* dir;
+    struct dirent * entry;
+    int dirLength, nbFiles = 0;
+
+    if (!(dir = opendir(dirName))) {
+        fprintf(stderr, "Cannot open directory '%s': %s\n", dirName, strerror(errno));
+        return 0;
+    }
+
+    dirLength = (int)strlen(dirName);
+    errno = 0;
+    while ((entry = readdir(dir)) != NULL) {
+        char* path;
+        int fnameLength, pathLength;
+        if (strcmp (entry->d_name, "..") == 0 ||
+            strcmp (entry->d_name, ".") == 0) continue;
+        fnameLength = (int)strlen(entry->d_name);
+        path = (char*) malloc(dirLength + fnameLength + 2);
+        if (!path) { closedir(dir); return 0; }
+        memcpy(path, dirName, dirLength);
+        path[dirLength] = '/';
+        memcpy(path+dirLength+1, entry->d_name, fnameLength);
+        pathLength = dirLength+1+fnameLength;
+        path[pathLength] = 0;
+
+        if (UTIL_isDirectory(path)) {
+            nbFiles += UTIL_prepareFileList(path, bufStart, pos, bufEnd);  /* Recursively call "UTIL_prepareFileList" with the new path. */
+            if (*bufStart == NULL) { free(path); closedir(dir); return 0; }
+        } else {
+            if (*bufStart + *pos + pathLength >= *bufEnd) {
+                ptrdiff_t newListSize = (*bufEnd - *bufStart) + LIST_SIZE_INCREASE;
+                *bufStart = (char*)UTIL_realloc(*bufStart, newListSize);
+                *bufEnd = *bufStart + newListSize;
+                if (*bufStart == NULL) { free(path); closedir(dir); return 0; }
+            }
+            if (*bufStart + *pos + pathLength < *bufEnd) {
+                strncpy(*bufStart + *pos, path, *bufEnd - (*bufStart + *pos));
+                *pos += pathLength + 1;
+                nbFiles++;
+            }
+        }
+        free(path);
+        errno = 0; /* clear errno after UTIL_isDirectory, UTIL_prepareFileList */
+    }
+
+    if (errno != 0) {
+        fprintf(stderr, "readdir(%s) error: %s\n", dirName, strerror(errno));
+        free(*bufStart);
+        *bufStart = NULL;
+    }
+    closedir(dir);
+    return nbFiles;
+}
+
+#else
+
+UTIL_STATIC int UTIL_prepareFileList(const char* dirName, char** bufStart, size_t* pos, char** bufEnd)
+{
+    (void)bufStart; (void)bufEnd; (void)pos;
+    fprintf(stderr, "Directory %s ignored (compiled without _WIN32 or _POSIX_C_SOURCE)\n", dirName);
+    return 0;
+}
+
+#endif /* #ifdef _WIN32 */
+
+/*
+ * UTIL_createFileList - takes a list of files and directories (params: inputNames, inputNamesNb), scans directories,
+ *                       and returns a new list of files (params: return value, allocatedBuffer, allocatedNamesNb).
+ * After finishing usage of the list the structures should be freed with UTIL_freeFileList(params: return value, allocatedBuffer)
+ * In case of error UTIL_createFileList returns NULL and UTIL_freeFileList should not be called.
+ */
+UTIL_STATIC const char**
+UTIL_createFileList(const char** inputNames, unsigned inputNamesNb,
+                    char** allocatedBuffer, unsigned* allocatedNamesNb)
+{
+    size_t pos;
+    unsigned i, nbFiles;
+    char* buf = (char*)malloc(LIST_SIZE_INCREASE);
+    size_t bufSize = LIST_SIZE_INCREASE;
+    const char** fileTable;
+
+    if (!buf) return NULL;
+
+    for (i=0, pos=0, nbFiles=0; i= bufSize) {
+                while (pos + len >= bufSize) bufSize += LIST_SIZE_INCREASE;
+                buf = (char*)UTIL_realloc(buf, bufSize);
+                if (!buf) return NULL;
+            }
+            assert(pos + len < bufSize);
+            memcpy(buf + pos, inputNames[i], len);
+            pos += len;
+            nbFiles++;
+        } else {
+            char* bufend = buf + bufSize;
+            nbFiles += (unsigned)UTIL_prepareFileList(inputNames[i], &buf, &pos, &bufend);
+            if (buf == NULL) return NULL;
+            assert(bufend > buf);
+            bufSize = (size_t)(bufend - buf);
+    }   }
+
+    if (nbFiles == 0) { free(buf); return NULL; }
+
+    fileTable = (const char**)malloc(((size_t)nbFiles+1) * sizeof(const char*));
+    if (!fileTable) { free(buf); return NULL; }
+
+    for (i=0, pos=0; i bufSize) {
+        free(buf);
+        free((void*)fileTable);
+        return NULL;
+    }   /* can this happen ? */
+
+    *allocatedBuffer = buf;
+    *allocatedNamesNb = nbFiles;
+
+    return fileTable;
+}
+
+
+UTIL_STATIC void
+UTIL_freeFileList(const char** filenameTable, char* allocatedBuffer)
+{
+    if (allocatedBuffer) free(allocatedBuffer);
+    if (filenameTable) free((void*)filenameTable);
+}
+
+
+#if defined (__cplusplus)
+}
+#endif
+
+#endif /* UTIL_H_MODULE */
diff --git a/lz4/tests/.gitignore b/lz4/tests/.gitignore
new file mode 100644
index 0000000..99351af
--- /dev/null
+++ b/lz4/tests/.gitignore
@@ -0,0 +1,22 @@
+
+# build artefacts
+datagen
+frametest
+frametest32
+fullbench
+fullbench32
+fuzzer
+fuzzer32
+fasttest
+roundTripTest
+checkTag
+checkFrame
+decompress-partial
+
+# test artefacts
+tmp*
+versionsTest
+lz4_all.c
+
+# local tests
+afl
diff --git a/lz4/tests/COPYING b/lz4/tests/COPYING
new file mode 100644
index 0000000..d159169
--- /dev/null
+++ b/lz4/tests/COPYING
@@ -0,0 +1,339 @@
+                    GNU GENERAL PUBLIC LICENSE
+                       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+                            NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    
+    Copyright (C)   
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  , 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.
diff --git a/lz4/tests/Makefile b/lz4/tests/Makefile
new file mode 100644
index 0000000..6eee132
--- /dev/null
+++ b/lz4/tests/Makefile
@@ -0,0 +1,544 @@
+# ##########################################################################
+# LZ4 programs - Makefile
+# Copyright (C) Yann Collet 2011-present
+#
+# GPL v2 License
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# You can contact the author at :
+#  - LZ4 homepage : http://www.lz4.org
+#  - LZ4 source repository : https://github.com/lz4/lz4
+# ##########################################################################
+# fuzzer  : Test tool, to check lz4 integrity on target platform
+# frametest  : Test tool, to check lz4frame integrity on target platform
+# fullbench  : Precisely measure speed for each LZ4 function variant
+# datagen : generates synthetic data samples for tests & benchmarks
+# ##########################################################################
+
+LZ4DIR  := ../lib
+PRGDIR  := ../programs
+TESTDIR := versionsTest
+PYTHON  ?= python3
+
+DEBUGLEVEL?= 1
+DEBUGFLAGS = -g -DLZ4_DEBUG=$(DEBUGLEVEL)
+CFLAGS  ?= -O3 # can select custom optimization flags. Example : CFLAGS=-O2 make
+CFLAGS  += -Wall -Wextra -Wundef -Wcast-qual -Wcast-align -Wshadow \
+           -Wswitch-enum -Wdeclaration-after-statement -Wstrict-prototypes \
+           -Wpointer-arith -Wstrict-aliasing=1
+CFLAGS  += $(DEBUGFLAGS) $(MOREFLAGS)
+CPPFLAGS+= -I$(LZ4DIR) -I$(PRGDIR) -DXXH_NAMESPACE=LZ4_
+FLAGS    = $(CFLAGS) $(CPPFLAGS) $(LDFLAGS)
+
+include ../Makefile.inc
+
+LZ4 := $(PRGDIR)/lz4$(EXT)
+
+
+# Default test parameters
+TEST_FILES   := COPYING
+FUZZER_TIME  := -T90s
+NB_LOOPS     ?= -i1
+
+.PHONY: default
+default: all
+
+all: fullbench fuzzer frametest roundTripTest datagen checkFrame decompress-partial
+
+all32: CFLAGS+=-m32
+all32: all
+
+lz4:
+	$(MAKE) -C $(PRGDIR) $@ CFLAGS="$(CFLAGS)"
+
+lib liblz4.pc:
+	$(MAKE) -C $(LZ4DIR) $@ CFLAGS="$(CFLAGS)"
+
+lz4c unlz4 lz4cat: lz4
+	$(LN_SF) $(LZ4) $(PRGDIR)/$@
+
+lz4c32:   # create a 32-bits version for 32/64 interop tests
+	$(MAKE) -C $(PRGDIR) $@ CFLAGS="-m32 $(CFLAGS)"
+
+%.o : $(LZ4DIR)/%.c $(LZ4DIR)/%.h
+	$(CC) -c $(CFLAGS) $(CPPFLAGS) $< -o $@
+
+fullbench : DEBUGLEVEL=0
+fullbench : lz4.o lz4hc.o lz4frame.o xxhash.o fullbench.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+$(LZ4DIR)/liblz4.a:
+	$(MAKE) -C $(LZ4DIR) liblz4.a
+
+fullbench-lib: fullbench.c $(LZ4DIR)/liblz4.a
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+fullbench-dll: fullbench.c $(LZ4DIR)/xxhash.c
+	$(MAKE) -C $(LZ4DIR) liblz4
+	$(CC) $(FLAGS) $^ -o $@$(EXT) -DLZ4_DLL_IMPORT=1 $(LZ4DIR)/dll/$(LIBLZ4).dll
+
+# test LZ4_USER_MEMORY_FUNCTIONS
+fullbench-wmalloc: CPPFLAGS += -DLZ4_USER_MEMORY_FUNCTIONS
+fullbench-wmalloc: fullbench
+
+fuzzer  : lz4.o lz4hc.o xxhash.o fuzzer.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+frametest: lz4frame.o lz4.o lz4hc.o xxhash.o frametest.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+roundTripTest : lz4.o lz4hc.o xxhash.o roundTripTest.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+datagen : $(PRGDIR)/datagen.c datagencli.c
+	$(CC) $(FLAGS) -I$(PRGDIR) $^ -o $@$(EXT)
+
+checkFrame : lz4frame.o lz4.o lz4hc.o xxhash.o checkFrame.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+decompress-partial: lz4.o decompress-partial.c
+	$(CC) $(FLAGS) $^ -o $@$(EXT)
+
+.PHONY: clean
+clean:
+	@$(MAKE) -C $(LZ4DIR) $@ > $(VOID)
+	@$(MAKE) -C $(PRGDIR) $@ > $(VOID)
+	@$(RM) -rf core *.o *.test tmp* \
+        fullbench-dll$(EXT) fullbench-lib$(EXT) \
+        fullbench$(EXT) fullbench32$(EXT) \
+        fuzzer$(EXT) fuzzer32$(EXT) \
+        frametest$(EXT) frametest32$(EXT) \
+        fasttest$(EXT) roundTripTest$(EXT) \
+        datagen$(EXT) checkTag$(EXT) \
+        frameTest$(EXT) decompress-partial$(EXT) \
+		lz4_all.c
+	@$(RM) -rf $(TESTDIR)
+	@echo Cleaning completed
+
+.PHONY: versionsTest
+versionsTest:
+	$(PYTHON) test-lz4-versions.py
+
+.PHONY: listTest
+listTest: lz4
+	QEMU_SYS=$(QEMU_SYS) $(PYTHON) test-lz4-list.py
+
+checkTag: checkTag.c $(LZ4DIR)/lz4.h
+	$(CC) $(FLAGS) $< -o $@$(EXT)
+
+#-----------------------------------------------------------------------------
+# validated only for Linux, OSX, BSD, Hurd and Solaris targets
+#-----------------------------------------------------------------------------
+ifeq ($(POSIX_ENV),Yes)
+
+MD5:=md5sum
+ifneq (,$(filter $(shell uname), Darwin ))
+MD5:=md5 -r
+endif
+
+# note : we should probably settle on a single compare utility
+CMP:=cmp
+DIFF:=diff
+ifneq (,$(filter $(shell uname),SunOS))
+DIFF:=gdiff
+endif
+
+CAT:=cat
+DD:=dd
+DATAGEN:=./datagen
+
+.PHONY: list
+list:
+	@$(MAKE) -pRrq -f $(lastword $(MAKEFILE_LIST)) : 2>/dev/null | awk -v RS= -F: '/^# File/,/^# Finished Make data base/ {if ($$1 !~ "^[#.]") {print $$1}}' | sort | egrep -v -e '^[^[:alnum:]]' -e '^$@$$' | xargs
+
+.PHONY: check
+check: test-lz4-essentials
+
+.PHONY: test
+test: test-lz4 test-lz4c test-frametest test-fullbench test-fuzzer test-install test-amalgamation listTest test-decompress-partial
+
+.PHONY: test32
+test32: CFLAGS+=-m32
+test32: test
+
+test-amalgamation: lz4_all.o
+
+lz4_all.c: $(LZ4DIR)/lz4.c $(LZ4DIR)/lz4hc.c $(LZ4DIR)/lz4frame.c
+	$(CAT) $^ > $@
+
+test-install: lz4 lib liblz4.pc
+	lz4_root=.. ./test_install.sh
+
+test-lz4-sparse: lz4 datagen
+	@echo "\n ---- test sparse file support ----"
+	$(DATAGEN) -g5M  -P100 > tmplsdg5M
+	$(LZ4) -B4D tmplsdg5M -c | $(LZ4) -dv --sparse > tmplscB4
+	$(DIFF) -s tmplsdg5M tmplscB4
+	$(LZ4) -B5D tmplsdg5M -c | $(LZ4) -dv --sparse > tmplscB5
+	$(DIFF) -s tmplsdg5M tmplscB5
+	$(LZ4) -B6D tmplsdg5M -c | $(LZ4) -dv --sparse > tmplscB6
+	$(DIFF) -s tmplsdg5M tmplscB6
+	$(LZ4) -B7D tmplsdg5M -c | $(LZ4) -dv --sparse > tmplscB7
+	$(DIFF) -s tmplsdg5M tmplscB7
+	$(LZ4) tmplsdg5M -c | $(LZ4) -dv --no-sparse > tmplsnosparse
+	$(DIFF) -s tmplsdg5M tmplsnosparse
+	ls -ls tmpls*
+	$(DATAGEN) -s1 -g1200007 -P100 | $(LZ4) | $(LZ4) -dv --sparse > tmplsodd   # Odd size file (to generate non-full last block)
+	$(DATAGEN) -s1 -g1200007 -P100 | $(DIFF) -s - tmplsodd
+	ls -ls tmplsodd
+	@$(RM) tmpls*
+	@echo "\n Compatibility with Console :"
+	echo "Hello World 1 !" | $(LZ4) | $(LZ4) -d -c
+	echo "Hello World 2 !" | $(LZ4) | $(LZ4) -d | $(CAT)
+	echo "Hello World 3 !" | $(LZ4) --no-frame-crc | $(LZ4) -d -c
+	@echo "\n Compatibility with Append :"
+	$(DATAGEN) -P100 -g1M > tmplsdg1M
+	$(CAT) tmplsdg1M tmplsdg1M > tmpls2M
+	$(LZ4) -B5 -v tmplsdg1M tmplsc
+	$(LZ4) -d -v tmplsc tmplsr
+	$(LZ4) -d -v tmplsc -c >> tmplsr
+	ls -ls tmp*
+	$(DIFF) tmpls2M tmplsr
+	@$(RM) tmpls*
+
+test-lz4-contentSize: lz4 datagen
+	@echo "\n ---- test original size support ----"
+	$(DATAGEN) -g15M > tmplc1
+	$(LZ4) -v tmplc1 -c | $(LZ4) -t
+	$(LZ4) -v --content-size tmplc1 -c | $(LZ4) -d > tmplc2
+	$(DIFF) tmplc1 tmplc2
+	$(LZ4) -f tmplc1 -c > tmplc1.lz4
+	$(LZ4) --content-size tmplc1 -c > tmplc2.lz4
+	! $(DIFF) tmplc1.lz4 tmplc2.lz4  # must differ, due to content size
+	$(LZ4) --content-size < tmplc1 > tmplc3.lz4
+	$(DIFF) tmplc2.lz4 tmplc3.lz4  # both must contain content size
+	$(CAT) tmplc1 | $(LZ4) > tmplc4.lz4
+	$(DIFF) tmplc1.lz4 tmplc4.lz4  # both don't have content size
+	$(CAT) tmplc1 | $(LZ4) --content-size > tmplc5.lz4 # can't determine content size
+	$(DIFF) tmplc1.lz4 tmplc5.lz4  # both don't have content size
+	@$(RM) tmplc*
+
+test-lz4-frame-concatenation: lz4 datagen
+	@echo "\n ---- test frame concatenation ----"
+	@echo -n > tmp-lfc-empty
+	@echo hi > tmp-lfc-nonempty
+	$(CAT) tmp-lfc-nonempty tmp-lfc-empty tmp-lfc-nonempty > tmp-lfc-src
+	$(LZ4) -zq tmp-lfc-empty -c > tmp-lfc-empty.lz4
+	$(LZ4) -zq tmp-lfc-nonempty -c > tmp-lfc-nonempty.lz4
+	$(CAT) tmp-lfc-nonempty.lz4 tmp-lfc-empty.lz4 tmp-lfc-nonempty.lz4 > tmp-lfc-concat.lz4
+	$(LZ4) -d tmp-lfc-concat.lz4 -c > tmp-lfc-result
+	$(CMP) tmp-lfc-src tmp-lfc-result
+	@$(RM) tmp-lfc-*
+	@echo frame concatenation test completed
+
+test-lz4-multiple: lz4 datagen
+	@echo "\n ---- test multiple files ----"
+	@$(DATAGEN) -s1        > tmp-tlm1 2> $(VOID)
+	@$(DATAGEN) -s2 -g100K > tmp-tlm2 2> $(VOID)
+	@$(DATAGEN) -s3 -g200K > tmp-tlm3 2> $(VOID)
+	# compress multiple files : one .lz4 per source file
+	$(LZ4) -f -m tmp-tlm*
+	test -f tmp-tlm1.lz4
+	test -f tmp-tlm2.lz4
+	test -f tmp-tlm3.lz4
+	# decompress multiple files : one output file per .lz4
+	mv tmp-tlm1 tmp-tlm1-orig
+	mv tmp-tlm2 tmp-tlm2-orig
+	mv tmp-tlm3 tmp-tlm3-orig
+	$(LZ4) -d -f -m tmp-tlm*.lz4
+	$(CMP) tmp-tlm1 tmp-tlm1-orig   # must be identical
+	$(CMP) tmp-tlm2 tmp-tlm2-orig
+	$(CMP) tmp-tlm3 tmp-tlm3-orig
+	# compress multiple files into stdout
+	$(CAT) tmp-tlm1.lz4 tmp-tlm2.lz4 tmp-tlm3.lz4 > tmp-tlm-concat1
+	$(RM) *.lz4
+	$(LZ4) -m tmp-tlm1 tmp-tlm2 tmp-tlm3 -c > tmp-tlm-concat2
+	test ! -f tmp-tlm1.lz4  # must not create .lz4 artefact
+	$(CMP) tmp-tlm-concat1 tmp-tlm-concat2  # must be equivalent
+	# decompress multiple files into stdout
+	$(RM) tmp-tlm-concat1 tmp-tlm-concat2
+	$(LZ4) -f -m tmp-tlm1 tmp-tlm2 tmp-tlm3   # generate .lz4 to decompress
+	$(CAT) tmp-tlm1 tmp-tlm2 tmp-tlm3 > tmp-tlm-concat1   # create concatenated reference
+	$(RM) tmp-tlm1 tmp-tlm2 tmp-tlm3
+	$(LZ4) -d -m tmp-tlm1.lz4 tmp-tlm2.lz4 tmp-tlm3.lz4 -c > tmp-tlm-concat2
+	test ! -f tmp-tlm1  # must not create file artefact
+	$(CMP) tmp-tlm-concat1 tmp-tlm-concat2  # must be equivalent
+	# compress multiple files, one of which is absent (must fail)
+	! $(LZ4) -f -m tmp-tlm-concat1 notHere tmp-tlm-concat2  # must fail : notHere not present
+	@$(RM) tmp-tlm*
+
+test-lz4-multiple-legacy: lz4 datagen
+	@echo "\n ---- test multiple files (Legacy format) ----"
+	@$(DATAGEN) -s1        > tmp-tlm1 2> $(VOID)
+	@$(DATAGEN) -s2 -g100K > tmp-tlm2 2> $(VOID)
+	@$(DATAGEN) -s3 -g200K > tmp-tlm3 2> $(VOID)
+	# compress multiple files using legacy format: one .lz4 per source file
+	$(LZ4) -f -l -m tmp-tlm*
+	test -f tmp-tlm1.lz4
+	test -f tmp-tlm2.lz4
+	test -f tmp-tlm3.lz4
+	# decompress multiple files compressed using legacy format: one output file per .lz4
+	mv tmp-tlm1 tmp-tlm1-orig
+	mv tmp-tlm2 tmp-tlm2-orig
+	mv tmp-tlm3 tmp-tlm3-orig
+	$(LZ4) -d -f -m tmp-tlm*.lz4
+	$(LZ4) -l -d -f -m tmp-tlm*.lz4 # -l mustn't impact -d option
+	$(CMP) tmp-tlm1 tmp-tlm1-orig   # must be identical
+	$(CMP) tmp-tlm2 tmp-tlm2-orig
+	$(CMP) tmp-tlm3 tmp-tlm3-orig
+	# compress multiple files into stdout using legacy format
+	$(CAT) tmp-tlm1.lz4 tmp-tlm2.lz4 tmp-tlm3.lz4 > tmp-tlm-concat1
+	$(RM) *.lz4
+	$(LZ4) -l -m tmp-tlm1 tmp-tlm2 tmp-tlm3 -c > tmp-tlm-concat2
+	test ! -f tmp-tlm1.lz4  # must not create .lz4 artefact
+	$(CMP) tmp-tlm-concat1 tmp-tlm-concat2  # must be equivalent
+	# # # decompress multiple files into stdout using legacy format
+	$(RM) tmp-tlm-concat1 tmp-tlm-concat2
+	$(LZ4) -l -f -m tmp-tlm1 tmp-tlm2 tmp-tlm3   # generate .lz4 to decompress
+	$(CAT) tmp-tlm1 tmp-tlm2 tmp-tlm3 > tmp-tlm-concat1   # create concatenated reference
+	$(RM) tmp-tlm1 tmp-tlm2 tmp-tlm3
+	$(LZ4) -d -m tmp-tlm1.lz4 tmp-tlm2.lz4 tmp-tlm3.lz4 -c > tmp-tlm-concat2
+	$(LZ4) -d -l -m tmp-tlm1.lz4 tmp-tlm2.lz4 tmp-tlm3.lz4 -c > tmp-tlm-concat2 # -l mustn't impact option -d
+	test ! -f tmp-tlm1  # must not create file artefact
+	$(CMP) tmp-tlm-concat1 tmp-tlm-concat2  # must be equivalent
+	# # # compress multiple files, one of which is absent (must fail)
+	! $(LZ4) -f -l -m tmp-tlm-concat1 notHere-legacy tmp-tlm-concat2  # must fail : notHere-legacy not present
+	@$(RM) tmp-tlm*
+
+test-lz4-basic: lz4 datagen unlz4 lz4cat
+	@echo "\n ---- test lz4 basic compression/decompression ----"
+	$(DATAGEN) -g0       | $(LZ4) -v     | $(LZ4) -t
+	$(DATAGEN) -g16KB    | $(LZ4) -9     | $(LZ4) -t
+	$(DATAGEN) -g20KB > tmp-tlb-dg20k
+	$(LZ4) < tmp-tlb-dg20k | $(LZ4) -d > tmp-tlb-dec
+	$(DIFF) -q tmp-tlb-dg20k tmp-tlb-dec
+	$(LZ4) --no-frame-crc < tmp-tlb-dg20k | $(LZ4) -d > tmp-tlb-dec
+	$(DIFF) -q tmp-tlb-dg20k tmp-tlb-dec
+	$(DATAGEN)           | $(LZ4) -BI    | $(LZ4) -t
+	$(DATAGEN) -g6M -P99 | $(LZ4) -9BD   | $(LZ4) -t
+	$(DATAGEN) -g17M     | $(LZ4) -9v    | $(LZ4) -qt
+	$(DATAGEN) -g33M     | $(LZ4) --no-frame-crc | $(LZ4) -t
+	$(DATAGEN) -g256MB   | $(LZ4) -vqB4D | $(LZ4) -t
+	@echo "hello world" > tmp-tlb-hw
+	$(LZ4) --rm -f tmp-tlb-hw tmp-tlb-hw.lz4
+	test ! -f tmp-tlb-hw                      # must fail (--rm)
+	test   -f tmp-tlb-hw.lz4
+	$(PRGDIR)/lz4cat tmp-tlb-hw.lz4           # must display hello world
+	test   -f tmp-tlb-hw.lz4
+	$(PRGDIR)/unlz4 --rm tmp-tlb-hw.lz4 tmp-tlb-hw
+	test   -f tmp-tlb-hw
+	test ! -f tmp-tlb-hw.lz4                  # must fail (--rm)
+	test ! -f tmp-tlb-hw.lz4.lz4              # must fail (unlz4)
+	$(PRGDIR)/lz4cat tmp-tlb-hw               # pass-through mode
+	test   -f tmp-tlb-hw
+	test ! -f tmp-tlb-hw.lz4                  # must fail (lz4cat)
+	$(LZ4) tmp-tlb-hw tmp-tlb-hw.lz4          # creates tmp-tlb-hw.lz4
+	$(PRGDIR)/lz4cat < tmp-tlb-hw.lz4 > tmp-tlb3  # checks lz4cat works with stdin (#285)
+	$(DIFF) -q tmp-tlb-hw tmp-tlb3
+	$(PRGDIR)/lz4cat < tmp-tlb-hw > tmp-tlb2      # checks lz4cat works in pass-through mode
+	$(DIFF) -q tmp-tlb-hw tmp-tlb2
+	cp tmp-tlb-hw ./-d
+	$(LZ4) --rm -- -d -d.lz4               # compresses ./d into ./-d.lz4
+	test   -f ./-d.lz4
+	test ! -f ./-d
+	mv ./-d.lz4 ./-z
+	$(LZ4) -d --rm -- -z tmp-tlb4          # uncompresses ./-z into tmp-tlb4
+	test ! -f ./-z
+	$(DIFF) -q tmp-tlb-hw tmp-tlb4
+	$(LZ4) -f tmp-tlb-hw
+	$(LZ4) --list tmp-tlb-hw.lz4           # test --list on valid single-frame file
+	$(CAT) tmp-tlb-hw >> tmp-tlb-hw.lz4
+	$(LZ4) -f tmp-tlb-hw.lz4               # uncompress valid frame followed by invalid data
+	$(LZ4) -BX tmp-tlb-hw -c -q | $(LZ4) -tv  # test block checksum
+	# $(DATAGEN) -g20KB generates the same file every single time
+	# cannot save output of $(DATAGEN) -g20KB as input file to lz4 because the following shell commands are run before $(DATAGEN) -g20KB
+	test "$(shell $(DATAGEN) -g20KB | $(LZ4) -c --fast | wc -c)" -lt "$(shell $(DATAGEN) -g20KB | $(LZ4) -c --fast=9 | wc -c)" # -1 vs -9
+	test "$(shell $(DATAGEN) -g20KB | $(LZ4) -c -1 | wc -c)" -lt "$(shell $(DATAGEN) -g20KB| $(LZ4) -c --fast=1 | wc -c)" # 1 vs -1
+	test "$(shell $(DATAGEN) -g20KB | $(LZ4) -c --fast=1 | wc -c)" -eq "$(shell $(DATAGEN) -g20KB| $(LZ4) -c --fast| wc -c)" # checks default fast compression is -1
+	! $(LZ4) -c --fast=0 tmp-tlb-dg20K # lz4 should fail when fast=0
+	! $(LZ4) -c --fast=-1 tmp-tlb-dg20K # lz4 should fail when fast=-1
+	# High --fast values can result in out-of-bound dereferences #876
+	$(DATAGEN) -g1M | $(LZ4) -c --fast=999999999 > /dev/null
+	# Test for #596
+	@echo "TEST" > tmp-tlb-test
+	$(LZ4) -m tmp-tlb-test
+	$(LZ4) tmp-tlb-test.lz4 tmp-tlb-test2
+	$(DIFF) -q tmp-tlb-test tmp-tlb-test2
+	@$(RM) tmp-tlb*
+
+
+
+test-lz4-dict: lz4 datagen
+	@echo "\n ---- test lz4 compression/decompression with dictionary ----"
+	$(DATAGEN) -g16KB > tmp-dict
+	$(DATAGEN) -g32KB > tmp-dict-sample-32k
+	< tmp-dict-sample-32k $(LZ4) -D tmp-dict | $(LZ4) -dD tmp-dict | diff - tmp-dict-sample-32k
+	$(DATAGEN) -g128MB > tmp-dict-sample-128m
+	< tmp-dict-sample-128m $(LZ4) -D tmp-dict | $(LZ4) -dD tmp-dict | diff - tmp-dict-sample-128m
+	touch tmp-dict-sample-0
+	< tmp-dict-sample-0 $(LZ4) -D tmp-dict | $(LZ4) -dD tmp-dict | diff - tmp-dict-sample-0
+
+	< tmp-dict-sample-32k $(LZ4) -D tmp-dict-sample-0 | $(LZ4) -dD tmp-dict-sample-0 | diff - tmp-dict-sample-32k
+	< tmp-dict-sample-0 $(LZ4) -D tmp-dict-sample-0 | $(LZ4) -dD tmp-dict-sample-0 | diff - tmp-dict-sample-0
+
+	@echo "\n ---- test lz4 dictionary loading ----"
+	$(DATAGEN) -g128KB > tmp-dict-data-128KB
+	set -e; \
+	for l in 0 1 4 128 32767 32768 32769 65535 65536 65537 98303 98304 98305 131071 131072 131073; do \
+		$(DATAGEN) -g$$l > tmp-dict-$$l; \
+		$(DD) if=tmp-dict-$$l of=tmp-dict-$$l-tail bs=1 count=65536 skip=$$((l > 65536 ? l - 65536 : 0)); \
+		< tmp-dict-$$l      $(LZ4) -D stdin tmp-dict-data-128KB -c | $(LZ4) -dD tmp-dict-$$l-tail | $(DIFF) - tmp-dict-data-128KB; \
+		< tmp-dict-$$l-tail $(LZ4) -D stdin tmp-dict-data-128KB -c | $(LZ4) -dD tmp-dict-$$l      | $(DIFF) - tmp-dict-data-128KB; \
+	done
+
+	@$(RM) tmp-dict*
+
+test-lz4-hugefile: lz4 datagen
+	@echo "\n ---- test huge files compression/decompression ----"
+	./datagen -g6GB    | $(LZ4) -vB5D  | $(LZ4) -qt
+	./datagen -g4500MB | $(LZ4) -v3BD | $(LZ4) -qt
+	# test large file size [2-4] GB
+	@$(DATAGEN) -g3G -P100 | $(LZ4) -vv | $(LZ4) --decompress --force --sparse - tmphf1
+	@ls -ls tmphf1
+	@$(DATAGEN) -g3G -P100 | $(LZ4) --quiet --content-size | $(LZ4) --verbose --decompress --force --sparse - tmphf2
+	@ls -ls tmphf2
+	$(DIFF) -s tmphf1 tmphf2
+	@$(RM) tmphf*
+
+test-lz4-testmode: lz4 datagen
+	@echo "\n ---- bench mode ----"
+	$(LZ4) -bi0
+	@echo "\n ---- test mode ----"
+	! $(DATAGEN) | $(LZ4) -t
+	! $(DATAGEN) | $(LZ4) -tf
+	@echo "\n ---- pass-through mode ----"
+	@echo "Why hello there " > tmp-tlt2.lz4
+	! $(LZ4) -f tmp-tlt2.lz4 > $(VOID)
+	! $(DATAGEN) | $(LZ4) -dc  > $(VOID)
+	! $(DATAGEN) | $(LZ4) -df > $(VOID)
+	$(DATAGEN) | $(LZ4) -dcf > $(VOID)
+	@echo "Hello World !" > tmp-tlt1
+	$(LZ4) -dcf tmp-tlt1
+	@echo "from underground..." > tmp-tlt2
+	$(LZ4) -dcfm tmp-tlt1 tmp-tlt2
+	@echo "\n ---- non-existing source ----"
+	! $(LZ4)     file-does-not-exist
+	! $(LZ4) -f  file-does-not-exist
+	! $(LZ4) -t  file-does-not-exist
+	! $(LZ4) -fm file1-dne file2-dne
+	@$(RM) tmp-tlt tmp-tlt1 tmp-tlt2 tmp-tlt2.lz4
+
+test-lz4-opt-parser: lz4 datagen
+	@echo "\n ---- test opt-parser ----"
+	$(DATAGEN) -g16KB      | $(LZ4) -12      | $(LZ4) -t
+	$(DATAGEN) -P10        | $(LZ4) -12B4    | $(LZ4) -t
+	$(DATAGEN) -g256K      | $(LZ4) -12B4D   | $(LZ4) -t
+	$(DATAGEN) -g512K -P25 | $(LZ4) -12BD    | $(LZ4) -t
+	$(DATAGEN) -g1M        | $(LZ4) -12B5    | $(LZ4) -t
+	$(DATAGEN) -g2M -P99   | $(LZ4) -11B4D   | $(LZ4) -t
+	$(DATAGEN) -g4M        | $(LZ4) -11vq    | $(LZ4) -qt
+	$(DATAGEN) -g8M        | $(LZ4) -11B4    | $(LZ4) -t
+	$(DATAGEN) -g16M -P90  | $(LZ4) -11B5    | $(LZ4) -t
+	$(DATAGEN) -g32M -P10  | $(LZ4) -11B5D   | $(LZ4) -t
+
+test-lz4-essentials : lz4 datagen test-lz4-basic test-lz4-multiple test-lz4-multiple-legacy \
+                      test-lz4-frame-concatenation test-lz4-testmode \
+                      test-lz4-contentSize test-lz4-dict
+	@$(RM) tmp*
+
+test-lz4: lz4 datagen test-lz4-essentials test-lz4-opt-parser \
+          test-lz4-sparse test-lz4-hugefile test-lz4-dict
+	@$(RM) tmp*
+
+test-lz4c: lz4c datagen
+	@echo "\n ---- test lz4c variant ----"
+	$(DATAGEN) -g256MB | $(LZ4)c -l -v    | $(LZ4)c   -t
+
+test-lz4c32: CFLAGS+=-m32
+test-lz4c32: test-lz4
+
+test-interop-32-64: lz4 lz4c32 datagen
+	@echo "\n ---- test interoperability 32-bits -vs- 64 bits ----"
+	$(DATAGEN) -g16KB  | $(LZ4)c32 -9     | $(LZ4)    -t
+	$(DATAGEN) -P10    | $(LZ4)    -9B4   | $(LZ4)c32 -t
+	$(DATAGEN)         | $(LZ4)c32        | $(LZ4)    -t
+	$(DATAGEN) -g1M    | $(LZ4)    -3B5   | $(LZ4)c32 -t
+	$(DATAGEN) -g256MB | $(LZ4)c32 -vqB4D | $(LZ4)    -qt
+	$(DATAGEN) -g1G -P90 | $(LZ4)         | $(LZ4)c32 -t
+	$(DATAGEN) -g6GB   | $(LZ4)c32 -vq9BD | $(LZ4)    -qt
+
+test-lz4c32-basic: lz4c32 datagen
+	@echo "\n ---- test lz4c32 32-bits version ----"
+	$(DATAGEN) -g16KB  | $(LZ4)c32 -9     | $(LZ4)c32 -t
+	$(DATAGEN)         | $(LZ4)c32        | $(LZ4)c32 -t
+	$(DATAGEN) -g256MB | $(LZ4)c32 -vqB4D | $(LZ4)c32 -qt
+	$(DATAGEN) -g6GB   | $(LZ4)c32 -vqB5D | $(LZ4)c32 -qt
+
+test-platform:
+	@echo "\n ---- test lz4 $(QEMU_SYS) platform ----"
+	$(QEMU_SYS) $(DATAGEN) -g16KB  | $(QEMU_SYS) $(LZ4) -9     | $(QEMU_SYS) $(LZ4) -t
+	$(QEMU_SYS) $(DATAGEN)         | $(QEMU_SYS) $(LZ4)        | $(QEMU_SYS) $(LZ4) -t
+	$(QEMU_SYS) $(DATAGEN) -g256MB | $(QEMU_SYS) $(LZ4) -vqB4D | $(QEMU_SYS) $(LZ4) -qt
+ifneq ($(QEMU_SYS),qemu-arm-static)
+	$(QEMU_SYS) $(DATAGEN) -g3GB   | $(QEMU_SYS) $(LZ4) -vqB5D | $(QEMU_SYS) $(LZ4) -qt
+endif
+
+test-fullbench: fullbench
+	./fullbench --no-prompt $(NB_LOOPS) $(TEST_FILES)
+
+test-fullbench32: CFLAGS += -m32
+test-fullbench32: test-fullbench
+
+test-fuzzer: fuzzer
+	./fuzzer $(FUZZER_TIME)
+
+test-fuzzer32: CFLAGS += -m32
+test-fuzzer32: test-fuzzer
+
+test-frametest: frametest
+	./frametest -v $(FUZZER_TIME)
+
+test-frametest32: CFLAGS += -m32
+test-frametest32: test-frametest
+
+test-mem: lz4 datagen fuzzer frametest fullbench
+	@echo "\n ---- valgrind tests : memory analyzer ----"
+	valgrind --leak-check=yes --error-exitcode=1 $(DATAGEN) -g50M > $(VOID)
+	$(DATAGEN) -g16KB > ftmdg16K
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) -9 -BD -f ftmdg16K $(VOID)
+	$(DATAGEN) -g16KB -s2 > ftmdg16K2
+	$(DATAGEN) -g16KB -s3 > ftmdg16K3
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) --force --multiple ftmdg16K ftmdg16K2 ftmdg16K3
+	$(DATAGEN) -g7MB > ftmdg7M
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) -9 -B5D -f ftmdg7M ftmdg16K2
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) -t ftmdg16K2
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) -bi1 ftmdg7M
+	valgrind --leak-check=yes --error-exitcode=1 ./fullbench -i1 ftmdg7M ftmdg16K2
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) -B4D -f -vq ftmdg7M $(VOID)
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) --list -m ftm*.lz4
+	valgrind --leak-check=yes --error-exitcode=1 $(LZ4) --list -m -v ftm*.lz4
+	$(RM) ftm*
+	valgrind --leak-check=yes --error-exitcode=1 ./fuzzer -i64 -t1
+	valgrind --leak-check=yes --error-exitcode=1 ./frametest -i256
+
+test-mem32: lz4c32 datagen
+# unfortunately, valgrind doesn't seem to work with non-native binary...
+
+test-decompress-partial : decompress-partial
+	@echo "\n ---- test decompress-partial ----"
+	./decompress-partial$(EXT)
+
+endif
diff --git a/lz4/tests/README.md b/lz4/tests/README.md
new file mode 100644
index 0000000..75b7b9f
--- /dev/null
+++ b/lz4/tests/README.md
@@ -0,0 +1,71 @@
+Programs and scripts for automated testing of LZ4
+=======================================================
+
+This directory contains the following programs and scripts:
+- `datagen` : Synthetic and parametrable data generator, for tests
+- `frametest` : Test tool that checks lz4frame integrity on target platform
+- `fullbench`  : Precisely measure speed for each lz4 inner functions
+- `fuzzer`  : Test tool, to check lz4 integrity on target platform
+- `test-lz4-speed.py` : script for testing lz4 speed difference between commits
+- `test-lz4-versions.py` : compatibility test between lz4 versions stored on Github
+
+
+#### `test-lz4-versions.py` - script for testing lz4 interoperability between versions
+
+This script creates `versionsTest` directory to which lz4 repository is cloned.
+Then all taged (released) versions of lz4 are compiled.
+In the following step interoperability between lz4 versions is checked.
+
+
+#### `test-lz4-speed.py` - script for testing lz4 speed difference between commits
+
+This script creates `speedTest` directory to which lz4 repository is cloned.
+Then it compiles all branches of lz4 and performs a speed benchmark for a given list of files (the `testFileNames` parameter).
+After `sleepTime` (an optional parameter, default 300 seconds) seconds the script checks repository for new commits.
+If a new commit is found it is compiled and a speed benchmark for this commit is performed.
+The results of the speed benchmark are compared to the previous results.
+If compression or decompression speed for one of lz4 levels is lower than `lowerLimit` (an optional parameter, default 0.98) the speed benchmark is restarted.
+If second results are also lower than `lowerLimit` the warning e-mail is send to recipients from the list (the `emails` parameter).
+
+Additional remarks:
+- To be sure that speed results are accurate the script should be run on a "stable" target system with no other jobs running in parallel
+- Using the script with virtual machines can lead to large variations of speed results
+- The speed benchmark is not performed until computers' load average is lower than `maxLoadAvg` (an optional parameter, default 0.75)
+- The script sends e-mails using `mutt`; if `mutt` is not available it sends e-mails without attachments using `mail`; if both are not available it only prints a warning
+
+
+The example usage with two test files, one e-mail address, and with an additional message:
+```
+./test-lz4-speed.py "silesia.tar calgary.tar" "email@gmail.com" --message "tested on my laptop" --sleepTime 60
+``` 
+
+To run the script in background please use:
+```
+nohup ./test-lz4-speed.py testFileNames emails &
+```
+
+The full list of parameters:
+```
+positional arguments:
+  testFileNames         file names list for speed benchmark
+  emails                list of e-mail addresses to send warnings
+
+optional arguments:
+  -h, --help            show this help message and exit
+  --message MESSAGE     attach an additional message to e-mail
+  --lowerLimit LOWERLIMIT
+                        send email if speed is lower than given limit
+  --maxLoadAvg MAXLOADAVG
+                        maximum load average to start testing
+  --lastCLevel LASTCLEVEL
+                        last compression level for testing
+  --sleepTime SLEEPTIME
+                        frequency of repository checking in seconds
+```
+
+
+#### License
+
+All files in this directory are licensed under GPL-v2.
+See [COPYING](COPYING) for details.
+The text of the license is also included at the top of each source file.
diff --git a/lz4/tests/checkFrame.c b/lz4/tests/checkFrame.c
new file mode 100644
index 0000000..f9a1c14
--- /dev/null
+++ b/lz4/tests/checkFrame.c
@@ -0,0 +1,303 @@
+  /*
+      checkFrame - verify frame headers
+      Copyright (C) Yann Collet 2014-present
+
+      GPL v2 License
+
+      This program is free software; you can redistribute it and/or modify
+      it under the terms of the GNU General Public License as published by
+      the Free Software Foundation; either version 2 of the License, or
+      (at your option) any later version.
+
+      This program is distributed in the hope that it will be useful,
+      but WITHOUT ANY WARRANTY; without even the implied warranty of
+      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+      GNU General Public License for more details.
+
+      You should have received a copy of the GNU General Public License along
+      with this program; if not, write to the Free Software Foundation, Inc.,
+      51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+      You can contact the author at :
+      - LZ4 homepage : http://www.lz4.org
+      - LZ4 source repository : https://github.com/lz4/lz4
+  */
+
+  /*-************************************
+  *  Includes
+  **************************************/
+  #include "util.h"       /* U32 */
+  #include      /* malloc, free */
+  #include       /* fprintf */
+  #include      /* strcmp */
+  #include        /* clock_t, clock(), CLOCKS_PER_SEC */
+  #include 
+  #include "lz4frame.h"   /* include multiple times to test correctness/safety */
+  #include "lz4frame.h"
+  #define LZ4F_STATIC_LINKING_ONLY
+  #include "lz4frame.h"
+  #include "lz4frame.h"
+  #include "lz4.h"        /* LZ4_VERSION_STRING */
+  #define XXH_STATIC_LINKING_ONLY
+  #include "xxhash.h"     /* XXH64 */
+
+
+  /*-************************************
+  *  Constants
+  **************************************/
+  #define KB *(1U<<10)
+  #define MB *(1U<<20)
+  #define GB *(1U<<30)
+
+
+  /*-************************************
+  *  Macros
+  **************************************/
+  #define DISPLAY(...)          fprintf(stderr, __VA_ARGS__)
+  #define DISPLAYLEVEL(l, ...)  if (displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+
+  /**************************************
+  *  Exceptions
+  ***************************************/
+  #ifndef DEBUG
+  #  define DEBUG 0
+  #endif
+  #define DEBUGOUTPUT(...) if (DEBUG) DISPLAY(__VA_ARGS__);
+  #define EXM_THROW(error, ...)                                             \
+{                                                                         \
+    DEBUGOUTPUT("Error defined at %s, line %i : \n", __FILE__, __LINE__); \
+    DISPLAYLEVEL(1, "Error %i : ", error);                                \
+    DISPLAYLEVEL(1, __VA_ARGS__);                                         \
+    DISPLAYLEVEL(1, " \n");                                               \
+    return(error);                                                          \
+}
+
+
+
+/*-***************************************
+*  Local Parameters
+*****************************************/
+static U32 no_prompt = 0;
+static U32 displayLevel = 2;
+static U32 use_pause = 0;
+
+
+/*-*******************************************************
+*  Fuzzer functions
+*********************************************************/
+#define MIN(a,b)  ( (a) < (b) ? (a) : (b) )
+#define MAX(a,b)  ( (a) > (b) ? (a) : (b) )
+
+typedef struct {
+    void*  srcBuffer;
+    size_t srcBufferSize;
+    void*  dstBuffer;
+    size_t dstBufferSize;
+    LZ4F_decompressionContext_t ctx;
+} cRess_t;
+
+static int createCResources(cRess_t* ress)
+{
+    ress->srcBufferSize = 4 MB;
+    ress->srcBuffer = malloc(ress->srcBufferSize);
+    ress->dstBufferSize = 4 MB;
+    ress->dstBuffer = malloc(ress->dstBufferSize);
+
+    if (!ress->srcBuffer || !ress->dstBuffer) {
+        free(ress->srcBuffer);
+        free(ress->dstBuffer);
+        EXM_THROW(20, "Allocation error : not enough memory");
+    }
+
+    if (LZ4F_isError( LZ4F_createDecompressionContext(&(ress->ctx), LZ4F_VERSION) )) {
+        free(ress->srcBuffer);
+        free(ress->dstBuffer);
+        EXM_THROW(21, "Unable to create decompression context");
+    }
+    return 0;
+}
+
+static void freeCResources(cRess_t ress)
+{
+    free(ress.srcBuffer);
+    free(ress.dstBuffer);
+
+    (void) LZ4F_freeDecompressionContext(ress.ctx);
+}
+
+int frameCheck(cRess_t ress, FILE* const srcFile, unsigned bsid, size_t blockSize)
+{
+    LZ4F_errorCode_t nextToLoad = 0;
+    size_t curblocksize = 0;
+    int partialBlock = 0;
+
+    /* Main Loop */
+    for (;;) {
+        size_t readSize;
+        size_t pos = 0;
+        size_t decodedBytes = ress.dstBufferSize;
+        size_t remaining;
+        LZ4F_frameInfo_t frameInfo;
+
+        /* Read input */
+        readSize = fread(ress.srcBuffer, 1, ress.srcBufferSize, srcFile);
+        if (!readSize) break;   /* reached end of file or stream */
+
+        while (pos < readSize) {  /* still to read */
+            /* Decode Input (at least partially) */
+            if (!nextToLoad) {
+                /* LZ4F_decompress returned 0 : starting new frame */
+                curblocksize = 0;
+                remaining = readSize - pos;
+                nextToLoad = LZ4F_getFrameInfo(ress.ctx, &frameInfo, (char*)(ress.srcBuffer)+pos, &remaining);
+                if (LZ4F_isError(nextToLoad))
+                    EXM_THROW(22, "Error getting frame info: %s",
+                                LZ4F_getErrorName(nextToLoad));
+                if (frameInfo.blockSizeID != bsid)
+                    EXM_THROW(23, "Block size ID %u != expected %u",
+                                frameInfo.blockSizeID, bsid);
+                pos += remaining;
+                /* nextToLoad should be block header size */
+                remaining = nextToLoad;
+                decodedBytes = ress.dstBufferSize;
+                nextToLoad = LZ4F_decompress(ress.ctx, ress.dstBuffer, &decodedBytes, (char*)(ress.srcBuffer)+pos, &remaining, NULL);
+                if (LZ4F_isError(nextToLoad)) EXM_THROW(24, "Decompression error : %s", LZ4F_getErrorName(nextToLoad));
+                pos += remaining;
+            }
+            decodedBytes = ress.dstBufferSize;
+            /* nextToLoad should be just enough to cover the next block */
+            if (nextToLoad > (readSize - pos)) {
+                /* block is not fully contained in current buffer */
+                partialBlock = 1;
+                remaining = readSize - pos;
+            } else {
+                if (partialBlock) {
+                    partialBlock = 0;
+                }
+                remaining = nextToLoad;
+            }
+            nextToLoad = LZ4F_decompress(ress.ctx, ress.dstBuffer, &decodedBytes, (char*)(ress.srcBuffer)+pos, &remaining, NULL);
+            if (LZ4F_isError(nextToLoad)) EXM_THROW(24, "Decompression error : %s", LZ4F_getErrorName(nextToLoad));
+            curblocksize += decodedBytes;
+            pos += remaining;
+            if (!partialBlock) {
+                /* detect small block due to end of frame; the final 4-byte frame checksum could be left in the buffer */
+                if ((curblocksize != 0) && (nextToLoad > 4)) {
+                    if (curblocksize != blockSize)
+                        EXM_THROW(25, "Block size %u != expected %u, pos %u\n",
+                                    (unsigned)curblocksize, (unsigned)blockSize, (unsigned)pos);
+                }
+                curblocksize = 0;
+            }
+        }
+    }
+    /* can be out because readSize == 0, which could be an fread() error */
+    if (ferror(srcFile)) EXM_THROW(26, "Read error");
+
+    if (nextToLoad!=0) EXM_THROW(27, "Unfinished stream");
+
+    return 0;
+}
+
+int FUZ_usage(const char* programName)
+{
+    DISPLAY( "Usage :\n");
+    DISPLAY( "      %s [args] filename\n", programName);
+    DISPLAY( "\n");
+    DISPLAY( "Arguments :\n");
+    DISPLAY( " -b#    : expected blocksizeID [4-7] (required)\n");
+    DISPLAY( " -B#    : expected blocksize [32-4194304] (required)\n");
+    DISPLAY( " -v     : verbose\n");
+    DISPLAY( " -h     : display help and exit\n");
+    return 0;
+}
+
+
+int main(int argc, const char** argv)
+{
+    int argNb;
+    unsigned bsid=0;
+    size_t blockSize=0;
+    const char* const programName = argv[0];
+
+    /* Check command line */
+    for (argNb=1; argNb='0') && (*argument<='9')) {
+                        bsid *= 10;
+                        bsid += (unsigned)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+
+                case 'B':
+                    argument++;
+                    blockSize=0;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        blockSize *= 10;
+                        blockSize += (size_t)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+
+                default:
+                    ;
+                    return FUZ_usage(programName);
+                }
+            }
+        } else {
+            int err;
+            FILE *srcFile;
+            cRess_t ress;
+            if (bsid == 0 || blockSize == 0)
+              return FUZ_usage(programName);
+            DISPLAY("Starting frame checker (%i-bits, %s)\n", (int)(sizeof(size_t)*8), LZ4_VERSION_STRING);
+            err = createCResources(&ress);
+            if (err) return (err);
+            srcFile = fopen(argument, "rb");
+            if ( srcFile==NULL ) {
+                freeCResources(ress);
+                EXM_THROW(1, "%s: %s \n", argument, strerror(errno));
+            }
+            assert (srcFile != NULL);
+            err = frameCheck(ress, srcFile, bsid, blockSize);
+            freeCResources(ress);
+            fclose(srcFile);
+            return (err);
+        }
+    }
+    return 0;
+}
diff --git a/lz4/tests/checkTag.c b/lz4/tests/checkTag.c
new file mode 100644
index 0000000..4a33415
--- /dev/null
+++ b/lz4/tests/checkTag.c
@@ -0,0 +1,79 @@
+/*
+    checkTag.c - Version validation tool for LZ4
+    Copyright (C) Yann Collet 2018 - present
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+    - LZ4 homepage : http://www.lz4.org
+    - LZ4 source repo : https://github.com/lz4/lz4
+*/
+
+/* checkTag command :
+ * $ ./checkTag tag
+ * checkTag validates tags of following format : v[0-9].[0-9].[0-9]{any}
+ * The tag is then compared to LZ4 version number.
+ * They are compatible if first 3 digits are identical.
+ * Anything beyond that is free, and doesn't impact validation.
+ * Example : tag v1.8.1.2 is compatible with version 1.8.1
+ * When tag and version are not compatible, program exits with error code 1.
+ * When they are compatible, it exists with a code 0.
+ * checkTag is intended to be used in automated testing environment.
+ */
+
+#include    /* printf */
+#include   /* strlen, strncmp */
+#include "lz4.h"     /* LZ4_VERSION_STRING */
+
+
+/*  validate() :
+ * @return 1 if tag is compatible, 0 if not.
+ */
+static int validate(const char* const tag)
+{
+    size_t const tagLength = strlen(tag);
+    size_t const verLength = strlen(LZ4_VERSION_STRING);
+
+    if (tagLength < 2) return 0;
+    if (tag[0] != 'v') return 0;
+    if (tagLength <= verLength) return 0;
+
+    if (strncmp(LZ4_VERSION_STRING, tag+1, verLength)) return 0;
+
+    return 1;
+}
+
+int main(int argc, const char** argv)
+{
+    const char* const exeName = argv[0];
+    const char* const tag = argv[1];
+    if (argc!=2) {
+        printf("incorrect usage : %s tag \n", exeName);
+        return 2;
+    }
+
+    printf("Version : %s \n", LZ4_VERSION_STRING);
+    printf("Tag     : %s \n", tag);
+
+    if (validate(tag)) {
+        printf("OK : tag is compatible with lz4 version \n");
+        return 0;
+    }
+
+    printf("!! error : tag and versions are not compatible !! \n");
+    return 1;
+}
diff --git a/lz4/tests/datagencli.c b/lz4/tests/datagencli.c
new file mode 100644
index 0000000..c985197
--- /dev/null
+++ b/lz4/tests/datagencli.c
@@ -0,0 +1,172 @@
+/*
+    datagencli.c
+    compressible data command line generator
+    Copyright (C) Yann Collet 2012-2016
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+   - LZ4 source repository : https://github.com/lz4/lz4
+   - Public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+
+/**************************************
+*  Includes
+**************************************/
+#include "util.h"      /* U32 */
+#include      /* fprintf, stderr */
+#include "datagen.h"   /* RDG_generate */
+#include "lz4.h"       /* LZ4_VERSION_STRING */
+
+
+/**************************************
+*  Constants
+**************************************/
+#define KB *(1 <<10)
+#define MB *(1 <<20)
+#define GB *(1U<<30)
+
+#define SIZE_DEFAULT (64 KB)
+#define SEED_DEFAULT 0
+#define COMPRESSIBILITY_DEFAULT 50
+
+
+/**************************************
+*  Macros
+**************************************/
+#define DISPLAY(...)         fprintf(stderr, __VA_ARGS__)
+#define DISPLAYLEVEL(l, ...) if (displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+static unsigned displayLevel = 2;
+
+
+/*********************************************************
+*  Command line
+*********************************************************/
+static int usage(char* programName)
+{
+    DISPLAY( "Compressible data generator\n");
+    DISPLAY( "Usage :\n");
+    DISPLAY( "      %s [size] [args]\n", programName);
+    DISPLAY( "\n");
+    DISPLAY( "Arguments :\n");
+    DISPLAY( " -g#    : generate # data (default:%i)\n", SIZE_DEFAULT);
+    DISPLAY( " -s#    : Select seed (default:%i)\n", SEED_DEFAULT);
+    DISPLAY( " -P#    : Select compressibility in %% (default:%i%%)\n", COMPRESSIBILITY_DEFAULT);
+    DISPLAY( " -h     : display help and exit\n");
+    DISPLAY( "Special values :\n");
+    DISPLAY( " -P0    : generate incompressible noise\n");
+    DISPLAY( " -P100  : generate sparse files\n");
+    return 0;
+}
+
+
+int main(int argc, char** argv)
+{
+    int argNb;
+    double proba = (double)COMPRESSIBILITY_DEFAULT / 100;
+    double litProba = 0.0;
+    U64 size = SIZE_DEFAULT;
+    U32 seed = SEED_DEFAULT;
+    char* programName;
+
+    /* Check command line */
+    programName = argv[0];
+    for(argNb=1; argNb='0') && (*argument<='9'))
+                    {
+                        size *= 10;
+                        size += *argument - '0';
+                        argument++;
+                    }
+                    if (*argument=='K') { size <<= 10; argument++; }
+                    if (*argument=='M') { size <<= 20; argument++; }
+                    if (*argument=='G') { size <<= 30; argument++; }
+                    if (*argument=='B') { argument++; }
+                    break;
+                case 's':
+                    argument++;
+                    seed=0;
+                    while ((*argument>='0') && (*argument<='9'))
+                    {
+                        seed *= 10;
+                        seed += *argument - '0';
+                        argument++;
+                    }
+                    break;
+                case 'P':
+                    argument++;
+                    proba=0.0;
+                    while ((*argument>='0') && (*argument<='9'))
+                    {
+                        proba *= 10;
+                        proba += *argument - '0';
+                        argument++;
+                    }
+                    if (proba>100.) proba=100.;
+                    proba /= 100.;
+                    break;
+                case 'L':   /* hidden argument : Literal distribution probability */
+                    argument++;
+                    litProba=0.;
+                    while ((*argument>='0') && (*argument<='9'))
+                    {
+                        litProba *= 10;
+                        litProba += *argument - '0';
+                        argument++;
+                    }
+                    if (litProba>100.) litProba=100.;
+                    litProba /= 100.;
+                    break;
+                case 'v':
+                    displayLevel = 4;
+                    argument++;
+                    break;
+                default:
+                    return usage(programName);
+                }
+            }
+
+        }
+    }
+
+    DISPLAYLEVEL(4, "Data Generator %s \n", LZ4_VERSION_STRING);
+    DISPLAYLEVEL(3, "Seed = %u \n", seed);
+    if (proba!=COMPRESSIBILITY_DEFAULT) DISPLAYLEVEL(3, "Compressibility : %i%%\n", (U32)(proba*100));
+
+    RDG_genOut(size, proba, litProba, seed);
+    DISPLAYLEVEL(1, "\n");
+
+    return 0;
+}
diff --git a/lz4/tests/decompress-partial.c b/lz4/tests/decompress-partial.c
new file mode 100644
index 0000000..4e124b7
--- /dev/null
+++ b/lz4/tests/decompress-partial.c
@@ -0,0 +1,49 @@
+#include "stdio.h"
+#include "string.h"
+#include "lz4.h"
+
+const char source[] =
+  "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod\n"
+  "tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim\n"
+  "veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea\n"
+  "commodo consequat. Duis aute irure dolor in reprehenderit in voluptate\n"
+  "velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat\n"
+  "cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id\n"
+  "est laborum.\n"
+  "\n"
+  "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium\n"
+  "doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore\n"
+  "veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim\n"
+  "ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia\n"
+  "consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque\n"
+  "porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur,\n"
+  "adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore\n"
+  "et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis\n"
+  "nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid\n"
+  "ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea\n"
+  "voluptate velit esse quam nihil molestiae consequatur, vel illum qui\n"
+  "dolorem eum fugiat quo voluptas nulla pariatur?\n";
+
+#define BUFFER_SIZE 2048
+
+int main(void)
+{
+  int srcLen = (int)strlen(source);
+  char cmpBuffer[BUFFER_SIZE];
+  char outBuffer[BUFFER_SIZE];
+  int cmpSize;
+  int i;
+  
+  cmpSize = LZ4_compress_default(source, cmpBuffer, srcLen, BUFFER_SIZE);
+
+  for (i = cmpSize; i < cmpSize + 10; ++i) {
+    int result = LZ4_decompress_safe_partial(cmpBuffer, outBuffer, i, srcLen, BUFFER_SIZE);
+    if ((result < 0) || (result != srcLen) || memcmp(source, outBuffer, srcLen)) {
+      printf("test decompress-partial error \n");
+      return -1;
+    }
+  }
+  
+  printf("test decompress-partial OK \n");
+  return 0;
+}
diff --git a/lz4/tests/frametest.c b/lz4/tests/frametest.c
new file mode 100644
index 0000000..e613cbf
--- /dev/null
+++ b/lz4/tests/frametest.c
@@ -0,0 +1,1281 @@
+/*
+    frameTest - test tool for lz4frame
+    Copyright (C) Yann Collet 2014-2016
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+    - LZ4 homepage : http://www.lz4.org
+    - LZ4 source repository : https://github.com/lz4/lz4
+*/
+
+/*-************************************
+*  Compiler specific
+**************************************/
+#ifdef _MSC_VER    /* Visual Studio */
+#  pragma warning(disable : 26451)     /* disable: Arithmetic overflow */
+#endif
+
+
+/*-************************************
+*  Includes
+**************************************/
+#include "util.h"       /* U32 */
+#include      /* malloc, free */
+#include       /* fprintf */
+#include      /* strcmp */
+#include        /* clock_t, clock(), CLOCKS_PER_SEC */
+#include 
+#include "lz4frame.h"   /* included multiple times to test correctness/safety */
+#include "lz4frame.h"
+#define LZ4F_STATIC_LINKING_ONLY
+#include "lz4frame.h"
+#include "lz4frame.h"
+#define LZ4_STATIC_LINKING_ONLY  /* LZ4_DISTANCE_MAX */
+#include "lz4.h"        /* LZ4_VERSION_STRING */
+#define XXH_STATIC_LINKING_ONLY
+#include "xxhash.h"     /* XXH64 */
+
+
+/* unoptimized version; solves endianess & alignment issues */
+static void FUZ_writeLE32 (void* dstVoidPtr, U32 value32)
+{
+    BYTE* dstPtr = (BYTE*)dstVoidPtr;
+    dstPtr[0] = (BYTE) value32;
+    dstPtr[1] = (BYTE)(value32 >> 8);
+    dstPtr[2] = (BYTE)(value32 >> 16);
+    dstPtr[3] = (BYTE)(value32 >> 24);
+}
+
+
+/*-************************************
+*  Constants
+**************************************/
+#define LZ4F_MAGIC_SKIPPABLE_START 0x184D2A50U
+
+#define KB *(1U<<10)
+#define MB *(1U<<20)
+#define GB *(1U<<30)
+
+static const U32 nbTestsDefault = 256 KB;
+#define FUZ_COMPRESSIBILITY_DEFAULT 50
+static const U32 prime1 = 2654435761U;
+static const U32 prime2 = 2246822519U;
+
+
+/*-************************************
+*  Macros
+**************************************/
+#define DISPLAY(...)          fprintf(stderr, __VA_ARGS__)
+#define DISPLAYLEVEL(l, ...)  if (displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+#define DISPLAYUPDATE(l, ...) if (displayLevel>=l) { \
+            if ((FUZ_GetClockSpan(g_clockTime) > refreshRate) || (displayLevel>=4)) \
+            { g_clockTime = clock(); DISPLAY(__VA_ARGS__); \
+            if (displayLevel>=4) fflush(stdout); } }
+static const clock_t refreshRate = CLOCKS_PER_SEC / 6;
+static clock_t g_clockTime = 0;
+
+
+/*-***************************************
+*  Local Parameters
+*****************************************/
+static U32 no_prompt = 0;
+static U32 displayLevel = 2;
+static U32 use_pause = 0;
+
+
+/*-*******************************************************
+*  Fuzzer functions
+*********************************************************/
+#define MIN(a,b)  ( (a) < (b) ? (a) : (b) )
+#define MAX(a,b)  ( (a) > (b) ? (a) : (b) )
+
+static clock_t FUZ_GetClockSpan(clock_t clockStart)
+{
+    return clock() - clockStart;   /* works even if overflow; max span ~ 30 mn */
+}
+
+
+#define FUZ_rotl32(x,r) ((x << r) | (x >> (32 - r)))
+unsigned int FUZ_rand(unsigned int* src)
+{
+    U32 rand32 = *src;
+    rand32 *= prime1;
+    rand32 += prime2;
+    rand32  = FUZ_rotl32(rand32, 13);
+    *src = rand32;
+    return rand32 >> 5;
+}
+
+
+#define FUZ_RAND15BITS  (FUZ_rand(seed) & 0x7FFF)
+#define FUZ_RANDLENGTH  ( (FUZ_rand(seed) & 3) ? (FUZ_rand(seed) % 15) : (FUZ_rand(seed) % 510) + 15)
+static void FUZ_fillCompressibleNoiseBuffer(void* buffer, size_t bufferSize, double proba, U32* seed)
+{
+    BYTE* BBuffer = (BYTE*)buffer;
+    size_t pos = 0;
+    U32 P32 = (U32)(32768 * proba);
+
+    /* First Byte */
+    BBuffer[pos++] = (BYTE)(FUZ_rand(seed));
+
+    while (pos < bufferSize) {
+        /* Select : Literal (noise) or copy (within 64K) */
+        if (FUZ_RAND15BITS < P32) {
+            /* Copy (within 64K) */
+            size_t const lengthRand = FUZ_RANDLENGTH + 4;
+            size_t const length = MIN(lengthRand, bufferSize - pos);
+            size_t const end = pos + length;
+            size_t const offsetRand = FUZ_RAND15BITS + 1;
+            size_t const offset = MIN(offsetRand, pos);
+            size_t match = pos - offset;
+            while (pos < end) BBuffer[pos++] = BBuffer[match++];
+        } else {
+            /* Literal (noise) */
+            size_t const lengthRand = FUZ_RANDLENGTH + 4;
+            size_t const length = MIN(lengthRand, bufferSize - pos);
+            size_t const end = pos + length;
+            while (pos < end) BBuffer[pos++] = (BYTE)(FUZ_rand(seed) >> 5);
+    }   }
+}
+
+
+static unsigned FUZ_highbit(U32 v32)
+{
+    unsigned nbBits = 0;
+    if (v32==0) return 0;
+    while (v32) {v32 >>= 1; nbBits ++;}
+    return nbBits;
+}
+
+
+/*-*******************************************************
+*  Tests
+*********************************************************/
+#define CHECK_V(v,f) v = f; if (LZ4F_isError(v)) { fprintf(stderr, "%s \n", LZ4F_getErrorName(v)); goto _output_error; }
+#define CHECK(f)   { LZ4F_errorCode_t const CHECK_V(err_ , f); }
+
+int basicTests(U32 seed, double compressibility)
+{
+#define COMPRESSIBLE_NOISE_LENGTH (2 MB)
+    void* const CNBuffer = malloc(COMPRESSIBLE_NOISE_LENGTH);
+    size_t const cBuffSize = LZ4F_compressFrameBound(COMPRESSIBLE_NOISE_LENGTH, NULL);
+    void* const compressedBuffer = malloc(cBuffSize);
+    void* const decodedBuffer = malloc(COMPRESSIBLE_NOISE_LENGTH);
+    U32 randState = seed;
+    size_t cSize, testSize;
+    LZ4F_decompressionContext_t dCtx = NULL;
+    LZ4F_compressionContext_t cctx = NULL;
+    U64 crcOrig;
+    int basicTests_error = 0;
+    LZ4F_preferences_t prefs;
+    memset(&prefs, 0, sizeof(prefs));
+
+    if (!CNBuffer || !compressedBuffer || !decodedBuffer) {
+        DISPLAY("allocation error, not enough memory to start fuzzer tests \n");
+        goto _output_error;
+    }
+    FUZ_fillCompressibleNoiseBuffer(CNBuffer, COMPRESSIBLE_NOISE_LENGTH, compressibility, &randState);
+    crcOrig = XXH64(CNBuffer, COMPRESSIBLE_NOISE_LENGTH, 1);
+
+    /* LZ4F_compressBound() : special case : srcSize == 0 */
+    DISPLAYLEVEL(3, "LZ4F_compressBound(0) = ");
+    {   size_t const cBound = LZ4F_compressBound(0, NULL);
+        if (cBound < 64 KB) goto _output_error;
+        DISPLAYLEVEL(3, " %u \n", (U32)cBound);
+    }
+
+    /* LZ4F_compressBound() : special case : automatic flushing enabled */
+    DISPLAYLEVEL(3, "LZ4F_compressBound(1 KB, autoFlush=1) = ");
+    {   size_t cBound;
+        LZ4F_preferences_t autoFlushPrefs;
+        memset(&autoFlushPrefs, 0, sizeof(autoFlushPrefs));
+        autoFlushPrefs.autoFlush = 1;
+        cBound = LZ4F_compressBound(1 KB, &autoFlushPrefs);
+        if (cBound > 64 KB) goto _output_error;
+        DISPLAYLEVEL(3, " %u \n", (U32)cBound);
+    }
+
+    /* LZ4F_compressBound() : special case : automatic flushing disabled */
+    DISPLAYLEVEL(3, "LZ4F_compressBound(1 KB, autoFlush=0) = ");
+    {   size_t const cBound = LZ4F_compressBound(1 KB, &prefs);
+        if (cBound < 64 KB) goto _output_error;
+        DISPLAYLEVEL(3, " %u \n", (U32)cBound);
+    }
+
+    /* Special case : null-content frame */
+    testSize = 0;
+    DISPLAYLEVEL(3, "LZ4F_compressFrame, compress null content : ");
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, NULL), CNBuffer, testSize, NULL));
+    DISPLAYLEVEL(3, "null content encoded into a %u bytes frame \n", (unsigned)cSize);
+
+    DISPLAYLEVEL(3, "LZ4F_createDecompressionContext \n");
+    CHECK ( LZ4F_createDecompressionContext(&dCtx, LZ4F_VERSION) );
+
+    DISPLAYLEVEL(3, "LZ4F_getFrameInfo on null-content frame (#157) \n");
+    assert(cSize >= LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH);
+    {   LZ4F_frameInfo_t frame_info;
+        size_t const fhs = LZ4F_headerSize(compressedBuffer, LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH);
+        size_t avail_in = fhs;
+        CHECK( fhs );
+        CHECK( LZ4F_getFrameInfo(dCtx, &frame_info, compressedBuffer, &avail_in) );
+        if (avail_in != fhs) goto _output_error;  /* must consume all, since header size is supposed to be exact */
+    }
+
+    DISPLAYLEVEL(3, "LZ4F_freeDecompressionContext \n");
+    CHECK( LZ4F_freeDecompressionContext(dCtx) );
+    dCtx = NULL;
+
+    /* test one-pass frame compression */
+    testSize = COMPRESSIBLE_NOISE_LENGTH;
+
+    DISPLAYLEVEL(3, "LZ4F_compressFrame, using fast level -3 : ");
+    {   LZ4F_preferences_t fastCompressPrefs;
+        memset(&fastCompressPrefs, 0, sizeof(fastCompressPrefs));
+        fastCompressPrefs.compressionLevel = -3;
+        CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, NULL), CNBuffer, testSize, &fastCompressPrefs));
+        DISPLAYLEVEL(3, "Compressed %u bytes into a %u bytes frame \n", (U32)testSize, (U32)cSize);
+    }
+
+    DISPLAYLEVEL(3, "LZ4F_compressFrame, using default preferences : ");
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, NULL), CNBuffer, testSize, NULL));
+    DISPLAYLEVEL(3, "Compressed %u bytes into a %u bytes frame \n", (U32)testSize, (U32)cSize);
+
+    DISPLAYLEVEL(3, "Decompression test : \n");
+    {   size_t decodedBufferSize = COMPRESSIBLE_NOISE_LENGTH;
+        size_t compressedBufferSize = cSize;
+
+        CHECK( LZ4F_createDecompressionContext(&dCtx, LZ4F_VERSION) );
+
+        DISPLAYLEVEL(3, "Single Pass decompression : ");
+        CHECK( LZ4F_decompress(dCtx, decodedBuffer, &decodedBufferSize, compressedBuffer, &compressedBufferSize, NULL) );
+        { U64 const crcDest = XXH64(decodedBuffer, decodedBufferSize, 1);
+          if (crcDest != crcOrig) goto _output_error; }
+        DISPLAYLEVEL(3, "Regenerated %u bytes \n", (U32)decodedBufferSize);
+
+        DISPLAYLEVEL(3, "Reusing decompression context \n");
+        {   size_t const missingBytes = 4;
+            size_t iSize = compressedBufferSize - missingBytes;
+            const BYTE* cBuff = (const BYTE*) compressedBuffer;
+            BYTE* const ostart = (BYTE*)decodedBuffer;
+            BYTE* op = ostart;
+            BYTE* const oend = (BYTE*)decodedBuffer + COMPRESSIBLE_NOISE_LENGTH;
+            size_t decResult, oSize = COMPRESSIBLE_NOISE_LENGTH;
+            DISPLAYLEVEL(3, "Missing last %u bytes : ", (U32)missingBytes);
+            CHECK_V(decResult, LZ4F_decompress(dCtx, op, &oSize, cBuff, &iSize, NULL));
+            if (decResult != missingBytes) {
+                DISPLAY("%u bytes missing != %u bytes requested \n", (U32)missingBytes, (U32)decResult);
+                goto _output_error;
+            }
+            DISPLAYLEVEL(3, "indeed, requests %u bytes \n", (unsigned)decResult);
+            cBuff += iSize;
+            iSize = decResult;
+            op += oSize;
+            oSize = (size_t)(oend-op);
+            decResult = LZ4F_decompress(dCtx, op, &oSize, cBuff, &iSize, NULL);
+            if (decResult != 0) goto _output_error;   /* should finish now */
+            op += oSize;
+            if (op>oend) { DISPLAY("decompression write overflow \n"); goto _output_error; }
+            {   U64 const crcDest = XXH64(decodedBuffer, (size_t)(op-ostart), 1);
+                if (crcDest != crcOrig) goto _output_error;
+        }   }
+
+        {   size_t oSize = 0;
+            size_t iSize = 0;
+            LZ4F_frameInfo_t fi;
+            const BYTE* ip = (BYTE*)compressedBuffer;
+
+            DISPLAYLEVEL(3, "Start by feeding 0 bytes, to get next input size : ");
+            CHECK( LZ4F_decompress(dCtx, NULL, &oSize, ip, &iSize, NULL) );
+            //DISPLAYLEVEL(3, " %u  \n", (unsigned)errorCode);
+            DISPLAYLEVEL(3, " OK  \n");
+
+            DISPLAYLEVEL(3, "LZ4F_getFrameInfo on zero-size input : ");
+            {   size_t nullSize = 0;
+                size_t const fiError = LZ4F_getFrameInfo(dCtx, &fi, ip, &nullSize);
+                if (LZ4F_getErrorCode(fiError) != LZ4F_ERROR_frameHeader_incomplete) {
+                    DISPLAYLEVEL(3, "incorrect error : %s != ERROR_frameHeader_incomplete \n",
+                                    LZ4F_getErrorName(fiError));
+                    goto _output_error;
+                }
+                DISPLAYLEVEL(3, " correctly failed : %s \n", LZ4F_getErrorName(fiError));
+            }
+
+            DISPLAYLEVEL(3, "LZ4F_getFrameInfo on not enough input : ");
+            {   size_t inputSize = 6;
+                size_t const fiError = LZ4F_getFrameInfo(dCtx, &fi, ip, &inputSize);
+                if (LZ4F_getErrorCode(fiError) != LZ4F_ERROR_frameHeader_incomplete) {
+                    DISPLAYLEVEL(3, "incorrect error : %s != ERROR_frameHeader_incomplete \n", LZ4F_getErrorName(fiError));
+                    goto _output_error;
+                }
+                DISPLAYLEVEL(3, " correctly failed : %s \n", LZ4F_getErrorName(fiError));
+            }
+
+            DISPLAYLEVEL(3, "LZ4F_getFrameInfo on enough input : ");
+            iSize = LZ4F_headerSize(ip, LZ4F_MIN_SIZE_TO_KNOW_HEADER_LENGTH);
+            CHECK( iSize );
+            CHECK( LZ4F_getFrameInfo(dCtx, &fi, ip, &iSize) );
+            DISPLAYLEVEL(3, " correctly decoded \n");
+        }
+
+        DISPLAYLEVEL(3, "Decode a buggy input : ");
+        assert(COMPRESSIBLE_NOISE_LENGTH > 64);
+        assert(cSize > 48);
+        memcpy(decodedBuffer, (char*)compressedBuffer+16, 32);  /* save correct data */
+        memcpy((char*)compressedBuffer+16, (const char*)decodedBuffer+32, 32);  /* insert noise */
+        {   size_t dbSize = COMPRESSIBLE_NOISE_LENGTH;
+            size_t cbSize = cSize;
+            size_t const decompressError = LZ4F_decompress(dCtx, decodedBuffer, &dbSize,
+                                                               compressedBuffer, &cbSize,
+                                                               NULL);
+            if (!LZ4F_isError(decompressError)) goto _output_error;
+            DISPLAYLEVEL(3, "error detected : %s \n", LZ4F_getErrorName(decompressError));
+        }
+        memcpy((char*)compressedBuffer+16, decodedBuffer, 32);  /* restore correct data */
+
+        DISPLAYLEVEL(3, "Reset decompression context, since it's left in error state \n");
+        LZ4F_resetDecompressionContext(dCtx);   /* always successful */
+
+        DISPLAYLEVEL(3, "Byte after byte : ");
+        {   BYTE* const ostart = (BYTE*)decodedBuffer;
+            BYTE* op = ostart;
+            BYTE* const oend = (BYTE*)decodedBuffer + COMPRESSIBLE_NOISE_LENGTH;
+            const BYTE* ip = (const BYTE*) compressedBuffer;
+            const BYTE* const iend = ip + cSize;
+            while (ip < iend) {
+                size_t oSize = (size_t)(oend-op);
+                size_t iSize = 1;
+                CHECK( LZ4F_decompress(dCtx, op, &oSize, ip, &iSize, NULL) );
+                op += oSize;
+                ip += iSize;
+            }
+            {   U64 const crcDest = XXH64(decodedBuffer, COMPRESSIBLE_NOISE_LENGTH, 1);
+                if (crcDest != crcOrig) goto _output_error;
+            }
+            DISPLAYLEVEL(3, "Regenerated %u/%u bytes \n", (unsigned)(op-ostart), (unsigned)COMPRESSIBLE_NOISE_LENGTH);
+        }
+    }
+
+    DISPLAYLEVEL(3, "Using 64 KB block : ");
+    prefs.frameInfo.blockSizeID = LZ4F_max64KB;
+    prefs.frameInfo.contentChecksumFlag = LZ4F_contentChecksumEnabled;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs));
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "without checksum : ");
+    prefs.frameInfo.contentChecksumFlag = LZ4F_noContentChecksum;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs));
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "Using 256 KB block : ");
+    prefs.frameInfo.blockSizeID = LZ4F_max256KB;
+    prefs.frameInfo.contentChecksumFlag = LZ4F_contentChecksumEnabled;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs));
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "Decompression test : \n");
+    {   size_t const decodedBufferSize = COMPRESSIBLE_NOISE_LENGTH;
+        unsigned const maxBits = FUZ_highbit((U32)decodedBufferSize);
+        BYTE* const ostart = (BYTE*)decodedBuffer;
+        BYTE* op = ostart;
+        BYTE* const oend = ostart + COMPRESSIBLE_NOISE_LENGTH;
+        const BYTE* ip = (const BYTE*)compressedBuffer;
+        const BYTE* const iend = (const BYTE*)compressedBuffer + cSize;
+
+        DISPLAYLEVEL(3, "random segment sizes : ");
+        while (ip < iend) {
+            unsigned const nbBits = FUZ_rand(&randState) % maxBits;
+            size_t iSize = (FUZ_rand(&randState) & ((1< (size_t)(iend-ip)) iSize = (size_t)(iend-ip);
+            CHECK( LZ4F_decompress(dCtx, op, &oSize, ip, &iSize, NULL) );
+            op += oSize;
+            ip += iSize;
+        }
+        {   size_t const decodedSize = (size_t)(op - ostart);
+            U64 const crcDest = XXH64(decodedBuffer, decodedSize, 1);
+            if (crcDest != crcOrig) goto _output_error;
+            DISPLAYLEVEL(3, "Regenerated %u bytes \n", (U32)decodedSize);
+         }
+
+        CHECK( LZ4F_freeDecompressionContext(dCtx) );
+        dCtx = NULL;
+    }
+
+    DISPLAYLEVEL(3, "without checksum : ");
+    prefs.frameInfo.contentChecksumFlag = LZ4F_noContentChecksum;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs) );
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "Using 1 MB block : ");
+    prefs.frameInfo.blockSizeID = LZ4F_max1MB;
+    prefs.frameInfo.contentChecksumFlag = LZ4F_contentChecksumEnabled;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs) );
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "without frame checksum : ");
+    prefs.frameInfo.contentChecksumFlag = LZ4F_noContentChecksum;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs) );
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "Using 4 MB block : ");
+    prefs.frameInfo.blockSizeID = LZ4F_max4MB;
+    prefs.frameInfo.contentChecksumFlag = LZ4F_contentChecksumEnabled;
+    {   size_t const dstCapacity = LZ4F_compressFrameBound(testSize, &prefs);
+        DISPLAYLEVEL(4, "dstCapacity = %u  ; ", (U32)dstCapacity)
+        CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, dstCapacity, CNBuffer, testSize, &prefs) );
+        DISPLAYLEVEL(3, "Compressed %u bytes into a %u bytes frame \n", (U32)testSize, (U32)cSize);
+    }
+
+    DISPLAYLEVEL(3, "without frame checksum : ");
+    prefs.frameInfo.contentChecksumFlag = LZ4F_noContentChecksum;
+    {   size_t const dstCapacity = LZ4F_compressFrameBound(testSize, &prefs);
+        DISPLAYLEVEL(4, "dstCapacity = %u  ; ", (U32)dstCapacity)
+        CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, dstCapacity, CNBuffer, testSize, &prefs) );
+        DISPLAYLEVEL(3, "Compressed %u bytes into a %u bytes frame \n", (U32)testSize, (U32)cSize);
+    }
+
+    DISPLAYLEVEL(3, "LZ4F_compressFrame with block checksum : ");
+    memset(&prefs, 0, sizeof(prefs));
+    prefs.frameInfo.blockChecksumFlag = LZ4F_blockChecksumEnabled;
+    CHECK_V(cSize, LZ4F_compressFrame(compressedBuffer, LZ4F_compressFrameBound(testSize, &prefs), CNBuffer, testSize, &prefs) );
+    DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)cSize);
+
+    DISPLAYLEVEL(3, "Decompress with block checksum : ");
+    {   size_t iSize = cSize;
+        size_t decodedSize = COMPRESSIBLE_NOISE_LENGTH;
+        LZ4F_decompressionContext_t dctx;
+        CHECK( LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION) );
+        CHECK( LZ4F_decompress(dctx, decodedBuffer, &decodedSize, compressedBuffer, &iSize, NULL) );
+        if (decodedSize != testSize) goto _output_error;
+        if (iSize != cSize) goto _output_error;
+        {   U64 const crcDest = XXH64(decodedBuffer, decodedSize, 1);
+            U64 const crcSrc = XXH64(CNBuffer, testSize, 1);
+            if (crcDest != crcSrc) goto _output_error;
+        }
+        DISPLAYLEVEL(3, "Regenerated %u bytes \n", (U32)decodedSize);
+
+        CHECK( LZ4F_freeDecompressionContext(dctx) );
+    }
+
+    /* frame content size tests */
+    {   size_t cErr;
+        BYTE* const ostart = (BYTE*)compressedBuffer;
+        BYTE* op = ostart;
+        CHECK( LZ4F_createCompressionContext(&cctx, LZ4F_VERSION) );
+
+        DISPLAYLEVEL(3, "compress without frameSize : ");
+        memset(&(prefs.frameInfo), 0, sizeof(prefs.frameInfo));
+        CHECK_V(cErr, LZ4F_compressBegin(cctx, compressedBuffer, testSize, &prefs));
+        op += cErr;
+        CHECK_V(cErr, LZ4F_compressUpdate(cctx, op, LZ4F_compressBound(testSize, &prefs), CNBuffer, testSize, NULL));
+        op += cErr;
+        CHECK( LZ4F_compressEnd(cctx, compressedBuffer, testSize, NULL) );
+        DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)(op-ostart));
+
+        DISPLAYLEVEL(3, "compress with frameSize : ");
+        prefs.frameInfo.contentSize = testSize;
+        op = ostart;
+        CHECK_V(cErr, LZ4F_compressBegin(cctx, compressedBuffer, testSize, &prefs));
+        op += cErr;
+        CHECK_V(cErr, LZ4F_compressUpdate(cctx, op, LZ4F_compressBound(testSize, &prefs), CNBuffer, testSize, NULL));
+        op += cErr;
+        CHECK( LZ4F_compressEnd(cctx, compressedBuffer, testSize, NULL) );
+        DISPLAYLEVEL(3, "Compressed %i bytes into a %i bytes frame \n", (int)testSize, (int)(op-ostart));
+
+        DISPLAYLEVEL(3, "compress with wrong frameSize : ");
+        prefs.frameInfo.contentSize = testSize+1;
+        op = ostart;
+        CHECK_V(cErr, LZ4F_compressBegin(cctx, compressedBuffer, testSize, &prefs));
+        op += cErr;
+        CHECK_V(cErr, LZ4F_compressUpdate(cctx, op, LZ4F_compressBound(testSize, &prefs), CNBuffer, testSize, NULL));
+        op += cErr;
+        cErr = LZ4F_compressEnd(cctx, op, testSize, NULL);
+        if (!LZ4F_isError(cErr)) goto _output_error;
+        DISPLAYLEVEL(3, "Error correctly detected : %s \n", LZ4F_getErrorName(cErr));
+
+        CHECK( LZ4F_freeCompressionContext(cctx) );
+        cctx = NULL;
+    }
+
+    /* dictID tests */
+    {   size_t cErr;
+        U32 const dictID = 0x99;
+        CHECK( LZ4F_createCompressionContext(&cctx, LZ4F_VERSION) );
+
+        DISPLAYLEVEL(3, "insert a dictID : ");
+        memset(&prefs.frameInfo, 0, sizeof(prefs.frameInfo));
+        prefs.frameInfo.dictID = dictID;
+        CHECK_V(cErr, LZ4F_compressBegin(cctx, compressedBuffer, testSize, &prefs));
+        DISPLAYLEVEL(3, "created frame header of size %i bytes  \n", (int)cErr);
+
+        DISPLAYLEVEL(3, "read a dictID : ");
+        CHECK( LZ4F_createDecompressionContext(&dCtx, LZ4F_VERSION) );
+        memset(&prefs.frameInfo, 0, sizeof(prefs.frameInfo));
+        CHECK( LZ4F_getFrameInfo(dCtx, &prefs.frameInfo, compressedBuffer, &cErr) );
+        if (prefs.frameInfo.dictID != dictID) goto _output_error;
+        DISPLAYLEVEL(3, "%u \n", (U32)prefs.frameInfo.dictID);
+
+        CHECK( LZ4F_freeDecompressionContext(dCtx) ); dCtx = NULL;
+        CHECK( LZ4F_freeCompressionContext(cctx) ); cctx = NULL;
+    }
+
+    /* Dictionary compression test */
+    {   size_t const dictSize = 63 KB;
+        size_t const dstCapacity = LZ4F_compressFrameBound(dictSize, NULL);
+        size_t cSizeNoDict, cSizeWithDict;
+        LZ4F_CDict* const cdict = LZ4F_createCDict(CNBuffer, dictSize);
+        if (cdict == NULL) goto _output_error;
+        CHECK( LZ4F_createCompressionContext(&cctx, LZ4F_VERSION) );
+
+        DISPLAYLEVEL(3, "LZ4F_compressFrame_usingCDict, with NULL dict : ");
+        CHECK_V(cSizeNoDict,
+                LZ4F_compressFrame_usingCDict(cctx, compressedBuffer, dstCapacity,
+                                              CNBuffer, dictSize,
+                                              NULL, NULL) );
+        DISPLAYLEVEL(3, "%u bytes \n", (unsigned)cSizeNoDict);
+
+        CHECK( LZ4F_freeCompressionContext(cctx) );
+        CHECK( LZ4F_createCompressionContext(&cctx, LZ4F_VERSION) );
+        DISPLAYLEVEL(3, "LZ4F_compressFrame_usingCDict, with dict : ");
+        CHECK_V(cSizeWithDict,
+                LZ4F_compressFrame_usingCDict(cctx, compressedBuffer, dstCapacity,
+                                              CNBuffer, dictSize,
+                                              cdict, NULL) );
+        DISPLAYLEVEL(3, "compressed %u bytes into %u bytes \n",
+                        (unsigned)dictSize, (unsigned)cSizeWithDict);
+        if ((LZ4_DISTANCE_MAX > dictSize) && (cSizeWithDict >= cSizeNoDict)) goto _output_error;  /* must be more efficient */
+        crcOrig = XXH64(CNBuffer, dictSize, 0);
+
+        DISPLAYLEVEL(3, "LZ4F_decompress_usingDict : ");
+        {   LZ4F_dctx* dctx;
+            size_t decodedSize = COMPRESSIBLE_NOISE_LENGTH;
+            size_t compressedSize = cSizeWithDict;
+            CHECK( LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION) );
+            CHECK( LZ4F_decompress_usingDict(dctx,
+                                        decodedBuffer, &decodedSize,
+                                        compressedBuffer, &compressedSize,
+                                        CNBuffer, dictSize,
+                                        NULL) );
+            if (compressedSize != cSizeWithDict) goto _output_error;
+            if (decodedSize != dictSize) goto _output_error;
+            { U64 const crcDest = XXH64(decodedBuffer, decodedSize, 0);
+              if (crcDest != crcOrig) goto _output_error; }
+            DISPLAYLEVEL(3, "Regenerated %u bytes \n", (U32)decodedSize);
+            CHECK( LZ4F_freeDecompressionContext(dctx) );
+        }
+
+        DISPLAYLEVEL(3, "LZ4F_compressFrame_usingCDict, with dict, negative level : ");
+        {   size_t cSizeLevelMax;
+            LZ4F_preferences_t cParams;
+            memset(&cParams, 0, sizeof(cParams));
+            cParams.compressionLevel = -3;
+            CHECK_V(cSizeLevelMax,
+                LZ4F_compressFrame_usingCDict(cctx, compressedBuffer, dstCapacity,
+                                              CNBuffer, dictSize,
+                                              cdict, &cParams) );
+            DISPLAYLEVEL(3, "%u bytes \n", (unsigned)cSizeLevelMax);
+        }
+
+        DISPLAYLEVEL(3, "LZ4F_compressFrame_usingCDict, with dict, level max : ");
+        {   size_t cSizeLevelMax;
+            LZ4F_preferences_t cParams;
+            memset(&cParams, 0, sizeof(cParams));
+            cParams.compressionLevel = LZ4F_compressionLevel_max();
+            CHECK_V(cSizeLevelMax,
+                LZ4F_compressFrame_usingCDict(cctx, compressedBuffer, dstCapacity,
+                                              CNBuffer, dictSize,
+                                              cdict, &cParams) );
+            DISPLAYLEVEL(3, "%u bytes \n", (unsigned)cSizeLevelMax);
+        }
+
+        DISPLAYLEVEL(3, "LZ4F_compressFrame_usingCDict, multiple linked blocks : ");
+        {   size_t cSizeContiguous;
+            size_t const inSize = dictSize * 3;
+            size_t const outCapacity = LZ4F_compressFrameBound(inSize, NULL);
+            LZ4F_preferences_t cParams;
+            memset(&cParams, 0, sizeof(cParams));
+            cParams.frameInfo.blockMode = LZ4F_blockLinked;
+            cParams.frameInfo.blockSizeID = LZ4F_max64KB;
+            CHECK_V(cSizeContiguous,
+                LZ4F_compressFrame_usingCDict(cctx, compressedBuffer, outCapacity,
+                                              CNBuffer, inSize,
+                                              cdict, &cParams) );
+            DISPLAYLEVEL(3, "compressed %u bytes into %u bytes \n",
+                        (unsigned)inSize, (unsigned)cSizeContiguous);
+
+            DISPLAYLEVEL(3, "LZ4F_decompress_usingDict on multiple linked blocks : ");
+            {   LZ4F_dctx* dctx;
+                size_t decodedSize = COMPRESSIBLE_NOISE_LENGTH;
+                size_t compressedSize = cSizeContiguous;
+                CHECK( LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION) );
+                CHECK( LZ4F_decompress_usingDict(dctx,
+                                            decodedBuffer, &decodedSize,
+                                            compressedBuffer, &compressedSize,
+                                            CNBuffer, dictSize,
+                                            NULL) );
+                if (compressedSize != cSizeContiguous) goto _output_error;
+                if (decodedSize != inSize) goto _output_error;
+                crcOrig = XXH64(CNBuffer, inSize, 0);
+                { U64 const crcDest = XXH64(decodedBuffer, decodedSize, 0);
+                  if (crcDest != crcOrig) goto _output_error; }
+                DISPLAYLEVEL(3, "Regenerated %u bytes \n", (U32)decodedSize);
+                CHECK( LZ4F_freeDecompressionContext(dctx) );
+            }
+        }
+
+
+        DISPLAYLEVEL(3, "LZ4F_compressFrame_usingCDict, multiple independent blocks : ");
+        {   size_t cSizeIndep;
+            size_t const inSize = dictSize * 3;
+            size_t const outCapacity = LZ4F_compressFrameBound(inSize, NULL);
+            LZ4F_preferences_t cParams;
+            memset(&cParams, 0, sizeof(cParams));
+            cParams.frameInfo.blockMode = LZ4F_blockIndependent;
+            cParams.frameInfo.blockSizeID = LZ4F_max64KB;
+            CHECK_V(cSizeIndep,
+                LZ4F_compressFrame_usingCDict(cctx, compressedBuffer, outCapacity,
+                                              CNBuffer, inSize,
+                                              cdict, &cParams) );
+            DISPLAYLEVEL(3, "compressed %u bytes into %u bytes \n",
+                        (unsigned)inSize, (unsigned)cSizeIndep);
+
+            DISPLAYLEVEL(3, "LZ4F_decompress_usingDict on multiple independent blocks : ");
+            {   LZ4F_dctx* dctx;
+                size_t decodedSize = COMPRESSIBLE_NOISE_LENGTH;
+                size_t compressedSize = cSizeIndep;
+                CHECK( LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION) );
+                CHECK( LZ4F_decompress_usingDict(dctx,
+                                            decodedBuffer, &decodedSize,
+                                            compressedBuffer, &compressedSize,
+                                            CNBuffer, dictSize,
+                                            NULL) );
+                if (compressedSize != cSizeIndep) goto _output_error;
+                if (decodedSize != inSize) goto _output_error;
+                crcOrig = XXH64(CNBuffer, inSize, 0);
+                { U64 const crcDest = XXH64(decodedBuffer, decodedSize, 0);
+                  if (crcDest != crcOrig) goto _output_error; }
+                DISPLAYLEVEL(3, "Regenerated %u bytes \n", (U32)decodedSize);
+                CHECK( LZ4F_freeDecompressionContext(dctx) );
+            }
+        }
+
+        LZ4F_freeCDict(cdict);
+        CHECK( LZ4F_freeCompressionContext(cctx) ); cctx = NULL;
+    }
+
+    DISPLAYLEVEL(3, "getBlockSize test: \n");
+    { size_t result;
+      unsigned blockSizeID;
+      for (blockSizeID = 4; blockSizeID < 8; ++blockSizeID) {
+        result = LZ4F_getBlockSize(blockSizeID);
+        CHECK(result);
+        DISPLAYLEVEL(3, "Returned block size of %u bytes for blockID %u \n",
+                         (unsigned)result, blockSizeID);
+      }
+
+      /* Test an invalid input that's too large */
+      result = LZ4F_getBlockSize(8);
+      if(!LZ4F_isError(result) ||
+          LZ4F_getErrorCode(result) != LZ4F_ERROR_maxBlockSize_invalid)
+        goto _output_error;
+
+      /* Test an invalid input that's too small */
+      result = LZ4F_getBlockSize(3);
+      if(!LZ4F_isError(result) ||
+          LZ4F_getErrorCode(result) != LZ4F_ERROR_maxBlockSize_invalid)
+        goto _output_error;
+    }
+
+
+    DISPLAYLEVEL(3, "Skippable frame test : \n");
+    {   size_t decodedBufferSize = COMPRESSIBLE_NOISE_LENGTH;
+        unsigned maxBits = FUZ_highbit((U32)decodedBufferSize);
+        BYTE* op = (BYTE*)decodedBuffer;
+        BYTE* const oend = (BYTE*)decodedBuffer + COMPRESSIBLE_NOISE_LENGTH;
+        BYTE* ip = (BYTE*)compressedBuffer;
+        BYTE* iend = (BYTE*)compressedBuffer + cSize + 8;
+
+        CHECK( LZ4F_createDecompressionContext(&dCtx, LZ4F_VERSION) );
+
+        /* generate skippable frame */
+        FUZ_writeLE32(ip, LZ4F_MAGIC_SKIPPABLE_START);
+        FUZ_writeLE32(ip+4, (U32)cSize);
+
+        DISPLAYLEVEL(3, "random segment sizes : \n");
+        while (ip < iend) {
+            unsigned nbBits = FUZ_rand(&randState) % maxBits;
+            size_t iSize = (FUZ_rand(&randState) & ((1< (size_t)(iend-ip)) iSize = (size_t)(iend-ip);
+            CHECK( LZ4F_decompress(dCtx, op, &oSize, ip, &iSize, NULL) );
+            op += oSize;
+            ip += iSize;
+        }
+        DISPLAYLEVEL(3, "Skipped %i bytes \n", (int)decodedBufferSize);
+
+        /* generate zero-size skippable frame */
+        DISPLAYLEVEL(3, "zero-size skippable frame\n");
+        ip = (BYTE*)compressedBuffer;
+        op = (BYTE*)decodedBuffer;
+        FUZ_writeLE32(ip, LZ4F_MAGIC_SKIPPABLE_START+1);
+        FUZ_writeLE32(ip+4, 0);
+        iend = ip+8;
+
+        while (ip < iend) {
+            unsigned const nbBits = FUZ_rand(&randState) % maxBits;
+            size_t iSize = (FUZ_rand(&randState) & ((1< (size_t)(iend-ip)) iSize = (size_t)(iend-ip);
+            CHECK( LZ4F_decompress(dCtx, op, &oSize, ip, &iSize, NULL) );
+            op += oSize;
+            ip += iSize;
+        }
+        DISPLAYLEVEL(3, "Skipped %i bytes \n", (int)(ip - (BYTE*)compressedBuffer - 8));
+
+        DISPLAYLEVEL(3, "Skippable frame header complete in first call \n");
+        ip = (BYTE*)compressedBuffer;
+        op = (BYTE*)decodedBuffer;
+        FUZ_writeLE32(ip, LZ4F_MAGIC_SKIPPABLE_START+2);
+        FUZ_writeLE32(ip+4, 10);
+        iend = ip+18;
+        while (ip < iend) {
+            size_t iSize = 10;
+            size_t oSize = 10;
+            if (iSize > (size_t)(iend-ip)) iSize = (size_t)(iend-ip);
+            CHECK( LZ4F_decompress(dCtx, op, &oSize, ip, &iSize, NULL) );
+            op += oSize;
+            ip += iSize;
+        }
+        DISPLAYLEVEL(3, "Skipped %i bytes \n", (int)(ip - (BYTE*)compressedBuffer - 8));
+    }
+
+    DISPLAY("Basic tests completed \n");
+_end:
+    free(CNBuffer);
+    free(compressedBuffer);
+    free(decodedBuffer);
+    LZ4F_freeDecompressionContext(dCtx); dCtx = NULL;
+    LZ4F_freeCompressionContext(cctx); cctx = NULL;
+    return basicTests_error;
+
+_output_error:
+    basicTests_error = 1;
+    DISPLAY("Error detected ! \n");
+    goto _end;
+}
+
+
+typedef enum { o_contiguous, o_noncontiguous, o_overwrite } o_scenario_e;
+
+static void locateBuffDiff(const void* buff1, const void* buff2, size_t size, o_scenario_e o_scenario)
+{
+    if (displayLevel >= 2) {
+        size_t p=0;
+        const BYTE* b1=(const BYTE*)buff1;
+        const BYTE* b2=(const BYTE*)buff2;
+        DISPLAY("locateBuffDiff: looking for error position \n");
+        if (o_scenario != o_contiguous) {
+            DISPLAY("mode %i: non-contiguous output (%u bytes), cannot search \n",
+                    (int)o_scenario, (unsigned)size);
+            return;
+        }
+        while (p < size && b1[p]==b2[p]) p++;
+        if (p != size) {
+            DISPLAY("Error at pos %i/%i : %02X != %02X \n", (int)p, (int)size, b1[p], b2[p]);
+        }
+    }
+}
+
+#   define EXIT_MSG(...) { DISPLAY("Error => "); DISPLAY(__VA_ARGS__); \
+                           DISPLAY(" (seed %u, test nb %u)  \n", seed, testNb); exit(1); }
+#   undef CHECK
+#   define CHECK(cond, ...) { if (cond) { EXIT_MSG(__VA_ARGS__); } }
+
+
+size_t test_lz4f_decompression_wBuffers(
+          const void* cSrc, size_t cSize,
+                void* dst, size_t dstCapacity, o_scenario_e o_scenario,
+          const void* srcRef, size_t decompressedSize,
+                U64 crcOrig,
+                U32* const randState,
+                LZ4F_dctx* const dCtx,
+                U32 seed, U32 testNb,
+                int findErrorPos)
+{
+    const BYTE* ip = (const BYTE*)cSrc;
+    const BYTE* const iend = ip + cSize;
+
+    BYTE* op = (BYTE*)dst;
+    BYTE* const oend = op + dstCapacity;
+
+    unsigned const suggestedBits = FUZ_highbit((U32)cSize);
+    unsigned const maxBits = MAX(3, suggestedBits);
+    size_t totalOut = 0;
+    size_t moreToFlush = 0;
+    XXH64_state_t xxh64;
+    XXH64_reset(&xxh64, 1);
+    assert(ip < iend);
+    while (ip < iend) {
+        unsigned const nbBitsI = (FUZ_rand(randState) % (maxBits-1)) + 1;
+        unsigned const nbBitsO = (FUZ_rand(randState) % (maxBits)) + 1;
+        size_t const iSizeCand = (FUZ_rand(randState) & ((1< 2x4MB to test large blocks */
+    void* CNBuffer = NULL;
+    size_t const compressedBufferSize = LZ4F_compressFrameBound(CNBufferLength, NULL) + 4 MB;  /* needs some margin */
+    void* compressedBuffer = NULL;
+    void* decodedBuffer = NULL;
+    U32 coreRand = seed;
+    LZ4F_decompressionContext_t dCtx = NULL;
+    LZ4F_decompressionContext_t dCtxNoise = NULL;
+    LZ4F_compressionContext_t cCtx = NULL;
+    clock_t const startClock = clock();
+    clock_t const clockDuration = duration_s * CLOCKS_PER_SEC;
+
+    /* Create buffers */
+    {   size_t const creationStatus = LZ4F_createDecompressionContext(&dCtx, LZ4F_VERSION);
+        CHECK(LZ4F_isError(creationStatus), "Allocation failed (error %i)", (int)creationStatus); }
+    {   size_t const creationStatus = LZ4F_createDecompressionContext(&dCtxNoise, LZ4F_VERSION);
+        CHECK(LZ4F_isError(creationStatus), "Allocation failed (error %i)", (int)creationStatus); }
+    {   size_t const creationStatus = LZ4F_createCompressionContext(&cCtx, LZ4F_VERSION);
+        CHECK(LZ4F_isError(creationStatus), "Allocation failed (error %i)", (int)creationStatus); }
+    CNBuffer = malloc(CNBufferLength);
+    CHECK(CNBuffer==NULL, "CNBuffer Allocation failed");
+    compressedBuffer = malloc(compressedBufferSize);
+    CHECK(compressedBuffer==NULL, "compressedBuffer Allocation failed");
+    decodedBuffer = calloc(1, CNBufferLength);   /* calloc avoids decodedBuffer being considered "garbage" by scan-build */
+    CHECK(decodedBuffer==NULL, "decodedBuffer Allocation failed");
+    FUZ_fillCompressibleNoiseBuffer(CNBuffer, CNBufferLength, compressibility, &coreRand);
+
+    /* jump to requested testNb */
+    for (testNb =0; (testNb < startTest); testNb++) (void)FUZ_rand(&coreRand);   /* sync randomizer */
+
+    /* main fuzzer test loop */
+    for ( ; (testNb < nbTests) || (clockDuration > FUZ_GetClockSpan(startClock)) ; testNb++) {
+        U32 randState = coreRand ^ prime1;
+        unsigned const srcBits = (FUZ_rand(&randState) % (FUZ_highbit((U32)(CNBufferLength-1)) - 1)) + 1;
+        size_t const srcSize = (FUZ_rand(&randState) & ((1<frameInfo.blockChecksumFlag) {
+                                U32 const bc32 = XXH32(op, 0, 0);
+                                op[0] = (BYTE)bc32;  /* little endian format */
+                                op[1] = (BYTE)(bc32>>8);
+                                op[2] = (BYTE)(bc32>>16);
+                                op[3] = (BYTE)(bc32>>24);
+                                op += 4;
+                }   }   }   }
+            }  /* while (ip=oend, "LZ4F_compressFrameBound overflow");
+            {   size_t const dstEndSafeSize = LZ4F_compressBound(0, prefsPtr);
+                int const tooSmallDstEnd = ((FUZ_rand(&randState) & 31) == 3);
+                size_t const dstEndTooSmallSize = (FUZ_rand(&randState) % dstEndSafeSize) + 1;
+                size_t const dstEndSize = tooSmallDstEnd ? dstEndTooSmallSize : dstEndSafeSize;
+                BYTE const canaryByte = (BYTE)(FUZ_rand(&randState) & 255);
+                size_t flushedSize;
+                DISPLAYLEVEL(7,"canaryByte at pos %u / %u \n",
+                            (unsigned)((size_t)(op - (BYTE*)compressedBuffer) + dstEndSize),
+                            (unsigned)compressedBufferSize);
+                assert(op + dstEndSize < (BYTE*)compressedBuffer + compressedBufferSize);
+                op[dstEndSize] = canaryByte;
+                flushedSize = LZ4F_compressEnd(cCtx, op, dstEndSize, &cOptions);
+                CHECK(op[dstEndSize] != canaryByte, "LZ4F_compressEnd writes beyond dstCapacity !");
+                if (LZ4F_isError(flushedSize)) {
+                    if (tooSmallDstEnd) /* failure is allowed */ continue;
+                    CHECK(!tooSmallDstEnd, "Compression completion failed (error %i : %s)",
+                            (int)flushedSize, LZ4F_getErrorName(flushedSize));
+                }
+                op += flushedSize;
+            }
+            cSize = (size_t)(op - (BYTE*)compressedBuffer);
+            DISPLAYLEVEL(5, "\nCompressed %u bytes into %u \n", (U32)srcSize, (U32)cSize);
+        }
+
+
+        /* multi-segments decompression */
+        DISPLAYLEVEL(6, "normal decompression \n");
+        {   size_t result = test_lz4f_decompression(compressedBuffer, cSize, srcStart, srcSize, crcOrig, &randState, dCtx, seed, testNb, 1 /*findError*/ );
+            CHECK (LZ4F_isError(result), "multi-segment decompression failed (error %i => %s)",
+                                        (int)result, LZ4F_getErrorName(result));
+        }
+
+#if 1
+        /* insert noise into src */
+        {   U32 const maxNbBits = FUZ_highbit((U32)cSize);
+            size_t pos = 0;
+            for (;;) {
+                /* keep some original src */
+                {   U32 const nbBits = FUZ_rand(&randState) % maxNbBits;
+                    size_t const mask = (1<= cSize) break;
+                /* add noise */
+                {   U32 const nbBitsCodes = FUZ_rand(&randState) % maxNbBits;
+                    U32 const nbBits = nbBitsCodes ? nbBitsCodes-1 : 0;
+                    size_t const mask = (1<='0') && (*argument<='9')) {
+                        nbTests *= 10;
+                        nbTests += (unsigned)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+
+                case 'T':
+                    argument++;
+                    nbTests = 0; duration = 0;
+                    for (;;) {
+                        switch(*argument)
+                        {
+                            case 'm': duration *= 60; argument++; continue;
+                            case 's':
+                            case 'n': argument++; continue;
+                            case '0':
+                            case '1':
+                            case '2':
+                            case '3':
+                            case '4':
+                            case '5':
+                            case '6':
+                            case '7':
+                            case '8':
+                            case '9': duration *= 10; duration += (U32)(*argument++ - '0'); continue;
+                        }
+                        break;
+                    }
+                    break;
+
+                case 's':
+                    argument++;
+                    seed=0;
+                    seedset=1;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        seed *= 10;
+                        seed += (U32)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+                case 't':
+                    argument++;
+                    testNb=0;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        testNb *= 10;
+                        testNb += (unsigned)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+                case 'P':   /* compressibility % */
+                    argument++;
+                    proba=0;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        proba *= 10;
+                        proba += *argument - '0';
+                        argument++;
+                    }
+                    if (proba<0) proba=0;
+                    if (proba>100) proba=100;
+                    break;
+                default:
+                    ;
+                    return FUZ_usage(programName);
+                }
+            }
+        }
+    }
+
+    /* Get Seed */
+    DISPLAY("Starting lz4frame tester (%i-bits, %s)\n", (int)(sizeof(size_t)*8), LZ4_VERSION_STRING);
+
+    if (!seedset) {
+        time_t const t = time(NULL);
+        U32 const h = XXH32(&t, sizeof(t), 1);
+        seed = h % 10000;
+    }
+    DISPLAY("Seed = %u\n", seed);
+    if (proba!=FUZ_COMPRESSIBILITY_DEFAULT) DISPLAY("Compressibility : %i%%\n", proba);
+
+    nbTests += (nbTests==0);  /* avoid zero */
+
+    if (testNb==0) result = basicTests(seed, ((double)proba) / 100);
+    if (result) return 1;
+    return fuzzerTests(seed, nbTests, testNb, ((double)proba) / 100, duration);
+}
diff --git a/lz4/tests/fullbench.c b/lz4/tests/fullbench.c
new file mode 100644
index 0000000..cb9b684
--- /dev/null
+++ b/lz4/tests/fullbench.c
@@ -0,0 +1,869 @@
+/*
+    bench.c - Demo program to benchmark open-source compression algorithm
+    Copyright (C) Yann Collet 2012-2016
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+    - LZ4 source repository : https://github.com/lz4/lz4
+    - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c
+*/
+
+
+#if defined(_MSC_VER) || defined(_WIN32)
+   /* S_ISREG & gettimeofday() are not supported by MSVC */
+#  define BMK_LEGACY_TIMER 1
+#endif
+
+
+/**************************************
+*  Includes
+**************************************/
+#include "platform.h"    /* _CRT_SECURE_NO_WARNINGS, Large Files support */
+#include "util.h"        /* U32, UTIL_getFileSize */
+#include       /* malloc, free */
+#include        /* fprintf, fopen, ftello */
+#include    /* stat64 */
+#include     /* stat64 */
+#include       /* strcmp */
+#include         /* clock_t, clock(), CLOCKS_PER_SEC */
+
+#define LZ4_DISABLE_DEPRECATE_WARNINGS   /* LZ4_decompress_fast */
+#include "lz4.h"
+#include "lz4hc.h"
+#include "lz4frame.h"
+
+#include "xxhash.h"
+
+
+/**************************************
+*  Constants
+**************************************/
+#define PROGRAM_DESCRIPTION "LZ4 speed analyzer"
+#define AUTHOR "Yann Collet"
+#define WELCOME_MESSAGE "*** %s v%s %i-bits, by %s ***\n", PROGRAM_DESCRIPTION, LZ4_VERSION_STRING, (int)(sizeof(void*)*8), AUTHOR
+
+#define NBLOOPS    6
+#define TIMELOOP   (CLOCKS_PER_SEC * 25 / 10)
+
+#define KB *(1 <<10)
+#define MB *(1 <<20)
+#define GB *(1U<<30)
+
+#define KNUTH      2654435761U
+#define MAX_MEM    (1920 MB)
+#define DEFAULT_CHUNKSIZE   (4 MB)
+
+#define ALL_COMPRESSORS 0
+#define ALL_DECOMPRESSORS 0
+
+
+/**************************************
+*  Local structures
+**************************************/
+struct chunkParameters
+{
+    U32   id;
+    char* origBuffer;
+    char* compressedBuffer;
+    int   origSize;
+    int   compressedSize;
+};
+
+
+/**************************************
+*  Macros
+**************************************/
+#define DISPLAY(...) fprintf(stderr, __VA_ARGS__)
+#define PROGRESS(...) g_noPrompt ? 0 : DISPLAY(__VA_ARGS__)
+
+
+/**************************************
+*  Benchmark Parameters
+**************************************/
+static int g_chunkSize = DEFAULT_CHUNKSIZE;
+static int g_nbIterations = NBLOOPS;
+static int g_pause = 0;
+static int g_compressionTest = 1;
+static int g_compressionAlgo = ALL_COMPRESSORS;
+static int g_decompressionTest = 1;
+static int g_decompressionAlgo = ALL_DECOMPRESSORS;
+static int g_noPrompt = 0;
+
+static void BMK_setBlocksize(int bsize)
+{
+    g_chunkSize = bsize;
+    DISPLAY("-Using Block Size of %i KB-\n", g_chunkSize>>10);
+}
+
+static void BMK_setNbIterations(int nbLoops)
+{
+    g_nbIterations = nbLoops;
+    DISPLAY("- %i iterations -\n", g_nbIterations);
+}
+
+static void BMK_setPause(void)
+{
+    g_pause = 1;
+}
+
+
+/*********************************************************
+*  Private functions
+*********************************************************/
+static clock_t BMK_GetClockSpan( clock_t clockStart )
+{
+    return clock() - clockStart;   /* works even if overflow; max span ~30 mn */
+}
+
+
+static size_t BMK_findMaxMem(U64 requiredMem)
+{
+    size_t step = 64 MB;
+    BYTE* testmem = NULL;
+
+    requiredMem = (((requiredMem >> 26) + 1) << 26);
+    requiredMem += 2*step;
+    if (requiredMem > MAX_MEM) requiredMem = MAX_MEM;
+
+    while (!testmem) {
+        if (requiredMem > step) requiredMem -= step;
+        else requiredMem >>= 1;
+        testmem = (BYTE*) malloc ((size_t)requiredMem);
+    }
+    free (testmem);
+
+    /* keep some space available */
+    if (requiredMem > step) requiredMem -= step;
+    else requiredMem >>= 1;
+
+    return (size_t)requiredMem;
+}
+
+
+/*********************************************************
+*  Memory management, to test LZ4_USER_MEMORY_FUNCTIONS
+*********************************************************/
+void* LZ4_malloc(size_t s) { return malloc(s); }
+void* LZ4_calloc(size_t n, size_t s) { return calloc(n,s); }
+void  LZ4_free(void* p) { free(p); }
+
+
+/*********************************************************
+*  Benchmark function
+*********************************************************/
+static LZ4_stream_t LZ4_stream;
+static void local_LZ4_resetDictT(void)
+{
+    void* const r = LZ4_initStream(&LZ4_stream, sizeof(LZ4_stream));
+    assert(r != NULL); (void)r;
+}
+
+static void local_LZ4_createStream(void)
+{
+    void* const r = LZ4_initStream(&LZ4_stream, sizeof(LZ4_stream));
+    assert(r != NULL); (void)r;
+}
+
+static int local_LZ4_saveDict(const char* in, char* out, int inSize)
+{
+    (void)in;
+    return LZ4_saveDict(&LZ4_stream, out, inSize);
+}
+
+static int local_LZ4_compress_default_large(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_default(in, out, inSize, LZ4_compressBound(inSize));
+}
+
+static int local_LZ4_compress_default_small(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_default(in, out, inSize, LZ4_compressBound(inSize)-1);
+}
+
+static int local_LZ4_compress_destSize(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_destSize(in, out, &inSize, LZ4_compressBound(inSize)-1);
+}
+
+static int local_LZ4_compress_fast0(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_fast(in, out, inSize, LZ4_compressBound(inSize), 0);
+}
+
+static int local_LZ4_compress_fast1(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_fast(in, out, inSize, LZ4_compressBound(inSize), 1);
+}
+
+static int local_LZ4_compress_fast2(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_fast(in, out, inSize, LZ4_compressBound(inSize), 2);
+}
+
+static int local_LZ4_compress_fast17(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_fast(in, out, inSize, LZ4_compressBound(inSize), 17);
+}
+
+static int local_LZ4_compress_fast_extState0(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_fast_extState(&LZ4_stream, in, out, inSize, LZ4_compressBound(inSize), 0);
+}
+
+static int local_LZ4_compress_fast_continue0(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_fast_continue(&LZ4_stream, in, out, inSize, LZ4_compressBound(inSize), 0);
+}
+
+#ifndef LZ4_DLL_IMPORT
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+/* declare hidden function */
+extern int LZ4_compress_forceExtDict (LZ4_stream_t* LZ4_stream, const char* source, char* dest, int inputSize);
+
+#if defined (__cplusplus)
+}
+#endif
+
+static int local_LZ4_compress_forceDict(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_forceExtDict(&LZ4_stream, in, out, inSize);
+}
+#endif
+
+
+/* HC compression functions */
+LZ4_streamHC_t LZ4_streamHC;
+static void local_LZ4_resetStreamHC(void)
+{
+    LZ4_initStreamHC(&LZ4_streamHC, sizeof(LZ4_streamHC));
+}
+
+static int local_LZ4_saveDictHC(const char* in, char* out, int inSize)
+{
+    (void)in;
+    return LZ4_saveDictHC(&LZ4_streamHC, out, inSize);
+}
+
+static int local_LZ4_compress_HC(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_HC(in, out, inSize, LZ4_compressBound(inSize), 9);
+}
+
+static int local_LZ4_compress_HC_extStateHC(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_HC_extStateHC(&LZ4_streamHC, in, out, inSize, LZ4_compressBound(inSize), 9);
+}
+
+static int local_LZ4_compress_HC_continue(const char* in, char* out, int inSize)
+{
+    return LZ4_compress_HC_continue(&LZ4_streamHC, in, out, inSize, LZ4_compressBound(inSize));
+}
+
+
+/* decompression functions */
+static int local_LZ4_decompress_fast(const char* in, char* out, int inSize, int outSize)
+{
+    (void)inSize;
+    LZ4_decompress_fast(in, out, outSize);
+    return outSize;
+}
+
+static int local_LZ4_decompress_fast_usingDict_prefix(const char* in, char* out, int inSize, int outSize)
+{
+    (void)inSize;
+    LZ4_decompress_fast_usingDict(in, out, outSize, out - 65536, 65536);
+    return outSize;
+}
+
+static int local_LZ4_decompress_fast_usingExtDict(const char* in, char* out, int inSize, int outSize)
+{
+    (void)inSize;
+    LZ4_decompress_fast_usingDict(in, out, outSize, out - 65536, 65535);
+    return outSize;
+}
+
+static int local_LZ4_decompress_safe_withPrefix64k(const char* in, char* out, int inSize, int outSize)
+{
+    LZ4_decompress_safe_withPrefix64k(in, out, inSize, outSize);
+    return outSize;
+}
+
+static int local_LZ4_decompress_safe_usingDict(const char* in, char* out, int inSize, int outSize)
+{
+    LZ4_decompress_safe_usingDict(in, out, inSize, outSize, out - 65536, 65536);
+    return outSize;
+}
+
+#ifndef LZ4_DLL_IMPORT
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+extern int LZ4_decompress_safe_forceExtDict(const char* in, char* out, int inSize, int outSize, const void* dict, size_t dictSize);
+
+#if defined (__cplusplus)
+}
+#endif
+
+static int local_LZ4_decompress_safe_forceExtDict(const char* in, char* out, int inSize, int outSize)
+{
+    (void)inSize;
+    LZ4_decompress_safe_forceExtDict(in, out, inSize, outSize, out - 65536, 65536);
+    return outSize;
+}
+#endif
+
+static int local_LZ4_decompress_safe_partial(const char* in, char* out, int inSize, int outSize)
+{
+    int result = LZ4_decompress_safe_partial(in, out, inSize, outSize - 5, outSize);
+    if (result < 0) return result;
+    return outSize;
+}
+
+
+/* frame functions */
+static int local_LZ4F_compressFrame(const char* in, char* out, int inSize)
+{
+    assert(inSize >= 0);
+    return (int)LZ4F_compressFrame(out, LZ4F_compressFrameBound((size_t)inSize, NULL), in, (size_t)inSize, NULL);
+}
+
+static LZ4F_decompressionContext_t g_dCtx;
+
+static int local_LZ4F_decompress(const char* in, char* out, int inSize, int outSize)
+{
+    size_t srcSize = (size_t)inSize;
+    size_t dstSize = (size_t)outSize;
+    size_t result;
+    assert(inSize >= 0);
+    assert(outSize >= 0);
+    result = LZ4F_decompress(g_dCtx, out, &dstSize, in, &srcSize, NULL);
+    if (result!=0) { DISPLAY("Error decompressing frame : unfinished frame \n"); exit(8); }
+    if (srcSize != (size_t)inSize) { DISPLAY("Error decompressing frame : read size incorrect \n"); exit(9); }
+    return (int)dstSize;
+}
+
+static int local_LZ4F_decompress_followHint(const char* src, char* dst, int srcSize, int dstSize)
+{
+    size_t totalInSize = (size_t)srcSize;
+    size_t maxOutSize = (size_t)dstSize;
+
+    size_t inPos = 0;
+    size_t inSize = 0;
+    size_t outPos = 0;
+    size_t outRemaining = maxOutSize - outPos;
+
+    for (;;) {
+        size_t const sizeHint = LZ4F_decompress(g_dCtx, dst+outPos, &outRemaining, src+inPos, &inSize, NULL);
+        assert(!LZ4F_isError(sizeHint));
+
+        inPos += inSize;
+        inSize = sizeHint;
+
+        outPos += outRemaining;
+        outRemaining = maxOutSize - outPos;
+
+        if (!sizeHint) break;
+    }
+
+    /* frame completed */
+    if (inPos != totalInSize) {
+        DISPLAY("Error decompressing frame : must read (%u) full frame (%u) \n",
+                (unsigned)inPos, (unsigned)totalInSize);
+        exit(10);
+    }
+    return (int)outPos;
+
+}
+
+/* always provide input by block of 64 KB */
+static int local_LZ4F_decompress_noHint(const char* src, char* dst, int srcSize, int dstSize)
+{
+    size_t totalInSize = (size_t)srcSize;
+    size_t maxOutSize = (size_t)dstSize;
+
+    size_t inPos = 0;
+    size_t inSize = 64 KB;
+    size_t outPos = 0;
+    size_t outRemaining = maxOutSize - outPos;
+
+    for (;;) {
+        size_t const sizeHint = LZ4F_decompress(g_dCtx, dst+outPos, &outRemaining, src+inPos, &inSize, NULL);
+        assert(!LZ4F_isError(sizeHint));
+
+        inPos += inSize;
+        inSize = (inPos + 64 KB <= totalInSize) ? 64 KB : totalInSize - inPos;
+
+        outPos += outRemaining;
+        outRemaining = maxOutSize - outPos;
+
+        if (!sizeHint) break;
+    }
+
+    /* frame completed */
+    if (inPos != totalInSize) {
+        DISPLAY("Error decompressing frame : must read (%u) full frame (%u) \n",
+                (unsigned)inPos, (unsigned)totalInSize);
+        exit(10);
+    }
+    return (int)outPos;
+
+}
+
+#define NB_COMPRESSION_ALGORITHMS 100
+#define NB_DECOMPRESSION_ALGORITHMS 100
+int fullSpeedBench(const char** fileNamesTable, int nbFiles)
+{
+    int fileIdx=0;
+
+    /* Init */
+    { size_t const errorCode = LZ4F_createDecompressionContext(&g_dCtx, LZ4F_VERSION);
+      if (LZ4F_isError(errorCode)) { DISPLAY("dctx allocation issue \n"); return 10; } }
+
+    /* Loop for each fileName */
+    while (fileIdx inFileSize) benchedSize = (size_t)inFileSize;
+      if (benchedSize < inFileSize) {
+          DISPLAY("Not enough memory for '%s' full size; testing %i MB only... \n",
+                inFileName, (int)(benchedSize>>20));
+      }
+
+      /* Allocation */
+      chunkP = (struct chunkParameters*) malloc(((benchedSize / (size_t)g_chunkSize)+1) * sizeof(struct chunkParameters));
+      orig_buff = (char*) malloc(benchedSize);
+      nbChunks = (int) ((benchedSize + (size_t)g_chunkSize - 1) / (size_t)g_chunkSize);
+      maxCompressedChunkSize = LZ4_compressBound(g_chunkSize);
+      compressedBuffSize = nbChunks * maxCompressedChunkSize;
+      compressed_buff = (char*)malloc((size_t)compressedBuffSize);
+      if(!chunkP || !orig_buff || !compressed_buff) {
+          DISPLAY("\nError: not enough memory! \n");
+          fclose(inFile);
+          free(orig_buff);
+          free(compressed_buff);
+          free(chunkP);
+          return(12);
+      }
+
+      /* Fill in src buffer */
+      DISPLAY("Loading %s...       \r", inFileName);
+      readSize = fread(orig_buff, 1, benchedSize, inFile);
+      fclose(inFile);
+
+      if (readSize != benchedSize) {
+        DISPLAY("\nError: problem reading file '%s' !!    \n", inFileName);
+        free(orig_buff);
+        free(compressed_buff);
+        free(chunkP);
+        return 13;
+      }
+
+      /* Calculating input Checksum */
+      crcOriginal = XXH32(orig_buff, benchedSize,0);
+
+
+      /* Bench */
+      { int loopNb, nb_loops, chunkNb, cAlgNb, dAlgNb;
+        size_t cSize=0;
+        double ratio=0.;
+
+        DISPLAY("\r%79s\r", "");
+        DISPLAY(" %s : \n", inFileName);
+
+        /* Bench Compression Algorithms */
+        for (cAlgNb=0; (cAlgNb <= NB_COMPRESSION_ALGORITHMS) && (g_compressionTest); cAlgNb++) {
+            const char* compressorName;
+            int (*compressionFunction)(const char*, char*, int);
+            void (*initFunction)(void) = NULL;
+            double bestTime = 100000000.;
+
+            /* filter compressionAlgo only */
+            if ((g_compressionAlgo != ALL_COMPRESSORS) && (g_compressionAlgo != cAlgNb)) continue;
+
+            /* Init data chunks */
+            {   int i;
+                size_t remaining = benchedSize;
+                char* in = orig_buff;
+                char* out = compressed_buff;
+                assert(nbChunks >= 1);
+                for (i=0; i 0);
+                    if (remaining > (size_t)g_chunkSize) {
+                        chunkP[i].origSize = g_chunkSize;
+                        remaining -= (size_t)g_chunkSize;
+                    } else {
+                        chunkP[i].origSize = (int)remaining;
+                        remaining = 0;
+                    }
+                    chunkP[i].compressedBuffer = out; out += maxCompressedChunkSize;
+                    chunkP[i].compressedSize = 0;
+                }
+            }
+
+            switch(cAlgNb)
+            {
+            case 0 : DISPLAY("Compression functions : \n"); continue;
+            case 1 : compressionFunction = local_LZ4_compress_default_large; compressorName = "LZ4_compress_default"; break;
+            case 2 : compressionFunction = local_LZ4_compress_default_small; compressorName = "LZ4_compress_default(small dst)"; break;
+            case 3 : compressionFunction = local_LZ4_compress_destSize; compressorName = "LZ4_compress_destSize"; break;
+            case 4 : compressionFunction = local_LZ4_compress_fast0; compressorName = "LZ4_compress_fast(0)"; break;
+            case 5 : compressionFunction = local_LZ4_compress_fast1; compressorName = "LZ4_compress_fast(1)"; break;
+            case 6 : compressionFunction = local_LZ4_compress_fast2; compressorName = "LZ4_compress_fast(2)"; break;
+            case 7 : compressionFunction = local_LZ4_compress_fast17; compressorName = "LZ4_compress_fast(17)"; break;
+            case 8 : compressionFunction = local_LZ4_compress_fast_extState0; compressorName = "LZ4_compress_fast_extState(0)"; break;
+            case 9 : compressionFunction = local_LZ4_compress_fast_continue0; initFunction = local_LZ4_createStream; compressorName = "LZ4_compress_fast_continue(0)"; break;
+
+            case 10: compressionFunction = local_LZ4_compress_HC; compressorName = "LZ4_compress_HC"; break;
+            case 12: compressionFunction = local_LZ4_compress_HC_extStateHC; compressorName = "LZ4_compress_HC_extStateHC"; break;
+            case 14: compressionFunction = local_LZ4_compress_HC_continue; initFunction = local_LZ4_resetStreamHC; compressorName = "LZ4_compress_HC_continue"; break;
+#ifndef LZ4_DLL_IMPORT
+            case 20: compressionFunction = local_LZ4_compress_forceDict; initFunction = local_LZ4_resetDictT; compressorName = "LZ4_compress_forceDict"; break;
+#endif
+            case 30: compressionFunction = local_LZ4F_compressFrame; compressorName = "LZ4F_compressFrame";
+                        chunkP[0].origSize = (int)benchedSize; nbChunks=1;
+                        break;
+            case 40: compressionFunction = local_LZ4_saveDict; compressorName = "LZ4_saveDict";
+                        if (chunkP[0].origSize < 8) { DISPLAY(" cannot bench %s with less then 8 bytes \n", compressorName); continue; }
+                        LZ4_loadDict(&LZ4_stream, chunkP[0].origBuffer, chunkP[0].origSize);
+                        break;
+            case 41: compressionFunction = local_LZ4_saveDictHC; compressorName = "LZ4_saveDictHC";
+                        if (chunkP[0].origSize < 8) { DISPLAY(" cannot bench %s with less then 8 bytes \n", compressorName); continue; }
+                        LZ4_loadDictHC(&LZ4_streamHC, chunkP[0].origBuffer, chunkP[0].origSize);
+                        break;
+            default :
+                continue;   /* unknown ID : just skip */
+            }
+
+            for (loopNb = 1; loopNb <= g_nbIterations; loopNb++) {
+                double averageTime;
+                clock_t clockTime;
+
+                PROGRESS("%2i-%-34.34s :%10i ->\r", loopNb, compressorName, (int)benchedSize);
+                { size_t i; for (i=0; i%9i (%5.2f%%),%7.1f MB/s\r", loopNb, compressorName, (int)benchedSize, (int)cSize, ratio, (double)benchedSize / bestTime / 1000000);
+            }
+
+            if (ratio<100.)
+                DISPLAY("%2i-%-34.34s :%10i ->%9i (%5.2f%%),%7.1f MB/s\n", cAlgNb, compressorName, (int)benchedSize, (int)cSize, ratio, (double)benchedSize / bestTime / 1000000);
+            else
+                DISPLAY("%2i-%-34.34s :%10i ->%9i (%5.1f%%),%7.1f MB/s\n", cAlgNb, compressorName, (int)benchedSize, (int)cSize, ratio, (double)benchedSize / bestTime / 100000);
+        }
+
+        /* Prepare layout for decompression */
+        /* Init data chunks */
+        { int i;
+          size_t remaining = benchedSize;
+          char* in = orig_buff;
+          char* out = compressed_buff;
+
+          nbChunks = (int) (((int)benchedSize + (g_chunkSize-1))/ g_chunkSize);
+          for (i=0; i g_chunkSize) {
+                  chunkP[i].origSize = g_chunkSize;
+                  remaining -= (size_t)g_chunkSize;
+              } else {
+                  chunkP[i].origSize = (int)remaining;
+                  remaining = 0;
+              }
+              chunkP[i].compressedBuffer = out; out += maxCompressedChunkSize;
+              chunkP[i].compressedSize = 0;
+          }
+        }
+        for (chunkNb=0; chunkNb\r", loopNb, dName, (int)benchedSize);
+
+                nb_loops = 0;
+                clockTime = clock();
+                while(clock() == clockTime);
+                clockTime = clock();
+                while(BMK_GetClockSpan(clockTime) < TIMELOOP) {
+                    for (chunkNb=0; chunkNb %7.1f MB/s\r", loopNb, dName, (int)benchedSize, (double)benchedSize / bestTime / 1000000);
+
+                /* CRC Checking */
+                crcDecoded = XXH32(orig_buff, benchedSize, 0);
+                if (checkResult && (crcOriginal!=crcDecoded)) {
+                    DISPLAY("\n!!! WARNING !!! %14s : Invalid Checksum : %x != %x\n",
+                            inFileName, (unsigned)crcOriginal, (unsigned)crcDecoded);
+                    exit(1);
+            }   }
+
+            DISPLAY("%2i-%-34.34s :%10i -> %7.1f MB/s\n", dAlgNb, dName, (int)benchedSize, (double)benchedSize / bestTime / 1000000);
+        }
+      }
+      free(orig_buff);
+      free(compressed_buff);
+      free(chunkP);
+    }
+
+    LZ4F_freeDecompressionContext(g_dCtx);
+    if (g_pause) { printf("press enter...\n"); (void)getchar(); }
+
+    return 0;
+}
+
+
+static int usage(const char* exename)
+{
+    DISPLAY( "Usage :\n");
+    DISPLAY( "      %s [arg] file1 file2 ... fileX\n", exename);
+    DISPLAY( "Arguments :\n");
+    DISPLAY( " -c     : compression tests only\n");
+    DISPLAY( " -d     : decompression tests only\n");
+    DISPLAY( " -H/-h  : Help (this text + advanced options)\n");
+    return 0;
+}
+
+static int usage_advanced(void)
+{
+    DISPLAY( "\nAdvanced options :\n");
+    DISPLAY( " -c#    : test only compression function # [1-%i]\n", NB_COMPRESSION_ALGORITHMS);
+    DISPLAY( " -d#    : test only decompression function # [1-%i]\n", NB_DECOMPRESSION_ALGORITHMS);
+    DISPLAY( " -i#    : iteration loops [1-9](default : %i)\n", NBLOOPS);
+    DISPLAY( " -B#    : Block size [4-7](default : 7)\n");
+    return 0;
+}
+
+static int badusage(const char* exename)
+{
+    DISPLAY("Wrong parameters\n");
+    usage(exename);
+    return 0;
+}
+
+int main(int argc, const char** argv)
+{
+    int i,
+        filenamesStart=2;
+    const char* exename = argv[0];
+    const char* input_filename=0;
+
+    // Welcome message
+    DISPLAY(WELCOME_MESSAGE);
+
+    if (argc<2) { badusage(exename); return 1; }
+
+    for(i=1; i= '0') && (argument[1]<= '9')) {
+                        g_compressionAlgo *= 10;
+                        g_compressionAlgo += argument[1] - '0';
+                        argument++;
+                    }
+                    break;
+
+                    // Select decompression algorithm only
+                case 'd':
+                    g_compressionTest = 0;
+                    while ((argument[1]>= '0') && (argument[1]<= '9')) {
+                        g_decompressionAlgo *= 10;
+                        g_decompressionAlgo += argument[1] - '0';
+                        argument++;
+                    }
+                    break;
+
+                    // Display help on usage
+                case 'h' :
+                case 'H': usage(exename); usage_advanced(); return 0;
+
+                    // Modify Block Properties
+                case 'B':
+                    while (argument[1]!=0)
+                    switch(argument[1])
+                    {
+                    case '4':
+                    case '5':
+                    case '6':
+                    case '7':
+                    {   int B = argument[1] - '0';
+                        int S = 1 << (8 + 2*B);
+                        BMK_setBlocksize(S);
+                        argument++;
+                        break;
+                    }
+                    case 'D': argument++; break;
+                    default : goto _exit_blockProperties;
+                    }
+_exit_blockProperties:
+                    break;
+
+                    // Modify Nb Iterations
+                case 'i':
+                    if ((argument[1] >='0') && (argument[1] <='9')) {
+                        int iters = argument[1] - '0';
+                        BMK_setNbIterations(iters);
+                        argument++;
+                    }
+                    break;
+
+                    // Pause at the end (hidden option)
+                case 'p': BMK_setPause(); break;
+
+                    // Unknown command
+                default : badusage(exename); return 1;
+                }
+            }
+            continue;
+        }
+
+        // first provided filename is input
+        if (!input_filename) { input_filename=argument; filenamesStart=i; continue; }
+
+    }
+
+    // No input filename ==> Error
+    if(!input_filename) { badusage(exename); return 1; }
+
+    return fullSpeedBench(argv+filenamesStart, argc-filenamesStart);
+
+}
diff --git a/lz4/tests/fuzzer.c b/lz4/tests/fuzzer.c
new file mode 100644
index 0000000..a824813
--- /dev/null
+++ b/lz4/tests/fuzzer.c
@@ -0,0 +1,1841 @@
+/*
+    fuzzer.c - Fuzzer test tool for LZ4
+    Copyright (C) Yann Collet 2012-2017
+
+    GPL v2 License
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License along
+    with this program; if not, write to the Free Software Foundation, Inc.,
+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+    You can contact the author at :
+    - LZ4 homepage : http://www.lz4.org
+    - LZ4 source repo : https://github.com/lz4/lz4
+*/
+
+/*-************************************
+*  Compiler options
+**************************************/
+#ifdef _MSC_VER    /* Visual Studio */
+#  pragma warning(disable : 4127)    /* disable: C4127: conditional expression is constant */
+#  pragma warning(disable : 4146)    /* disable: C4146: minus unsigned expression */
+#  pragma warning(disable : 4310)    /* disable: C4310: constant char value > 127 */
+#endif
+
+
+/*-************************************
+*  Dependencies
+**************************************/
+#if defined(__unix__) && !defined(_AIX)   /* must be included before platform.h for MAP_ANONYMOUS */
+#  undef  _GNU_SOURCE     /* in case it's already defined */
+#  define _GNU_SOURCE     /* MAP_ANONYMOUS even in -std=c99 mode */
+#  include    /* mmap */
+#endif
+#include "platform.h"   /* _CRT_SECURE_NO_WARNINGS */
+#include "util.h"       /* U32 */
+#include 
+#include       /* fgets, sscanf */
+#include      /* strcmp */
+#include        /* clock_t, clock, CLOCKS_PER_SEC */
+#include 
+#include      /* INT_MAX */
+
+#if defined(_AIX)
+#  include    /* mmap */
+#endif
+
+#define LZ4_DISABLE_DEPRECATE_WARNINGS   /* LZ4_decompress_fast */
+#define LZ4_STATIC_LINKING_ONLY
+#include "lz4.h"
+#define LZ4_HC_STATIC_LINKING_ONLY
+#include "lz4hc.h"
+#define XXH_STATIC_LINKING_ONLY
+#include "xxhash.h"
+
+
+/*-************************************
+*  Basic Types
+**************************************/
+#if !defined(__cplusplus) && !(defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */)
+typedef size_t uintptr_t;   /* true on most systems, except OpenVMS-64 (which doesn't need address overflow test) */
+#endif
+
+
+/*-************************************
+*  Constants
+**************************************/
+#define NB_ATTEMPTS (1<<16)
+#define COMPRESSIBLE_NOISE_LENGTH (1 << 21)
+#define FUZ_MAX_BLOCK_SIZE (1 << 17)
+#define FUZ_MAX_DICT_SIZE  (1 << 15)
+#define FUZ_COMPRESSIBILITY_DEFAULT 60
+#define PRIME1   2654435761U
+#define PRIME2   2246822519U
+#define PRIME3   3266489917U
+
+#define KB *(1U<<10)
+#define MB *(1U<<20)
+#define GB *(1U<<30)
+
+
+/*-***************************************
+*  Macros
+*****************************************/
+#define DISPLAY(...)         fprintf(stdout, __VA_ARGS__)
+#define DISPLAYLEVEL(l, ...) if (g_displayLevel>=l) { DISPLAY(__VA_ARGS__); }
+static int g_displayLevel = 2;
+
+#define MIN(a,b)   ( (a) < (b) ? (a) : (b) )
+
+
+/*-*******************************************************
+*  Fuzzer functions
+*********************************************************/
+static clock_t FUZ_GetClockSpan(clock_t clockStart)
+{
+    return clock() - clockStart;   /* works even if overflow; max span ~ 30mn */
+}
+
+static void FUZ_displayUpdate(unsigned testNb)
+{
+    static clock_t g_time = 0;
+    static const clock_t g_refreshRate = CLOCKS_PER_SEC / 5;
+    if ((FUZ_GetClockSpan(g_time) > g_refreshRate) || (g_displayLevel>=4)) {
+        g_time = clock();
+        DISPLAY("\r%5u   ", testNb);
+        fflush(stdout);
+    }
+}
+
+static U32 FUZ_rotl32(U32 u32, U32 nbBits)
+{
+    return ((u32 << nbBits) | (u32 >> (32 - nbBits)));
+}
+
+static U32 FUZ_highbit32(U32 v32)
+{
+    unsigned nbBits = 0;
+    if (v32==0) return 0;
+    while (v32) { v32 >>= 1; nbBits++; }
+    return nbBits;
+}
+
+static U32 FUZ_rand(U32* src)
+{
+    U32 rand32 = *src;
+    rand32 *= PRIME1;
+    rand32 ^= PRIME2;
+    rand32  = FUZ_rotl32(rand32, 13);
+    *src = rand32;
+    return rand32;
+}
+
+
+#define FUZ_RAND15BITS  ((FUZ_rand(seed) >> 3) & 32767)
+#define FUZ_RANDLENGTH  ( ((FUZ_rand(seed) >> 7) & 3) ? (FUZ_rand(seed) % 15) : (FUZ_rand(seed) % 510) + 15)
+static void FUZ_fillCompressibleNoiseBuffer(void* buffer, size_t bufferSize, double proba, U32* seed)
+{
+    BYTE* const BBuffer = (BYTE*)buffer;
+    size_t pos = 0;
+    U32 const P32 = (U32)(32768 * proba);
+
+    /* First Bytes */
+    while (pos < 20)
+        BBuffer[pos++] = (BYTE)(FUZ_rand(seed));
+
+    while (pos < bufferSize) {
+        /* Select : Literal (noise) or copy (within 64K) */
+        if (FUZ_RAND15BITS < P32) {
+            /* Copy (within 64K) */
+            size_t const length = (size_t)FUZ_RANDLENGTH + 4;
+            size_t const d = MIN(pos+length, bufferSize);
+            size_t match;
+            size_t offset = (size_t)FUZ_RAND15BITS + 1;
+            while (offset > pos) offset >>= 1;
+            match = pos - offset;
+            while (pos < d) BBuffer[pos++] = BBuffer[match++];
+        } else {
+            /* Literal (noise) */
+            size_t const length = FUZ_RANDLENGTH;
+            size_t const d = MIN(pos+length, bufferSize);
+            while (pos < d) BBuffer[pos++] = (BYTE)(FUZ_rand(seed) >> 5);
+        }
+    }
+}
+
+
+#define MAX_NB_BUFF_I134 150
+#define BLOCKSIZE_I134   (32 MB)
+/*! FUZ_AddressOverflow() :
+*   Aggressively pushes memory allocation limits,
+*   and generates patterns which create address space overflow.
+*   only possible in 32-bits mode */
+static int FUZ_AddressOverflow(void)
+{
+    char* buffers[MAX_NB_BUFF_I134+1];
+    int nbBuff=0;
+    int highAddress = 0;
+
+    DISPLAY("Overflow tests : ");
+
+    /* Only possible in 32-bits */
+    if (sizeof(void*)==8) {
+        DISPLAY("64 bits mode : no overflow \n");
+        fflush(stdout);
+        return 0;
+    }
+
+    buffers[0] = (char*)malloc(BLOCKSIZE_I134);
+    buffers[1] = (char*)malloc(BLOCKSIZE_I134);
+    if ((!buffers[0]) || (!buffers[1])) {
+        free(buffers[0]); free(buffers[1]);
+        DISPLAY("not enough memory for tests \n");
+        return 0;
+    }
+
+    for (nbBuff=2; nbBuff < MAX_NB_BUFF_I134; nbBuff++) {
+        DISPLAY("%3i \b\b\b\b", nbBuff); fflush(stdout);
+        buffers[nbBuff] = (char*)malloc(BLOCKSIZE_I134);
+        if (buffers[nbBuff]==NULL) goto _endOfTests;
+
+        if (((uintptr_t)buffers[nbBuff] > (uintptr_t)0x80000000) && (!highAddress)) {
+            DISPLAY("high address detected : ");
+            fflush(stdout);
+            highAddress=1;
+        }
+
+        {   size_t const sizeToGenerateOverflow = (size_t)(- ((uintptr_t)buffers[nbBuff-1]) + 512);
+            int const nbOf255 = (int)((sizeToGenerateOverflow / 255) + 1);
+            char* const input = buffers[nbBuff-1];
+            char* output = buffers[nbBuff];
+            int r;
+            input[0] = (char)0xF0;   /* Literal length overflow */
+            input[1] = (char)0xFF;
+            input[2] = (char)0xFF;
+            input[3] = (char)0xFF;
+            { int u; for(u = 4; u <= nbOf255+4; u++) input[u] = (char)0xff; }
+            r = LZ4_decompress_safe(input, output, nbOf255+64, BLOCKSIZE_I134);
+            if (r>0) { DISPLAY("LZ4_decompress_safe = %i \n", r); goto _overflowError; }
+            input[0] = (char)0x1F;   /* Match length overflow */
+            input[1] = (char)0x01;
+            input[2] = (char)0x01;
+            input[3] = (char)0x00;
+            r = LZ4_decompress_safe(input, output, nbOf255+64, BLOCKSIZE_I134);
+            if (r>0) { DISPLAY("LZ4_decompress_safe = %i \n", r); goto _overflowError; }
+
+            output = buffers[nbBuff-2];   /* Reverse in/out pointer order */
+            input[0] = (char)0xF0;   /* Literal length overflow */
+            input[1] = (char)0xFF;
+            input[2] = (char)0xFF;
+            input[3] = (char)0xFF;
+            r = LZ4_decompress_safe(input, output, nbOf255+64, BLOCKSIZE_I134);
+            if (r>0) goto _overflowError;
+            input[0] = (char)0x1F;   /* Match length overflow */
+            input[1] = (char)0x01;
+            input[2] = (char)0x01;
+            input[3] = (char)0x00;
+            r = LZ4_decompress_safe(input, output, nbOf255+64, BLOCKSIZE_I134);
+            if (r>0) goto _overflowError;
+        }
+    }
+
+    nbBuff++;
+_endOfTests:
+    { int i; for (i=0 ; i=4) {          \
+                    printf("\r%4u - %2u :", cycleNb, testNb);  \
+                    printf(" " __VA_ARGS__);      \
+                    printf("   ");                \
+                    fflush(stdout);               \
+            }   }
+
+
+    /* init */
+    if(!CNBuffer || !compressedBuffer || !decodedBuffer || !LZ4dictHC) {
+        DISPLAY("Not enough memory to start fuzzer tests");
+        exit(1);
+    }
+    if ( LZ4_initStream(&LZ4dictBody, sizeof(LZ4dictBody)) == NULL) abort();
+    {   U32 randState = coreRandState ^ PRIME3;
+        FUZ_fillCompressibleNoiseBuffer(CNBuffer, COMPRESSIBLE_NOISE_LENGTH, compressibility, &randState);
+    }
+
+    /* move to startCycle */
+    for (cycleNb = 0; cycleNb < startCycle; cycleNb++)
+        (void) FUZ_rand(&coreRandState);   /* sync coreRandState */
+
+    /* Main test loop */
+    for (cycleNb = startCycle;
+        (cycleNb < nbCycles) || (FUZ_GetClockSpan(clockStart) < clockDuration);
+        cycleNb++) {
+        U32 testNb = 0;
+        U32 randState = FUZ_rand(&coreRandState) ^ PRIME3;
+        int const blockSize  = (FUZ_rand(&randState) % (FUZ_MAX_BLOCK_SIZE-1)) + 1;
+        int const blockStart = (int)(FUZ_rand(&randState) % (U32)(COMPRESSIBLE_NOISE_LENGTH - blockSize - 1)) + 1;
+        int const dictSizeRand = FUZ_rand(&randState) % FUZ_MAX_DICT_SIZE;
+        int const dictSize = MIN(dictSizeRand, blockStart - 1);
+        int const compressionLevel = FUZ_rand(&randState) % (LZ4HC_CLEVEL_MAX+1);
+        const char* block = ((char*)CNBuffer) + blockStart;
+        const char* dict = block - dictSize;
+        int compressedSize, HCcompressedSize;
+        int blockContinueCompressedSize;
+        U32 const crcOrig = XXH32(block, (size_t)blockSize, 0);
+        int ret;
+
+        FUZ_displayUpdate(cycleNb);
+
+        /* Compression tests */
+        if ( ((FUZ_rand(&randState) & 63) == 2)
+          && ((size_t)blockSize < labSize) ) {
+            memcpy(lowAddrBuffer, block, blockSize);
+            block = (const char*)lowAddrBuffer;
+        }
+
+        /* Test compression destSize */
+        FUZ_DISPLAYTEST("test LZ4_compress_destSize()");
+        {   int cSize, srcSize = blockSize;
+            int const targetSize = srcSize * (int)((FUZ_rand(&randState) & 127)+1) >> 7;
+            char const endCheck = (char)(FUZ_rand(&randState) & 255);
+            compressedBuffer[targetSize] = endCheck;
+            cSize = LZ4_compress_destSize(block, compressedBuffer, &srcSize, targetSize);
+            FUZ_CHECKTEST(cSize > targetSize, "LZ4_compress_destSize() result larger than dst buffer !");
+            FUZ_CHECKTEST(compressedBuffer[targetSize] != endCheck, "LZ4_compress_destSize() overwrite dst buffer !");
+            FUZ_CHECKTEST(srcSize > blockSize, "LZ4_compress_destSize() read more than src buffer !");
+            DISPLAYLEVEL(5, "destSize : %7i/%7i; content%7i/%7i ", cSize, targetSize, srcSize, blockSize);
+            if (targetSize>0) {
+                /* check correctness */
+                U32 const crcBase = XXH32(block, (size_t)srcSize, 0);
+                char const canary = (char)(FUZ_rand(&randState) & 255);
+                FUZ_CHECKTEST((cSize==0), "LZ4_compress_destSize() compression failed");
+                FUZ_DISPLAYTEST();
+                decodedBuffer[srcSize] = canary;
+                {   int const dSize = LZ4_decompress_safe(compressedBuffer, decodedBuffer, cSize, srcSize);
+                    FUZ_CHECKTEST(dSize<0, "LZ4_decompress_safe() failed on data compressed by LZ4_compress_destSize");
+                    FUZ_CHECKTEST(dSize!=srcSize, "LZ4_decompress_safe() failed : did not fully decompressed data");
+                }
+                FUZ_CHECKTEST(decodedBuffer[srcSize] != canary, "LZ4_decompress_safe() overwrite dst buffer !");
+                {   U32 const crcDec = XXH32(decodedBuffer, (size_t)srcSize, 0);
+                    FUZ_CHECKTEST(crcDec!=crcBase, "LZ4_decompress_safe() corrupted decoded data");
+            }   }
+            DISPLAYLEVEL(5, " OK \n");
+        }
+
+        /* Test compression HC destSize */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC_destSize()");
+        {   int cSize, srcSize = blockSize;
+            int const targetSize = srcSize * (int)((FUZ_rand(&randState) & 127)+1) >> 7;
+            char const endCheck = (char)(FUZ_rand(&randState) & 255);
+            void* const ctx = LZ4_createHC(block);
+            FUZ_CHECKTEST(ctx==NULL, "LZ4_createHC() allocation failed");
+            compressedBuffer[targetSize] = endCheck;
+            cSize = LZ4_compress_HC_destSize(ctx, block, compressedBuffer, &srcSize, targetSize, compressionLevel);
+            DISPLAYLEVEL(5, "LZ4_compress_HC_destSize(%i): destSize : %7i/%7i; content%7i/%7i ",
+                            compressionLevel, cSize, targetSize, srcSize, blockSize);
+            LZ4_freeHC(ctx);
+            FUZ_CHECKTEST(cSize > targetSize, "LZ4_compress_HC_destSize() result larger than dst buffer !");
+            FUZ_CHECKTEST(compressedBuffer[targetSize] != endCheck, "LZ4_compress_HC_destSize() overwrite dst buffer !");
+            FUZ_CHECKTEST(srcSize > blockSize, "LZ4_compress_HC_destSize() fed more than src buffer !");
+            if (targetSize>0) {
+                /* check correctness */
+                U32 const crcBase = XXH32(block, (size_t)srcSize, 0);
+                char const canary = (char)(FUZ_rand(&randState) & 255);
+                FUZ_CHECKTEST((cSize==0), "LZ4_compress_HC_destSize() compression failed");
+                FUZ_DISPLAYTEST();
+                decodedBuffer[srcSize] = canary;
+                {   int const dSize = LZ4_decompress_safe(compressedBuffer, decodedBuffer, cSize, srcSize);
+                    FUZ_CHECKTEST(dSize<0, "LZ4_decompress_safe failed (%i) on data compressed by LZ4_compressHC_destSize", dSize);
+                    FUZ_CHECKTEST(dSize!=srcSize, "LZ4_decompress_safe failed : decompressed %i bytes, was supposed to decompress %i bytes", dSize, srcSize);
+                }
+                FUZ_CHECKTEST(decodedBuffer[srcSize] != canary, "LZ4_decompress_safe overwrite dst buffer !");
+                {   U32 const crcDec = XXH32(decodedBuffer, (size_t)srcSize, 0);
+                    FUZ_CHECKTEST(crcDec!=crcBase, "LZ4_decompress_safe() corrupted decoded data");
+            }   }
+            DISPLAYLEVEL(5, " OK \n");
+        }
+
+        /* Test compression HC */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC()");
+        HCcompressedSize = LZ4_compress_HC(block, compressedBuffer, blockSize, (int)compressedBufferSize, compressionLevel);
+        FUZ_CHECKTEST(HCcompressedSize==0, "LZ4_compress_HC() failed");
+
+        /* Test compression HC using external state */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC_extStateHC()");
+        {   int const r = LZ4_compress_HC_extStateHC(stateLZ4HC, block, compressedBuffer, blockSize, (int)compressedBufferSize, compressionLevel);
+            FUZ_CHECKTEST(r==0, "LZ4_compress_HC_extStateHC() failed")
+        }
+
+        /* Test compression HC using fast reset external state */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC_extStateHC_fastReset()");
+        {   int const r = LZ4_compress_HC_extStateHC_fastReset(stateLZ4HC, block, compressedBuffer, blockSize, (int)compressedBufferSize, compressionLevel);
+            FUZ_CHECKTEST(r==0, "LZ4_compress_HC_extStateHC_fastReset() failed");
+        }
+
+        /* Test compression using external state */
+        FUZ_DISPLAYTEST("test LZ4_compress_fast_extState()");
+        {   int const r = LZ4_compress_fast_extState(stateLZ4, block, compressedBuffer, blockSize, (int)compressedBufferSize, 8);
+            FUZ_CHECKTEST(r==0, "LZ4_compress_fast_extState() failed"); }
+
+        /* Test compression using fast reset external state*/
+        FUZ_DISPLAYTEST();
+        {   int const r = LZ4_compress_fast_extState_fastReset(stateLZ4, block, compressedBuffer, blockSize, (int)compressedBufferSize, 8);
+            FUZ_CHECKTEST(r==0, "LZ4_compress_fast_extState_fastReset() failed"); }
+
+        /* Test compression */
+        FUZ_DISPLAYTEST("test LZ4_compress_default()");
+        compressedSize = LZ4_compress_default(block, compressedBuffer, blockSize, (int)compressedBufferSize);
+        FUZ_CHECKTEST(compressedSize<=0, "LZ4_compress_default() failed");
+
+        /* Decompression tests */
+
+        /* Test decompress_fast() with input buffer size exactly correct => must not read out of bound */
+        {   char* const cBuffer_exact = (char*)malloc((size_t)compressedSize);
+            assert(cBuffer_exact != NULL);
+            assert(compressedSize <= (int)compressedBufferSize);
+            memcpy(cBuffer_exact, compressedBuffer, compressedSize);
+
+            /* Test decoding with output size exactly correct => must work */
+            FUZ_DISPLAYTEST("LZ4_decompress_fast() with exact output buffer");
+            {   int const r = LZ4_decompress_fast(cBuffer_exact, decodedBuffer, blockSize);
+                FUZ_CHECKTEST(r<0, "LZ4_decompress_fast failed despite correct space");
+                FUZ_CHECKTEST(r!=compressedSize, "LZ4_decompress_fast failed : did not fully read compressed data");
+            }
+            {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+                FUZ_CHECKTEST(crcCheck!=crcOrig, "LZ4_decompress_fast corrupted decoded data");
+            }
+
+            /* Test decoding with one byte missing => must fail */
+            FUZ_DISPLAYTEST("LZ4_decompress_fast() with output buffer 1-byte too short");
+            decodedBuffer[blockSize-1] = 0;
+            {   int const r = LZ4_decompress_fast(cBuffer_exact, decodedBuffer, blockSize-1);
+                FUZ_CHECKTEST(r>=0, "LZ4_decompress_fast should have failed, due to Output Size being too small");
+            }
+            FUZ_CHECKTEST(decodedBuffer[blockSize-1]!=0, "LZ4_decompress_fast overrun specified output buffer");
+
+            /* Test decoding with one byte too much => must fail */
+            FUZ_DISPLAYTEST();
+            {   int const r = LZ4_decompress_fast(cBuffer_exact, decodedBuffer, blockSize+1);
+                FUZ_CHECKTEST(r>=0, "LZ4_decompress_fast should have failed, due to Output Size being too large");
+            }
+
+            /* Test decoding with output size exactly what's necessary => must work */
+            FUZ_DISPLAYTEST();
+            decodedBuffer[blockSize] = 0;
+            {   int const r = LZ4_decompress_safe(cBuffer_exact, decodedBuffer, compressedSize, blockSize);
+                FUZ_CHECKTEST(r<0, "LZ4_decompress_safe failed despite sufficient space");
+                FUZ_CHECKTEST(r!=blockSize, "LZ4_decompress_safe did not regenerate original data");
+            }
+            FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_safe overrun specified output buffer size");
+            {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+                FUZ_CHECKTEST(crcCheck!=crcOrig, "LZ4_decompress_safe corrupted decoded data");
+            }
+
+            /* Test decoding with more than enough output size => must work */
+            FUZ_DISPLAYTEST();
+            decodedBuffer[blockSize] = 0;
+            decodedBuffer[blockSize+1] = 0;
+            {   int const r = LZ4_decompress_safe(cBuffer_exact, decodedBuffer, compressedSize, blockSize+1);
+                FUZ_CHECKTEST(r<0, "LZ4_decompress_safe failed despite amply sufficient space");
+                FUZ_CHECKTEST(r!=blockSize, "LZ4_decompress_safe did not regenerate original data");
+            }
+            FUZ_CHECKTEST(decodedBuffer[blockSize+1], "LZ4_decompress_safe overrun specified output buffer size");
+            {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+                FUZ_CHECKTEST(crcCheck!=crcOrig, "LZ4_decompress_safe corrupted decoded data");
+            }
+
+            /* Test decoding with output size being one byte too short => must fail */
+            FUZ_DISPLAYTEST();
+            decodedBuffer[blockSize-1] = 0;
+            {   int const r = LZ4_decompress_safe(cBuffer_exact, decodedBuffer, compressedSize, blockSize-1);
+                FUZ_CHECKTEST(r>=0, "LZ4_decompress_safe should have failed, due to Output Size being one byte too short");
+            }
+            FUZ_CHECKTEST(decodedBuffer[blockSize-1], "LZ4_decompress_safe overrun specified output buffer size");
+
+            /* Test decoding with output size being 10 bytes too short => must fail */
+            FUZ_DISPLAYTEST();
+            if (blockSize>10) {
+                decodedBuffer[blockSize-10] = 0;
+                {   int const r = LZ4_decompress_safe(cBuffer_exact, decodedBuffer, compressedSize, blockSize-10);
+                    FUZ_CHECKTEST(r>=0, "LZ4_decompress_safe should have failed, due to Output Size being 10 bytes too short");
+                }
+                FUZ_CHECKTEST(decodedBuffer[blockSize-10], "LZ4_decompress_safe overrun specified output buffer size");
+            }
+
+            /* noisy src decompression test */
+
+            /* insert noise into src */
+            {   U32 const maxNbBits = FUZ_highbit32((U32)compressedSize);
+                size_t pos = 0;
+                for (;;) {
+                    /* keep some original src */
+                    {   U32 const nbBits = FUZ_rand(&randState) % maxNbBits;
+                        size_t const mask = (1<= (size_t)compressedSize) break;
+                    /* add noise */
+                    {   U32 const nbBitsCodes = FUZ_rand(&randState) % maxNbBits;
+                        U32 const nbBits = nbBitsCodes ? nbBitsCodes-1 : 0;
+                        size_t const mask = (1< blockSize, "LZ4_decompress_safe on noisy src : result is too large : %u > %u (dst buffer)", (unsigned)decompressResult, (unsigned)blockSize);
+                }
+                {   U32 endCheck; memcpy(&endCheck, decodedBuffer+blockSize, sizeof(endCheck));
+                    FUZ_CHECKTEST(endMark!=endCheck, "LZ4_decompress_safe on noisy src : dst buffer overflow");
+            }   }   /* noisy src decompression test */
+
+            free(cBuffer_exact);
+        }
+
+        /* Test decoding with input size being one byte too short => must fail */
+        FUZ_DISPLAYTEST();
+        {   int const r = LZ4_decompress_safe(compressedBuffer, decodedBuffer, compressedSize-1, blockSize);
+            FUZ_CHECKTEST(r>=0, "LZ4_decompress_safe should have failed, due to input size being one byte too short (blockSize=%i, result=%i, compressedSize=%i)", blockSize, r, compressedSize);
+        }
+
+        /* Test decoding with input size being one byte too large => must fail */
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize] = 0;
+        {   int const r = LZ4_decompress_safe(compressedBuffer, decodedBuffer, compressedSize+1, blockSize);
+            FUZ_CHECKTEST(r>=0, "LZ4_decompress_safe should have failed, due to input size being too large");
+        }
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_safe overrun specified output buffer size");
+
+        /* Test partial decoding => must work */
+        FUZ_DISPLAYTEST("test LZ4_decompress_safe_partial");
+        {   size_t const missingOutBytes = FUZ_rand(&randState) % (unsigned)blockSize;
+            int const targetSize = (int)((size_t)blockSize - missingOutBytes);
+            size_t const extraneousInBytes = FUZ_rand(&randState) % 2;
+            int const inCSize = (int)((size_t)compressedSize + extraneousInBytes);
+            char const sentinel = decodedBuffer[targetSize] = block[targetSize] ^ 0x5A;
+            int const decResult = LZ4_decompress_safe_partial(compressedBuffer, decodedBuffer, inCSize, targetSize, blockSize);
+            FUZ_CHECKTEST(decResult<0, "LZ4_decompress_safe_partial failed despite valid input data (error:%i)", decResult);
+            FUZ_CHECKTEST(decResult != targetSize, "LZ4_decompress_safe_partial did not regenerated required amount of data (%i < %i <= %i)", decResult, targetSize, blockSize);
+            FUZ_CHECKTEST(decodedBuffer[targetSize] != sentinel, "LZ4_decompress_safe_partial overwrite beyond requested size (though %i <= %i <= %i)", decResult, targetSize, blockSize);
+            FUZ_CHECKTEST(memcmp(block, decodedBuffer, (size_t)targetSize), "LZ4_decompress_safe_partial: corruption detected in regenerated data");
+        }
+
+        /* Test Compression with limited output size */
+
+        /* Test compression with output size being exactly what's necessary (should work) */
+        FUZ_DISPLAYTEST("test LZ4_compress_default() with output buffer just the right size");
+        ret = LZ4_compress_default(block, compressedBuffer, blockSize, compressedSize);
+        FUZ_CHECKTEST(ret==0, "LZ4_compress_default() failed despite sufficient space");
+
+        /* Test compression with output size being exactly what's necessary and external state (should work) */
+        FUZ_DISPLAYTEST("test LZ4_compress_fast_extState() with output buffer just the right size");
+        ret = LZ4_compress_fast_extState(stateLZ4, block, compressedBuffer, blockSize, compressedSize, 1);
+        FUZ_CHECKTEST(ret==0, "LZ4_compress_fast_extState() failed despite sufficient space");
+
+        /* Test HC compression with output size being exactly what's necessary (should work) */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC() with output buffer just the right size");
+        ret = LZ4_compress_HC(block, compressedBuffer, blockSize, HCcompressedSize, compressionLevel);
+        FUZ_CHECKTEST(ret==0, "LZ4_compress_HC() failed despite sufficient space");
+
+        /* Test HC compression with output size being exactly what's necessary (should work) */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC_extStateHC() with output buffer just the right size");
+        ret = LZ4_compress_HC_extStateHC(stateLZ4HC, block, compressedBuffer, blockSize, HCcompressedSize, compressionLevel);
+        FUZ_CHECKTEST(ret==0, "LZ4_compress_HC_extStateHC() failed despite sufficient space");
+
+        /* Test compression with missing bytes into output buffer => must fail */
+        FUZ_DISPLAYTEST("test LZ4_compress_default() with output buffer a bit too short");
+        {   int missingBytes = (FUZ_rand(&randState) % 0x3F) + 1;
+            if (missingBytes >= compressedSize) missingBytes = compressedSize-1;
+            missingBytes += !missingBytes;   /* avoid special case missingBytes==0 */
+            compressedBuffer[compressedSize-missingBytes] = 0;
+            {   int const cSize = LZ4_compress_default(block, compressedBuffer, blockSize, compressedSize-missingBytes);
+                FUZ_CHECKTEST(cSize, "LZ4_compress_default should have failed (output buffer too small by %i byte)", missingBytes);
+            }
+            FUZ_CHECKTEST(compressedBuffer[compressedSize-missingBytes], "LZ4_compress_default overran output buffer ! (%i missingBytes)", missingBytes)
+        }
+
+        /* Test HC compression with missing bytes into output buffer => must fail */
+        FUZ_DISPLAYTEST("test LZ4_compress_HC() with output buffer a bit too short");
+        {   int missingBytes = (FUZ_rand(&randState) % 0x3F) + 1;
+            if (missingBytes >= HCcompressedSize) missingBytes = HCcompressedSize-1;
+            missingBytes += !missingBytes;   /* avoid special case missingBytes==0 */
+            compressedBuffer[HCcompressedSize-missingBytes] = 0;
+            {   int const hcSize = LZ4_compress_HC(block, compressedBuffer, blockSize, HCcompressedSize-missingBytes, compressionLevel);
+                FUZ_CHECKTEST(hcSize, "LZ4_compress_HC should have failed (output buffer too small by %i byte)", missingBytes);
+            }
+            FUZ_CHECKTEST(compressedBuffer[HCcompressedSize-missingBytes], "LZ4_compress_HC overran output buffer ! (%i missingBytes)", missingBytes)
+        }
+
+
+        /*-******************/
+        /* Dictionary tests */
+        /*-******************/
+
+        /* Compress using dictionary */
+        FUZ_DISPLAYTEST("test LZ4_compress_fast_continue() with dictionary of size %i", dictSize);
+        {   LZ4_stream_t LZ4_stream;
+            LZ4_initStream(&LZ4_stream, sizeof(LZ4_stream));
+            LZ4_compress_fast_continue (&LZ4_stream, dict, compressedBuffer, dictSize, (int)compressedBufferSize, 1);   /* Just to fill hash tables */
+            blockContinueCompressedSize = LZ4_compress_fast_continue (&LZ4_stream, block, compressedBuffer, blockSize, (int)compressedBufferSize, 1);
+            FUZ_CHECKTEST(blockContinueCompressedSize==0, "LZ4_compress_fast_continue failed");
+        }
+
+        /* Decompress with dictionary as prefix */
+        FUZ_DISPLAYTEST("test LZ4_decompress_fast_usingDict() with dictionary as prefix");
+        memcpy(decodedBuffer, dict, dictSize);
+        ret = LZ4_decompress_fast_usingDict(compressedBuffer, decodedBuffer+dictSize, blockSize, decodedBuffer, dictSize);
+        FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_decompress_fast_usingDict did not read all compressed block input");
+        {   U32 const crcCheck = XXH32(decodedBuffer+dictSize, (size_t)blockSize, 0);
+            if (crcCheck!=crcOrig) {
+                FUZ_findDiff(block, decodedBuffer);
+                EXIT_MSG("LZ4_decompress_fast_usingDict corrupted decoded data (dict %i)", dictSize);
+        }   }
+
+        FUZ_DISPLAYTEST("test LZ4_decompress_safe_usingDict()");
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer+dictSize, blockContinueCompressedSize, blockSize, decodedBuffer, dictSize);
+        FUZ_CHECKTEST(ret!=blockSize, "LZ4_decompress_safe_usingDict did not regenerate original data");
+        {   U32 const crcCheck = XXH32(decodedBuffer+dictSize, (size_t)blockSize, 0);
+            FUZ_CHECKTEST(crcCheck!=crcOrig, "LZ4_decompress_safe_usingDict corrupted decoded data");
+        }
+
+        /* Compress using External dictionary */
+        FUZ_DISPLAYTEST("test LZ4_compress_fast_continue(), with non-contiguous dictionary");
+        dict -= (size_t)(FUZ_rand(&randState) & 0xF) + 1;   /* create space, so now dictionary is an ExtDict */
+        if (dict < (char*)CNBuffer) dict = (char*)CNBuffer;
+        LZ4_loadDict(&LZ4dictBody, dict, dictSize);
+        blockContinueCompressedSize = LZ4_compress_fast_continue(&LZ4dictBody, block, compressedBuffer, blockSize, (int)compressedBufferSize, 1);
+        FUZ_CHECKTEST(blockContinueCompressedSize==0, "LZ4_compress_fast_continue failed");
+
+        FUZ_DISPLAYTEST("LZ4_compress_fast_continue() with dictionary and output buffer too short by one byte");
+        LZ4_loadDict(&LZ4dictBody, dict, dictSize);
+        ret = LZ4_compress_fast_continue(&LZ4dictBody, block, compressedBuffer, blockSize, blockContinueCompressedSize-1, 1);
+        FUZ_CHECKTEST(ret>0, "LZ4_compress_fast_continue using ExtDict should fail : one missing byte for output buffer : %i written, %i buffer", ret, blockContinueCompressedSize);
+
+        FUZ_DISPLAYTEST("test LZ4_compress_fast_continue() with dictionary loaded with LZ4_loadDict()");
+        DISPLAYLEVEL(5, " compress %i bytes from buffer(%p) into dst(%p) using dict(%p) of size %i \n",
+                     blockSize, (const void *)block, (void *)decodedBuffer, (const void *)dict, dictSize);
+        LZ4_loadDict(&LZ4dictBody, dict, dictSize);
+        ret = LZ4_compress_fast_continue(&LZ4dictBody, block, compressedBuffer, blockSize, blockContinueCompressedSize, 1);
+        FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_compress_limitedOutput_compressed size is different (%i != %i)", ret, blockContinueCompressedSize);
+        FUZ_CHECKTEST(ret<=0, "LZ4_compress_fast_continue should work : enough size available within output buffer");
+
+        /* Decompress with dictionary as external */
+        FUZ_DISPLAYTEST("test LZ4_decompress_fast_usingDict() with dictionary as extDict");
+        DISPLAYLEVEL(5, " decoding %i bytes from buffer(%p) using dict(%p) of size %i \n",
+                     blockSize, (void *)decodedBuffer, (const void *)dict, dictSize);
+        decodedBuffer[blockSize] = 0;
+        ret = LZ4_decompress_fast_usingDict(compressedBuffer, decodedBuffer, blockSize, dict, dictSize);
+        FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_decompress_fast_usingDict did not read all compressed block input");
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_fast_usingDict overrun specified output buffer size");
+        {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+            if (crcCheck!=crcOrig) {
+                FUZ_findDiff(block, decodedBuffer);
+                EXIT_MSG("LZ4_decompress_fast_usingDict corrupted decoded data (dict %i)", dictSize);
+        }   }
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize] = 0;
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize, dict, dictSize);
+        FUZ_CHECKTEST(ret!=blockSize, "LZ4_decompress_safe_usingDict did not regenerate original data");
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_safe_usingDict overrun specified output buffer size");
+        {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+            FUZ_CHECKTEST(crcCheck!=crcOrig, "LZ4_decompress_safe_usingDict corrupted decoded data");
+        }
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize-1] = 0;
+        ret = LZ4_decompress_fast_usingDict(compressedBuffer, decodedBuffer, blockSize-1, dict, dictSize);
+        FUZ_CHECKTEST(ret>=0, "LZ4_decompress_fast_usingDict should have failed : wrong original size (-1 byte)");
+        FUZ_CHECKTEST(decodedBuffer[blockSize-1], "LZ4_decompress_fast_usingDict overrun specified output buffer size");
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize-1] = 0;
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize-1, dict, dictSize);
+        FUZ_CHECKTEST(ret>=0, "LZ4_decompress_safe_usingDict should have failed : not enough output size (-1 byte)");
+        FUZ_CHECKTEST(decodedBuffer[blockSize-1], "LZ4_decompress_safe_usingDict overrun specified output buffer size");
+
+        FUZ_DISPLAYTEST();
+        {   int const missingBytes = (FUZ_rand(&randState) & 0xF) + 2;
+            if (blockSize > missingBytes) {
+                decodedBuffer[blockSize-missingBytes] = 0;
+                ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize-missingBytes, dict, dictSize);
+                FUZ_CHECKTEST(ret>=0, "LZ4_decompress_safe_usingDict should have failed : output buffer too small (-%i byte)", missingBytes);
+                FUZ_CHECKTEST(decodedBuffer[blockSize-missingBytes], "LZ4_decompress_safe_usingDict overrun specified output buffer size (-%i byte) (blockSize=%i)", missingBytes, blockSize);
+        }   }
+
+        /* Compress using external dictionary stream */
+        {   LZ4_stream_t LZ4_stream;
+            int expectedSize;
+            U32 expectedCrc;
+
+            FUZ_DISPLAYTEST("LZ4_compress_fast_continue() after LZ4_loadDict()");
+            LZ4_loadDict(&LZ4dictBody, dict, dictSize);
+            expectedSize = LZ4_compress_fast_continue(&LZ4dictBody, block, compressedBuffer, blockSize, (int)compressedBufferSize, 1);
+            FUZ_CHECKTEST(expectedSize<=0, "LZ4_compress_fast_continue reference compression for extDictCtx should have succeeded");
+            expectedCrc = XXH32(compressedBuffer, (size_t)expectedSize, 0);
+
+            FUZ_DISPLAYTEST("LZ4_compress_fast_continue() after LZ4_attach_dictionary()");
+            LZ4_loadDict(&LZ4dictBody, dict, dictSize);
+            LZ4_initStream(&LZ4_stream, sizeof(LZ4_stream));
+            LZ4_attach_dictionary(&LZ4_stream, &LZ4dictBody);
+            blockContinueCompressedSize = LZ4_compress_fast_continue(&LZ4_stream, block, compressedBuffer, blockSize, (int)compressedBufferSize, 1);
+            FUZ_CHECKTEST(blockContinueCompressedSize==0, "LZ4_compress_fast_continue using extDictCtx failed");
+
+            /* In the future, it might be desirable to let extDictCtx mode's
+             * output diverge from the output generated by regular extDict mode.
+             * Until that time, this comparison serves as a good regression
+             * test.
+             */
+            FUZ_CHECKTEST(blockContinueCompressedSize != expectedSize, "LZ4_compress_fast_continue using extDictCtx produced different-sized output (%d expected vs %d actual)", expectedSize, blockContinueCompressedSize);
+            FUZ_CHECKTEST(XXH32(compressedBuffer, (size_t)blockContinueCompressedSize, 0) != expectedCrc, "LZ4_compress_fast_continue using extDictCtx produced different output");
+
+            FUZ_DISPLAYTEST("LZ4_compress_fast_continue() after LZ4_attach_dictionary(), but output buffer is 1 byte too short");
+            LZ4_resetStream_fast(&LZ4_stream);
+            LZ4_attach_dictionary(&LZ4_stream, &LZ4dictBody);
+            ret = LZ4_compress_fast_continue(&LZ4_stream, block, compressedBuffer, blockSize, blockContinueCompressedSize-1, 1);
+            FUZ_CHECKTEST(ret>0, "LZ4_compress_fast_continue using extDictCtx should fail : one missing byte for output buffer : %i written, %i buffer", ret, blockContinueCompressedSize);
+            /* note : context is no longer dirty after a failed compressed block */
+
+            FUZ_DISPLAYTEST();
+            LZ4_resetStream_fast(&LZ4_stream);
+            LZ4_attach_dictionary(&LZ4_stream, &LZ4dictBody);
+            ret = LZ4_compress_fast_continue(&LZ4_stream, block, compressedBuffer, blockSize, blockContinueCompressedSize, 1);
+            FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_compress_limitedOutput_compressed size is different (%i != %i)", ret, blockContinueCompressedSize);
+            FUZ_CHECKTEST(ret<=0, "LZ4_compress_fast_continue using extDictCtx should work : enough size available within output buffer");
+            FUZ_CHECKTEST(ret != expectedSize, "LZ4_compress_fast_continue using extDictCtx produced different-sized output");
+            FUZ_CHECKTEST(XXH32(compressedBuffer, (size_t)ret, 0) != expectedCrc, "LZ4_compress_fast_continue using extDictCtx produced different output");
+
+            FUZ_DISPLAYTEST();
+            LZ4_resetStream_fast(&LZ4_stream);
+            LZ4_attach_dictionary(&LZ4_stream, &LZ4dictBody);
+            ret = LZ4_compress_fast_continue(&LZ4_stream, block, compressedBuffer, blockSize, blockContinueCompressedSize, 1);
+            FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_compress_limitedOutput_compressed size is different (%i != %i)", ret, blockContinueCompressedSize);
+            FUZ_CHECKTEST(ret<=0, "LZ4_compress_fast_continue using extDictCtx with re-used context should work : enough size available within output buffer");
+            FUZ_CHECKTEST(ret != expectedSize, "LZ4_compress_fast_continue using extDictCtx produced different-sized output");
+            FUZ_CHECKTEST(XXH32(compressedBuffer, (size_t)ret, 0) != expectedCrc, "LZ4_compress_fast_continue using extDictCtx produced different output");
+        }
+
+        /* Decompress with dictionary as external */
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize] = 0;
+        ret = LZ4_decompress_fast_usingDict(compressedBuffer, decodedBuffer, blockSize, dict, dictSize);
+        FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_decompress_fast_usingDict did not read all compressed block input");
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_fast_usingDict overrun specified output buffer size");
+        {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+            if (crcCheck!=crcOrig) {
+                FUZ_findDiff(block, decodedBuffer);
+                EXIT_MSG("LZ4_decompress_fast_usingDict corrupted decoded data (dict %i)", dictSize);
+        }   }
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize] = 0;
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize, dict, dictSize);
+        FUZ_CHECKTEST(ret!=blockSize, "LZ4_decompress_safe_usingDict did not regenerate original data");
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_safe_usingDict overrun specified output buffer size");
+        {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+            FUZ_CHECKTEST(crcCheck!=crcOrig, "LZ4_decompress_safe_usingDict corrupted decoded data");
+        }
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize-1] = 0;
+        ret = LZ4_decompress_fast_usingDict(compressedBuffer, decodedBuffer, blockSize-1, dict, dictSize);
+        FUZ_CHECKTEST(ret>=0, "LZ4_decompress_fast_usingDict should have failed : wrong original size (-1 byte)");
+        FUZ_CHECKTEST(decodedBuffer[blockSize-1], "LZ4_decompress_fast_usingDict overrun specified output buffer size");
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize-1] = 0;
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize-1, dict, dictSize);
+        FUZ_CHECKTEST(ret>=0, "LZ4_decompress_safe_usingDict should have failed : not enough output size (-1 byte)");
+        FUZ_CHECKTEST(decodedBuffer[blockSize-1], "LZ4_decompress_safe_usingDict overrun specified output buffer size");
+
+        FUZ_DISPLAYTEST("LZ4_decompress_safe_usingDict with a too small output buffer");
+        {   int const missingBytes = (FUZ_rand(&randState) & 0xF) + 2;
+            if (blockSize > missingBytes) {
+                decodedBuffer[blockSize-missingBytes] = 0;
+                ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize-missingBytes, dict, dictSize);
+                FUZ_CHECKTEST(ret>=0, "LZ4_decompress_safe_usingDict should have failed : output buffer too small (-%i byte)", missingBytes);
+                FUZ_CHECKTEST(decodedBuffer[blockSize-missingBytes], "LZ4_decompress_safe_usingDict overrun specified output buffer size (-%i byte) (blockSize=%i)", missingBytes, blockSize);
+        }   }
+
+        /* Compress HC using External dictionary */
+        FUZ_DISPLAYTEST("LZ4_compress_HC_continue with an external dictionary");
+        dict -= (FUZ_rand(&randState) & 7);    /* even bigger separation */
+        if (dict < (char*)CNBuffer) dict = (char*)CNBuffer;
+        LZ4_loadDictHC(LZ4dictHC, dict, dictSize);
+        LZ4_setCompressionLevel (LZ4dictHC, compressionLevel);
+        blockContinueCompressedSize = LZ4_compress_HC_continue(LZ4dictHC, block, compressedBuffer, blockSize, (int)compressedBufferSize);
+        FUZ_CHECKTEST(blockContinueCompressedSize==0, "LZ4_compress_HC_continue failed");
+        FUZ_CHECKTEST(LZ4dictHC->internal_donotuse.dirty, "Context should be clean");
+
+        FUZ_DISPLAYTEST("LZ4_compress_HC_continue with same external dictionary, but output buffer 1 byte too short");
+        LZ4_loadDictHC(LZ4dictHC, dict, dictSize);
+        ret = LZ4_compress_HC_continue(LZ4dictHC, block, compressedBuffer, blockSize, blockContinueCompressedSize-1);
+        FUZ_CHECKTEST(ret>0, "LZ4_compress_HC_continue using ExtDict should fail : one missing byte for output buffer (expected %i, but result=%i)", blockContinueCompressedSize, ret);
+        /* note : context is no longer dirty after a failed compressed block */
+
+        FUZ_DISPLAYTEST("LZ4_compress_HC_continue with same external dictionary, and output buffer exactly the right size");
+        LZ4_loadDictHC(LZ4dictHC, dict, dictSize);
+        ret = LZ4_compress_HC_continue(LZ4dictHC, block, compressedBuffer, blockSize, blockContinueCompressedSize);
+        FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_compress_HC_continue size is different : ret(%i) != expected(%i)", ret, blockContinueCompressedSize);
+        FUZ_CHECKTEST(ret<=0, "LZ4_compress_HC_continue should work : enough size available within output buffer");
+        FUZ_CHECKTEST(LZ4dictHC->internal_donotuse.dirty, "Context should be clean");
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize] = 0;
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize, dict, dictSize);
+        FUZ_CHECKTEST(ret!=blockSize, "LZ4_decompress_safe_usingDict did not regenerate original data");
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_safe_usingDict overrun specified output buffer size");
+        {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+            if (crcCheck!=crcOrig) {
+                FUZ_findDiff(block, decodedBuffer);
+                EXIT_MSG("LZ4_decompress_safe_usingDict corrupted decoded data");
+        }   }
+
+        /* Compress HC using external dictionary stream */
+        FUZ_DISPLAYTEST();
+        {   LZ4_streamHC_t* const LZ4_streamHC = LZ4_createStreamHC();
+
+            LZ4_loadDictHC(LZ4dictHC, dict, dictSize);
+            LZ4_attach_HC_dictionary(LZ4_streamHC, LZ4dictHC);
+            LZ4_setCompressionLevel (LZ4_streamHC, compressionLevel);
+            blockContinueCompressedSize = LZ4_compress_HC_continue(LZ4_streamHC, block, compressedBuffer, blockSize, (int)compressedBufferSize);
+            FUZ_CHECKTEST(blockContinueCompressedSize==0, "LZ4_compress_HC_continue with ExtDictCtx failed");
+            FUZ_CHECKTEST(LZ4_streamHC->internal_donotuse.dirty, "Context should be clean");
+
+            FUZ_DISPLAYTEST();
+            LZ4_resetStreamHC_fast (LZ4_streamHC, compressionLevel);
+            LZ4_attach_HC_dictionary(LZ4_streamHC, LZ4dictHC);
+            ret = LZ4_compress_HC_continue(LZ4_streamHC, block, compressedBuffer, blockSize, blockContinueCompressedSize-1);
+            FUZ_CHECKTEST(ret>0, "LZ4_compress_HC_continue using ExtDictCtx should fail : one missing byte for output buffer (%i != %i)", ret, blockContinueCompressedSize);
+            /* note : context is no longer dirty after a failed compressed block */
+
+            FUZ_DISPLAYTEST();
+            LZ4_resetStreamHC_fast (LZ4_streamHC, compressionLevel);
+            LZ4_attach_HC_dictionary(LZ4_streamHC, LZ4dictHC);
+            ret = LZ4_compress_HC_continue(LZ4_streamHC, block, compressedBuffer, blockSize, blockContinueCompressedSize);
+            FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_compress_HC_continue using ExtDictCtx size is different (%i != %i)", ret, blockContinueCompressedSize);
+            FUZ_CHECKTEST(ret<=0, "LZ4_compress_HC_continue using ExtDictCtx should work : enough size available within output buffer");
+            FUZ_CHECKTEST(LZ4_streamHC->internal_donotuse.dirty, "Context should be clean");
+
+            FUZ_DISPLAYTEST();
+            LZ4_resetStreamHC_fast (LZ4_streamHC, compressionLevel);
+            LZ4_attach_HC_dictionary(LZ4_streamHC, LZ4dictHC);
+            ret = LZ4_compress_HC_continue(LZ4_streamHC, block, compressedBuffer, blockSize, blockContinueCompressedSize);
+            FUZ_CHECKTEST(ret!=blockContinueCompressedSize, "LZ4_compress_HC_continue using ExtDictCtx and fast reset size is different (%i != %i)",
+                        ret, blockContinueCompressedSize);
+            FUZ_CHECKTEST(ret<=0, "LZ4_compress_HC_continue using ExtDictCtx and fast reset should work : enough size available within output buffer");
+            FUZ_CHECKTEST(LZ4_streamHC->internal_donotuse.dirty, "Context should be clean");
+
+            LZ4_freeStreamHC(LZ4_streamHC);
+        }
+
+        FUZ_DISPLAYTEST();
+        decodedBuffer[blockSize] = 0;
+        ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, blockSize, dict, dictSize);
+        FUZ_CHECKTEST(ret!=blockSize, "LZ4_decompress_safe_usingDict did not regenerate original data");
+        FUZ_CHECKTEST(decodedBuffer[blockSize], "LZ4_decompress_safe_usingDict overrun specified output buffer size");
+        {   U32 const crcCheck = XXH32(decodedBuffer, (size_t)blockSize, 0);
+            if (crcCheck!=crcOrig) {
+                FUZ_findDiff(block, decodedBuffer);
+                EXIT_MSG("LZ4_decompress_safe_usingDict corrupted decoded data");
+        }   }
+
+        /* Compress HC continue destSize */
+        FUZ_DISPLAYTEST();
+        {   int const availableSpace = (int)(FUZ_rand(&randState) % (U32)blockSize) + 5;
+            int consumedSize = blockSize;
+            FUZ_DISPLAYTEST();
+            LZ4_loadDictHC(LZ4dictHC, dict, dictSize);
+            LZ4_setCompressionLevel(LZ4dictHC, compressionLevel);
+            blockContinueCompressedSize = LZ4_compress_HC_continue_destSize(LZ4dictHC, block, compressedBuffer, &consumedSize, availableSpace);
+            DISPLAYLEVEL(5, " LZ4_compress_HC_continue_destSize : compressed %6i/%6i into %6i/%6i at cLevel=%i \n",
+                        consumedSize, blockSize, blockContinueCompressedSize, availableSpace, compressionLevel);
+            FUZ_CHECKTEST(blockContinueCompressedSize==0, "LZ4_compress_HC_continue_destSize failed");
+            FUZ_CHECKTEST(blockContinueCompressedSize > availableSpace, "LZ4_compress_HC_continue_destSize write overflow");
+            FUZ_CHECKTEST(consumedSize > blockSize, "LZ4_compress_HC_continue_destSize read overflow");
+
+            FUZ_DISPLAYTEST();
+            decodedBuffer[consumedSize] = 0;
+            ret = LZ4_decompress_safe_usingDict(compressedBuffer, decodedBuffer, blockContinueCompressedSize, consumedSize, dict, dictSize);
+            FUZ_CHECKTEST(ret != consumedSize, "LZ4_decompress_safe_usingDict regenerated %i bytes (%i expected)", ret, consumedSize);
+            FUZ_CHECKTEST(decodedBuffer[consumedSize], "LZ4_decompress_safe_usingDict overrun specified output buffer size")
+            {   U32 const crcSrc = XXH32(block, (size_t)consumedSize, 0);
+                U32 const crcDst = XXH32(decodedBuffer, (size_t)consumedSize, 0);
+                if (crcSrc!=crcDst) {
+                    FUZ_findDiff(block, decodedBuffer);
+                    EXIT_MSG("LZ4_decompress_safe_usingDict corrupted decoded data");
+            }   }
+        }
+
+        /* ***** End of tests *** */
+        /* Fill stats */
+        assert(blockSize >= 0);
+        bytes += (unsigned)blockSize;
+        assert(compressedSize >= 0);
+        cbytes += (unsigned)compressedSize;
+        assert(HCcompressedSize >= 0);
+        hcbytes += (unsigned)HCcompressedSize;
+        assert(blockContinueCompressedSize >= 0);
+        ccbytes += (unsigned)blockContinueCompressedSize;
+    }
+
+    if (nbCycles<=1) nbCycles = cycleNb;   /* end by time */
+    bytes += !bytes;   /* avoid division by 0 */
+    printf("\r%7u /%7u   - ", cycleNb, nbCycles);
+    printf("all tests completed successfully \n");
+    printf("compression ratio: %0.3f%%\n", (double)cbytes/bytes*100);
+    printf("HC compression ratio: %0.3f%%\n", (double)hcbytes/bytes*100);
+    printf("ratio with dict: %0.3f%%\n", (double)ccbytes/bytes*100);
+
+    /* release memory */
+    free(CNBuffer);
+    free(compressedBuffer);
+    free(decodedBuffer);
+    FUZ_freeLowAddr(lowAddrBuffer, labSize);
+    LZ4_freeStreamHC(LZ4dictHC);
+    free(stateLZ4);
+    free(stateLZ4HC);
+    return result;
+}
+
+
+#define testInputSize (196 KB)
+#define testCompressedSize (130 KB)
+#define ringBufferSize (8 KB)
+
+static void FUZ_unitTests(int compressionLevel)
+{
+    const unsigned testNb = 0;
+    const unsigned seed   = 0;
+    const unsigned cycleNb= 0;
+    char* testInput = (char*)malloc(testInputSize);
+    char* testCompressed = (char*)malloc(testCompressedSize);
+    char* testVerify = (char*)malloc(testInputSize);
+    char ringBuffer[ringBufferSize] = {0};
+    U32 randState = 1;
+
+    /* Init */
+    if (!testInput || !testCompressed || !testVerify) {
+        EXIT_MSG("not enough memory for FUZ_unitTests");
+    }
+    FUZ_fillCompressibleNoiseBuffer(testInput, testInputSize, 0.50, &randState);
+
+    /* 32-bits address space overflow test */
+    FUZ_AddressOverflow();
+
+    /* Test decoding with empty input */
+    DISPLAYLEVEL(3, "LZ4_decompress_safe() with empty input \n");
+    LZ4_decompress_safe(testCompressed, testVerify, 0, testInputSize);
+
+    /* Test decoding with a one byte input */
+    DISPLAYLEVEL(3, "LZ4_decompress_safe() with one byte input \n");
+    {   char const tmp = (char)0xFF;
+        LZ4_decompress_safe(&tmp, testVerify, 1, testInputSize);
+    }
+
+    /* Test decoding shortcut edge case */
+    DISPLAYLEVEL(3, "LZ4_decompress_safe() with shortcut edge case \n");
+    {   char tmp[17];
+        /* 14 bytes of literals, followed by a 14 byte match.
+         * Should not read beyond the end of the buffer.
+         * See https://github.com/lz4/lz4/issues/508. */
+        *tmp = (char)0xEE;
+        memset(tmp + 1, 0, 14);
+        tmp[15] = 14;
+        tmp[16] = 0;
+        {   int const r = LZ4_decompress_safe(tmp, testVerify, sizeof(tmp), testInputSize);
+            FUZ_CHECKTEST(r >= 0, "LZ4_decompress_safe() should fail");
+    }   }
+
+
+    /* to be tested with undefined sanitizer */
+    DISPLAYLEVEL(3, "LZ4_compress_default() with NULL input:");
+    {	int const maxCSize = LZ4_compressBound(0);
+        int const cSize = LZ4_compress_default(NULL, testCompressed, 0, maxCSize);
+        FUZ_CHECKTEST(!(cSize==1 && testCompressed[0]==0),
+                    "compressing empty should give byte 0"
+                    " (maxCSize == %i) (cSize == %i) (byte == 0x%02X)",
+                    maxCSize, cSize, testCompressed[0]);
+    }
+    DISPLAYLEVEL(3, " OK \n");
+
+    DISPLAYLEVEL(3, "LZ4_compress_default() with both NULL input and output:");
+    {	int const cSize = LZ4_compress_default(NULL, NULL, 0, 0);
+        FUZ_CHECKTEST(cSize != 0,
+                    "compressing into NULL must fail"
+                    " (cSize == %i !=  0)", cSize);
+    }
+    DISPLAYLEVEL(3, " OK \n");
+
+    /* in-place compression test */
+    DISPLAYLEVEL(3, "in-place compression using LZ4_compress_default() :");
+    {   int const sampleSize = 65 KB;
+        int const maxCSize = LZ4_COMPRESSBOUND(sampleSize);
+        int const outSize = LZ4_COMPRESS_INPLACE_BUFFER_SIZE(maxCSize);
+        int const startInputIndex = outSize - sampleSize;
+        char* const startInput = testCompressed + startInputIndex;
+        XXH32_hash_t const crcOrig = XXH32(testInput, sampleSize, 0);
+        int cSize;
+        assert(outSize < (int)testCompressedSize);
+        memcpy(startInput, testInput, sampleSize);  /* copy at end of buffer */
+        /* compress in-place */
+        cSize = LZ4_compress_default(startInput, testCompressed, sampleSize, maxCSize);
+        assert(cSize != 0);  /* ensure compression is successful */
+        assert(maxCSize < INT_MAX);
+        assert(cSize <= maxCSize);
+        /* decompress and verify */
+        {   int const dSize = LZ4_decompress_safe(testCompressed, testVerify, cSize, testInputSize);
+            assert(dSize == sampleSize);   /* correct size */
+            {   XXH32_hash_t const crcCheck = XXH32(testVerify, (size_t)dSize, 0);
+                FUZ_CHECKTEST(crcCheck != crcOrig, "LZ4_decompress_safe decompression corruption");
+    }   }   }
+    DISPLAYLEVEL(3, " OK \n");
+
+    /* in-place decompression test */
+    DISPLAYLEVEL(3, "in-place decompression, limit case:");
+    {   int const sampleSize = 65 KB;
+
+        FUZ_fillCompressibleNoiseBuffer(testInput, sampleSize, 0.0, &randState);
+        memset(testInput, 0, 267);   /* calculated exactly so that compressedSize == originalSize-1 */
+
+        {   XXH64_hash_t const crcOrig = XXH64(testInput, sampleSize, 0);
+            int const cSize = LZ4_compress_default(testInput, testCompressed, sampleSize, testCompressedSize);
+            assert(cSize == sampleSize - 1);  /* worst case for in-place decompression */
+
+            {   int const bufferSize = LZ4_DECOMPRESS_INPLACE_BUFFER_SIZE(sampleSize);
+                int const startInputIndex = bufferSize - cSize;
+                char* const startInput = testVerify + startInputIndex;
+                memcpy(startInput, testCompressed, cSize);
+
+                /* decompress and verify */
+                {   int const dSize = LZ4_decompress_safe(startInput, testVerify, cSize, sampleSize);
+                    assert(dSize == sampleSize);   /* correct size */
+                    {   XXH64_hash_t const crcCheck = XXH64(testVerify, (size_t)dSize, 0);
+                        FUZ_CHECKTEST(crcCheck != crcOrig, "LZ4_decompress_safe decompression corruption");
+    }   }   }   }   }
+    DISPLAYLEVEL(3, " OK \n");
+
+    DISPLAYLEVEL(3, "LZ4_initStream with multiple valid alignments : ");
+    {   typedef struct {
+            LZ4_stream_t state1;
+            LZ4_stream_t state2;
+            char              c;
+            LZ4_stream_t state3;
+        } shct;
+        shct* const shc = (shct*)malloc(sizeof(*shc));
+        assert(shc != NULL);
+        memset(shc, 0, sizeof(*shc));
+        DISPLAYLEVEL(4, "state1(%p) state2(%p) state3(%p) LZ4_stream_t size(0x%x): ",
+                    &(shc->state1), &(shc->state2), &(shc->state3), (unsigned)sizeof(LZ4_stream_t));
+        FUZ_CHECKTEST( LZ4_initStream(&(shc->state1), sizeof(shc->state1)) == NULL, "state1 (%p) failed init", &(shc->state1) );
+        FUZ_CHECKTEST( LZ4_initStream(&(shc->state2), sizeof(shc->state2)) == NULL, "state2 (%p) failed init", &(shc->state2)  );
+        FUZ_CHECKTEST( LZ4_initStream(&(shc->state3), sizeof(shc->state3)) == NULL, "state3 (%p) failed init", &(shc->state3)  );
+        FUZ_CHECKTEST( LZ4_initStream((char*)&(shc->state1) + 1, sizeof(shc->state1)) != NULL,
+                       "hc1+1 (%p) init must fail, due to bad alignment", (char*)&(shc->state1) + 1 );
+        free(shc);
+    }
+    DISPLAYLEVEL(3, "all inits OK \n");
+
+    /* Allocation test */
+    {   LZ4_stream_t* const statePtr = LZ4_createStream();
+        FUZ_CHECKTEST(statePtr==NULL, "LZ4_createStream() allocation failed");
+        LZ4_freeStream(statePtr);
+    }
+
+    /* LZ4 streaming tests */
+    {   LZ4_stream_t streamingState;
+
+        /* simple compression test */
+        LZ4_initStream(&streamingState, sizeof(streamingState));
+        {   int const cs = LZ4_compress_fast_continue(&streamingState, testInput, testCompressed, testCompressedSize, testCompressedSize-1, 1);
+            FUZ_CHECKTEST(cs==0, "LZ4_compress_fast_continue() compression failed!");
+            {   int const r = LZ4_decompress_safe(testCompressed, testVerify, cs, testCompressedSize);
+                FUZ_CHECKTEST(r!=(int)testCompressedSize, "LZ4_decompress_safe() decompression failed");
+        }   }
+        {   U64 const crcOrig = XXH64(testInput, testCompressedSize, 0);
+            U64 const crcNew = XXH64(testVerify, testCompressedSize, 0);
+            FUZ_CHECKTEST(crcOrig!=crcNew, "LZ4_decompress_safe() decompression corruption");
+        }
+
+        /* early saveDict */
+        DISPLAYLEVEL(3, "saveDict (right after init) : ");
+        {   LZ4_stream_t* const ctx = LZ4_initStream(&streamingState, sizeof(streamingState));
+            assert(ctx != NULL);  /* ensure init is successful */
+
+            /* Check access violation with asan */
+            FUZ_CHECKTEST( LZ4_saveDict(ctx, NULL, 0) != 0,
+            "LZ4_saveDict() can't save anything into (NULL,0)");
+
+            /* Check access violation with asan */
+            {   char tmp_buffer[240] = { 0 };
+                FUZ_CHECKTEST( LZ4_saveDict(ctx, tmp_buffer, sizeof(tmp_buffer)) != 0,
+                "LZ4_saveDict() can't save anything since compression hasn't started");
+        }   }
+        DISPLAYLEVEL(3, "OK \n");
+
+        /* ring buffer test */
+        {   XXH64_state_t xxhOrig;
+            XXH64_state_t xxhNewSafe, xxhNewFast;
+            LZ4_streamDecode_t decodeStateSafe, decodeStateFast;
+            const U32 maxMessageSizeLog = 10;
+            const U32 maxMessageSizeMask = (1< ringBufferSize) rNext = 0;
+                if (dNext + messageSize > dBufferSize) dNext = 0;
+        }   }
+    }
+
+    DISPLAYLEVEL(3, "LZ4_initStreamHC with multiple valid alignments : ");
+    {   typedef struct {
+            LZ4_streamHC_t hc1;
+            LZ4_streamHC_t hc2;
+            char             c;
+            LZ4_streamHC_t hc3;
+        } shct;
+        shct* const shc = (shct*)malloc(sizeof(*shc));
+        assert(shc != NULL);
+        memset(shc, 0, sizeof(*shc));
+        DISPLAYLEVEL(4, "hc1(%p) hc2(%p) hc3(%p) size(0x%x): ",
+                    &(shc->hc1), &(shc->hc2), &(shc->hc3), (unsigned)sizeof(LZ4_streamHC_t));
+        FUZ_CHECKTEST( LZ4_initStreamHC(&(shc->hc1), sizeof(shc->hc1)) == NULL, "hc1 (%p) failed init", &(shc->hc1) );
+        FUZ_CHECKTEST( LZ4_initStreamHC(&(shc->hc2), sizeof(shc->hc2)) == NULL, "hc2 (%p) failed init", &(shc->hc2)  );
+        FUZ_CHECKTEST( LZ4_initStreamHC(&(shc->hc3), sizeof(shc->hc3)) == NULL, "hc3 (%p) failed init", &(shc->hc3)  );
+        FUZ_CHECKTEST( LZ4_initStreamHC((char*)&(shc->hc1) + 1, sizeof(shc->hc1)) != NULL,
+                        "hc1+1 (%p) init must fail, due to bad alignment", (char*)&(shc->hc1) + 1 );
+        free(shc);
+    }
+    DISPLAYLEVEL(3, "all inits OK \n");
+
+    /* LZ4 HC streaming tests */
+    {   LZ4_streamHC_t sHC;   /* statically allocated */
+        int result;
+        LZ4_initStreamHC(&sHC, sizeof(sHC));
+
+        /* Allocation test */
+        DISPLAYLEVEL(3, "Basic HC allocation : ");
+        {   LZ4_streamHC_t* const sp = LZ4_createStreamHC();
+            FUZ_CHECKTEST(sp==NULL, "LZ4_createStreamHC() allocation failed");
+            LZ4_freeStreamHC(sp);
+        }
+        DISPLAYLEVEL(3, "OK \n");
+
+        /* simple HC compression test */
+        DISPLAYLEVEL(3, "Simple HC round-trip : ");
+        {   U64 const crc64 = XXH64(testInput, testCompressedSize, 0);
+            LZ4_setCompressionLevel(&sHC, compressionLevel);
+            result = LZ4_compress_HC_continue(&sHC, testInput, testCompressed, testCompressedSize, testCompressedSize-1);
+            FUZ_CHECKTEST(result==0, "LZ4_compressHC_limitedOutput_continue() compression failed");
+            FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+
+            result = LZ4_decompress_safe(testCompressed, testVerify, result, testCompressedSize);
+            FUZ_CHECKTEST(result!=(int)testCompressedSize, "LZ4_decompress_safe() decompression failed");
+            {   U64 const crcNew = XXH64(testVerify, testCompressedSize, 0);
+                FUZ_CHECKTEST(crc64!=crcNew, "LZ4_decompress_safe() decompression corruption");
+        }   }
+        DISPLAYLEVEL(3, "OK \n");
+
+        /* saveDictHC test #926 */
+        DISPLAYLEVEL(3, "saveDictHC test #926 : ");
+        {   LZ4_streamHC_t* const ctx = LZ4_initStreamHC(&sHC, sizeof(sHC));
+            assert(ctx != NULL);  /* ensure init is successful */
+
+            /* Check access violation with asan */
+            FUZ_CHECKTEST( LZ4_saveDictHC(ctx, NULL, 0) != 0,
+            "LZ4_saveDictHC() can't save anything into (NULL,0)");
+
+            /* Check access violation with asan */
+            {   char tmp_buffer[240] = { 0 };
+                FUZ_CHECKTEST( LZ4_saveDictHC(ctx, tmp_buffer, sizeof(tmp_buffer)) != 0,
+                "LZ4_saveDictHC() can't save anything since compression hasn't started");
+        }   }
+        DISPLAYLEVEL(3, "OK \n");
+
+        /* long sequence test */
+        DISPLAYLEVEL(3, "Long sequence HC_destSize test : ");
+        {   size_t const blockSize = 1 MB;
+            size_t const targetSize = 4116;  /* size carefully selected to trigger an overflow */
+            void*  const block = malloc(blockSize);
+            void*  const dstBlock = malloc(targetSize+1);
+            BYTE   const sentinel = 101;
+            int srcSize;
+
+            assert(block != NULL); assert(dstBlock != NULL);
+            memset(block, 0, blockSize);
+            ((char*)dstBlock)[targetSize] = sentinel;
+
+            LZ4_resetStreamHC_fast(&sHC, 3);
+            assert(blockSize < INT_MAX);
+            srcSize = (int)blockSize;
+            assert(targetSize < INT_MAX);
+            result = LZ4_compress_HC_destSize(&sHC, (const char*)block, (char*)dstBlock, &srcSize, (int)targetSize, 3);
+            DISPLAYLEVEL(4, "cSize=%i; readSize=%i; ", result, srcSize);
+            FUZ_CHECKTEST(result != 4116, "LZ4_compress_HC_destSize() : "
+                "compression (%i->%i) must fill dstBuffer (%i) exactly",
+                srcSize, result, (int)targetSize);
+            FUZ_CHECKTEST(((char*)dstBlock)[targetSize] != sentinel,
+                "LZ4_compress_HC_destSize() overwrites dst buffer");
+            FUZ_CHECKTEST(srcSize < 1045000, "LZ4_compress_HC_destSize() doesn't compress enough"
+                " (%i -> %i , expected > %i)", srcSize, result, 1045000);
+
+            LZ4_resetStreamHC_fast(&sHC, 3);   /* make sure the context is clean after the test */
+            free(block);
+            free(dstBlock);
+        }
+        DISPLAYLEVEL(3, " OK \n");
+
+        /* simple dictionary HC compression test */
+        DISPLAYLEVEL(3, "HC dictionary compression test : ");
+        {   U64 const crc64 = XXH64(testInput + 64 KB, testCompressedSize, 0);
+            LZ4_resetStreamHC_fast(&sHC, compressionLevel);
+            LZ4_loadDictHC(&sHC, testInput, 64 KB);
+            {   int const cSize = LZ4_compress_HC_continue(&sHC, testInput + 64 KB, testCompressed, testCompressedSize, testCompressedSize-1);
+                FUZ_CHECKTEST(cSize==0, "LZ4_compressHC_limitedOutput_continue() dictionary compression failed : @return = %i", cSize);
+                FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+                {   int const dSize = LZ4_decompress_safe_usingDict(testCompressed, testVerify, cSize, testCompressedSize, testInput, 64 KB);
+                    FUZ_CHECKTEST(dSize!=(int)testCompressedSize, "LZ4_decompress_safe() simple dictionary decompression test failed");
+            }   }
+            {   U64 const crcNew = XXH64(testVerify, testCompressedSize, 0);
+                FUZ_CHECKTEST(crc64!=crcNew, "LZ4_decompress_safe() simple dictionary decompression test : corruption");
+        }   }
+        DISPLAYLEVEL(3, " OK \n");
+
+        /* multiple HC compression test with dictionary */
+        {   int result1, result2;
+            int segSize = testCompressedSize / 2;
+            XXH64_hash_t const crc64 = ( (void)assert((unsigned)segSize + testCompressedSize < testInputSize) ,
+                                        XXH64(testInput + segSize, testCompressedSize, 0) );
+            LZ4_resetStreamHC_fast(&sHC, compressionLevel);
+            LZ4_loadDictHC(&sHC, testInput, segSize);
+            result1 = LZ4_compress_HC_continue(&sHC, testInput + segSize, testCompressed, segSize, segSize -1);
+            FUZ_CHECKTEST(result1==0, "LZ4_compressHC_limitedOutput_continue() dictionary compression failed : result = %i", result1);
+            FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+            result2 = LZ4_compress_HC_continue(&sHC, testInput + 2*(size_t)segSize, testCompressed+result1, segSize, segSize-1);
+            FUZ_CHECKTEST(result2==0, "LZ4_compressHC_limitedOutput_continue() dictionary compression failed : result = %i", result2);
+            FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+
+            result = LZ4_decompress_safe_usingDict(testCompressed, testVerify, result1, segSize, testInput, segSize);
+            FUZ_CHECKTEST(result!=segSize, "LZ4_decompress_safe() dictionary decompression part 1 failed");
+            result = LZ4_decompress_safe_usingDict(testCompressed+result1, testVerify+segSize, result2, segSize, testInput, 2*segSize);
+            FUZ_CHECKTEST(result!=segSize, "LZ4_decompress_safe() dictionary decompression part 2 failed");
+            {   XXH64_hash_t const crcNew = XXH64(testVerify, testCompressedSize, 0);
+                FUZ_CHECKTEST(crc64!=crcNew, "LZ4_decompress_safe() dictionary decompression corruption");
+        }   }
+
+        /* remote dictionary HC compression test */
+        {   U64 const crc64 = XXH64(testInput + 64 KB, testCompressedSize, 0);
+            LZ4_resetStreamHC_fast(&sHC, compressionLevel);
+            LZ4_loadDictHC(&sHC, testInput, 32 KB);
+            result = LZ4_compress_HC_continue(&sHC, testInput + 64 KB, testCompressed, testCompressedSize, testCompressedSize-1);
+            FUZ_CHECKTEST(result==0, "LZ4_compressHC_limitedOutput_continue() remote dictionary failed : result = %i", result);
+            FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+
+            result = LZ4_decompress_safe_usingDict(testCompressed, testVerify, result, testCompressedSize, testInput, 32 KB);
+            FUZ_CHECKTEST(result!=(int)testCompressedSize, "LZ4_decompress_safe_usingDict() decompression failed following remote dictionary HC compression test");
+            {   U64 const crcNew = XXH64(testVerify, testCompressedSize, 0);
+                FUZ_CHECKTEST(crc64!=crcNew, "LZ4_decompress_safe_usingDict() decompression corruption");
+        }   }
+
+        /* multiple HC compression with ext. dictionary */
+        {   XXH64_state_t crcOrigState;
+            XXH64_state_t crcNewState;
+            const char* dict = testInput + 3;
+            size_t dictSize = (FUZ_rand(&randState) & 8191);
+            char* dst = testVerify;
+
+            size_t segStart = dictSize + 7;
+            size_t segSize = (FUZ_rand(&randState) & 8191);
+            int segNb = 1;
+
+            LZ4_resetStreamHC_fast(&sHC, compressionLevel);
+            LZ4_loadDictHC(&sHC, dict, (int)dictSize);
+
+            XXH64_reset(&crcOrigState, 0);
+            XXH64_reset(&crcNewState, 0);
+
+            while (segStart + segSize < testInputSize) {
+                XXH64_hash_t crcOrig;
+                XXH64_update(&crcOrigState, testInput + segStart, segSize);
+                crcOrig = XXH64_digest(&crcOrigState);
+                assert(segSize <= INT_MAX);
+                result = LZ4_compress_HC_continue(&sHC, testInput + segStart, testCompressed, (int)segSize, LZ4_compressBound((int)segSize));
+                FUZ_CHECKTEST(result==0, "LZ4_compressHC_limitedOutput_continue() dictionary compression failed : result = %i", result);
+                FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+
+                result = LZ4_decompress_safe_usingDict(testCompressed, dst, result, (int)segSize, dict, (int)dictSize);
+                FUZ_CHECKTEST(result!=(int)segSize, "LZ4_decompress_safe_usingDict() dictionary decompression part %i failed", (int)segNb);
+                XXH64_update(&crcNewState, dst, segSize);
+                {   U64 const crcNew = XXH64_digest(&crcNewState);
+                    if (crcOrig != crcNew) FUZ_findDiff(dst, testInput+segStart);
+                    FUZ_CHECKTEST(crcOrig!=crcNew, "LZ4_decompress_safe_usingDict() part %i corruption", segNb);
+                }
+
+                dict = dst;
+                dictSize = segSize;
+
+                dst += segSize + 1;
+                segNb ++;
+
+                segStart += segSize + (FUZ_rand(&randState) & 0xF) + 1;
+                segSize = (FUZ_rand(&randState) & 8191);
+        }   }
+
+        /* ring buffer test */
+        {   XXH64_state_t xxhOrig;
+            XXH64_state_t xxhNewSafe, xxhNewFast;
+            LZ4_streamDecode_t decodeStateSafe, decodeStateFast;
+            const U32 maxMessageSizeLog = 10;
+            const U32 maxMessageSizeMask = (1< ringBufferSize) rNext = 0;
+                if (dNext + messageSize > dBufferSize) dNext = 0;
+            }
+        }
+
+        /* Ring buffer test : Non synchronized decoder */
+        /* This test uses minimum amount of memory required to setup a decoding ring buffer
+         * while being unsynchronized with encoder
+         * (no assumption done on how the data is encoded, it just follows LZ4 format specification).
+         * This size is documented in lz4.h, and is LZ4_decoderRingBufferSize(maxBlockSize).
+         */
+        {   XXH64_state_t xxhOrig;
+            XXH64_state_t xxhNewSafe, xxhNewFast;
+            XXH64_hash_t crcOrig;
+            LZ4_streamDecode_t decodeStateSafe, decodeStateFast;
+            const int maxMessageSizeLog = 12;
+            const int maxMessageSize = 1 << maxMessageSizeLog;
+            const int maxMessageSizeMask = maxMessageSize - 1;
+            int messageSize;
+            U32 totalMessageSize = 0;
+            const int dBufferSize = LZ4_decoderRingBufferSize(maxMessageSize);
+            char* const ringBufferSafe = testVerify;
+            char* const ringBufferFast = testVerify + dBufferSize + 1;   /* used by LZ4_decompress_fast_continue */
+            int iNext = 0;
+            int dNext = 0;
+            int compressedSize;
+
+            assert((size_t)dBufferSize * 2 + 1 < testInputSize);   /* space used by ringBufferSafe and ringBufferFast */
+            XXH64_reset(&xxhOrig, 0);
+            XXH64_reset(&xxhNewSafe, 0);
+            XXH64_reset(&xxhNewFast, 0);
+            LZ4_resetStreamHC_fast(&sHC, compressionLevel);
+            LZ4_setStreamDecode(&decodeStateSafe, NULL, 0);
+            LZ4_setStreamDecode(&decodeStateFast, NULL, 0);
+
+#define BSIZE1 (dBufferSize - (maxMessageSize-1))
+
+            /* first block */
+            messageSize = BSIZE1;   /* note : we cheat a bit here, in theory no message should be > maxMessageSize. We just want to fill the decoding ring buffer once. */
+            XXH64_update(&xxhOrig, testInput + iNext, (size_t)messageSize);
+            crcOrig = XXH64_digest(&xxhOrig);
+
+            compressedSize = LZ4_compress_HC_continue(&sHC, testInput + iNext, testCompressed, messageSize, testCompressedSize-ringBufferSize);
+            FUZ_CHECKTEST(compressedSize==0, "LZ4_compress_HC_continue() compression failed");
+            FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+
+            result = LZ4_decompress_safe_continue(&decodeStateSafe, testCompressed, ringBufferSafe + dNext, compressedSize, messageSize);
+            FUZ_CHECKTEST(result!=messageSize, "64K D.ringBuffer : LZ4_decompress_safe_continue() test failed");
+
+            XXH64_update(&xxhNewSafe, ringBufferSafe + dNext, (size_t)messageSize);
+            { U64 const crcNew = XXH64_digest(&xxhNewSafe);
+              FUZ_CHECKTEST(crcOrig!=crcNew, "LZ4_decompress_safe_continue() decompression corruption"); }
+
+            result = LZ4_decompress_fast_continue(&decodeStateFast, testCompressed, ringBufferFast + dNext, messageSize);
+            FUZ_CHECKTEST(result!=compressedSize, "64K D.ringBuffer : LZ4_decompress_fast_continue() test failed");
+
+            XXH64_update(&xxhNewFast, ringBufferFast + dNext, (size_t)messageSize);
+            { U64 const crcNew = XXH64_digest(&xxhNewFast);
+              FUZ_CHECKTEST(crcOrig!=crcNew, "LZ4_decompress_fast_continue() decompression corruption"); }
+
+            /* prepare second message */
+            dNext += messageSize;
+            assert(messageSize >= 0);
+            totalMessageSize += (unsigned)messageSize;
+            messageSize = maxMessageSize;
+            iNext = BSIZE1+1;
+            assert(BSIZE1 >= 65535);
+            memcpy(testInput + iNext, testInput + (BSIZE1-65535), messageSize);  /* will generate a match at max distance == 65535 */
+            FUZ_CHECKTEST(dNext+messageSize <= dBufferSize, "Ring buffer test : second message should require restarting from beginning");
+            dNext = 0;
+
+            while (totalMessageSize < 9 MB) {
+                XXH64_update(&xxhOrig, testInput + iNext, (size_t)messageSize);
+                crcOrig = XXH64_digest(&xxhOrig);
+
+                compressedSize = LZ4_compress_HC_continue(&sHC, testInput + iNext, testCompressed, messageSize, testCompressedSize-ringBufferSize);
+                FUZ_CHECKTEST(compressedSize==0, "LZ4_compress_HC_continue() compression failed");
+                FUZ_CHECKTEST(sHC.internal_donotuse.dirty, "Context should be clean");
+                DISPLAYLEVEL(5, "compressed %i bytes to %i bytes \n", messageSize, compressedSize);
+
+                /* test LZ4_decompress_safe_continue */
+                assert(dNext < dBufferSize);
+                assert(dBufferSize - dNext >= maxMessageSize);
+                result = LZ4_decompress_safe_continue(&decodeStateSafe,
+                                                      testCompressed, ringBufferSafe + dNext,
+                                                      compressedSize, dBufferSize - dNext);   /* works without knowing messageSize, under assumption that messageSize <= maxMessageSize */
+                FUZ_CHECKTEST(result!=messageSize, "D.ringBuffer : LZ4_decompress_safe_continue() test failed");
+                XXH64_update(&xxhNewSafe, ringBufferSafe + dNext, (size_t)messageSize);
+                {   U64 const crcNew = XXH64_digest(&xxhNewSafe);
+                    if (crcOrig != crcNew) FUZ_findDiff(testInput + iNext, ringBufferSafe + dNext);
+                    FUZ_CHECKTEST(crcOrig!=crcNew, "LZ4_decompress_safe_continue() decompression corruption during D.ringBuffer test");
+                }
+
+                /* test LZ4_decompress_fast_continue in its own buffer ringBufferFast */
+                result = LZ4_decompress_fast_continue(&decodeStateFast, testCompressed, ringBufferFast + dNext, messageSize);
+                FUZ_CHECKTEST(result!=compressedSize, "D.ringBuffer : LZ4_decompress_fast_continue() test failed");
+                XXH64_update(&xxhNewFast, ringBufferFast + dNext, (size_t)messageSize);
+                {   U64 const crcNew = XXH64_digest(&xxhNewFast);
+                    if (crcOrig != crcNew) FUZ_findDiff(testInput + iNext, ringBufferFast + dNext);
+                    FUZ_CHECKTEST(crcOrig!=crcNew, "LZ4_decompress_fast_continue() decompression corruption during D.ringBuffer test");
+                }
+
+                /* prepare next message */
+                dNext += messageSize;
+                assert(messageSize >= 0);
+                totalMessageSize += (unsigned)messageSize;
+                messageSize = (FUZ_rand(&randState) & maxMessageSizeMask) + 1;
+                iNext = (FUZ_rand(&randState) & 65535);
+                if (dNext + maxMessageSize > dBufferSize) dNext = 0;
+            }
+        }  /* Ring buffer test : Non synchronized decoder */
+    }
+
+    DISPLAYLEVEL(3, "LZ4_compress_HC_destSize : ");
+    /* encode congenerical sequence test for HC compressors */
+    {   LZ4_streamHC_t* const sHC = LZ4_createStreamHC();
+        int const src_buf_size = 3 MB;
+        int const dst_buf_size = 6 KB;
+        int const payload = 0;
+        int const dst_step = 43;
+        int const dst_min_len = 33 + (FUZ_rand(&randState) % dst_step);
+        int const dst_max_len = 5000;
+        int slen, dlen;
+        char* sbuf1 = (char*)malloc(src_buf_size + 1);
+        char* sbuf2 = (char*)malloc(src_buf_size + 1);
+        char* dbuf1 = (char*)malloc(dst_buf_size + 1);
+        char* dbuf2 = (char*)malloc(dst_buf_size + 1);
+
+        assert(sHC != NULL);
+        assert(dst_buf_size > dst_max_len);
+        if (!sbuf1 || !sbuf2 || !dbuf1 || !dbuf2) {
+            EXIT_MSG("not enough memory for FUZ_unitTests (destSize)");
+        }
+        for (dlen = dst_min_len; dlen <= dst_max_len; dlen += dst_step) {
+            int src_len = (dlen - 10)*255 + 24;
+            if (src_len + 10 >= src_buf_size) break;   /* END of check */
+            for (slen = src_len - 3; slen <= src_len + 3; slen++) {
+                int srcsz1, srcsz2;
+                int dsz1, dsz2;
+                int res1, res2;
+                char const endchk = (char)0x88;
+                DISPLAYLEVEL(5, "slen = %i, ", slen);
+
+                srcsz1 = slen;
+                memset(sbuf1, payload, slen);
+                memset(dbuf1, 0, dlen);
+                dbuf1[dlen] = endchk;
+                dsz1 = LZ4_compress_destSize(sbuf1, dbuf1, &srcsz1, dlen);
+                DISPLAYLEVEL(5, "LZ4_compress_destSize: %i bytes compressed into %i bytes, ", srcsz1, dsz1);
+                DISPLAYLEVEL(5, "last token : 0x%0X, ", dbuf1[dsz1 - 6]);
+                DISPLAYLEVEL(5, "last ML extra lenbyte : 0x%0X, \n", dbuf1[dsz1 - 7]);
+                FUZ_CHECKTEST(dbuf1[dlen] != endchk, "LZ4_compress_destSize() overwrite dst buffer !");
+                FUZ_CHECKTEST(dsz1 <= 0,             "LZ4_compress_destSize() compression failed");
+                FUZ_CHECKTEST(dsz1 > dlen,           "LZ4_compress_destSize() result larger than dst buffer !");
+                FUZ_CHECKTEST(srcsz1 > slen,         "LZ4_compress_destSize() read more than src buffer !");
+
+                res1 = LZ4_decompress_safe(dbuf1, sbuf1, dsz1, src_buf_size);
+                FUZ_CHECKTEST(res1 != srcsz1,        "LZ4_compress_destSize() decompression failed!");
+
+                srcsz2 = slen;
+                memset(sbuf2, payload, slen);
+                memset(dbuf2, 0, dlen);
+                dbuf2[dlen] = endchk;
+                LZ4_resetStreamHC(sHC, compressionLevel);
+                dsz2 = LZ4_compress_HC_destSize(sHC, sbuf2, dbuf2, &srcsz2, dlen, compressionLevel);
+                DISPLAYLEVEL(5, "LZ4_compress_HC_destSize: %i bytes compressed into %i bytes, ", srcsz2, dsz2);
+                DISPLAYLEVEL(5, "last token : 0x%0X, ", dbuf2[dsz2 - 6]);
+                DISPLAYLEVEL(5, "last ML extra lenbyte : 0x%0X, \n", dbuf2[dsz2 - 7]);
+                FUZ_CHECKTEST(dbuf2[dlen] != endchk,      "LZ4_compress_HC_destSize() overwrite dst buffer !");
+                FUZ_CHECKTEST(dsz2 <= 0,                  "LZ4_compress_HC_destSize() compression failed");
+                FUZ_CHECKTEST(dsz2 > dlen,                "LZ4_compress_HC_destSize() result larger than dst buffer !");
+                FUZ_CHECKTEST(srcsz2 > slen,              "LZ4_compress_HC_destSize() read more than src buffer !");
+                FUZ_CHECKTEST(dsz2 != dsz1,               "LZ4_compress_HC_destSize() return incorrect result !");
+                FUZ_CHECKTEST(srcsz2 != srcsz1,           "LZ4_compress_HC_destSize() return incorrect src buffer size "
+                                                          ": srcsz2(%i) != srcsz1(%i)", srcsz2, srcsz1);
+                FUZ_CHECKTEST(memcmp(dbuf2, dbuf1, (size_t)dsz2), "LZ4_compress_HC_destSize() return incorrect data into dst buffer !");
+
+                res2 = LZ4_decompress_safe(dbuf2, sbuf1, dsz2, src_buf_size);
+                FUZ_CHECKTEST(res2 != srcsz1,             "LZ4_compress_HC_destSize() decompression failed!");
+
+                FUZ_CHECKTEST(memcmp(sbuf1, sbuf2, (size_t)res2), "LZ4_compress_HC_destSize() decompression corruption!");
+            }
+        }
+        LZ4_freeStreamHC(sHC);
+        free(sbuf1);
+        free(sbuf2);
+        free(dbuf1);
+        free(dbuf2);
+    }
+    DISPLAYLEVEL(3, " OK \n");
+
+
+    /* clean up */
+    free(testInput);
+    free(testCompressed);
+    free(testVerify);
+
+    printf("All unit tests completed successfully compressionLevel=%d \n", compressionLevel);
+    return;
+}
+
+
+
+/* =======================================
+ * CLI
+ * ======================================= */
+
+static int FUZ_usage(const char* programName)
+{
+    DISPLAY( "Usage :\n");
+    DISPLAY( "      %s [args]\n", programName);
+    DISPLAY( "\n");
+    DISPLAY( "Arguments :\n");
+    DISPLAY( " -i#    : Nb of tests (default:%i) \n", NB_ATTEMPTS);
+    DISPLAY( " -T#    : Duration of tests, in seconds (default: use Nb of tests) \n");
+    DISPLAY( " -s#    : Select seed (default:prompt user)\n");
+    DISPLAY( " -t#    : Select starting test number (default:0)\n");
+    DISPLAY( " -P#    : Select compressibility in %% (default:%i%%)\n", FUZ_COMPRESSIBILITY_DEFAULT);
+    DISPLAY( " -v     : verbose\n");
+    DISPLAY( " -p     : pause at the end\n");
+    DISPLAY( " -h     : display help and exit\n");
+    return 0;
+}
+
+
+int main(int argc, const char** argv)
+{
+    U32 seed = 0;
+    int seedset = 0;
+    int argNb;
+    unsigned nbTests = NB_ATTEMPTS;
+    unsigned testNb = 0;
+    int proba = FUZ_COMPRESSIBILITY_DEFAULT;
+    int use_pause = 0;
+    const char* programName = argv[0];
+    U32 duration = 0;
+
+    /* Check command line */
+    for(argNb=1; argNb='0') && (*argument<='9')) {
+                        nbTests *= 10;
+                        nbTests += (unsigned)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+
+                case 'T':
+                    argument++;
+                    nbTests = 0; duration = 0;
+                    for (;;) {
+                        switch(*argument)
+                        {
+                            case 'm': duration *= 60; argument++; continue;
+                            case 's':
+                            case 'n': argument++; continue;
+                            case '0':
+                            case '1':
+                            case '2':
+                            case '3':
+                            case '4':
+                            case '5':
+                            case '6':
+                            case '7':
+                            case '8':
+                            case '9': duration *= 10; duration += (U32)(*argument++ - '0'); continue;
+                        }
+                        break;
+                    }
+                    break;
+
+                case 's':
+                    argument++;
+                    seed=0; seedset=1;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        seed *= 10;
+                        seed += (U32)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+
+                case 't':   /* select starting test nb */
+                    argument++;
+                    testNb=0;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        testNb *= 10;
+                        testNb += (unsigned)(*argument - '0');
+                        argument++;
+                    }
+                    break;
+
+                case 'P':  /* change probability */
+                    argument++;
+                    proba=0;
+                    while ((*argument>='0') && (*argument<='9')) {
+                        proba *= 10;
+                        proba += *argument - '0';
+                        argument++;
+                    }
+                    if (proba<0) proba=0;
+                    if (proba>100) proba=100;
+                    break;
+                default: ;
+                }
+            }
+        }
+    }
+
+    printf("Starting LZ4 fuzzer (%i-bits, v%s)\n", (int)(sizeof(size_t)*8), LZ4_versionString());
+
+    if (!seedset) {
+        time_t const t = time(NULL);
+        U32 const h = XXH32(&t, sizeof(t), 1);
+        seed = h % 10000;
+    }
+    printf("Seed = %u\n", seed);
+
+    if (proba!=FUZ_COMPRESSIBILITY_DEFAULT) printf("Compressibility : %i%%\n", proba);
+
+    if ((seedset==0) && (testNb==0)) { FUZ_unitTests(LZ4HC_CLEVEL_DEFAULT); FUZ_unitTests(LZ4HC_CLEVEL_OPT_MIN); }
+
+    nbTests += (nbTests==0);  /* avoid zero */
+
+    {   int const result = FUZ_test(seed, nbTests, testNb, ((double)proba) / 100, duration);
+        if (use_pause) {
+            DISPLAY("press enter ... \n");
+            (void)getchar();
+        }
+        return result;
+    }
+}
diff --git a/lz4/tests/roundTripTest.c b/lz4/tests/roundTripTest.c
new file mode 100644
index 0000000..2d34451
--- /dev/null
+++ b/lz4/tests/roundTripTest.c
@@ -0,0 +1,248 @@
+/*
+ * Copyright (c) 2016-present, Yann Collet, Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under both the BSD-style license (found in the
+ * LICENSE file in the root directory of this source tree) and the GPLv2 (found
+ * in the COPYING file in the root directory of this source tree).
+ * You may select, at your option, one of the above-listed licenses.
+ */
+
+/*
+ * This program takes a file in input,
+ * performs an LZ4 round-trip test (compress + decompress)
+ * compares the result with original
+ * and generates an abort() on corruption detection,
+ * in order for afl to register the event as a crash.
+*/
+
+
+/*===========================================
+*   Tuning Constant
+*==========================================*/
+#ifndef MIN_CLEVEL
+#  define MIN_CLEVEL (int)(-5)
+#endif
+
+
+
+/*===========================================
+*   Dependencies
+*==========================================*/
+#include      /* size_t */
+#include      /* malloc, free, exit */
+#include       /* fprintf */
+#include      /* strcmp */
+#include 
+#include   /* stat */
+#include    /* stat */
+#include "xxhash.h"
+
+#include "lz4.h"
+#include "lz4hc.h"
+
+
+/*===========================================
+*   Macros
+*==========================================*/
+#define MIN(a,b)  ( (a) < (b) ? (a) : (b) )
+
+#define MSG(...)    fprintf(stderr, __VA_ARGS__)
+
+#define CONTROL_MSG(c, ...) {   \
+    if ((c)) {                  \
+        MSG(__VA_ARGS__);       \
+        MSG(" \n");             \
+        abort();                \
+    }                           \
+}
+
+
+static size_t checkBuffers(const void* buff1, const void* buff2, size_t buffSize)
+{
+    const char* const ip1 = (const char*)buff1;
+    const char* const ip2 = (const char*)buff2;
+    size_t pos;
+
+    for (pos=0; pos= LZ4_compressBound(srcSize)`
+ *         for compression to be guaranteed to work */
+static void roundTripTest(void* resultBuff, size_t resultBuffCapacity,
+                          void* compressedBuff, size_t compressedBuffCapacity,
+                    const void* srcBuff, size_t srcSize,
+                          int clevel)
+{
+    int const proposed_clevel = clevel ? clevel : select_clevel(srcBuff, srcSize);
+    int const selected_clevel = proposed_clevel < 0 ? -proposed_clevel : proposed_clevel;   /* if level < 0, it becomes an accelearion value */
+    compressFn compress = selected_clevel >= LZ4HC_CLEVEL_MIN ? LZ4_compress_HC : LZ4_compress_fast;
+    int const cSize = compress((const char*)srcBuff, (char*)compressedBuff, (int)srcSize, (int)compressedBuffCapacity, selected_clevel);
+    CONTROL_MSG(cSize == 0, "Compression error !");
+
+    {   int const dSize = LZ4_decompress_safe((const char*)compressedBuff, (char*)resultBuff, cSize, (int)resultBuffCapacity);
+        CONTROL_MSG(dSize < 0, "Decompression detected an error !");
+        CONTROL_MSG(dSize != (int)srcSize, "Decompression corruption error : wrong decompressed size !");
+    }
+
+    /* check potential content corruption error */
+    assert(resultBuffCapacity >= srcSize);
+    {   size_t const errorPos = checkBuffers(srcBuff, resultBuff, srcSize);
+        CONTROL_MSG(errorPos != srcSize,
+                    "Silent decoding corruption, at pos %u !!!",
+                    (unsigned)errorPos);
+    }
+
+}
+
+static void roundTripCheck(const void* srcBuff, size_t srcSize, int clevel)
+{
+    size_t const cBuffSize = LZ4_compressBound((int)srcSize);
+    void* const cBuff = malloc(cBuffSize);
+    void* const rBuff = malloc(cBuffSize);
+
+    if (!cBuff || !rBuff) {
+        fprintf(stderr, "not enough memory ! \n");
+        exit(1);
+    }
+
+    roundTripTest(rBuff, cBuffSize,
+                  cBuff, cBuffSize,
+                  srcBuff, srcSize,
+                  clevel);
+
+    free(rBuff);
+    free(cBuff);
+}
+
+
+static size_t getFileSize(const char* infilename)
+{
+    int r;
+#if defined(_MSC_VER)
+    struct _stat64 statbuf;
+    r = _stat64(infilename, &statbuf);
+    if (r || !(statbuf.st_mode & S_IFREG)) return 0;   /* No good... */
+#else
+    struct stat statbuf;
+    r = stat(infilename, &statbuf);
+    if (r || !S_ISREG(statbuf.st_mode)) return 0;   /* No good... */
+#endif
+    return (size_t)statbuf.st_size;
+}
+
+
+static int isDirectory(const char* infilename)
+{
+    int r;
+#if defined(_MSC_VER)
+    struct _stat64 statbuf;
+    r = _stat64(infilename, &statbuf);
+    if (!r && (statbuf.st_mode & _S_IFDIR)) return 1;
+#else
+    struct stat statbuf;
+    r = stat(infilename, &statbuf);
+    if (!r && S_ISDIR(statbuf.st_mode)) return 1;
+#endif
+    return 0;
+}
+
+
+/** loadFile() :
+ *  requirement : `buffer` size >= `fileSize` */
+static void loadFile(void* buffer, const char* fileName, size_t fileSize)
+{
+    FILE* const f = fopen(fileName, "rb");
+    if (isDirectory(fileName)) {
+        MSG("Ignoring %s directory \n", fileName);
+        exit(2);
+    }
+    if (f==NULL) {
+        MSG("Impossible to open %s \n", fileName);
+        exit(3);
+    }
+    {   size_t const readSize = fread(buffer, 1, fileSize, f);
+        if (readSize != fileSize) {
+            MSG("Error reading %s \n", fileName);
+            exit(5);
+    }   }
+    fclose(f);
+}
+
+
+static void fileCheck(const char* fileName, int clevel)
+{
+    size_t const fileSize = getFileSize(fileName);
+    void* const buffer = malloc(fileSize + !fileSize /* avoid 0 */);
+    if (!buffer) {
+        MSG("not enough memory \n");
+        exit(4);
+    }
+    loadFile(buffer, fileName, fileSize);
+    roundTripCheck(buffer, fileSize, clevel);
+    free (buffer);
+}
+
+
+int bad_usage(const char* exeName)
+{
+    MSG(" \n");
+    MSG("bad usage: \n");
+    MSG(" \n");
+    MSG("%s [Options] fileName \n", exeName);
+    MSG(" \n");
+    MSG("Options: \n");
+    MSG("-#     : use #=[0-9] compression level (default:0 == random) \n");
+    return 1;
+}
+
+
+int main(int argCount, const char** argv)
+{
+    const char* const exeName = argv[0];
+    int argNb = 1;
+    int clevel = 0;
+
+    assert(argCount >= 1);
+    if (argCount < 2) return bad_usage(exeName);
+
+    if (argv[1][0] == '-') {
+        clevel = argv[1][1] - '0';
+        argNb = 2;
+    }
+
+    if (argNb >= argCount) return bad_usage(exeName);
+
+    fileCheck(argv[argNb], clevel);
+    MSG("no pb detected \n");
+    return 0;
+}
diff --git a/lz4/tests/test-lz4-list.py b/lz4/tests/test-lz4-list.py
new file mode 100644
index 0000000..ce89757
--- /dev/null
+++ b/lz4/tests/test-lz4-list.py
@@ -0,0 +1,282 @@
+#! /usr/bin/env python3
+import subprocess
+import time
+import glob
+import os
+import tempfile
+import unittest
+
+SIZES = [3, 11]  # Always 2 sizes
+MIB = 1048576
+LZ4 = os.path.dirname(os.path.realpath(__file__)) + "/../lz4"
+if not os.path.exists(LZ4):
+    LZ4 = os.path.dirname(os.path.realpath(__file__)) + "/../programs/lz4"
+TEMP = tempfile.gettempdir()
+
+
+class NVerboseFileInfo(object):
+    def __init__(self, line_in):
+        self.line = line_in
+        splitlines = line_in.split()
+        if len(splitlines) != 7:
+            errout("Unexpected line: {}".format(line_in))
+        self.frames, self.type, self.block, self.compressed, self.uncompressed, self.ratio, self.filename = splitlines
+        self.exp_unc_size = 0
+        # Get real file sizes
+        if "concat-all" in self.filename or "2f--content-size" in self.filename:
+            for i in SIZES:
+                self.exp_unc_size += os.path.getsize("{}/test_list_{}M".format(TEMP, i))
+        else:
+            uncompressed_filename = self.filename.split("-")[0]
+            self.exp_unc_size += os.path.getsize("{}/{}".format(TEMP, uncompressed_filename))
+        self.exp_comp_size = os.path.getsize("{}/{}".format(TEMP, self.filename))
+
+
+class TestNonVerbose(unittest.TestCase):
+    @classmethod
+    def setUpClass(self):
+        self.nvinfo_list = []
+        for i, line in enumerate(execute("{} --list -m {}/test_list_*.lz4".format(LZ4, TEMP), print_output=True)):
+            if i > 0:
+                self.nvinfo_list.append(NVerboseFileInfo(line))
+
+    def test_frames(self):
+        all_concat_frames = 0
+        all_concat_index = None
+        for i, nvinfo in enumerate(self.nvinfo_list):
+            if "concat-all" in nvinfo.filename:
+                all_concat_index = i
+            elif "2f--content-size" in nvinfo.filename:
+                self.assertEqual("2", nvinfo.frames, nvinfo.line)
+                all_concat_frames += 2
+            else:
+                self.assertEqual("1", nvinfo.frames, nvinfo.line)
+                all_concat_frames += 1
+        self.assertNotEqual(None, all_concat_index, "Couldn't find concat-all file index.")
+        self.assertEqual(self.nvinfo_list[all_concat_index].frames, str(all_concat_frames), self.nvinfo_list[all_concat_index].line)
+
+    def test_frame_types(self):
+        for nvinfo in self.nvinfo_list:
+            if "-lz4f-" in nvinfo.filename:
+                self.assertEqual(nvinfo.type, "LZ4Frame", nvinfo.line)
+            elif "-legc-" in nvinfo.filename:
+                self.assertEqual(nvinfo.type, "LegacyFrame", nvinfo.line)
+            elif "-skip-" in nvinfo.filename:
+                self.assertEqual(nvinfo.type, "SkippableFrame", nvinfo.line)
+
+    def test_block(self):
+        for nvinfo in self.nvinfo_list:
+            # if "-leg" in nvinfo.filename or "-skip" in nvinfo.filename:
+            #     self.assertEqual(nvinfo.block, "-", nvinfo.line)
+            if "--BD" in nvinfo.filename:
+                self.assertRegex(nvinfo.block, "^B[0-9]+D$", nvinfo.line)
+            elif "--BI" in nvinfo.filename:
+                self.assertRegex(nvinfo.block, "^B[0-9]+I$", nvinfo.line)
+
+    def test_compressed_size(self):
+        for nvinfo in self.nvinfo_list:
+            self.assertEqual(nvinfo.compressed, to_human(nvinfo.exp_comp_size), nvinfo.line)
+
+    def test_ratio(self):
+        for nvinfo in self.nvinfo_list:
+            if "--content-size" in nvinfo.filename:
+                self.assertEqual(nvinfo.ratio, "{:.2f}%".format(float(nvinfo.exp_comp_size) / float(nvinfo.exp_unc_size) * 100), nvinfo.line)
+
+    def test_uncompressed_size(self):
+        for nvinfo in self.nvinfo_list:
+            if "--content-size" in nvinfo.filename:
+                self.assertEqual(nvinfo.uncompressed, to_human(nvinfo.exp_unc_size), nvinfo.line)
+
+
+class VerboseFileInfo(object):
+    def __init__(self, lines):
+        # Parse lines
+        self.frame_list = []
+        self.file_frame_map = []
+        for i, line in enumerate(lines):
+            if i == 0:
+                self.filename = line
+                continue
+            elif i == 1:
+                # Skip header
+                continue
+            frame_info = dict(zip(["frame", "type", "block", "checksum", "compressed", "uncompressed", "ratio"], line.split()))
+            frame_info["line"] = line
+            self.frame_list.append(frame_info)
+
+
+class TestVerbose(unittest.TestCase):
+    @classmethod
+    def setUpClass(self):
+        # Even do we're listing 2 files to test multiline working as expected.
+        # we're only really interested in testing the output of the concat-all file.
+        self.vinfo_list = []
+        start = end = 0
+        output = execute("{} --list -m -v {}/test_list_concat-all.lz4 {}/test_list_*M-lz4f-2f--content-size.lz4".format(LZ4, TEMP, TEMP), print_output=True)
+        for i, line in enumerate(output):
+            if line.startswith("test_list"):
+                if start != 0 and end != 0:
+                    self.vinfo_list.append(VerboseFileInfo(output[start:end]))
+                start = i
+            if not line:
+                end = i
+        self.vinfo_list.append(VerboseFileInfo(output[start:end]))
+        # Populate file_frame_map as a reference of the expected info
+        concat_file_list = glob.glob("/tmp/test_list_[!concat]*.lz4")
+        # One of the files has 2 frames so duplicate it in this list to map each frame 1 to a single file
+        for i, filename in enumerate(concat_file_list):
+            if "2f--content-size" in filename:
+                concat_file_list.insert(i, filename)
+                break
+        self.cvinfo = self.vinfo_list[0]
+        self.cvinfo.file_frame_map = concat_file_list
+        self.cvinfo.compressed_size = os.path.getsize("{}/test_list_concat-all.lz4".format(TEMP))
+
+    def test_filename(self):
+        for i, vinfo in enumerate(self.vinfo_list):
+            self.assertRegex(vinfo.filename, "^test_list_.*({}/{})".format(i + 1, len(self.vinfo_list)))
+
+    def test_frame_number(self):
+        for vinfo in self.vinfo_list:
+            for i, frame_info in enumerate(vinfo.frame_list):
+                self.assertEqual(frame_info["frame"], str(i + 1), frame_info["line"])
+
+    def test_frame_type(self):
+        for i, frame_info in enumerate(self.cvinfo.frame_list):
+            if "-lz4f-" in self.cvinfo.file_frame_map[i]:
+                self.assertEqual(self.cvinfo.frame_list[i]["type"], "LZ4Frame", self.cvinfo.frame_list[i]["line"])
+            elif "-legc-" in self.cvinfo.file_frame_map[i]:
+                self.assertEqual(self.cvinfo.frame_list[i]["type"], "LegacyFrame", self.cvinfo.frame_list[i]["line"])
+            elif "-skip-" in self.cvinfo.file_frame_map[i]:
+                self.assertEqual(self.cvinfo.frame_list[i]["type"], "SkippableFrame", self.cvinfo.frame_list[i]["line"])
+
+    def test_block(self):
+        for i, frame_info in enumerate(self.cvinfo.frame_list):
+            if "--BD" in self.cvinfo.file_frame_map[i]:
+                self.assertRegex(self.cvinfo.frame_list[i]["block"], "^B[0-9]+D$", self.cvinfo.frame_list[i]["line"])
+            elif "--BI" in self.cvinfo.file_frame_map[i]:
+                self.assertEqual(self.cvinfo.frame_list[i]["block"], "^B[0-9]+I$", self.cvinfo.frame_list[i]["line"])
+
+    def test_checksum(self):
+        for i, frame_info in enumerate(self.cvinfo.frame_list):
+            if "-lz4f-" in self.cvinfo.file_frame_map[i] and "--no-frame-crc" not in self.cvinfo.file_frame_map[i]:
+                self.assertEqual(self.cvinfo.frame_list[i]["checksum"], "XXH32", self.cvinfo.frame_list[i]["line"])
+
+    def test_compressed(self):
+        total = 0
+        for i, frame_info in enumerate(self.cvinfo.frame_list):
+            if "-2f-" not in self.cvinfo.file_frame_map[i]:
+                expected_size = os.path.getsize(self.cvinfo.file_frame_map[i])
+                self.assertEqual(self.cvinfo.frame_list[i]["compressed"], str(expected_size), self.cvinfo.frame_list[i]["line"])
+            total += int(self.cvinfo.frame_list[i]["compressed"])
+        self.assertEqual(total, self.cvinfo.compressed_size, "Expected total sum ({}) to match {} filesize".format(total, self.cvinfo.filename))
+
+    def test_uncompressed(self):
+        for i, frame_info in enumerate(self.cvinfo.frame_list):
+            ffm = self.cvinfo.file_frame_map[i]
+            if "-2f-" not in ffm and "--content-size" in ffm:
+                expected_size_unc = int(ffm[ffm.rindex("_") + 1:ffm.index("M")]) * 1048576
+                self.assertEqual(self.cvinfo.frame_list[i]["uncompressed"], str(expected_size_unc), self.cvinfo.frame_list[i]["line"])
+
+    def test_ratio(self):
+        for i, frame_info in enumerate(self.cvinfo.frame_list):
+            if "--content-size" in self.cvinfo.file_frame_map[i]:
+                self.assertEqual(self.cvinfo.frame_list[i]['ratio'],
+                                 "{:.2f}%".format(float(self.cvinfo.frame_list[i]['compressed']) / float(self.cvinfo.frame_list[i]['uncompressed']) * 100),
+                                 self.cvinfo.frame_list[i]["line"])
+
+
+def to_human(size):
+    for unit in ['', 'K', 'M', 'G', 'T', 'P', 'E', 'Z', 'Y']:
+        if size < 1024.0:
+            break
+        size /= 1024.0
+    return "{:.2f}{}".format(size, unit)
+
+
+def log(text):
+    print(time.strftime("%Y/%m/%d %H:%M:%S") + ' - ' + text)
+
+
+def errout(text, err=1):
+    log(text)
+    exit(err)
+
+
+def execute(command, print_command=True, print_output=False, print_error=True, param_shell=True):
+    if os.environ.get('QEMU_SYS'):
+        command = "{} {}".format(os.environ['QEMU_SYS'], command)
+    if print_command:
+        log("> " + command)
+    popen = subprocess.Popen(command, stdout=subprocess.PIPE, stderr=subprocess.PIPE, shell=param_shell)
+    stdout_lines, stderr_lines = popen.communicate()
+    stderr_lines = stderr_lines.decode("utf-8")
+    stdout_lines = stdout_lines.decode("utf-8")
+    if print_output:
+        if stdout_lines:
+            print(stdout_lines)
+        if stderr_lines:
+            print(stderr_lines)
+    if popen.returncode is not None and popen.returncode != 0:
+        if stderr_lines and not print_output and print_error:
+            print(stderr_lines)
+        errout("Failed to run: {}\n".format(command, stdout_lines + stderr_lines))
+    return (stdout_lines + stderr_lines).splitlines()
+
+
+def cleanup(silent=False):
+    for f in glob.glob("{}/test_list*".format(TEMP)):
+        if not silent:
+            log("Deleting {}".format(f))
+        os.unlink(f)
+
+
+def datagen(file_name, size):
+    non_sparse_size = size // 2
+    sparse_size = size - non_sparse_size
+    with open(file_name, "wb") as f:
+        f.seek(sparse_size)
+        f.write(os.urandom(non_sparse_size))
+
+
+def generate_files():
+    # file format  ~ test_list-f.lz4 ~
+    # Generate LZ4Frames
+    for i in SIZES:
+        filename = "{}/test_list_{}M".format(TEMP, i)
+        log("Generating {}".format(filename))
+        datagen(filename, i * MIB)
+        for j in ["--content-size", "-BI", "-BD", "-BX", "--no-frame-crc"]:
+            lz4file = "{}-lz4f-1f{}.lz4".format(filename, j)
+            execute("{} {} {} {}".format(LZ4, j, filename, lz4file))
+        # Generate skippable frames
+        lz4file = "{}-skip-1f.lz4".format(filename)
+        skipsize = i * 1024
+        skipbytes = bytes([80, 42, 77, 24]) + skipsize.to_bytes(4, byteorder='little', signed=False)
+        with open(lz4file, 'wb') as f:
+            f.write(skipbytes)
+            f.write(os.urandom(skipsize))
+        # Generate legacy frames
+        lz4file = "{}-legc-1f.lz4".format(filename)
+        execute("{} -l {} {}".format(LZ4, filename, lz4file))
+
+    # Concatenate --content-size files
+    file_list = glob.glob("{}/test_list_*-lz4f-1f--content-size.lz4".format(TEMP))
+    with open("{}/test_list_{}M-lz4f-2f--content-size.lz4".format(TEMP, sum(SIZES)), 'ab') as outfile:
+        for fname in file_list:
+            with open(fname, 'rb') as infile:
+                outfile.write(infile.read())
+
+    # Concatenate all files
+    file_list = glob.glob("{}/test_list_*.lz4".format(TEMP))
+    with open("{}/test_list_concat-all.lz4".format(TEMP), 'ab') as outfile:
+        for fname in file_list:
+            with open(fname, 'rb') as infile:
+                outfile.write(infile.read())
+
+
+if __name__ == '__main__':
+    cleanup()
+    generate_files()
+    unittest.main(verbosity=2, exit=False)
+    cleanup(silent=True)
diff --git a/lz4/tests/test-lz4-speed.py b/lz4/tests/test-lz4-speed.py
new file mode 100644
index 0000000..ca8f010
--- /dev/null
+++ b/lz4/tests/test-lz4-speed.py
@@ -0,0 +1,351 @@
+#! /usr/bin/env python3
+
+#
+# Copyright (c) 2016-present, Przemyslaw Skibinski, Yann Collet, Facebook, Inc.
+# All rights reserved.
+#
+# This source code is licensed under the BSD-style license found in the
+# LICENSE file in the root directory of this source tree. An additional grant
+# of patent rights can be found in the PATENTS file in the same directory.
+#
+
+# Limitations:
+# - doesn't support filenames with spaces
+# - dir1/lz4 and dir2/lz4 will be merged in a single results file
+
+import argparse
+import os
+import string
+import subprocess
+import time
+import traceback
+import hashlib
+
+script_version = 'v1.7.2 (2016-11-08)'
+default_repo_url = 'https://github.com/lz4/lz4.git'
+working_dir_name = 'speedTest'
+working_path = os.getcwd() + '/' + working_dir_name     # /path/to/lz4/tests/speedTest
+clone_path = working_path + '/' + 'lz4'                 # /path/to/lz4/tests/speedTest/lz4
+email_header = 'lz4_speedTest'
+pid = str(os.getpid())
+verbose = False
+clang_version = "unknown"
+gcc_version = "unknown"
+args = None
+
+
+def hashfile(hasher, fname, blocksize=65536):
+    with open(fname, "rb") as f:
+        for chunk in iter(lambda: f.read(blocksize), b""):
+            hasher.update(chunk)
+    return hasher.hexdigest()
+
+
+def log(text):
+    print(time.strftime("%Y/%m/%d %H:%M:%S") + ' - ' + text)
+
+
+def execute(command, print_command=True, print_output=False, print_error=True, param_shell=True):
+    if print_command:
+        log("> " + command)
+    popen = subprocess.Popen(command, stdout=subprocess.PIPE, stderr=subprocess.PIPE, shell=param_shell, cwd=execute.cwd)
+    stdout_lines, stderr_lines = popen.communicate(timeout=args.timeout)
+    stderr_lines = stderr_lines.decode("utf-8")
+    stdout_lines = stdout_lines.decode("utf-8")
+    if print_output:
+        if stdout_lines:
+            print(stdout_lines)
+        if stderr_lines:
+            print(stderr_lines)
+    if popen.returncode is not None and popen.returncode != 0:
+        if stderr_lines and not print_output and print_error:
+            print(stderr_lines)
+        raise RuntimeError(stdout_lines + stderr_lines)
+    return (stdout_lines + stderr_lines).splitlines()
+execute.cwd = None
+
+
+def does_command_exist(command):
+    try:
+        execute(command, verbose, False, False)
+    except Exception:
+        return False
+    return True
+
+
+def send_email(emails, topic, text, have_mutt, have_mail):
+    logFileName = working_path + '/' + 'tmpEmailContent'
+    with open(logFileName, "w") as myfile:
+        myfile.writelines(text)
+        myfile.close()
+        if have_mutt:
+            execute('mutt -s "' + topic + '" ' + emails + ' < ' + logFileName, verbose)
+        elif have_mail:
+            execute('mail -s "' + topic + '" ' + emails + ' < ' + logFileName, verbose)
+        else:
+            log("e-mail cannot be sent (mail or mutt not found)")
+
+
+def send_email_with_attachments(branch, commit, last_commit, args, text, results_files,
+                                logFileName, have_mutt, have_mail):
+    with open(logFileName, "w") as myfile:
+        myfile.writelines(text)
+        myfile.close()
+        email_topic = '[%s:%s] Warning for %s:%s last_commit=%s speed<%s ratio<%s' \
+                      % (email_header, pid, branch, commit, last_commit,
+                         args.lowerLimit, args.ratioLimit)
+        if have_mutt:
+            execute('mutt -s "' + email_topic + '" ' + args.emails + ' -a ' + results_files
+                    + ' < ' + logFileName)
+        elif have_mail:
+            execute('mail -s "' + email_topic + '" ' + args.emails + ' < ' + logFileName)
+        else:
+            log("e-mail cannot be sent (mail or mutt not found)")
+
+
+def git_get_branches():
+    execute('git fetch -p', verbose)
+    branches = execute('git branch -rl', verbose)
+    output = []
+    for line in branches:
+        if ("HEAD" not in line) and ("coverity_scan" not in line) and ("gh-pages" not in line):
+            output.append(line.strip())
+    return output
+
+
+def git_get_changes(branch, commit, last_commit):
+    fmt = '--format="%h: (%an) %s, %ar"'
+    if last_commit is None:
+        commits = execute('git log -n 10 %s %s' % (fmt, commit))
+    else:
+        commits = execute('git --no-pager log %s %s..%s' % (fmt, last_commit, commit))
+    return str('Changes in %s since %s:\n' % (branch, last_commit)) + '\n'.join(commits)
+
+
+def get_last_results(resultsFileName):
+    if not os.path.isfile(resultsFileName):
+        return None, None, None, None
+    commit = None
+    csize = []
+    cspeed = []
+    dspeed = []
+    with open(resultsFileName, 'r') as f:
+        for line in f:
+            words = line.split()
+            if len(words) <= 4:   # branch + commit + compilerVer + md5
+                commit = words[1]
+                csize = []
+                cspeed = []
+                dspeed = []
+            if (len(words) == 8) or (len(words) == 9):  # results: "filename" or "XX files"
+                csize.append(int(words[1]))
+                cspeed.append(float(words[3]))
+                dspeed.append(float(words[5]))
+    return commit, csize, cspeed, dspeed
+
+
+def benchmark_and_compare(branch, commit, last_commit, args, executableName, md5sum, compilerVersion, resultsFileName,
+                          testFilePath, fileName, last_csize, last_cspeed, last_dspeed):
+    sleepTime = 30
+    while os.getloadavg()[0] > args.maxLoadAvg:
+        log("WARNING: bench loadavg=%.2f is higher than %s, sleeping for %s seconds"
+            % (os.getloadavg()[0], args.maxLoadAvg, sleepTime))
+        time.sleep(sleepTime)
+    start_load = str(os.getloadavg())
+    result = execute('programs/%s -rqi5b1e%s %s' % (executableName, args.lastCLevel, testFilePath), print_output=True)   
+    end_load = str(os.getloadavg())
+    linesExpected = args.lastCLevel + 1
+    if len(result) != linesExpected:
+        raise RuntimeError("ERROR: number of result lines=%d is different that expected %d\n%s" % (len(result), linesExpected, '\n'.join(result)))
+    with open(resultsFileName, "a") as myfile:
+        myfile.write('%s %s %s md5=%s\n' % (branch, commit, compilerVersion, md5sum))
+        myfile.write('\n'.join(result) + '\n')
+        myfile.close()
+        if (last_cspeed == None):
+            log("WARNING: No data for comparison for branch=%s file=%s " % (branch, fileName))
+            return ""
+        commit, csize, cspeed, dspeed = get_last_results(resultsFileName)
+        text = ""
+        for i in range(0, min(len(cspeed), len(last_cspeed))):
+            print("%s:%s -%d cSpeed=%6.2f cLast=%6.2f cDiff=%1.4f dSpeed=%6.2f dLast=%6.2f dDiff=%1.4f ratioDiff=%1.4f %s" % (branch, commit, i+1, cspeed[i], last_cspeed[i], cspeed[i]/last_cspeed[i], dspeed[i], last_dspeed[i], dspeed[i]/last_dspeed[i], float(last_csize[i])/csize[i], fileName))
+            if (cspeed[i]/last_cspeed[i] < args.lowerLimit):
+                text += "WARNING: %s -%d cSpeed=%.2f cLast=%.2f cDiff=%.4f %s\n" % (executableName, i+1, cspeed[i], last_cspeed[i], cspeed[i]/last_cspeed[i], fileName)
+            if (dspeed[i]/last_dspeed[i] < args.lowerLimit):
+                text += "WARNING: %s -%d dSpeed=%.2f dLast=%.2f dDiff=%.4f %s\n" % (executableName, i+1, dspeed[i], last_dspeed[i], dspeed[i]/last_dspeed[i], fileName)
+            if (float(last_csize[i])/csize[i] < args.ratioLimit):
+                text += "WARNING: %s -%d cSize=%d last_cSize=%d diff=%.4f %s\n" % (executableName, i+1, csize[i], last_csize[i], float(last_csize[i])/csize[i], fileName)
+        if text:
+            text = args.message + ("\nmaxLoadAvg=%s  load average at start=%s end=%s\n%s  last_commit=%s  md5=%s\n" % (args.maxLoadAvg, start_load, end_load, compilerVersion, last_commit, md5sum)) + text
+        return text
+
+
+def update_config_file(branch, commit):
+    last_commit = None
+    commitFileName = working_path + "/commit_" + branch.replace("/", "_") + ".txt"
+    if os.path.isfile(commitFileName):
+        with open(commitFileName, 'r') as infile:
+            last_commit = infile.read()
+    with open(commitFileName, 'w') as outfile:
+        outfile.write(commit)
+    return last_commit
+
+
+def double_check(branch, commit, args, executableName, md5sum, compilerVersion, resultsFileName, filePath, fileName):
+    last_commit, csize, cspeed, dspeed = get_last_results(resultsFileName)
+    if not args.dry_run:
+        text = benchmark_and_compare(branch, commit, last_commit, args, executableName, md5sum, compilerVersion, resultsFileName, filePath, fileName, csize, cspeed, dspeed)
+        if text:
+            log("WARNING: redoing tests for branch %s: commit %s" % (branch, commit))
+            text = benchmark_and_compare(branch, commit, last_commit, args, executableName, md5sum, compilerVersion, resultsFileName, filePath, fileName, csize, cspeed, dspeed)
+    return text
+
+
+def test_commit(branch, commit, last_commit, args, testFilePaths, have_mutt, have_mail):
+    local_branch = branch.split('/')[1]
+    version = local_branch.rpartition('-')[2] + '_' + commit
+    if not args.dry_run:
+        execute('make -C programs clean lz4 CC=clang MOREFLAGS="-Werror -Wconversion -Wno-sign-conversion -DLZ4_GIT_COMMIT=%s" && ' % version +
+                'mv programs/lz4 programs/lz4_clang && ' +
+                'make -C programs clean lz4 lz4c32 MOREFLAGS="-DLZ4_GIT_COMMIT=%s"' % version)
+    md5_lz4 = hashfile(hashlib.md5(), clone_path + '/programs/lz4')
+    md5_lz4c32 = hashfile(hashlib.md5(), clone_path + '/programs/lz4c32')
+    md5_lz4_clang = hashfile(hashlib.md5(), clone_path + '/programs/lz4_clang')
+    print("md5(lz4)=%s\nmd5(lz4c32)=%s\nmd5(lz4_clang)=%s" % (md5_lz4, md5_lz4c32, md5_lz4_clang))
+    print("gcc_version=%s clang_version=%s" % (gcc_version, clang_version))
+
+    logFileName = working_path + "/log_" + branch.replace("/", "_") + ".txt"
+    text_to_send = []
+    results_files = ""
+
+    for filePath in testFilePaths:
+        fileName = filePath.rpartition('/')[2]
+        resultsFileName = working_path + "/results_" + branch.replace("/", "_") + "_" + fileName.replace(".", "_") + ".txt"
+        text = double_check(branch, commit, args, 'lz4', md5_lz4, 'gcc_version='+gcc_version, resultsFileName, filePath, fileName)
+        if text:
+            text_to_send.append(text)
+            results_files += resultsFileName + " "
+        resultsFileName = working_path + "/results32_" + branch.replace("/", "_") + "_" + fileName.replace(".", "_") + ".txt"
+        text = double_check(branch, commit, args, 'lz4c32', md5_lz4c32, 'gcc_version='+gcc_version, resultsFileName, filePath, fileName)
+        if text:
+            text_to_send.append(text)
+            results_files += resultsFileName + " "
+        resultsFileName = working_path + "/resultsClang_" + branch.replace("/", "_") + "_" + fileName.replace(".", "_") + ".txt"
+        text = double_check(branch, commit, args, 'lz4_clang', md5_lz4_clang, 'clang_version='+clang_version, resultsFileName, filePath, fileName)
+        if text:
+            text_to_send.append(text)
+            results_files += resultsFileName + " "
+    if text_to_send:
+        send_email_with_attachments(branch, commit, last_commit, args, text_to_send, results_files, logFileName, have_mutt, have_mail)
+
+
+if __name__ == '__main__':
+    parser = argparse.ArgumentParser()
+    parser.add_argument('testFileNames', help='file or directory names list for speed benchmark')
+    parser.add_argument('emails', help='list of e-mail addresses to send warnings')
+    parser.add_argument('--message', '-m', help='attach an additional message to e-mail', default="")
+    parser.add_argument('--repoURL', help='changes default repository URL', default=default_repo_url)
+    parser.add_argument('--lowerLimit', '-l', type=float, help='send email if speed is lower than given limit', default=0.98)
+    parser.add_argument('--ratioLimit', '-r', type=float, help='send email if ratio is lower than given limit', default=0.999)
+    parser.add_argument('--maxLoadAvg', type=float, help='maximum load average to start testing', default=0.75)
+    parser.add_argument('--lastCLevel', type=int, help='last compression level for testing', default=5)
+    parser.add_argument('--sleepTime', '-s', type=int, help='frequency of repository checking in seconds', default=300)
+    parser.add_argument('--timeout', '-t', type=int, help='timeout for executing shell commands', default=1800)
+    parser.add_argument('--dry-run', dest='dry_run', action='store_true', help='not build', default=False)
+    parser.add_argument('--verbose', '-v', action='store_true', help='more verbose logs', default=False)
+    args = parser.parse_args()
+    verbose = args.verbose
+
+    # check if test files are accessible
+    testFileNames = args.testFileNames.split()
+    testFilePaths = []
+    for fileName in testFileNames:
+        fileName = os.path.expanduser(fileName)
+        if os.path.isfile(fileName) or os.path.isdir(fileName):
+            testFilePaths.append(os.path.abspath(fileName))
+        else:
+            log("ERROR: File/directory not found: " + fileName)
+            exit(1)
+
+    # check availability of e-mail senders
+    have_mutt = does_command_exist("mutt -h")
+    have_mail = does_command_exist("mail -V")
+    if not have_mutt and not have_mail:
+        log("ERROR: e-mail senders 'mail' or 'mutt' not found")
+        exit(1)
+
+    clang_version = execute("clang -v 2>&1 | grep 'clang version' | sed -e 's:.*version \\([0-9.]*\\).*:\\1:' -e 's:\\.\\([0-9][0-9]\\):\\1:g'", verbose)[0];
+    gcc_version = execute("gcc -dumpversion", verbose)[0];
+
+    if verbose:
+        print("PARAMETERS:\nrepoURL=%s" % args.repoURL)
+        print("working_path=%s" % working_path)
+        print("clone_path=%s" % clone_path)
+        print("testFilePath(%s)=%s" % (len(testFilePaths), testFilePaths))
+        print("message=%s" % args.message)
+        print("emails=%s" % args.emails)
+        print("maxLoadAvg=%s" % args.maxLoadAvg)
+        print("lowerLimit=%s" % args.lowerLimit)
+        print("ratioLimit=%s" % args.ratioLimit)
+        print("lastCLevel=%s" % args.lastCLevel)
+        print("sleepTime=%s" % args.sleepTime)
+        print("timeout=%s" % args.timeout)
+        print("dry_run=%s" % args.dry_run)
+        print("verbose=%s" % args.verbose)
+        print("have_mutt=%s have_mail=%s" % (have_mutt, have_mail))
+
+    # clone lz4 repo if needed
+    if not os.path.isdir(working_path):
+        os.mkdir(working_path)
+    if not os.path.isdir(clone_path):
+        execute.cwd = working_path
+        execute('git clone ' + args.repoURL)
+    if not os.path.isdir(clone_path):
+        log("ERROR: lz4 clone not found: " + clone_path)
+        exit(1)
+    execute.cwd = clone_path
+
+    # check if speedTest.pid already exists
+    pidfile = "./speedTest.pid"
+    if os.path.isfile(pidfile):
+        log("ERROR: %s already exists, exiting" % pidfile)
+        exit(1)
+
+    send_email(args.emails, '[%s:%s] test-lz4-speed.py %s has been started' % (email_header, pid, script_version), args.message, have_mutt, have_mail)
+    with open(pidfile, 'w') as the_file:
+        the_file.write(pid)
+
+    branch = ""
+    commit = ""
+    first_time = True
+    while True:
+        try:
+            if first_time:
+                first_time = False
+            else:
+                if verbose:
+                    log("sleep for %s seconds" % args.sleepTime)
+                time.sleep(args.sleepTime)
+            loadavg = os.getloadavg()[0]
+            if (loadavg <= args.maxLoadAvg):
+                branches = git_get_branches()
+                for branch in branches:
+                    commit = execute('git show -s --format=%h ' + branch, verbose)[0]
+                    last_commit = update_config_file(branch, commit)
+                    if commit == last_commit:
+                        log("skipping branch %s: head %s already processed" % (branch, commit))
+                    else:
+                        log("build branch %s: head %s is different from prev %s" % (branch, commit, last_commit))
+                        execute('git checkout -- . && git checkout ' + branch)
+                        print(git_get_changes(branch, commit, last_commit))
+                        test_commit(branch, commit, last_commit, args, testFilePaths, have_mutt, have_mail)
+            else:
+                log("WARNING: main loadavg=%.2f is higher than %s" % (loadavg, args.maxLoadAvg))
+        except Exception as e:
+            stack = traceback.format_exc()
+            email_topic = '[%s:%s] ERROR in %s:%s' % (email_header, pid, branch, commit)
+            send_email(args.emails, email_topic, stack, have_mutt, have_mail)
+            print(stack)
+        except KeyboardInterrupt:
+            os.unlink(pidfile)
+            send_email(args.emails, '[%s:%s] test-lz4-speed.py %s has been stopped' % (email_header, pid, script_version), args.message, have_mutt, have_mail)
+            exit(0)
diff --git a/lz4/tests/test-lz4-versions.py b/lz4/tests/test-lz4-versions.py
new file mode 100644
index 0000000..d7fd199
--- /dev/null
+++ b/lz4/tests/test-lz4-versions.py
@@ -0,0 +1,156 @@
+#!/usr/bin/env python3
+"""Test LZ4 interoperability between versions"""
+
+#
+# Copyright (C) 2011-present, Takayuki Matsuoka
+# All rights reserved.
+# GPL v2 License
+#
+
+import glob
+import subprocess
+import filecmp
+import os
+import shutil
+import sys
+import hashlib
+
+repo_url = 'https://github.com/lz4/lz4.git'
+tmp_dir_name = 'tests/versionsTest'
+make_cmd = 'make'
+git_cmd = 'git'
+test_dat_src = 'README.md'
+test_dat = 'test_dat'
+head = 'v999'
+
+def proc(cmd_args, pipe=True, dummy=False):
+    if dummy:
+        return
+    if pipe:
+        subproc = subprocess.Popen(cmd_args,
+                                   stdout=subprocess.PIPE,
+                                   stderr=subprocess.PIPE)
+    else:
+        subproc = subprocess.Popen(cmd_args)
+    return subproc.communicate()
+
+def make(args, pipe=True):
+    return proc([make_cmd] + args, pipe)
+
+def git(args, pipe=True):
+    return proc([git_cmd] + args, pipe)
+
+def get_git_tags():
+    stdout, stderr = git(['tag', '-l', 'r[0-9][0-9][0-9]'])
+    tags = stdout.decode('utf-8').split()
+    stdout, stderr = git(['tag', '-l', 'v[1-9].[0-9].[0-9]'])
+    tags += stdout.decode('utf-8').split()
+    return tags
+
+# https://stackoverflow.com/a/19711609/2132223
+def sha1_of_file(filepath):
+    with open(filepath, 'rb') as f:
+        return hashlib.sha1(f.read()).hexdigest()
+
+if __name__ == '__main__':
+    error_code = 0
+    base_dir = os.getcwd() + '/..'           # /path/to/lz4
+    tmp_dir = base_dir + '/' + tmp_dir_name  # /path/to/lz4/tests/versionsTest
+    clone_dir = tmp_dir + '/' + 'lz4'        # /path/to/lz4/tests/versionsTest/lz4
+    programs_dir = base_dir + '/programs'    # /path/to/lz4/programs
+    os.makedirs(tmp_dir, exist_ok=True)
+
+    # since Travis clones limited depth, we should clone full repository
+    if not os.path.isdir(clone_dir):
+        git(['clone', repo_url, clone_dir])
+
+    shutil.copy2(base_dir + '/' + test_dat_src, tmp_dir + '/' + test_dat)
+
+    # Retrieve all release tags
+    print('Retrieve all release tags :')
+    os.chdir(clone_dir)
+    tags = [head] + get_git_tags()
+    print(tags);
+
+    # Build all release lz4c and lz4c32
+    for tag in tags:
+        os.chdir(base_dir)
+        dst_lz4c   = '{}/lz4c.{}'  .format(tmp_dir, tag) # /path/to/lz4/test/lz4test/lz4c.
+        dst_lz4c32 = '{}/lz4c32.{}'.format(tmp_dir, tag) # /path/to/lz4/test/lz4test/lz4c32.
+        if not os.path.isfile(dst_lz4c) or not os.path.isfile(dst_lz4c32) or tag == head:
+            if tag != head:
+                r_dir = '{}/{}'.format(tmp_dir, tag)  # /path/to/lz4/test/lz4test/
+                os.makedirs(r_dir, exist_ok=True)
+                os.chdir(clone_dir)
+                git(['--work-tree=' + r_dir, 'checkout', tag, '--', '.'], False)
+                os.chdir(r_dir + '/programs')  # /path/to/lz4/lz4test//programs
+            else:
+                os.chdir(programs_dir)
+            make(['clean', 'lz4c'], False)
+            shutil.copy2('lz4c',   dst_lz4c)
+            make(['clean', 'lz4c32'], False)
+            shutil.copy2('lz4c32', dst_lz4c32)
+
+    # Compress test.dat by all released lz4c and lz4c32
+    print('Compress test.dat by all released lz4c and lz4c32')
+    os.chdir(tmp_dir)
+    for lz4 in glob.glob("*.lz4"):
+        os.remove(lz4)
+    for tag in tags:
+        proc(['./lz4c.'   + tag, '-1fz', test_dat, test_dat + '_1_64_' + tag + '.lz4'])
+        proc(['./lz4c.'   + tag, '-9fz', test_dat, test_dat + '_9_64_' + tag + '.lz4'])
+        proc(['./lz4c32.' + tag, '-1fz', test_dat, test_dat + '_1_32_' + tag + '.lz4'])
+        proc(['./lz4c32.' + tag, '-9fz', test_dat, test_dat + '_9_32_' + tag + '.lz4'])
+
+    print('Full list of compressed files')
+    lz4s = sorted(glob.glob('*.lz4'))
+    for lz4 in lz4s:
+        print(lz4 + ' : ' + repr(os.path.getsize(lz4)))
+
+    # Remove duplicated .lz4 files
+    print('')
+    print('Duplicated files')
+    lz4s = sorted(glob.glob('*.lz4'))
+    for i, lz4 in enumerate(lz4s):
+        if not os.path.isfile(lz4):
+            continue
+        for j in range(i+1, len(lz4s)):
+            lz4t = lz4s[j]
+            if not os.path.isfile(lz4t):
+                continue
+            if filecmp.cmp(lz4, lz4t):
+                os.remove(lz4t)
+                print('{} == {}'.format(lz4, lz4t))
+
+    print('Enumerate only different compressed files')
+    lz4s = sorted(glob.glob('*.lz4'))
+    for lz4 in lz4s:
+        print(lz4 + ' : ' + repr(os.path.getsize(lz4)) + ', ' + sha1_of_file(lz4))
+
+    # Decompress remained .lz4 files by all released lz4c and lz4c32
+    print('Decompression tests and verifications')
+    lz4s = sorted(glob.glob('*.lz4'))
+    for dec in glob.glob("*.dec"):
+        os.remove(dec)
+    for lz4 in lz4s:
+        print(lz4, end=" ")
+        for tag in tags:
+            print(tag, end=" ")
+            proc(['./lz4c.'   + tag, '-df', lz4, lz4 + '_d64_' + tag + '.dec'])
+            proc(['./lz4c32.' + tag, '-df', lz4, lz4 + '_d32_' + tag + '.dec'])
+        print(' OK')   # well, here, decompression has worked; but file is not yet verified
+
+    # Compare all '.dec' files with test_dat
+    decs = glob.glob('*.dec')
+    for dec in decs:
+        if not filecmp.cmp(dec, test_dat):
+            print('ERR : ' + dec)
+            error_code = 1
+        else:
+            print('OK  : ' + dec)
+            os.remove(dec)
+
+    if error_code != 0:
+        print('ERROR')
+
+    sys.exit(error_code)
diff --git a/lz4/tests/test_custom_block_sizes.sh b/lz4/tests/test_custom_block_sizes.sh
new file mode 100755
index 0000000..aba6733
--- /dev/null
+++ b/lz4/tests/test_custom_block_sizes.sh
@@ -0,0 +1,72 @@
+#/usr/bin/env sh
+set -e
+
+LZ4=../lz4
+CHECKFRAME=./checkFrame
+DATAGEN=./datagen
+
+failures=""
+
+TMPFILE=/tmp/test_custom_block_sizes.$$
+TMPFILE1=/tmp/test_custom_block_sizes1.$$
+TMPFILE2=/tmp/test_custom_block_sizes2.$$
+$DATAGEN -g12345678 > $TMPFILE1
+$DATAGEN -g12345678 > $TMPFILE2
+
+echo Testing -B31
+$LZ4 -f -B31 $TMPFILE1 && failures="31 (should fail) "
+
+for blocksize in 32 65535 65536
+do
+  echo Testing -B$blocksize
+  $LZ4 -f -B$blocksize $TMPFILE1
+  $LZ4 -f -B$blocksize $TMPFILE2
+  cat $TMPFILE1.lz4 $TMPFILE2.lz4 > $TMPFILE.lz4
+  $CHECKFRAME -B$blocksize -b4 $TMPFILE.lz4 || failures="$failures $blocksize "
+done
+
+for blocksize in 65537 262143 262144
+do
+  echo Testing -B$blocksize
+  $LZ4 -f -B$blocksize $TMPFILE1
+  $LZ4 -f -B$blocksize $TMPFILE2
+  cat $TMPFILE1.lz4 $TMPFILE2.lz4 > $TMPFILE.lz4
+  $CHECKFRAME -B$blocksize -b5 $TMPFILE.lz4 || failures="$failures $blocksize "
+done
+
+for blocksize in 262145 1048575 1048576
+do
+  echo Testing -B$blocksize
+  $LZ4 -f -B$blocksize $TMPFILE1
+  $LZ4 -f -B$blocksize $TMPFILE2
+  cat $TMPFILE1.lz4 $TMPFILE2.lz4 > $TMPFILE.lz4
+  $CHECKFRAME -B$blocksize -b6 $TMPFILE.lz4 || failures="$failures $blocksize "
+done
+
+for blocksize in 1048577 4194303 4194304
+do
+  echo Testing -B$blocksize
+  $LZ4 -f -B$blocksize $TMPFILE1
+  $LZ4 -f -B$blocksize $TMPFILE2
+  cat $TMPFILE1.lz4 $TMPFILE2.lz4 > $TMPFILE.lz4
+  $CHECKFRAME -B$blocksize -b7 $TMPFILE.lz4 || failures="$failures $blocksize "
+done
+
+for blocksize in 4194305 10485760
+do
+  echo Testing -B$blocksize
+  $LZ4 -f -B$blocksize $TMPFILE1
+  $LZ4 -f -B$blocksize $TMPFILE2
+  cat $TMPFILE1.lz4 $TMPFILE2.lz4 > $TMPFILE.lz4
+  $CHECKFRAME -B4194304 -b7 $TMPFILE.lz4 || failures="$failures $blocksize "
+done
+
+rm $TMPFILE.lz4 $TMPFILE1 $TMPFILE1.lz4 $TMPFILE2 $TMPFILE2.lz4
+if [ "$failures" == "" ]
+then
+  echo ---- All tests passed
+  exit 0
+else
+  echo ---- The following tests had failures: $failures
+  exit 1
+fi
diff --git a/lz4/tests/test_install.sh b/lz4/tests/test_install.sh
new file mode 100755
index 0000000..122bac5
--- /dev/null
+++ b/lz4/tests/test_install.sh
@@ -0,0 +1,28 @@
+#/usr/bin/env sh
+set -e
+
+
+make="make -C $lz4_root"
+unamestr=$(uname)
+if [ "$unamestr" = 'Linux' ]; then
+  make="make -C $lz4_root"
+elif [ "$unamestr" = 'FreeBSD' -o "$unamestr" = 'OpenBSD' ]; then
+  make="gmake -C $lz4_root"
+fi
+
+for cmd in install uninstall; do
+  for upper in DUMMY PREFIX EXEC_PREFIX LIBDIR INCLUDEDIR PKGCONFIGDIR BINDIR MANDIR MAN1DIR ; do
+    lower=$(echo $upper | tr '[:upper:]' '[:lower:]')
+    tmp_lower="$(pwd)/tmp-lower-$lower/"
+    tmp_upper="$(pwd)/tmp-upper-$lower/"
+    echo $make $cmd DESTDIR="$tmp_upper" $upper="test"
+    $make $cmd DESTDIR="$tmp_upper" $upper="test" >/dev/null
+    echo $make $cmd DESTDIR="$tmp_lower" $lower="test"
+    $make $cmd DESTDIR="$tmp_lower" $lower="test" >/dev/null
+    command diff -r "$tmp_lower" "$tmp_upper" && echo "SAME!" || false
+    if [ "x$cmd" = "xuninstall" ]; then
+      test -z "$(find "$tmp_lower" -type f)" && echo "EMPTY!" || false
+      rm -rf "$tmp_upper" "$tmp_lower"
+    fi
+  done
+done
diff --git a/lz4/tmp b/lz4/tmp
new file mode 100644
index 0000000..c97c12f
Binary files /dev/null and b/lz4/tmp differ
diff --git a/lz4/tmpsparse b/lz4/tmpsparse
new file mode 100644
index 0000000..c97c12f
Binary files /dev/null and b/lz4/tmpsparse differ
diff --git a/makefiles/Makefile-csug.in b/makefiles/Makefile-csug.in
new file mode 100644
index 0000000..6f8a8d9
--- /dev/null
+++ b/makefiles/Makefile-csug.in
@@ -0,0 +1,159 @@
+m = $(m)
+Scheme=../$m/bin/$m/scheme -b ../$m/boot/$m/petite.boot -b ../$m/boot/$m/scheme.boot
+STEXLIB=../stex
+installdir=/tmp/csug9.5
+INSTALL=../$m/installsh
+
+x = csug
+latex = pdflatex
+stexmacrofiles = tspl4-prep
+bib = $(x).bib
+index=yes
+TSPL=tspl4
+DIR=$(shell basename `pwd`)
+
+target: logcheck1 logcheck2 checklibs $(x).html $(x).pdf
+
+install: target
+	$(INSTALL) -m 2755 -d $(installdir)
+	$(INSTALL) -m 0644 --ifdiff *.html *.css $(installdir)
+	$(INSTALL) -m 0644 --ifdiff csug.pdf $(installdir)/csug9_5.pdf
+	$(INSTALL) -m 2755 -d $(installdir)/canned
+	$(INSTALL) -m 0644 --ifdiff canned/* $(installdir)/canned
+	$(INSTALL) -m 2755 -d $(installdir)/gifs
+	$(INSTALL) -m 0644 --ifdiff gifs/*.gif $(installdir)/gifs
+	$(INSTALL) -m 2755 -d $(installdir)/$(mathdir)
+	$(INSTALL) -m 0644 --ifdiff $(mathdir)/*.gif $(installdir)/$(mathdir)
+	(cd $(installdir); ln -s -f $(x).html index.html)
+
+# thrice is not enough when starting from scratch
+logcheck1: $(x).thirdrun
+	@if [ -n "`grep 'Warning: Label(s) may have changed' $(x).log`" ] ; then\
+            rm -f $(x).thirdrun ;\
+            $(MAKE) $(x).thirdrun;\
+         fi
+
+rerun: $(x).thirdrun
+
+logcheck2: $(x).thirdrun
+	@if [ -n "`grep Warning $(x).log | grep -v pdftex.map`" ] ; then\
+            echo "`grep Warning $(x).log | grep -v pdftex.map`";\
+            false;\
+         fi
+	@if [ -n "`grep Overfull $(x).log | grep -v pdftex.map`" ] ; then\
+            echo "`grep Overfull $(x).log | grep -v pdftex.map`";\
+            false;\
+         fi
+
+include $(STEXLIB)/Mf-stex
+
+stexsrc = csug.stex title.stex copyright.stex contents.stex\
+ preface.stex intro.stex use.stex expeditor.stex debug.stex foreign.stex\
+ binding.stex control.stex objects.stex numeric.stex io.stex\
+ libraries.stex syntax.stex system.stex smgmt.stex threads.stex\
+ compat.stex bibliography.stex summary.stex
+texsrc = ${stexsrc:%.stex=%.tex}
+
+title.tex contents.tex bibliography.tex:
+	rm -f $*.tex
+	echo "%%% DO NOT EDIT THIS FILE" > $*.tex
+	echo "%%% Edit the .stex version instead" >> $*.tex
+	echo "" >> $*.tex
+	cat $*.stex >> $*.tex
+	chmod -w $*.tex
+title.tex: title.stex
+contents.tex: contents.stex
+bibliography.tex: bibliography.stex
+
+$(x).firstrun: $(x).prefirstrun
+$(x).prefirstrun: tspl.aux tspl.rfm tspl.idx
+	touch $x.sfm
+	cat tspl.aux > $x.aux
+	cat tspl.rfm > $x.rfm
+	cat tspl.idx > $x.idx
+	touch $(x).prefirstrun
+
+$(x).secondrun: $(x).presecondrun
+$(x).presecondrun: $(x).firstrun
+	cat tspl.aux >> $x.aux
+	cat tspl.rfm >> $x.rfm
+	echo '(summary-make "$x")' | $(Scheme) setup.ss summary.ss
+	cat tspl.idx >> $x.idx
+	touch $(x).presecondrun
+
+$(x).thirdrun: $(x).prethirdrun canned/cisco-logo.png
+$(x).prethirdrun: $(x).secondrun
+	cat tspl.aux >> $x.aux
+	cat tspl.rfm >> $x.rfm
+	echo '(summary-make "$x")' | $(Scheme) setup.ss summary.ss
+	cat tspl.idx >> $x.idx
+	touch $(x).prethirdrun
+
+$(x).hfirstrun: $(x).hprefirstrun csug8.hcls
+$(x).hprefirstrun: $(x).thirdrun tspl.haux in.hidx
+	cat tspl.aux >> $x.aux
+	cat tspl.rfm >> $x.rfm
+	cat tspl.idx >> $x.idx
+	cat tspl.haux > $x.haux
+	touch $(x).hprefirstrun
+
+$(x).hsecondrun: $(x).hpresecondrun
+$(x).hpresecondrun: $(x).hfirstrun
+	cat tspl.haux >> $x.haux
+	touch $(x).hpresecondrun
+
+$(x).hthirdrun: $(x).hprethirdrun
+$(x).hprethirdrun: $(x).hsecondrun
+	cat tspl.haux >> $x.haux
+	touch $(x).hprethirdrun
+
+$(x).prefirstrun: $(texsrc) csug8.cls csug810.clo
+
+$(x).firstrun: scheme.sty
+
+tspl.aux: ${TSPL}/tspl.aux
+	cat ${TSPL}/*.aux | grep '\\newlabel' | \
+         sed -e 's/\\newlabel{\(.*\){\([^}]*\)}}/\\newlabel{TSPL:\1{t\2}}/' > tspl.aux
+
+tspl.haux: ${TSPL}/tspl.haux
+	sed -e 's/(putprop (quote /(putprop (quote |TSPL|:/' ${TSPL}/tspl.haux | \
+         sed -e 's;url) ";url) "http://scheme.com/${TSPL}/;' > tspl.haux
+
+tspl.rfm: ${TSPL}/tspl.rfm
+	sed -e 's/\\pageref{/\\pageref{TSPL:/' ${TSPL}/tspl.rfm > tspl.rfm
+
+# this version leaves tspl entries out of the printed index
+#tspl.idx:
+#	echo -n > tspl.idx
+
+# this version includes tspl entries in the printed index
+tspl.idx: ${TSPL}/tspl.idx
+	sed -e 's/{\([1-9][0-9]*\)}$$/{t\1}/' ${TSPL}/tspl.idx | \
+         sed -e 's/{\([ivx][ivx]*\)}$$/{t\1}/' > tspl.idx
+
+in.hidx: ${TSPL}/out.hidx
+	sed -e 's;"\(.*\)\.html#;"http://scheme.com/${TSPL}/\1.html#;' ${TSPL}/out.hidx | \
+         sed -e 's/"")$$/"t")/' > in.hidx
+
+$(texsrc): tspl4-prep.stex priminfo.ss ../s/primdata.ss
+
+checklibs: $(x).thirdrun
+	sort libsrecorded | uniq > libsrecorded.sort
+	sort libslisted | uniq > libslisted.sort
+	diff libsrecorded.sort libslisted.sort
+
+code: $(stexsrc)
+	extract.pl $(stexsrc) > code
+	echo '(load "code" pretty-print)' | $(Scheme) -q
+
+$(x).clean:
+	-rm -f $(x).rfm $(x).sfm $(x).prefirstrun $(x).presecondrun\
+                    $(x).prethirdrun $(x).ans\
+                    $(x).hprefirstrun $(x).hpresecondrun $(x).hprethirdrun\
+                    tspl.aux tspl.haux tspl.rfm tspl.idx in.hidx\
+                    libsrecorded{,.sort} libslisted{,.sort}\
+                    code
+
+$(x).reallyclean:
+
+$(x).reallyreallyclean:
diff --git a/makefiles/Makefile-release_notes.in b/makefiles/Makefile-release_notes.in
new file mode 100644
index 0000000..64348a4
--- /dev/null
+++ b/makefiles/Makefile-release_notes.in
@@ -0,0 +1,55 @@
+m = $(m)
+Scheme=../$m/bin/$m/scheme -b ../$m/boot/$m/petite.boot -b ../$m/boot/$m/scheme.boot
+STEXLIB=../stex
+installdir=/tmp/csv9
+INSTALL=../$m/installsh
+
+# define default document pathname here
+# override on command line with 'make x=newdoc'
+x = release_notes
+
+# define latex processor: latex or pdflatex
+latex = pdflatex
+
+# define stex macro files here
+stexmacrofiles =
+
+# list bibliography files here
+bib =
+
+# define index if an index is to be generated
+# index=yes
+
+include $(STEXLIB)/Mf-stex
+
+# define or override suffixes here
+
+# define any additional targets here
+
+install: $x.pdf $x.html
+	$(INSTALL) -m 2755 -d $(installdir)
+	$(INSTALL) -m 0644 --ifdiff $x.html $x.pdf $(installdir)
+	$(INSTALL) -m 0644 --ifdiff releasenotes.css $(installdir)
+	(X=`echo canned/*` ;\
+         if [ "$$X" != "canned/*" ] ; then\
+           $(INSTALL) -m 2755 -d $(installdir)/canned ;\
+           $(INSTALL) -m 0644 --ifdiff canned/* $(installdir)/canned ;\
+         fi)
+	$(INSTALL) -m 2755 -d $(installdir)/gifs
+	$(INSTALL) -m 0644 --ifdiff gifs/*.gif $(installdir)/gifs
+	$(INSTALL) -m 2755 -d $(installdir)/math
+	-rm -rf $(installdir)/$(mathdir)
+	$(INSTALL) -m 2755 -d $(installdir)/$(mathdir)
+	if [ -e $(mathdir)/0.gif ] ; then $(INSTALL) -m 0644 $(mathdir)/*.gif $(installdir)/$(mathdir) ; fi
+
+# define any dependencies here
+
+$(x).firstrun: macros.tex
+
+# define cleanup targets here:
+
+$(x).clean:
+
+$(x).reallyclean:
+
+$(x).reallyreallyclean:
diff --git a/makefiles/Makefile-workarea.in b/makefiles/Makefile-workarea.in
new file mode 100644
index 0000000..e330fd7
--- /dev/null
+++ b/makefiles/Makefile-workarea.in
@@ -0,0 +1,70 @@
+# Makefile-workarea.in
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+MAKEFLAGS += --no-print-directory
+PREFIX=
+
+.PHONY: build
+build:
+	(cd c && $(MAKE))
+	(cd s && $(MAKE) bootstrap)
+
+.PHONY: install
+install: build
+	$(MAKE) -f Mf-install
+
+.PHONY: uninstall
+uninstall:
+	$(MAKE) -f Mf-install uninstall
+
+.PHONY: test
+test: build
+	(cd mats && $(MAKE) allx)
+	@echo "test run complete.  check $(PREFIX)mats/summary for errors."
+
+.PHONY: coverage
+coverage:
+	rm -f s/bootstrap
+	(cd c && $(MAKE))
+	(cd s && $(MAKE) bootstrap p=t c=t)
+	(cd mats && $(MAKE) allx c=t)
+
+.PHONY: bootfiles
+bootfiles: build
+	$(MAKE) -f Mf-boot
+
+.PHONY: bintar
+bintar: build
+	(cd bintar && $(MAKE))
+
+.PHONY: rpm
+rpm: bintar
+	(cd rpm && $(MAKE))
+
+.PHONY: pkg
+pkg: bintar
+	(cd pkg && $(MAKE))
+
+.PHONY: clean
+clean:
+	rm -f petite.1 scheme.1
+	(cd s && $(MAKE) clean)
+	(cd c && $(MAKE) clean)
+	(cd mats && $(MAKE) clean)
+	(cd examples && $(MAKE) clean)
+	(cd bintar && $(MAKE) clean)
+	(cd rpm && $(MAKE) clean)
+	(cd pkg && $(MAKE) clean)
+	rm -f Make.out
diff --git a/makefiles/Makefile.in b/makefiles/Makefile.in
new file mode 100644
index 0000000..3b3119e
--- /dev/null
+++ b/makefiles/Makefile.in
@@ -0,0 +1,92 @@
+# Makefile.in
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+MAKEFLAGS += --no-print-directory
+
+.PHONY: build
+build:
+	(cd $(workarea) && $(MAKE) build)
+
+.PHONY: run
+run:
+	env SCHEMEHEAPDIRS=$(workarea)/boot/$(m) $(workarea)/bin/$(m)/scheme
+
+.PHONY: install
+install:
+	(cd $(workarea) && $(MAKE) install)
+
+.PHONY: uninstall
+uninstall:
+	(cd $(workarea) && $(MAKE) uninstall)
+
+.PHONY: test
+test:
+	(cd $(workarea) && $(MAKE) test PREFIX=$(workarea)/)
+
+.PHONY: coverage
+coverage:
+	(cd $(workarea) && $(MAKE) coverage)
+
+.PHONY: bootfiles
+bootfiles:
+	(cd $(workarea) && $(MAKE) bootfiles)
+
+# Supply XM= to build boot files for 
+.PHONY: boot
+boot: build
+	mkdir -p boot/$(XM)
+	(cd $(workarea) && $(MAKE) -f Mf-boot $(XM).boot)
+
+# Supply ORIG= to build using existing at 
+.PHONY: from-orig
+from-orig:
+	(cd $(m)/s && $(MAKE) -f Mf-cross m=$(m) xm=$(m) base=$(ORIG)/$(m))
+	$(MAKE) build
+
+.PHONY: docs
+docs: build
+	(cd csug && $(MAKE) m=$(m))
+	(cd release_notes && $(MAKE) m=$(m))
+
+.PHONY: install-docs
+install-docs: docs
+	(cd csug && $(MAKE) install m=$(m))
+	(cd release_notes && $(MAKE) install m=$(m))
+
+.PHONY: bintar
+bintar:
+	(cd $(workarea) && $(MAKE) bintar)
+
+.PHONY: rpm
+rpm:
+	(cd $(workarea) && $(MAKE) rpm)
+
+.PHONY: pkg
+pkg:
+	(cd $(workarea) && $(MAKE) pkg)
+
+.PHONY: clean
+clean:
+	(cd $(workarea) && $(MAKE) clean)
+
+.PHONY: distclean
+distclean:
+	(cd csug && if [ -e Makefile ] ; then $(MAKE) reallyreallyclean ; fi)
+	rm -f csug/Makefile
+	(cd release_notes && if [ -e Makefile ] ; then $(MAKE) reallyreallyclean ; fi)
+	rm -f release_notes/Makefile
+	rm -rf $(workarea)
+	rm -f Makefile
+	rm -f Make.out
diff --git a/makefiles/Mf-boot.in b/makefiles/Mf-boot.in
new file mode 100644
index 0000000..a079dd5
--- /dev/null
+++ b/makefiles/Mf-boot.in
@@ -0,0 +1,28 @@
+# Mf-boot.in
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+bootfiles=$(addsuffix .boot, $(shell cd ../boot ; echo *))
+
+doit: $(bootfiles)
+
+%.boot:
+	( cd .. ; ./workarea $* xc-$* )
+	( cd ../xc-$*/s ; make -f Mf-cross base=../../$(workarea) --jobs=2 m=$(m) xm=$* )
+	for x in `echo scheme.boot petite.boot scheme.h equates.h` ; do\
+          if [ ! -h ../xc-$*/boot/$*/$$x ] ; then \
+            mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\
+          fi ;\
+        done
+	rm -rf ../xc-$*
diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in
new file mode 100644
index 0000000..db18b57
--- /dev/null
+++ b/makefiles/Mf-install.in
@@ -0,0 +1,164 @@
+# Mf-install.in
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+###############################################################################
+#               the following variables are set up by configure               #
+###############################################################################
+
+m=none
+
+# The following variables determine where the executables, boot files,
+# example programs, and manual pages are installed.
+
+# executable directory
+InstallBin=/usr/bin
+
+# library directory
+InstallLib=/usr/lib
+
+# man page directory
+InstallMan=/usr/man/man1
+
+# installation owner
+InstallOwner=
+
+# installation group
+InstallGroup=
+
+# Files are actually installed at ${TempRoot}${InstallBin},
+# ${TempRoot}${InstallLib}, and ${TempRoot}${InstallMan}.
+# This useful for testing the install process and for building
+# installation scripts
+TempRoot=
+
+# compress man pages?
+GzipManPages=yes
+
+# executable names
+InstallSchemeName=scheme
+InstallPetiteName=petite
+InstallScriptName=scheme-script
+
+# Whether to install "kernel.o" or "libkernel.a"
+InstallKernelTarget=installkernellib
+
+# Maybe install libz.a and liblz4.a by setting to "installzlib" and "installliz4"
+InstallZlibTarget=
+InstallLZ4Target=
+
+###############################################################################
+#                 no changes should be needed below this point                #
+###############################################################################
+
+Version=csv9.5.9
+Include=boot/$m
+PetiteBoot=boot/$m/petite.boot
+SchemeBoot=boot/$m/scheme.boot
+Revision=boot/$m/revision
+Scheme=bin/$m/scheme
+Petite=bin/$m/petite
+InstallLibExamples=${InstallLib}/${Version}/examples
+InstallLibBin=${InstallLib}/${Version}/$m
+
+Bin=${TempRoot}${InstallBin}
+Lib=${TempRoot}${InstallLib}/${Version}
+LibExamples=${TempRoot}${InstallLibExamples}
+LibBin=${TempRoot}${InstallLibBin}
+Man=${TempRoot}${InstallMan}
+PetitePath=${Bin}/${InstallPetiteName}
+SchemePath=${Bin}/${InstallSchemeName}
+SchemeScriptPath=${Bin}/${InstallScriptName}
+
+install: bininstall libbininstall maninstall liblibinstall ${InstallKernelTarget}
+
+uninstall:
+	rm -rf ${Lib}
+	rm -f ${PetitePath}
+	rm -f ${SchemePath}
+	rm -f ${SchemeScriptPath}
+	rm -f ${Man}/${InstallPetiteName}.1{,.gz}
+	rm -f ${Man}/${InstallSchemeName}.1{,.gz}
+
+scheme.1 petite.1: scheme.1.in
+	sed -e "s;{InstallBin};${InstallBin};g" \
+            -e "s;{InstallLibExamples};${InstallLibExamples};g" \
+            -e "s;{InstallLibBin};${InstallLibBin};g" \
+            -e "s;{InstallPetiteName};${InstallPetiteName};g" \
+            -e "s;{InstallSchemeName};${InstallSchemeName};g" \
+            -e "s;{InstallScriptName};${InstallScriptName};g" \
+            scheme.1.in > $@
+
+###############################################################################
+#                  no useful external targets below this line                 #
+###############################################################################
+
+I=./installsh -o "${InstallOwner}" -g "${InstallGroup}"
+
+bininstall: ${Bin}
+	$I -m 555 ${Scheme} ${SchemePath}
+	ln -f ${SchemePath} ${PetitePath}
+	ln -f ${SchemePath} ${SchemeScriptPath}
+
+libbininstall: ${LibBin}
+	$I -m 444 ${PetiteBoot} ${LibBin}/petite.boot
+	if [ "${InstallPetiteName}" != "petite" ]; then\
+          rm -f ${LibBin}/${InstallPetiteName}.boot;\
+          ln -f ${LibBin}/petite.boot ${LibBin}/${InstallPetiteName}.boot;\
+        fi
+	$I -m 444 ${SchemeBoot} ${LibBin}/scheme.boot;\
+	if [ "${InstallSchemeName}" != "scheme" ]; then\
+          rm -f ${LibBin}/${InstallSchemeName}.boot;\
+          ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallSchemeName}.boot;\
+        fi
+	ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallScriptName}.boot;
+	$I -m 444 ${Include}/main.o ${LibBin}
+	$I -m 444 ${Include}/scheme.h ${LibBin}
+	$I -m 444 ${Revision} ${LibBin}/revision
+
+installkernelobj: ${LibBin}
+	$I -m 444 ${Include}/kernel.o ${LibBin}
+
+installkernellib: ${LibBin} ${InstallZlibTarget} ${InstallLZ4Target}
+	$I -m 444 ${Include}/libkernel.a ${LibBin}
+
+installzlib: ${LibBin}
+	$I -m 444 zlib/libz.a ${LibBin}
+
+installlz4: ${LibBin}
+	$I -m 444 lz4/lib/liblz4.a ${LibBin}
+
+maninstall: scheme.1 petite.1 ${Man}
+	$I -m 444 scheme.1 ${Man}/${InstallSchemeName}.1
+	if [ ${GzipManPages} = yes ] ; then gzip -f ${Man}/${InstallSchemeName}.1 ; fi
+	$I -m 444 petite.1 ${Man}/${InstallPetiteName}.1
+	if [ ${GzipManPages} = yes ] ; then gzip -f ${Man}/${InstallPetiteName}.1 ; fi
+
+liblibinstall: ${LibExamples}
+	$I -m 444 examples/* ${LibExamples}
+
+${Lib}:
+	$I -d -m 755 ${Lib}
+
+${LibBin}: ${Lib}
+	$I -d -m 755 ${LibBin}
+
+${LibExamples}: ${Lib}
+	$I -d -m 755 ${LibExamples}
+
+${Bin}:
+	$I -d -m 755 ${Bin}
+
+${Man}:
+	$I -d -m 755 ${Man}
diff --git a/makefiles/installsh b/makefiles/installsh
new file mode 100755
index 0000000..95d85fb
--- /dev/null
+++ b/makefiles/installsh
@@ -0,0 +1,79 @@
+#! /bin/sh
+if [ -x /bin/true ]; then TRUE=/bin/true;
+elif [ -x /usr/bin/true ]; then TRUE=/usr/bin/true;
+elif command -v true &> /dev/null; then TRUE=true;
+else echo "Can't find /bin/true or /usr/bin/true and no true command" ; exit 1;
+fi
+
+while ${TRUE} ; do
+  mkdirs=0
+  ifdiff=0
+  
+  while [ $# -ge 0 ] ; do
+    case $1 in
+      -d) mkdirs=1 ;;
+      -o) shift; owner=$1 ;;
+      -g) shift; group=$1 ;;
+      -m) shift; mode=$1 ;;
+      --ifdiff) ifdiff=1 ;;
+      -*) break 2 ;;
+      *) break ;;
+    esac
+    shift
+  done
+  
+  if [ $mkdirs -eq 1 ] && [ $ifdiff -eq 1 ] ; then
+    break
+  fi
+
+  if [ $mkdirs -eq 1 ] ; then
+    dirs=$*
+  
+    for dir in $dirs ; do
+      stack=""
+      while [ "$dir" != "/" -a "$dir" != "." -a "$dir" != ".." ] ; do
+        stack="$dir $stack"
+        dir=`dirname $dir`
+      done
+
+      for dir in $stack ; do
+        if [ ! -d $dir ] ; then
+          if mkdir $dir ; then
+            if [ "$owner" != "" ] ; then chown $owner $dir ; fi
+            if [ "$group" != "" ] ; then chgrp $group $dir ; fi
+            if [ "$mode" != "" ] ; then chmod $mode $dir ; fi
+          fi
+        fi
+      done
+    done
+  else
+    nargs=$#
+    if [ $nargs -lt 2 ] ; then break ; fi
+    
+    files=""
+    while [ $# -ne 1 ] ; do
+      files="$files $1"
+      shift
+    done
+    dest=$1
+    
+    if [ ! -d $dest -a $nargs -ne 2 ] ; then break ; fi
+  
+    for file in $files ; do
+      destfile=$dest
+      if [ -d $destfile ] ; then destfile=$destfile/`basename $file` ; fi
+      if [ $ifdiff -eq 1 ] && cmp -s $file $destfile || cp -f -p $file $destfile ; then
+        if [ "$owner" != "" ] ; then chown $owner $destfile ; fi
+        if [ "$group" != "" ] ; then chgrp $group $destfile ; fi
+        if [ "$mode" != "" ] ; then chmod $mode $destfile ; fi
+      fi
+    done
+  fi
+  
+  exit 0
+done
+
+echo "usage: $0 [ -o owner] [ -g group ] [ -m mode ] [ --ifdiff] file dest"
+echo "       $0 [ -o owner] [ -g group ] [ -m mode ] [ --ifdiff] file file ... dir"
+echo "       $0 -d [ -o owner] [ -g group ] [ -m mode ] dir dir ..."
+exit 1
diff --git a/mats/3.ms b/mats/3.ms
new file mode 100644
index 0000000..d8a3021
--- /dev/null
+++ b/mats/3.ms
@@ -0,0 +1,2310 @@
+;;; 3.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-syntax matrest
+  (lambda (x)
+    (define matrest-argerr-test
+      (lambda (ls)
+        (if (null? ls)
+            '()
+            (cons (with-syntax (((n ...) (make-list (length (cdr ls)) 1)))
+                    (syntax (error? (matrestf n ...))))
+                  (matrest-argerr-test (cdr ls))))))
+    (define iota
+      (lambda (i n)
+        (if (= i n)
+            '()
+            (cons i (iota (+ i 1) n)))))
+    (define matrest-test
+      (lambda (n ls)
+        (let* ((m (length ls)) (n (+ n m)))
+          (let f ((n n))
+            (if (< n m)
+                '()
+                (cons (with-syntax (((x ...) (iota 0 m))
+                                    ((y ...) (iota m n)))
+                        (syntax (equal? (matrestf x ... y ...)
+                                        '(y ...))))
+                      (f (- n 1))))))))
+    (syntax-case x ()
+      ((k n)
+       (let ((n (datum n)))
+         (with-syntax (((g ...) (generate-temporaries (make-list n)))
+                       (name (datum->syntax (syntax k)
+                               (string->symbol (format "matrest~s" n)))))
+           (with-syntax (((at ...) (matrest-argerr-test (syntax (g ...))))
+                         ((t ...) (matrest-test 10 (syntax (g ...)))))
+             (syntax
+                (mat name
+                  (begin (define (matrestf g ... . r) r) #t)
+                  at ...
+                  t ...
+                  )))))))))
+
+(matrest 0)
+(matrest 1)
+(matrest 2)
+(matrest 3)
+(matrest 4)
+(matrest 5)
+(matrest 6)
+(matrest 7)
+(matrest 8)
+(matrest 9)
+(matrest 10)
+
+(mat application
+   (error? ((list '(a b c))))
+ )
+
+(mat lambda
+    (let ((f (lambda () 'a))) (eq? (f) 'a))
+    (let ((f (lambda (x) x))) (eq? (f 'a) 'a))
+    (let ((f (lambda x x)))
+        (and (equal? (f) '())
+             (equal? (f 1) '(1))
+             (equal? (f 1 2) '(1 2))
+             (equal? (f 1 2 3 4 5 6 7) '(1 2 3 4 5 6 7))))
+    (let ((f (lambda (x y) (cons x y)))) (equal? (f 1 2) '(1 . 2)))
+    (let ((f (lambda (x . y) (cons x y))))
+        (and (equal? (f 1) '(1))
+             (equal? (f 1 2) '(1 2))
+             (equal? (f 1 2 3) '(1 2 3))
+             (equal? (f 1 2 3 4 5 6 7) '(1 2 3 4 5 6 7))))
+    (let ((f (lambda (x y z) (list x y z)))) (equal? (f 1 2 3) '(1 2 3)))
+    (let ((f (lambda (x y . z) (cons x (cons y z)))))
+        (and (equal? (f 1 2) '(1 2))
+             (equal? (f 1 2 3) '(1 2 3))
+             (equal? (f 1 2 3 4) '(1 2 3 4))
+             (equal? (f 1 2 3 4 5 6 7) '(1 2 3 4 5 6 7))))
+    (let ((f (lambda (x y) (set! x 3) (cons x y))))
+        ;see if there is an implicit "begin"
+        (equal? (f 1 2) '(3 . 2)))
+    (eqv?
+      (let ((f (case-lambda
+                 ((x) (+ x 1))
+                 ((x . xs) (cons (+ x 2) xs))
+                 (xs 0))))
+         (f))
+      0)
+ )
+
+(mat case-lambda
+    (procedure? (case-lambda))
+    (error? ((case-lambda)))
+    (error? (let ((f (case-lambda))) (f 3 4 5)))
+    (begin
+      (define foo (case-lambda [() 0] [(a b c) 3]))
+      (eq? (foo 1 2 3) 3))
+    (eq? (foo) 0)
+    (error? (foo 1))
+    (error? (foo 1 2))
+    (error? (foo 1 2 3 4))
+    (begin
+      (define foo (case-lambda [(a b c) 3] [() 0]))
+      (eq? (foo 1 2 3) 3))
+    (eq? (foo) 0)
+    (error? (foo 1))
+    (error? (foo 1 2))
+    (error? (foo 1 2 3 4))
+    (begin
+      (define foo (case-lambda [() 0] [(a) 1] [args 2]))
+      (eq? (foo 1 2 3) 2))
+    (eq? (foo) 0)
+    (eq? (foo 1) 1)
+    (begin
+      (define foo (case-lambda [() 0] [(a) 1] [(a b c . args) 3]))
+      (eq? (foo 1 2 3) 3))
+    (eq? (foo) 0)
+    (eq? (foo 1) 1)
+    (error? (foo 1 2))
+    (begin
+      (define foo (case-lambda [() 0] [args 1] [(a b c . args) 3]))
+      (and (eq? (foo 1 2 3) 1)
+           (eq? (foo 1 2) 1)
+           (eq? (foo 1) 1)
+           (eq? (foo) 0)))
+ )
+
+(mat let
+    (let ((x 'a)) (eq? x 'a))
+    (let ((x 'a)) (let ((x 'b)) (eq? x 'b)))
+    (let ((x 'a) (y 'b)) (equal? (cons x y) '(a . b)))
+    (let ((x 'a))
+        ;test for implicit "begin"
+        (let ((y 'b)) #f (set! x y))
+        (eq? x 'b))
+    ((lambda (x) (eq? x 'a)) 'a)
+    ((lambda (x . r) (eq? x 'a)) 'a)
+    ((lambda r (eq? (car r) 'a)) 'a)
+    (error? ((lambda (x . r) (eq? x 'a))))
+ )
+
+(mat let*
+    (let* ((x 'a)) (eq? x 'a))
+    (let* ((x (cons 1 2)) (y x)) (eq? x y))
+    (let ((x 1) (y 2)) (let* ((x 10) (y 12)) (equal? (cons x y) '(10 . 12))))
+    (let* ((x 'a))
+        ;test for implicit "begin"
+        (let* ((y 'b)) #f (set! x y))
+        (eq? x 'b))
+ )
+
+(mat letrec
+    (letrec ((f (lambda () x)) (x (cons 1 2))) (eq? (f) x))
+    (letrec ((f (lambda () g)) (g (lambda () f)))
+        (and (eq? (f) g) (eq? (g) f)))
+    (letrec ((f (lambda (x) (if (zero? x) 'odd (g (1- x)))))
+             (g (lambda (x) (if (zero? x) 'even (f (1- x))))))
+      (and
+        (eq? (g 10) 'even)
+        (eq? (g 13) 'odd)
+        (eq? (f 13) 'even)))
+    (letrec ((x 'a))
+        ;test for implicit "begin"
+        (letrec ((y 'b)) #f (set! x y))
+        (eq? x 'b))
+    #;(eqv? (letrec ((v 0) (k (call/cc (lambda (x) x)))) ; invalid in r6rs
+             ; david carlton's bug
+             (set! v (+ v 1))
+             (k (lambda (x) v)))
+          1)
+    #;(eqv? (letrec ((k (call/cc (lambda (x) x))) (v 0)) ; invalid in r6rs
+             ; david carlton's bug
+             (set! v (+ v 1))
+             (k (lambda (x) v)))
+          1)
+    #;(eqv? (letrec* ((v 0) (k (call/cc (lambda (x) x)))) ; invalid in r6rs
+             ; variation on david carlton's "bug"
+             (set! v (+ v 1))
+             (k (lambda (x) v)))
+          2)
+    #;(eqv? (letrec* ((k (call/cc (lambda (x) x))) (v 0)) ; invalid in r6rs
+             ; another variation on david carlton's "bug"
+             (set! v (+ v 1))
+             (k (lambda (x) v)))
+          1)
+   ; testing for named-let equivalents
+   (eqv? (letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (1- x))))))) (f 5))
+         120)
+   (letrec ((f (lambda (x) (if (zero? x) #t (f (1- x)))))) (f 10000))
+   (letrec ((f (lambda (x y) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))))
+     (f 10 0))
+   (eqv? (letrec ((f (lambda (x) (if (= x 0) 1 (+ (f (- x 1)) 1))))) (f 10)) 11)
+   (eqv? (let ([base 20])
+           (letrec ((f (lambda (x)
+                         (if (= x 0) base
+                             (+ (f (- x 1)) 1)))))
+             (f 10)))
+         30)
+   (error? (letrec ((x (lambda (x) x))) (f 3 4)))
+   (eq? (letrec ((f (lambda (x) (if x (list (f x)) 0)))) (f #f)) 0)
+   (equal? (letrec ((f (lambda (x) (if x (list (f (not x))) 0)))) (f #t)) '(0))
+   (equal? (letrec ((f (lambda (x) (if x (list (g x)) 0)))
+                    (g (lambda (x) (f #f))))
+             (f #t))
+     '(0))
+   (equal? (letrec ((f (lambda (x) (if x (list (g (not x))) 0)))
+                    (g (lambda (x) (f x))))
+             (g #t))
+     '(0))
+  (error? (letrec ([a 3] [b a]) (+ a b)))
+ ; shouldn't get warnings for these if valid-check algorithm is working
+ ; properly
+  (procedure? (letrec ([bar (letrec ([f (lambda (x) f)]) f)]) bar))
+  (eqv?
+    (letrec ([fllog 3] [flacosh (or values (lambda (x) fllog))]) (flacosh 4))
+    4)
+  (eqv?
+    (let ()
+      (define $b #t)
+      (letrec ([fllog 3] [flacosh (if $b (lambda (x) fllog) values)])
+        (flacosh 4)))
+    3)
+  (equal?
+    (letrec ([a 3] [b (#2%cons (lambda () a) (lambda (x) (set! a x)))])
+      ((cdr b) 17)
+      (list a ((car b))))
+    '(17 17))
+  #;(pair?
+    (member
+      (letrec ([k (call/cc (lambda (k) k))] ; invalid in r6rs
+               [f (let ([n 0]) (lambda (a) (set! n (+ n 1)) n))])
+        (f (void))
+        (let ([m (k f)])
+          (list (eq? k f) m (f (void)))))
+      '((#f 2 2) (#t 3 4))))
+  (error? (letrec ([a (set! b 0)] [b 3]) 17))
+ ; test strongly connected components algorithm used by cpletrec
+  (equal?
+    (letrec ([f0 (lambda (x) (f4 (cons 0 x)))]
+             [f1 (lambda (x)
+                   (if (fx> (length x) 10)
+                       x
+                       (f3 (f4 (cons 1 x)))))]
+             [f2 (lambda (x) (f3 (cons 2 x)))]
+             [f3 (lambda (x) (f1 (cons 3 x)))]
+             [f4 (lambda (x) (f1 (f2 (cons 4 x))))])
+      (apply
+        (lambda (t0 t1 t2 t3 t4)
+          (set! f0 (values t0))
+          (set! f1 (values t1))
+          (set! f2 (values t2))
+          (set! f3 (values t3))
+          (set! f4 (values t4)))
+        (list f0 f1 f2 f3 f4))
+      (f0 '()))
+    '(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
+  (equal?
+    (letrec ([f0 (list (lambda (x) ((car f4) (cons 0 x))))]
+             [f1 (list (lambda (x)
+                         (if (fx> (length x) 10)
+                             x
+                             ((car f3) ((car f4) (cons 1 x))))))]
+             [f2 (list (lambda (x) ((car f3) (cons 2 x))))]
+             [f3 (list (lambda (x) ((car f1) (cons 3 x))))]
+             [f4 (list (lambda (x) ((car f1) ((car f2) (cons 4 x)))))])
+      ((car f0) '()))
+    '(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
+ )
+
+(mat letrec*
+    (letrec* ((f (lambda () x)) (x (cons 1 2))) (eq? (f) x))
+    (letrec* ((f (lambda () g)) (g (lambda () f)))
+        (and (eq? (f) g) (eq? (g) f)))
+    (letrec* ((f (lambda (x) (if (zero? x) 'odd (g (1- x)))))
+              (g (lambda (x) (if (zero? x) 'even (f (1- x))))))
+      (and
+        (eq? (g 10) 'even)
+        (eq? (g 13) 'odd)
+        (eq? (f 13) 'even)))
+    (letrec* ((x 'a))
+        ;test for implicit "begin"
+        (letrec ((y 'b)) #f (set! x y))
+        (eq? x 'b))
+    #;(eqv? (letrec* ((v 0) (k (call/cc (lambda (x) x)))) ; invalid in r6rs
+             ; variation on david carlton's "bug"
+             (set! v (+ v 1))
+             (k (lambda (x) v)))
+          2)
+    #;(eqv? (letrec* ((k (call/cc (lambda (x) x))) (v 0)) ; invalid in r6rs
+             ; another variation on david carlton's "bug"
+             (set! v (+ v 1))
+             (k (lambda (x) v)))
+          1)
+   ; testing for named-let equivalents
+   (eqv? (letrec* ((f (lambda (x) (if (zero? x) 1 (* x (f (1- x))))))) (f 5))
+         120)
+   (letrec* ((f (lambda (x) (if (zero? x) #t (f (1- x)))))) (f 10000))
+   (letrec* ((f (lambda (x y) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))))
+     (f 10 0))
+   (eqv? (letrec* ((f (lambda (x) (if (= x 0) 1 (+ (f (- x 1)) 1))))) (f 10)) 11)
+   (eqv? (let ([base 20])
+           (letrec* ((f (lambda (x)
+                         (if (= x 0) base
+                             (+ (f (- x 1)) 1)))))
+             (f 10)))
+         30)
+   (error? (letrec* ((x (lambda (x) x))) (f 3 4)))
+   (eq? (letrec* ((f (lambda (x) (if x (list (f x)) 0)))) (f #f)) 0)
+   (equal? (letrec* ((f (lambda (x) (if x (list (f (not x))) 0)))) (f #t)) '(0))
+   (equal? (letrec* ((f (lambda (x) (if x (list (g x)) 0)))
+                    (g (lambda (x) (f #f))))
+             (f #t))
+     '(0))
+   (equal? (letrec* ((f (lambda (x) (if x (list (g (not x))) 0)))
+                    (g (lambda (x) (f x))))
+             (g #t))
+     '(0))
+  (equal? (letrec* ((x 3) (y x)) (+ x y)) 6)
+  (equal?
+    (parameterize ([internal-defines-as-letrec* #t])
+      (eval '(let ()
+               (define x 3)
+               (define y x)
+               (+ x y))))
+    6)
+  (error? (letrec* ((y x) (x 3)) (+ x y)))
+  (error? (letrec* ((x x)) x))
+ ; shouldn't get warnings for these if valid-check algorithm is working
+ ; properly
+  (procedure? (letrec* ([bar (letrec* ([f (lambda (x) f)]) f)]) bar))
+  (eqv?
+    (letrec* ([fllog 3] [flacosh (or values (lambda (x) fllog))]) (flacosh 4))
+    4)
+  (eqv?
+    (let ()
+      (define $b #t)
+      (letrec* ([fllog 3] [flacosh (if $b (lambda (x) fllog) values)])
+        (flacosh 4)))
+    3)
+  (equal?
+    (letrec* ([a 3] [b (#2%cons (lambda () a) (lambda (x) (set! a x)))])
+      ((cdr b) 17)
+      (list a ((car b))))
+    '(17 17))
+  (equal?
+    (letrec* ([f (let ([n 0]) (lambda () (set! n (+ n 1)) n))])
+      (letrec* ([x (f)] [y (f)])
+        (list x y)))
+    '(1 2))
+  (error? (letrec* ([a (set! b 0)] [b 3]) 17))
+  (eqv? (letrec* ([b 3] [a (set! b 0)]) 17) 17)
+  #;(equal?
+    (letrec* ([k (call/cc (lambda (k) k))] ; invalid in r6rs
+              [f (let ([n 0]) (lambda (a) (set! n (+ n 1)) n))])
+      (f (void))
+      (let ([m (k f)])
+        (list (eq? k f) m (f (void)))))
+    '(#f 2 2))
+  #;(equal?
+    (letrec* ([f (let ([n 0]) (lambda (a) (set! n (+ n 1)) n))]
+              [k (call/cc (lambda (k) k))]) ; invalid in r6rs
+      (f (void))
+      (let ([m (k f)])
+        (list (eq? k f) m (f (void)))))
+    '(#t 3 4))
+
+ ; make sure letrec* doesn't treat global or local assignable
+ ; variables simple
+  (begin
+    (define $frodo)
+    (letrec* ([merry 'merry]
+              [ignore (set! $frodo (lambda () pippin))]
+              [pippin (#3%cons $frodo $frodo)])
+      (void))
+    (eq? (car ($frodo)) $frodo))
+  (begin
+    (define $frodo)
+    (letrec* ([merry 'merry]
+              [ignore (set! $frodo (lambda () pippin))]
+              [pippin $frodo])
+      (void))
+    (eq? ($frodo) $frodo))
+  (let ([$frodo #f])
+    (letrec* ([merry 'merry]
+              [ignore (set! $frodo (lambda () pippin))]
+              [pippin $frodo])
+      (void))
+    (eq? ($frodo) $frodo))
+
+ ; similarly, make sure letrec* doesn't reorder primitives that can
+ ; observe effects of other expressions
+  (equal?
+    (letrec* ([t (cons 'a 'b)]
+              [f (lambda () y)]
+              [x (begin (set-car! t 'c) (car t))]
+              [p (car t)]
+              [g (lambda () x)]
+              [y (begin (set-car! t 'd) (car t))]
+              [q (car t)])
+      (list t p q x y (f) (g)))
+    `((d . b) c d c d d c))
+
+  (equal?
+    (letrec* ([t (gensym)]
+              [f (lambda () y)]
+              [x (list (putprop t 'ham f))]
+              [p (property-list t)]
+              [g (lambda () x)]
+              [y (list (putprop t 'spam g))]
+              [q (property-list t)])
+      (list
+        (equal? p (list 'ham f))
+        (or (equal? q (list 'ham f 'spam g))
+            (equal? q (list 'spam g 'ham f)))
+        (procedure? f)
+        (procedure? g)
+        x
+        y))
+    `(#t #t #t #t (,(void)) (,(void))))
+ ; test strongly connected components algorithm used by cpletrec
+  (equal?
+    (letrec* ([f0 (lambda (x) (f4 (cons 0 x)))]
+              [f1 (lambda (x)
+                    (if (fx> (length x) 10)
+                        x
+                        (f3 (f4 (cons 1 x)))))]
+              [f2 (lambda (x) (f3 (cons 2 x)))]
+              [f3 (lambda (x) (f1 (cons 3 x)))]
+              [f4 (lambda (x) (f1 (f2 (cons 4 x))))])
+      (apply
+        (lambda (t0 t1 t2 t3 t4)
+          (set! f0 (values t0))
+          (set! f1 (values t1))
+          (set! f2 (values t2))
+          (set! f3 (values t3))
+          (set! f4 (values t4)))
+        (list f0 f1 f2 f3 f4))
+      (f0 '()))
+    '(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
+  (equal?
+    (letrec* ([f0 (list (lambda (x) ((car f4) (cons 0 x))))]
+              [f1 (list (lambda (x)
+                          (if (fx> (length x) 10)
+                              x
+                              ((car f3) ((car f4) (cons 1 x))))))]
+              [f2 (list (lambda (x) ((car f3) (cons 2 x))))]
+              [f3 (list (lambda (x) ((car f1) (cons 3 x))))]
+              [f4 (list (lambda (x) ((car f1) ((car f2) (cons 4 x)))))])
+      ((car f0) '()))
+    '(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
+ )
+
+(mat dipa-letrec ; from Dipa Sarkar
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)] [b (a)] [c (cons 1 2)]) b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)]
+              [b (let ([d a]) (d))]
+              [c (cons 1 2)])
+      b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (let ([d (lambda () c)]) (d))]
+              [b a]
+              [c (cons 1 2)])
+      b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a
+               (letrec* ([b (lambda () c)] [d (b)] [c (cons 1 2)]) d)])
+      a))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)]
+              [b (lambda (f) (f))]
+              [d (b a)]
+              [c (cons 1 2)])
+      d))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)]
+              [b (lambda () a)]
+              [d ((b))]
+              [c (cons 1 2)])
+      d))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () (set! c d))]
+              [b (a)]
+              [c (cons 1 2)])
+      b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () (set! d c))]
+              [b (a)]
+              [c (cons 1 2)])
+      d))
+  
+  (equal?
+    (letrec* ([a (lambda () c)]
+              [b (if #t a (a))]
+              [c (cons 1 2)])
+      (b))
+    '(1 . 2))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)]
+              [b (if #t (a) a)]
+              [c (cons 1 2)])
+      b))
+  
+  (error? ; undefined variable a
+    (letrec ([a (letrec* ([b (lambda () a)]) (b))]
+             [c (cons 1 2)])
+      (cons a c)))
+  
+  (error? ; undefined variable a
+    (letrec ([a (lambda () c)]
+             [b (lambda () a)]
+             [c ((b))]
+             [d (cons 1 2)])
+      d))
+  
+  (error? ; undefined variable a
+    (letrec ([a (lambda () b)][b (lambda () c)][c (a)]) c))
+  
+  (error? ; undefined variable a
+    (letrec ([a
+              (letrec* ([b (lambda () c)] [c (cons 1 2)]) (b))]
+             [d a])
+      d))
+  
+  (error? ; undefined variable a
+    (letrec ([a (let ([x 0])(lambda () x))][b (let ([y 2]) (* y (a)))]) b))
+  
+  (error? ; undefined variable c
+    (letrec ([a (letrec* ([b (lambda () c)] [d c]) (b))]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)]) (cons (m) n))))
+  
+  (error? ; undefined variable c
+    (letrec ([a (letrec* ([b (lambda () c)] [d c]) b)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)]) (cons (m) n))))
+  
+  (equal?
+    '((3 . 4) 3 . 4)
+    (letrec ([a (letrec* ([b (lambda () c)] [d 0]) b)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)]) (cons (m) n))))
+  
+  (equal?
+    '((1 . 2) (3 . 4) 3 . 4)
+    (letrec ([a (letrec* ([b (lambda () (lambda () c))] [d (b)]) d)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)])
+        (cons c (cons (m) n)))))
+  
+  (error? ; undefined variable b
+    (letrec ([a
+              (letrec ([b (lambda () (lambda () c))] [d (b)]) d)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)])
+        (cons c (cons (m) n)))))
+  
+  (error? ; undefined variable b
+    (letrec ([a (letrec ([b (lambda () (lambda () c))] [d ((b))]) d)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)])
+        (cons c (cons (m) n)))))
+  
+  (error? ; undefined variable c
+    (letrec ([a (letrec* ([b (lambda () (lambda () c))] [d ((b))]) d)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons 3 4)])
+        (cons c (cons (m) n)))))
+  
+  (equal?
+    '((1 . 2) ((1 . 2) . 4) (1 . 2) . 4)
+    (letrec ([a (letrec* ([b (lambda () (lambda () c))] [d (b)]) d)]
+             [c (cons 1 2)])
+      (letrec* ([m (lambda () n)] [n (cons c 4)])
+        (cons (a) (cons (m) n)))))
+  
+  (equal? '(1 . 2)
+    (letrec* ([m (let ([f (lambda () n)]) f)][n (cons 1 2)]) n))
+  
+  (error? ; undefined variable n
+    (letrec* ([m (let ([f (lambda () n)]) (f))]
+              [n (cons 1 2)])
+      n))
+  
+  (eqv? #f
+   (letrec* ([a (lambda (n) (n 0))]
+             [b (a (lambda (x) (if (zero? x) #f c)))]
+             [c #t])
+     b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda (n) (n 0))]
+              [b (a (lambda (x) (if (zero? x) c #f)))]
+              [c #t])
+      b))
+  
+  (error? ; undefined variable a
+    (letrec ([a (letrec ([b (letrec ([c (lambda () a)]) (c))])
+                  (lambda () b))])
+      ((lambda () c))))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda (f g) (f g))][b (lambda (x) c)][c (b b)]) (list a b c)))
+  
+  (error? ; undefined variable m
+    (letrec ([m (lambda (x) (cons n x))] [n ((lambda () m))])
+      (m '())))
+  
+  (error? ; undefined variable a
+    (letrec ([a (lambda () 0)]
+             [b (zero? (a))]
+             [c (if b (a) a)])
+      c))
+  
+  (error? ; undefined variable y
+    (letrec ([x (lambda () y)] [y (lambda (f) (f))] [z (y (lambda () (x)))])
+      (z (lambda () 3))))
+  
+  (eq? 3
+    (letrec* ([x (lambda (f) (f))]
+              [y (lambda () x)]
+              [z (x y)])
+      (z (lambda () 3))))
+  
+  (eq? 3
+    (letrec ([x (lambda (f) (f))]
+             [y (lambda () x)]
+             [z (lambda () (x y))])
+      ((z) (lambda () 3))))
+  
+  #;(error? ; undefined variable y
+    (letrec ([x (lambda () y)]
+             [y (lambda (f) (f))]
+             [z (call/cc (lambda (k) (y (lambda () (x)))))]) ; invalid in r6rs
+      ((z) (lambda () 3))))
+  
+  #;(eq? 3
+       (letrec ([x (lambda (f) (f))]
+                [y (lambda () x)]
+                [z (call/cc (lambda (k) (lambda () (x y))))]) ; invalid in r6rs
+         ((z) (lambda () 3))))
+  
+  (error? ; undefined variable a
+    (letrec ([a 3]
+             [b (letrec* ([c (lambda () a)] [d (c)]) (* d d))])
+      (* a b)))
+  
+  (error? ; undefined variable a
+    (letrec ([a 3]
+             [b (letrec* ([c (lambda () (lambda () a))] [d (c)])
+                  (* (d) (d)))])
+      (* a b)))
+  
+  (eq? 9
+       (letrec ([a 3] [b (letrec* ([c (lambda () (lambda () a))] [d (c)]) d)])
+         (* a (b))))
+  
+  (eq? 27
+       (letrec ([a 3]
+          [b (lambda () (letrec* ([c (lambda () (lambda () a))]
+                [d (c)])
+               (* (d) (d))))])
+         (* a (b))))
+  
+  
+  #;(error? ; undefined variable b
+    (letrec* ([a (call/cc (lambda (k) (lambda (n) (if (zero? n) k b))))]
+              [b ((a 0) (a 10))]) ; invalid in r6rs
+      b))
+)
+
+(mat cpvalid
+  (error? (letrec ([a (lambda () c)] [b (a)] [c 4]) b))
+  (error? (letrec* ([a (lambda () c)] [b (a)] [c 4]) b))
+  (error? (letrec ([f (lambda () (g))] [h (f)] [g (lambda () 3)]) h))
+  (error? (letrec* ([f (lambda () (g))] [h (f)] [g (lambda () 3)]) h))
+  (error? (letrec ([a (set! b 0)] [b 3]) b))
+  (error? (letrec ([b 3] [a (set! b 723)]) b))
+  (error? (letrec* ([a (set! b 0)] [b 3]) b))
+  (eqv? (letrec* ([b 3] [a (set! b 723)]) b) 723)
+  (error? (letrec ([a (lambda () c)]
+                   [b (let ((f (lambda () (a)))) (f))]
+                   [c 44])
+            (list (a) b c)))
+  (error? (letrec* ([a (lambda () c)]
+                    [b (let ((f (lambda () (a)))) (f))]
+                    [c 44])
+            (list (a) b c)))
+  (error? (letrec ([a (lambda () c)]
+                   [b (let ((f (lambda () a))) (f))]
+                   [c 44])
+            (list (a) (b) c)))
+  (equal? (letrec* ([a (lambda () c)]
+                    [b (let ((f (lambda () a))) (f))]
+                    [c 44])
+            (list (a) (b) c))
+          '(44 44 44))
+  (equal? (letrec ([a (cons (lambda () b) (lambda () c))]
+                   [b (cons (lambda () a) (lambda () c))]
+                   [c (cons (lambda () a) (lambda () b))]
+                   [d (list (lambda () d))])
+            (map pair? (list ((car a)) ((cdr b)) c ((car d)))))
+          '(#t #t #t #t))
+  (equal? (letrec* ([a (cons (lambda () b) (lambda () c))]
+                    [b (cons (lambda () a) (lambda () c))]
+                    [c (cons (lambda () a) (lambda () b))]
+                    [d (list (lambda () d))])
+            (map pair? (list ((car a)) ((cdr b)) c ((car d)))))
+          '(#t #t #t #t))
+  (error? (letrec ([a (letrec ([b (lambda () (c))]
+                               [c (lambda () a)]
+                               [d (lambda () (b))])
+                        (d))])
+            (a 55)))
+  (error? (letrec ([a (letrec* ([b (lambda () (c))]
+                                [c (lambda () a)]
+                                [d (lambda () (b))])
+                        (d))])
+            (a 55)))
+  (error? (letrec ([a (letrec ([b (lambda () (c))]
+                               [c (lambda () a)]
+                               [d (b)])
+                        (d))])
+            (a 55)))
+  (error? (letrec ([a (letrec* ([b (lambda () (c))]
+                                [c (lambda () a)]
+                                [d (b)])
+                        (d))])
+            (a 55)))
+  (eqv? (letrec* ([b (lambda () (c))]
+                  [c (lambda () 73)]
+                  [d (b)])
+          d)
+        73)
+  (procedure?
+    (let ()
+        (define f (rec f* (lambda () (g))))
+        (define g (rec g* (lambda () (f))))
+        g))
+  (equal?
+    (let ([q #f])
+      (letrec ((a (letrec ((f (lambda () a)) (g (lambda () (set! q "hi\n"))))
+                    (g)
+                    (lambda () (f)))))
+        (list (eq? a (a)) q)))
+    '(#t "hi\n"))
+  (error? ; should complain about g
+    (let ()
+        (define f (letrec ((f* (lambda () (g)))) (f*)))
+        (define g (letrec ((g* (lambda () (f)))) (g*)))
+        g))
+  (internal-defines-as-letrec*)
+  (begin (internal-defines-as-letrec* #f) (not (internal-defines-as-letrec*)))
+  (error? ; might complain about f or g
+    (let ()
+        (define f (letrec ((f* (lambda () (g)))) (f*)))
+        (define g (letrec ((g* (lambda () (f)))) (g*)))
+        g))
+  (begin (internal-defines-as-letrec* #t) (internal-defines-as-letrec*))
+  (error?
+    (letrec* ((a (lambda () (c)))
+              (b (lambda () (d)))
+              (c (lambda () (f)))
+              (d (lambda () (f)))
+              (e (cons (a) (lambda () (b))))
+              (f ((cdr e))))
+      7))
+  (error?
+    (letrec* ((a (lambda () (b)))
+              (b (lambda () (c)))
+              (c (a)))
+      7))
+ ; verify that cpletrec output is straight rec-binding:
+  (equal? (letrec* ((e (lambda (x) (or (= x 0) (o (- x 1)))))
+                    (o (lambda (x) (and (not (= x 0)) (e (- x 1))))))
+            (list (e 7) (o 7) (e 6) (o 6)))
+          '(#f #t #t #f))
+ ; verify that cpletrec output is straight rec-binding:
+  (letrec ([a (letrec* ([b (lambda () (c))]
+                        [c (lambda () a)]
+                        [d (lambda () (b))])
+                (lambda () (d)))])
+    (eq? a (a)))
+ ; check for warnings when requested
+  (eq?
+    (parameterize ([undefined-variable-warnings "yes please!"])
+      (undefined-variable-warnings))
+    #t)
+  (warning? ; possible undefined variable
+    (parameterize ([undefined-variable-warnings #t] [optimize-level 2])
+      (eval '(let () (define x x) x))))
+  (error? ; undefined variable
+    (parameterize ([undefined-variable-warnings #f] [optimize-level 2])
+      (eval '(let () (define x x) x))))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda () (pretty-print '(let () (define x x) (x y))))
+      'replace)
+    #t)
+  (warning? ; possible undefined variable, with source info
+    (parameterize ([undefined-variable-warnings #t] [optimize-level 2])
+      (compile-file "testfile")))
+  (error? ; undefined variable, with source info
+    (parameterize ([undefined-variable-warnings #f] [optimize-level 2])
+      (compile-file "testfile")
+      (load "testfile.so")))
+)
+
+(mat cpvalid2 ; from Dipa
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)] [b (a)] [c (cons 1 2)]) b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)][b (let ((d a)) (d))][c (cons 1 2)]) b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (let ([d (lambda () c)]) (d))][b a][c (cons 1 2)]) b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (letrec* ([b (lambda () c)][d (b)][c (cons 1 2)]) d)]) a))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)][b (lambda (f) (f))][d (b a)][c (cons 1 2)]) d))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)][b (lambda () a)][d ((b))][c (cons 1 2)]) d))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () (set! c d))][b (a)][c (cons 1 2)]) b))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () (set! d c))][b (a)][c (cons 1 2)]) d))
+  
+  (equal?
+    (letrec* ([a (lambda () c)]
+              [b (if #t a (a))]
+              [c (cons 1 2)])
+      (b))
+    '(1 . 2))
+  
+  (error? ; undefined variable c
+    (letrec* ([a (lambda () c)][b (if #t (a) a)][c (cons 1 2)]) b))
+  
+  (error? ; undefined variable a
+    (letrec ([a (letrec* ([b (lambda () a)]) (b))][c (cons 1 2)]) (cons a c)))
+)
+
+(mat rec
+    (let ((f (rec g (lambda () g)))) (eq? f (f)))
+    (let ((f (rec g (lambda (x) (if (zero? x) 1 (* x (g (1- x))))))))
+        (= (f 4) 24))
+ )
+
+(mat define
+    (begin (define xxxx 'xxxxval) #t)
+    (and (top-level-bound? 'xxxx) (eqv? (top-level-value 'xxxx) 'xxxxval))
+    (begin (define (ffff x) (+ x x)) #t)
+    (and (top-level-bound? 'ffff) (eqv? ((top-level-value 'ffff) 17) 34))
+    (begin (define (eeee . l) l) #t)
+    (equal? (eeee 1 2 3) '(1 2 3))
+    (begin (define (dddd x . l) (cons x l)) #t)
+    (equal? (dddd 1 2 3 4) '(1 2 3 4))
+    ((lambda (x)
+        (define yyyy x)
+        (define (gggg y) (+ yyyy y))
+        (and (not (top-level-bound? 'yyyy))
+             (not (top-level-bound? 'gggg))
+             (eqv? (gggg 22) 25)))
+     3)
+    (let ((x 3))
+       (define yyyy x)
+       (define (gggg y) (+ yyyy y))
+       (and (not (top-level-bound? 'yyyy))
+            (not (top-level-bound? 'gggg))
+            (eqv? (gggg 22) 25)))
+    (let* ((x 3))
+       (define yyyy x)
+       (define (gggg y) (+ yyyy y))
+       (and (not (top-level-bound? 'yyyy))
+            (not (top-level-bound? 'gggg))
+            (eqv? (gggg 22) 25)))
+    (letrec ((x 3))
+       (define yyyy x)
+       (define (gggg y) (+ yyyy y))
+       (and (not (top-level-bound? 'yyyy))
+            (not (top-level-bound? 'gggg))
+            (eqv? (gggg 22) 25)))
+    (let ()
+       (begin (define x 3) (define y 4))
+       (begin)
+       (begin (define z 5))
+       (= (+ (* x x) (* y y)) (* z z)))
+    (error? (lambda () 0 (define x 3) x))
+    (error? (lambda () 0 (begin (define x 3)) x))
+    (error? (lambda () 0 (begin) x))
+    (error? (case-lambda [() 0 (define x 3) x]))
+    (error? (let () 0 (define x 3) x))
+    (error? (let* () 0 (define x 3) x))
+    (error? (letrec () 0 (define x 3) x))
+    (error? (if (define x 3) x x))
+ )
+
+(mat define-values
+  (begin (define-values ($dv-x $dv-y) (values 'a 'b)) #t)
+  (eq? $dv-x 'a)
+  (eq? $dv-y 'b)
+  (begin (define-values $dv-r (values)) #t)
+  (equal? $dv-r '())
+  (begin (define-values $dv-r (values 1)) #t)
+  (equal? $dv-r '(1))
+  (begin (define-values $dv-r (values 1 2 3 4 5)) #t)
+  (equal? $dv-r '(1 2 3 4 5))
+  (begin (define-values ($dv-x $dv-y . $dv-r) (values 1 2 3 4 5)) #t)
+  (eqv? $dv-x 1)
+  (eqv? $dv-y 2)
+  (equal? $dv-r '(3 4 5))
+  (begin (define-values ($dv-x $dv-y) (div-and-mod 19 4)) #t)
+  (eqv? $dv-x 4)
+  (eqv? $dv-y 3)
+  (begin (define-values ($dv-x $dv-y . $dv-z) (div-and-mod 19 4)) #t)
+  (eqv? $dv-x 4)
+  (eqv? $dv-y 3)
+  (equal? $dv-z '())
+  (error? ; invalid number of arguments
+    (define-values ($dv-x . $dv-r) (values)))
+  (error? ; invalid number of arguments
+    (define-values ($dv-x $dv-y . $dv-r) (values)))
+  (error? ; invalid number of arguments
+    (define-values ($dv-x $dv-y . $dv-r) (values 1)))
+  (error? ; invalid number of arguments
+    (define-values ($dv-x $dv-y $dv-z . $dv-r) (div-and-mod 19 4)))
+  (error? ; invalid number of arguments
+    (define-values ($dv-x) (div-and-mod 19 4)))
+  (error? ; invalid number of arguments
+    (define-values () (div-and-mod 19 4)))
+  (error? ; duplicate variable name
+    (define-values ($dv-x $dv-x) (div-and-mod 19 4)))
+  (error? ; duplicate variable name
+    (define-values ($dv-x . $dv-x) (div-and-mod 19 4)))
+  (equal?
+    (let ()
+      (define-values (x y) (values 'a 'b))
+      (list x y))
+    '(a b))
+  (equal?
+    (let ()
+      (define-values r (values))
+      r)
+    '())
+  (equal?
+    (let ()
+      (module (r)
+        (define-values r (values 1)))
+      r)
+    '(1))
+  (equal?
+    (let ()
+      (define-values r (values 1 2 3 4 5))
+      r)
+    '(1 2 3 4 5))
+  (equal?
+    (let ()
+      (define-values (x y . r) (values 1 2 3 4 5))
+      (vector x y r))
+    '#(1 2 (3 4 5)))
+  (equal?
+    (let ()
+      (define-values (x y) (div-and-mod 19 4))
+      (list y x))
+    '(3 4))
+  (equal?
+    (let ()
+      (define-values (x y . z) (div-and-mod 19 4))
+      (vector z x y))
+    '#(() 4 3))
+  (error? ; invalid number of arguments
+    (let ()
+      (define-values (x . r) (values))
+      r))
+  (error? ; no expressions in body
+    (let ()
+      (define-values (x y . r) (values))))
+  (error? ; invalid number of arguments
+    (let ()
+      (define-values (x y . r) (values 1))
+      x))
+  (error? ; invalid number of arguments
+    (let ()
+      (define-values (x y z . r) (div-and-mod 19 4))
+      x))
+  (error? ; invalid number of arguments
+    (let ()
+      (define-values (x) (div-and-mod 19 4))
+      x))
+  (error? ; invalid number of arguments
+    (let ()
+      (define-values () (div-and-mod 19 4))
+      #t))
+  (error? ; duplicate variable name
+    (let ()
+      (define-values (x x) (div-and-mod 19 4))
+      x))
+  (error? ; duplicate variable name
+    (let ()
+      (define-values (x . x) (div-and-mod 19 4))
+      x))
+  (begin
+    (library ($dv-foo) (export $dv-foo-x) (import (chezscheme))
+      (define-values $dv-foo-x (div-and-mod 19 4)))
+    #t)
+  (equal?
+    (let () (import ($dv-foo)) $dv-foo-x)
+    '(4 3))
+  (begin (import ($dv-foo)) #t)
+  (equal? $dv-foo-x '(4 3))
+  (begin
+    (library ($dv-foo1) (export $dv-foo1-x) (import (chezscheme))
+      (define-values ($dv-foo1-x . r) (values)))
+    #t)
+  (error? ; invalid number of arguments
+    (let () (import ($dv-foo1)) $dv-foo1-x))
+  (error? ; duplicate variable name
+    (library ($dv-foo2) (export $dv-foo2-x) (import (chezscheme))
+      (define-values ($dv-foo2-x . $dv-foo2-x) (values))
+      $dv-foo2-x))
+ ; make sure pattern variables and ellipses on RHS don't screw us up
+  (eqv?
+    (let ()
+      (define-syntax q
+        (lambda (x)
+          (syntax-case x ()
+            [(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
+      (define-values (a) (q ...))
+      a)
+    3)
+  (equal?
+    (let ()
+      (define-syntax q
+        (lambda (x)
+          (syntax-case x ()
+            [(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
+      (define-values a (q ...))
+      a)
+    '(3))
+  (equal?
+    (let ()
+      (define-syntax q
+        (lambda (x)
+          (syntax-case x ()
+            [(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
+      (define-values (a . b) (q ...))
+      (list a b))
+    '(3 ()))
+  (equal?
+    (syntax-case '(a b c) ()
+      [(x ...)
+       (let ()
+         (define-values (args) #'(x ...))
+         args)])
+    '(a b c))
+  (equal?
+    (syntax-case '(a b c) ()
+      [(x ...)
+       (let ()
+         (define-values (args . rot) (values #'(x ...) #'(x ...) 3))
+         (list args rot))])
+    '((a b c) ((a b c) 3)))
+  (equal?
+   (let ()
+     (define x 1)
+     (define-values ()
+       (begin
+         "don't interrupt definitions"
+         (values)))
+     (define y 2)
+     (list x y))
+   '(1 2))
+)
+
+(mat assimilation
+  (syntax-case (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
+                              [#%$suppress-primitive-inlining #f]
+                              [optimize-level 2])
+                 (expand/optimize
+                   '(letrec* ([x (let ([y 0])
+                                   (lambda ()
+                                     (set! y (- y 1))
+                                     y))]
+                              [z (lambda () (x))])
+                      (z)
+                      (x))))
+               (lambda set! - $primitive)
+    [(let ([y1 0])
+       (set! y2 (#2%- y3 1))
+       (set! y4 (#2%- y5 1))
+       y6)
+     #t]
+    [_ #f])
+  (syntax-case (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
+                              [#%$suppress-primitive-inlining #f]
+                              [optimize-level 2])
+                 (expand/optimize
+                   '(letrec ([x (let ([y 0])
+                                  (lambda ()
+                                    (set! y (- y 1))
+                                    y))]
+                             [z (lambda () (x))])
+                      (z)
+                      (x))))
+               (lambda set! - $primitive)
+    [(let ([y1 0])
+       (set! y2 (#2%- y3 1))
+       (set! y4 (#2%- y5 1))
+       y6)
+     #t]
+    [_ #f])
+  (syntax-case (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
+                              [#%$suppress-primitive-inlining #f]
+                              [optimize-level 2])
+                 (expand/optimize
+                   '(letrec* ([w 15]
+                              [x (let ([y w])
+                                   (lambda ()
+                                     (set! y (- y 1))
+                                     y))]
+                              [z (lambda () (x))])
+                      (z)
+                      (x))))
+               (lambda set! - $primitive)
+    [(let ([y1 15])
+      (set! y2 (#2%- y3 1))
+      (set! y4 (#2%- y5 1))
+      y6)
+     #t]
+    [_ #f])
+  (equal?
+    (let ([f (letrec ([e? (lambda (x) (or (zero? x) (o? (- x 1))))]
+                      [o? (lambda (x) (not (e? x)))])
+               (lambda (a b) (vector (e? a) (e? b) (o? a) (o? b))))])
+      (f 3 0))
+    '#(#f #t #t #f))
+  (equal?
+    (let ([f (letrec ([q? (lambda (x) (not (p? x)))]
+                      [p? (lambda (x) (> x 0))])
+               (lambda (a b) (vector (p? a) (p? b) (q? a) (q? b))))])
+      (f 3 -3))
+    '#(#t #f #f #t))
+  (equal?
+    (let ([f (letrec* ([x 5] [y (+ x x)])
+               (lambda ()
+                 (set! x (+ x y))
+                 (set! y (+ y x))
+                 (cons x y)))])
+      (let ([t (f)]) (list t (f))))
+    '((15 . 25) (40 . 65)))
+  (equal?
+    (letrec ([f (letrec* ([g (lambda (x)
+                               (lambda (y)
+                                 (if (= x y) 0 (+ 2 (h (- y 1))))))]
+                          [x0 17]
+                          [h (g x0)])
+                  (lambda (y1 y2) (cons (h y1) (h y2))))])
+      (list (f 20 25) (f 28 31)))
+    '((6 . 16) (22 . 28)))
+  (equal?
+    (letrec ([f (letrec* ([g (lambda (n f)
+                               (if (= n 0)
+                                   f
+                                   (g (- n 1) (lambda (m) (f (+ m 1))))))]
+                          [q 7]
+                          [h (g q (lambda (x) (* x 2)))])
+                  (lambda (y1 y2 y3) (list (h y1) (h y2) ((g 5 values) 7))))])
+      (vector (f 1 2 3) (f 4 5 6)))
+    '#((16 18 12) (22 24 12)))
+  (equal?
+    (letrec ([f (letrec* ([g (values
+                               (lambda (n f)
+                                 (if (= n 0)
+                                     f
+                                     (g (- n 1) (lambda (m) (f (+ m 1)))))))]
+                          [q 7]
+                          [h (g q (lambda (x) (* x 2)))])
+                  (lambda (y1 y2 y3) (list (h y1) (h y2) ((g 5 values) 7))))])
+      (vector (f 1 2 3) (f 4 5 6)))
+    '#((16 18 12) (22 24 12)))
+  (equal?
+    (letrec ([f (letrec* ([g (lambda (n f)
+                               (if (= n 0)
+                                   f
+                                   (g (- n 1) (lambda (m) (f (+ m 1))))))]
+                          [g^ g]
+                          [g^^ g^])
+                  (lambda (y1 y2 y3)
+                    (when #f (set! g 0) (set! g^ 1) (set! g^^ 2))
+                    (list ((g y1 values) y2)
+                          ((g^ y2 (lambda (x) (* x x))) y3)
+                          ((g^^ y3 (lambda (x) (- x))) y1))))])
+      (vector (f 1 2 3) (f 4 5 6)))
+    '#((3 25 -4) (9 121 -10)))
+)
+
+(mat set!
+    (begin (set! foo 'hello) (eq? foo 'hello))
+    (let ([x 'a]) (set! x 'b) (eq? x 'b))
+    (let ([x 'a])
+       (let ([f (lambda () (set! x 'b))])
+          (and (eq? x 'a) (begin (f) (eq? x 'b)))))
+   ; test gensym set!/reference
+    (equal? (begin (set! #0=#{a |pig|} '#0#) (set! #1=#{b |sty|} #0#) #1#) '#0#)
+ )
+
+(mat fluid-let
+    (fluid-let () #t)
+    (eq? (fluid-let () (define x 4) x) 4)
+    (let* ((x 'a) (f (lambda () x)))
+        (and
+            (fluid-let ((x 'b))
+                (and (eq? x 'b) (eq? (f) 'b)))
+            (eq? x 'a)
+            (eq? (f) 'a)))
+    (let* ((x 'a) (f (lambda () x)))
+        (and
+            (call/cc
+                (lambda (return)
+                    (fluid-let ((x 'b))
+                        (return (and (eq? x 'b) (eq? (f) 'b))))))
+            (eq? x 'a)
+            (eq? (f) 'a)))
+    (equal?
+      (let* ((x 'a) (f (lambda () x)))
+          ((call/cc
+              (lambda (return)
+                  (fluid-let ((x 'b))
+                      (call/cc
+                          (lambda (back)
+                               (return back)))
+                      (let ((ans (f))) (lambda (y) (list ans x))))))
+            '()))
+      '(b a))
+    (eqv?
+      (let ([x 75])
+        (fluid-let ([x 23] [x 23]) 0)
+        x)
+      75)
+ )
+
+;(mat variable
+;   (eq? (fluid-let ([car 3])
+;           ((parameterize ([optimize-level 2])
+;               (eval '(lambda () car)))))
+;        car)
+;   (eq? (fluid-let ([car 3])
+;           ((parameterize ([$compiling-system-code #t])
+;               (eval '(lambda () car)))))
+;        car)
+;   (eq? ((parameterize ([$compiling-system-code #t])   
+;            (eval '(lambda () $oblist))))
+;        (parameterize ([$compiling-system-code #t])
+;            (eval '$oblist)))
+;   (error? ((parameterize ([optimize-level 2])
+;               (eval '(lambda () (set! car 3))))))
+; )
+
+(mat mrvs
+  (error?
+    (values))
+  (error?
+    (if (values 1 2 3) 4 5))
+  (error?
+    (values 1 2 3))
+  (eq?
+    (values 2)
+    2)
+  (eq?
+    (let ((f (lambda () (values)))) 
+      (+ 2 (call-with-values f (lambda () 5))))
+    7)
+  (error?
+    (let ((f (lambda () (values)))) (+ 2 (f))))
+  (eq?
+    (call-with-values
+      (lambda () (begin 5 (values 2 3)))
+      (lambda (x y) (+ x y)))
+    5)
+  (error?
+    (call-with-values
+      (lambda () (begin 5 (values 2)))
+      (lambda (x y) (+ x y))))
+  (eq?
+    (call-with-values
+      (lambda () (begin 5 (values 1 2)))
+      (lambda (x y) (+ x y)))
+    3)
+  (eq?
+    (call-with-values
+      (lambda () (values 2 3))
+      (lambda (x y) (+ x y)))
+    5)
+  (equal?
+    (let ((f (lambda () (values 2 3)))
+          (g (lambda (x y) (cons x y))))
+      (call-with-values f g))
+    '(2 . 3))
+  (eq?
+    (let ((f (lambda () (lambda () (values 2 3))))
+          (g (lambda (x) x)))
+      (call-with-values (call-with-values f g) +))
+    5)
+  (eq?
+    (let ((f (lambda () (lambda () (values 2 3)))))
+      (call-with-values (car (call-with-values f list)) +))
+    5)
+  (equal?
+    (cons 1 (let ((f (lambda () (values 2 3)))) (call-with-values f list)))
+    '(1 2 3))
+  (eq?
+    (let ((f (lambda (g h) (+ 1 (call-with-values g h)))))
+      (f (lambda () (values 1 2))
+         (lambda (x y) (+ x y))))
+    4)
+  (eq?
+    (let ((f (lambda (f g) (call-with-values f g))))
+      (f (lambda () (call/cc (lambda (k) (values 5 k))))
+         (lambda (x k) (if (= x 5) (k 0 k) 1))))
+    1)
+  (eq?
+    (+ 2 (call/cc
+           (lambda (k)
+             (let ((f (lambda () (k 5))))
+               (call-with-values f list)))))
+    7)
+  (eq?
+    (let ((f (lambda () 
+               (let ((f (lambda (f g) (call-with-values f g))))
+                 (f (lambda ()
+                      (call/cc
+                        (lambda (k)
+                          (values 0 k))))
+                    (lambda (x k)
+                      (call/cc
+                        (lambda (k1)
+                          (k 1 k1))))))))
+          (g (lambda (x y) x)))
+      (call-with-values f g))
+    1)
+  (bignum?
+    (letrec ((f (lambda (x)
+                  (if (= x 0)
+                      (values 1 0 0)
+                      (let ((g (lambda (u v w)
+                                 (values (* x u) (+ v 1) (+ w 2)))))
+                        (call-with-values
+                          (lambda () (f (- x 1)))
+                          g))))))
+      (let ((h (lambda (x y z) x)))
+        (call-with-values
+          (lambda () (f 2000))
+          h))))
+  (equal?
+    (let ((h (lambda (x) (lambda (y z) (list x y z))))
+          (g (lambda (x) (lambda () (values x 3)))))
+      (cons 0 (call-with-values (g 2) (h 1))))
+    '(0 1 2 3))
+  (eqv? (call-with-values (lambda () (apply values (make-list 1000 1))) +)
+        1000)
+  (equal? (call-with-values (lambda () (if (random 10) 2 3)) list)
+          '(2))
+  (equal? (call-with-values (case-lambda (x x) (() 3)) list) '(()))
+  (eqv? (let ([f (lambda () (values 1 2 3))])
+          (+ 2 (call-with-values f (lambda x (length x)))))
+      5)
+  (equal? (let ((x list)) (call-with-values (lambda () (set! x +) 3) x))
+          '(3))
+  (error? (call-with-values values (lambda (x) x)))
+  (error? (call-with-values values (lambda (x y) x)))
+  (error? (let ((f values)) (call-with-values f (lambda (x y) x))))
+  (equal?
+    (let ()
+      (define f
+        (lambda (a b c)
+          (call-with-values
+          (let ((x values)) (lambda () (x 1 2)))
+            (lambda (d e)
+              (list a b c d e)))))
+      (f 3 4 5))
+    '(3 4 5 1 2))
+  (eqv?
+    (let ()
+        (define f1
+          (lambda (x) (values 1 0)))
+        (define f2
+          (lambda (a)
+            (vector-ref a 0)
+            (call-with-values
+              (lambda () (f1 a))
+              (lambda (d e) d)))) 
+        (f2 '#(a)))
+    1)
+  (equal?
+    (let ()
+        (define f1 (lambda (x) (lambda () (values 1 2))))
+        (define f2
+          (lambda (a)
+            (random 10)
+            (call-with-values
+              (f1 a)
+              (lambda (x y)
+                (random 20)
+                (list a x y)))))
+        (f2 0))
+    '(0 1 2))
+  (null? (call-with-values
+           (lambda () (call/cc (lambda (k) (values))))
+           (lambda args args)))
+  (null? (call-with-values
+           (lambda () (call/cc (lambda (k) (k))))
+           (lambda args args)))
+  (equal?
+    (call-with-values
+      (lambda () (call/cc (lambda (k) (k 'a 'b 'c))))
+      (lambda args args))
+    '(a b c))
+  (equal?
+    (call-with-values
+      (lambda () (call/cc (lambda (k) (values 'a 'b 'c))))
+      (lambda args args))
+    '(a b c))
+  (null? (call-with-values
+           (lambda () (dynamic-wind values values values))
+           list))
+  (equal?
+    (call-with-values
+      (lambda () (call/cc (lambda (k) (values 1 2 3 4 5 6 7 8 9 10))))
+      list)
+    '(1 2 3 4 5 6 7 8 9 10))
+  (eqv?
+    (letrec ((z 2)
+             (f (lambda () (values 1 z)))
+             (g (lambda (x y) (values x y z))))
+      (call-with-values
+        (lambda ()
+          (call-with-values
+            f
+            (lambda (z b) (g z b))))
+        (lambda (c d e)
+          (+ c d e z))))
+    7)
+  (or (= (optimize-level) 3)
+      (guard (c [(not (warning? c)) (collect) #t])
+        (if (call-with-values
+              current-output-port
+              (lambda (v out) (current-output-port)))
+          1
+          2)))
+  (equal?
+    (let ()
+      (define split
+        (lambda (ls)
+          (if (or (null? ls) (null? (cdr ls)))
+              (values ls '())
+              (call-with-values
+                (lambda () (split (cddr ls)))
+                (lambda (odds evens)
+                  (values (cons (car ls) odds)
+                          (cons (cadr ls) evens)))))))
+       (call-with-values
+         (lambda () (split '(a b c d e f)))
+         vector))
+    '#((a c e) (b d f)))
+
+  ; test chains of consumers
+  (begin
+    (define-syntax $mrvs-a
+      (syntax-rules ()
+        [(_) ($mrvs-f0)]
+        [(_ f1 f2 ...)
+         (let ([f1 (lambda (a b c d) (values d a b c))])
+           (call-with-values (lambda () ($mrvs-a f2 ...)) f1))]))
+    (define $mrvs-f0 (lambda () (values 1 2 3 4)))
+    (define $mrvs-list (lambda args args))
+    #t)
+
+  ; test chains of consumers ending in a non-tail call
+  (equal?
+    (call-with-values (lambda () ($mrvs-a)) $mrvs-list)
+    '(1 2 3 4))
+
+  (equal?
+    (call-with-values (lambda () ($mrvs-a f1)) $mrvs-list)
+    '(4 1 2 3))
+
+  (equal?
+    (call-with-values (lambda () ($mrvs-a f1 f2 f3 f4)) $mrvs-list)
+    '(1 2 3 4))
+
+  ; test chains of consumers ending in a tail call
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () ($mrvs-a)) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () ($mrvs-a f1)) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(4 1 2 3))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () ($mrvs-a f1 f2 f3 f4)) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (call-with-values (lambda () ($mrvs-a f1 f2 f3)) foo)))
+    #t)
+  (equal? ($mrvs-q $mrvs-list) '(2 3 4 1))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (lambda ()
+          (call-with-values (lambda () ($mrvs-a f1 f2 f3)) foo))))
+    #t)
+  (equal? (($mrvs-q $mrvs-list)) '(2 3 4 1))
+
+  ; test chains of consumers ending in a let-values
+  (equal?
+    (let-values ([(a . r) ($mrvs-a)]) (cons r a))
+    '((2 3 4) . 1))
+
+  (equal?
+    (let-values ([(a . r) ($mrvs-a f1)]) (cons r a))
+    '((1 2 3) . 4))
+
+  (equal?
+    (let-values ([(a . r) ($mrvs-a f1 f2 f3 f4)]) (cons r a))
+    '((2 3 4) . 1))
+
+  ; test chains of consumers ending in a let-values-like call-with-values
+  (equal?
+    (call-with-values
+      (lambda () ($mrvs-a))
+      (lambda (a b . r) (cons* r b a)))
+    '((3 4) 2 . 1))
+
+  (equal?
+    (call-with-values
+      (lambda () ($mrvs-a f1))
+      (lambda (a b . r) (cons* r b a)))
+    '((2 3) 1 . 4))
+
+  (equal?
+    (call-with-values
+      (lambda () ($mrvs-a f1 f2 f3 f4))
+      (lambda (a b . r) (cons* r b a)))
+    '((3 4) 2 . 1))
+
+  ; test chains of consumers w/fi as free variables
+  (begin
+    (define-syntax $mrvs-a
+      (syntax-rules ()
+        [(_ f ...)
+         (let ([x 17])
+           (let ([f (lambda (y a b c d) (values x d a b c))] ...)
+             (set! x (* x 4))
+             (lambda () ($mrvs-b f ...))))]))
+    (define-syntax $mrvs-b
+      (syntax-rules ()
+        [(_) ($mrvs-f0)]
+        [(_ f1 f2 ...) (call-with-values (lambda () ($mrvs-b f2 ...)) f1)]))
+    (define $mrvs-f0 (lambda () (values 0 1 2 3 4)))
+    (define $mrvs-list (lambda args args))
+    #t)
+
+  ; test chains of consumers ending in a non-tail call
+  (equal?
+    (call-with-values (lambda () (($mrvs-a))) $mrvs-list)
+    '(0 1 2 3 4))
+
+  (equal?
+    (call-with-values (lambda () (($mrvs-a f1))) $mrvs-list)
+    '(68 4 1 2 3))
+
+  (equal?
+    (call-with-values (lambda () (($mrvs-a f1 f2 f3 f4))) $mrvs-list)
+    '(68 1 2 3 4))
+
+  ; test chains of consumers ending in a tail call
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () (($mrvs-a))) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(0 1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () (($mrvs-a f1))) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(68 4 1 2 3))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () (($mrvs-a f1 f2 f3 f4))) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(68 1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (call-with-values (lambda () (($mrvs-a f1 f2 f3))) foo)))
+    #t)
+  (equal? ($mrvs-q $mrvs-list) '(68 2 3 4 1))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (lambda ()
+          (call-with-values (lambda () (($mrvs-a f1 f2 f3))) foo))))
+    #t)
+  (equal? (($mrvs-q $mrvs-list)) '(68 2 3 4 1))
+
+  ; test chains of consumers ending in a let-values
+  (equal?
+    (let-values ([(x a . r) (($mrvs-a))]) (cons* x r a))
+    '(0 (2 3 4) . 1))
+
+  (equal?
+    (let-values ([(x a . r) (($mrvs-a f1))]) (cons* x r a))
+    '(68 (1 2 3) . 4))
+
+  (equal?
+    (let-values ([(x a . r) (($mrvs-a f1 f2 f3 f4))]) (cons* x r a))
+    '(68 (2 3 4) . 1))
+
+  ; test chains of consumers ending in a let-values-like call-with-values
+  (equal?
+    (call-with-values
+      (lambda () (($mrvs-a)))
+      (lambda (x a b . r) (cons* x r b a)))
+    '(0 (3 4) 2 . 1))
+
+  (equal?
+    (call-with-values
+      (lambda () (($mrvs-a f1)))
+      (lambda (x a b . r) (cons* x r b a)))
+    '(68 (2 3) 1 . 4))
+
+  (equal?
+    (call-with-values
+      (lambda () (($mrvs-a f1 f2 f3 f4)))
+      (lambda (x a b . r) (cons* x r b a)))
+    '(68 (3 4) 2 . 1))
+
+  (begin
+    (define-syntax $mrvs-qcons (lambda (x) #`'#,cons))
+    (define-syntax $mrvs-qvalues (lambda (x) #`'#,(lambda args (apply values args))))
+    (define $mrvs-f (lambda () (values 1 2)))
+    #t)
+
+  (equal?
+    (call-with-values (lambda () (values 1 2)) $mrvs-qcons)
+    '(1 . 2))
+
+  (equal?
+    (let ([f (lambda () (values 1 2))])
+      (call-with-values f $mrvs-qcons))
+    '(1 . 2))
+
+  (equal?
+    (call-with-values $mrvs-f $mrvs-qcons)
+    '(1 . 2))
+
+  (equal?
+    (call-with-values (lambda () (call-with-values $mrvs-f $mrvs-qvalues)) $mrvs-qcons)
+    '(1 . 2))
+
+  (equal?
+    (let ([f (lambda () (call-with-values (lambda () (values 1 2)) $mrvs-qcons))])
+      (f))
+    '(1 . 2))
+
+  (equal?
+    (let ([f (lambda ()
+               (let ([f (lambda () (values 1 2))])
+                 (call-with-values f $mrvs-qcons)))])
+      (f))
+    '(1 . 2))
+
+  (equal?
+    (let ([f (lambda () (call-with-values $mrvs-f $mrvs-qcons))])
+      (f))
+    '(1 . 2))
+
+  (equal?
+    (let ([f (lambda ()
+               (call-with-values
+                 (lambda () (call-with-values $mrvs-f $mrvs-qvalues))
+                 $mrvs-qcons))])
+      (f))
+    '(1 . 2))
+
+  (equal?
+    (letrec ((f (lambda (x) (values 7 8 9))))
+      (let ((h list))
+        (call-with-values
+          (lambda () (f 0))
+          h)))
+    '(7 8 9))
+
+  (equal?
+    (let-values ([(a . b) (values 1 2 3)]) (cons b a))
+    '((2 3) . 1))
+
+  (equal?
+    (let ([f (lambda (x) (values x (+ x 1)))])
+      (let-values ([(a b) (f 3)]) (cons b a)))
+    '(4 . 3))
+
+  ; let-values inserts an "else" (effectively) clause---the following doesn't
+  (equal?
+    (let ([f (lambda (x) (values x (+ x 1)))])
+      (call-with-values
+        (lambda () (f 3))
+        (lambda (a b) (cons b a))))
+    '(4 . 3))
+
+  (equal?
+    (let ([f (lambda (x) (values x (+ x 1)))]) (begin (f 3) 7))
+    7)
+
+  (equal?
+    ((lambda (a . b) (cons b a)) 7 8 9)
+    '((8 9) . 7))
+
+  (equal?
+    (call-with-values
+      (lambda ()
+        (let ([f (lambda (x) (values x (+ x 1) (+ x 2)))]
+              [g (lambda () 7)])
+          (call-with-values g f)))
+      list*)
+    '(7 8 . 9))
+
+  (equal?
+    (let ([q (lambda () (let ([f (lambda (x) (values x (+ x 1) (+ x 2)))]
+                              [g (lambda () 7)])
+                          (call-with-values g f)))])
+      (call-with-values q (lambda (a b c) (list c b a))))
+    '(9 8 7))
+
+  (equal?
+    (let ([q (lambda () (let ([f (lambda (x y) (values x (+ x 1) (+ y 2)))]
+                              [g (lambda () (values 7 8))])
+                          (call-with-values g f)))])
+      (call-with-values q (lambda (a b c) (list c b a))))
+    '(10 8 7))
+  (error? ; unbound variable $mrvs-foo
+    (call-with-values (lambda () (set! $mrvs-foo list) (values 3 2 1)) $mrvs-foo))
+  (begin
+    (define $mrvs-foo 17)
+    #t)
+  (error? ; attempt to call nonprocedure 17
+    (call-with-values (lambda () (set! $mrvs-foo list) (values 3 2 1)) $mrvs-foo))
+  (begin
+    (define $mrvs-foo vector)
+    #t)
+  (equal?
+    (call-with-values (lambda () (set! $mrvs-foo list) (values 3 2 1)) $mrvs-foo)
+    '#(3 2 1))
+  (or (= (optimize-level) 3)
+      (eqv?
+        (let ([x 0] [f (lambda (x) (values 1 2))])
+          (guard (c [#t x])
+            (call-with-values
+              (begin (set! x (+ x 3)) f)
+              (begin (set! x (+ x 7)) 'oops))))
+        10))
+  (or (= (optimize-level) 3)
+      (eqv?
+        (let ([x 0] [f (lambda (x y z) (list z y x))])
+          (guard (c [#t x])
+            (#2%call-with-values
+              (begin (set! x (+ x 3)) 'oops)
+              (begin (set! x (+ x 7)) f))))
+        10))
+
+  ; testing of chains that do not get washed away into direct calls with mvlet
+  (begin
+    (define-syntax $mrvs-c
+      (lambda (x)
+        (define help
+          (lambda (f* k)
+            (if (null? f*)
+                (k #'($mrvs-f0))
+                (with-syntax ([f1 (car f*)])
+                  #`(let ([f1 (lambda (a b c d) (values d a b c))])
+                      ; using random to confuse cp0 until it gets smart enough to defeat this
+                      (let ([f1 (if (eqv? (random 5) 10) #f f1)])
+                        #,(help (cdr f*)
+                            (lambda (body)
+                              (k #`(call-with-values (lambda () #,body) f1))))))))))
+        (syntax-case x ()
+          [(_) #'($mrvs-f0)]
+          [(_ f1 f2 ...) (help #'(f1 f2 ...) values)])))
+    (define $mrvs-f0 (lambda () (values 1 2 3 4)))
+    (define $mrvs-list (lambda args args))
+    #t)
+
+  ; test chains of consumers ending in a non-tail call
+  (equal?
+    (call-with-values (lambda () ($mrvs-c)) $mrvs-list)
+    '(1 2 3 4))
+
+  (equal?
+    (call-with-values (lambda () ($mrvs-c f1)) $mrvs-list)
+    '(4 1 2 3))
+
+  (equal?
+    (call-with-values (lambda () ($mrvs-c f1 f2 f3 f4)) $mrvs-list)
+    '(1 2 3 4))
+
+  ; test chains of consumers ending in a tail call
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () ($mrvs-c)) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () ($mrvs-c f1)) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(4 1 2 3))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () ($mrvs-c f1 f2 f3 f4)) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (call-with-values (lambda () ($mrvs-c f1 f2 f3)) foo)))
+    #t)
+  (equal? ($mrvs-q $mrvs-list) '(2 3 4 1))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (lambda ()
+          (call-with-values (lambda () ($mrvs-c f1 f2 f3)) foo))))
+    #t)
+  (equal? (($mrvs-q $mrvs-list)) '(2 3 4 1))
+
+  ; test chains of consumers ending in a let-values
+  (equal?
+    (let-values ([(a . r) ($mrvs-c)]) (cons r a))
+    '((2 3 4) . 1))
+
+  (equal?
+    (let-values ([(a . r) ($mrvs-c f1)]) (cons r a))
+    '((1 2 3) . 4))
+
+  (equal?
+    (let-values ([(a . r) ($mrvs-c f1 f2 f3 f4)]) (cons r a))
+    '((2 3 4) . 1))
+
+  ; test chains of consumers ending in a let-values-like call-with-values
+  (equal?
+    (call-with-values
+      (lambda () ($mrvs-c))
+      (lambda (a b . r) (cons* r b a)))
+    '((3 4) 2 . 1))
+
+  (equal?
+    (call-with-values
+      (lambda () ($mrvs-c f1))
+      (lambda (a b . r) (cons* r b a)))
+    '((2 3) 1 . 4))
+
+  (equal?
+    (call-with-values
+      (lambda () ($mrvs-c f1 f2 f3 f4))
+      (lambda (a b . r) (cons* r b a)))
+    '((3 4) 2 . 1))
+
+  ; test chains of consumers w/fi as free variables
+  (begin
+    (define-syntax $mrvs-c
+      (syntax-rules ()
+        [(_ f ...)
+         (let ([x 17])
+           (let ([f (lambda (y a b c d) (values x d a b c))] ...)
+             (let ([f (if (eqv? (random 5) 10) #f f)] ...)
+               (set! x (* x 4))
+               (lambda () ($mrvs-d f ...)))))]))
+    (define-syntax $mrvs-d
+      (syntax-rules ()
+        [(_) ($mrvs-f0)]
+        [(_ f1 f2 ...) (call-with-values (lambda () ($mrvs-d f2 ...)) f1)]))
+    (define $mrvs-f0 (lambda () (values 0 1 2 3 4)))
+    (define $mrvs-list (lambda args args))
+    #t)
+
+  ; test chains of consumers ending in a non-tail call
+  (equal?
+    (call-with-values (lambda () (($mrvs-c))) $mrvs-list)
+    '(0 1 2 3 4))
+
+  (equal?
+    (call-with-values (lambda () (($mrvs-c f1))) $mrvs-list)
+    '(68 4 1 2 3))
+
+  (equal?
+    (call-with-values (lambda () (($mrvs-c f1 f2 f3 f4))) $mrvs-list)
+    '(68 1 2 3 4))
+
+  ; test chains of consumers ending in a tail call
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () (($mrvs-c))) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(0 1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () (($mrvs-c f1))) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(68 4 1 2 3))
+
+  (begin
+    (define $mrvs-q
+      (lambda ()
+        (call-with-values (lambda () (($mrvs-c f1 f2 f3 f4))) $mrvs-list)))
+    #t)
+  (equal? ($mrvs-q) '(68 1 2 3 4))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (call-with-values (lambda () (($mrvs-c f1 f2 f3))) foo)))
+    #t)
+  (equal? ($mrvs-q $mrvs-list) '(68 2 3 4 1))
+
+  (begin
+    (define $mrvs-q
+      (lambda (foo)
+        (lambda ()
+          (call-with-values (lambda () (($mrvs-c f1 f2 f3))) foo))))
+    #t)
+  (equal? (($mrvs-q $mrvs-list)) '(68 2 3 4 1))
+
+  ; test chains of consumers ending in a let-values
+  (equal?
+    (let-values ([(x a . r) (($mrvs-c))]) (cons* x r a))
+    '(0 (2 3 4) . 1))
+
+  (equal?
+    (let-values ([(x a . r) (($mrvs-c f1))]) (cons* x r a))
+    '(68 (1 2 3) . 4))
+
+  (equal?
+    (let-values ([(x a . r) (($mrvs-c f1 f2 f3 f4))]) (cons* x r a))
+    '(68 (2 3 4) . 1))
+
+  ; test chains of consumers ending in a let-values-like call-with-values
+  (equal?
+    (call-with-values
+      (lambda () (($mrvs-c)))
+      (lambda (x a b . r) (cons* x r b a)))
+    '(0 (3 4) 2 . 1))
+
+  (equal?
+    (call-with-values
+      (lambda () (($mrvs-c f1)))
+      (lambda (x a b . r) (cons* x r b a)))
+    '(68 (2 3) 1 . 4))
+
+  (equal?
+    (call-with-values
+      (lambda () (($mrvs-c f1 f2 f3 f4)))
+      (lambda (x a b . r) (cons* x r b a)))
+    '(68 (3 4) 2 . 1))
+
+  ; regression tests to make sure a bug in the compiler's handling of
+  ; values in a single value context is properly handled in all cases
+  (begin
+    (module $mrvs-double-call (double-call)
+      (define split
+        (lambda (ls)
+          (if (null? ls)
+              (values #f '())
+              (values #t (cdr ls)))))
+      (define double-call
+        (lambda (x)
+          (let-values ([(x y) (split (split x))])
+            (list y x)))))
+    #t)
+
+  (error? ; returned two values to single value return context
+    (let ()
+      (import $mrvs-double-call)
+      (double-call '(a b))))
+
+  (error? ; returned two values to single value return context
+    (let ()
+      (import $mrvs-double-call)
+      (double-call '())))
+
+  (error? ; a is not a pair
+    (let ()
+      (import $mrvs-double-call)
+      (double-call 'a)))
+
+  ; regression testing for handling mvset in tail context
+  (call-with-values
+    (lambda ()
+      (call-with-values
+        (lambda ()
+          (+ (random 1) 7))
+        list))
+    (lambda l (equal? l '((7)))))
+
+  ; regression testing for handling mvset in predicate context
+  (if (call-with-values
+        (lambda ()
+          (call-with-values
+            (lambda ()
+              (+ (random 1) 7))
+            list))
+        (lambda l (equal? l '((7)))))
+      #t
+      #f)
+
+  ; regression test for handling mvcall with inline form
+  (equal?
+   '(result x)
+   (let ([bx (box #f)])
+     (define-record-type thing
+       (fields pos)
+       (nongenerative #{thing hlg584lmg5htbdauw7dkid2sh-0}))
+     (set-box! bx (make-thing 'x))
+     (let ([posx (unbox bx)])
+       (cons 'result
+             (call-with-values
+                 (lambda ()
+                   (if (thing? posx)
+                       ;; compiled as inline load:
+                       (thing-pos posx)
+                       (do-something-else)))
+               list)))))
+
+  ;; regression test to make sure the continuation is well formed when
+  ;; an exception handler is call for a wrong number of values are
+  ;; returned to a multi-value context
+  (begin
+    (define ($go-fail-to-get-two-values)
+      (call-with-values (lambda () ($get-one-value))
+        (lambda (a b) (list a b))))
+    (define ($get-one-value)
+      (call/cc ; copies return address off stack
+       (lambda (k)
+         (collect) ; do something non-trivial
+         k)))
+    (#%$continuation?
+     (call/cc
+      (lambda (esc)
+        (car
+          (with-exception-handler
+           (lambda (exn)
+             (call/cc
+              (lambda (k) ; this continuation used to be broken, and
+                (collect) ; a GC was the simplest way of detecting it
+                (esc k))))
+           $go-fail-to-get-two-values))))))
+
+)
+
+(mat let-values
+  (error? (let-values))
+  (error? (let-values ((x))))
+  (error? (let-values ()))
+  (error? (let-values (((x) 3))))
+  (error? (let-values (((3) 4)) 5))
+  (error? (let-values (((3 4) (values 1 2))) 5))
+  (error? (let-values (((x . 3) (values 1 2 3))) x))
+  (error? (let-values ((() (values 1 2))) 7))
+  (error? (let-values (((x) (values 1 2))) x))
+  (error? (let-values (((x y z) (values 1 2))) x))
+  (error? (let-values (((x y z . w) (values 1 2))) x))
+  (error? (let-values ((() 1)) 7))
+  (error? (let-values (((x y) 1)) x))
+  (error? (let-values (((x y z) 1)) x))
+  (error? (let-values (((x y . w) 1)) x))
+  (error? (let-values (((x x . w) (values 1 2 3))) (list x w)))
+  (error? (let-values (((x y . w) (values 1 2 3)) [(x q) (values 4 5)]) (list x w q)))
+  (equal?
+    (let-values (((x) 3)) x)
+    3)
+  (equal?
+    (let-values (((x y) (values 3 4))) (list x y))
+    '(3 4))
+  (equal?
+    (let-values (((x . y) (values 3 4))) (list x y))
+    '(3 (4)))
+  (equal?
+    (let-values ((x (values 3 4))) x)
+    '(3 4))
+  (equal?
+    (let-values ((x 3)) x)
+    '(3))
+  (equal?
+    (let-values (((x . y) (values 1 2 3)) ((z) (values 4))) (list x y z))
+    '(1 (2 3) 4))
+  (equal?
+    (let ()
+      (define split
+        (lambda (ls)
+          (if (or (null? ls) (null? (cdr ls)))
+              (values ls '())
+              (let-values (((odds evens) (split (cddr ls))))
+                (values (cons (car ls) odds)
+                        (cons (cadr ls) evens))))))
+       (call-with-values
+         (lambda () (split '(a b c d e f)))
+         vector))
+    '#((a c e) (b d f)))
+  (equal?
+    (let ()
+      (define f
+        (lambda (a b c)
+          (let-values (((d e) (let ((x values)) (x 1 2))))
+            (list a b c d e))))
+      (f 3 4 5))
+    '(3 4 5 1 2))
+  (equal?
+    (let ()
+      (define f1
+        (lambda (x) (apply values (vector->list x))))
+      (define f2
+        (lambda (a b)
+          (let-values ([(d) (f1 a)]
+                       [(e . f) (f1 b)]
+                       [(g h i) (f1 b)]
+                       [j (f1 b)])
+            (list d e f g h i j))))
+      (f2 '#(a) '#(b c d)))
+    '(a b (c d) b c d (b c d)))
+  (eqv?
+    (letrec ((z 2)
+             (f (lambda () (values 1 z)))
+             (g (lambda (x y) (values x y z))))
+      (let-values ([(c d e) (let-values ([(z b) (f)]) (g z b))])
+        (+ c d e z)))
+    7)
+  (equal?
+    (let ([a 3])
+      (let-values ([(a b) (values (+ a 1) (+ a 2))]
+                   [(c) (values (+ a 3))])
+        (list a b c)))
+    '(4 5 6))
+ ; make sure pattern variables and ellipses on RHS don't screw us up
+  (eqv?
+    (let ()
+      (define-syntax q
+        (lambda (x)
+          (syntax-case x ()
+            [(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
+      (let-values ([(a) (q ...)]) a))
+    3)
+  (equal?
+    (syntax-case '(a b c) ()
+      [(x ...) (let-values ([(args) #'(x ...)]) args)])
+    '(a b c))
+)
+
+(mat let*-values
+  (error? (let*-values))
+  (error? (let*-values ((x))))
+  (error? (let*-values ()))
+  (error? (let*-values (((x) 3))))
+  (error? (let*-values (((3) 4)) 5))
+  (error? (let*-values (((3 4) (values 1 2))) 5))
+  (error? (let*-values (((x . 3) (values 1 2 3))) x))
+  (error? (let*-values ((() (values 1 2))) 7))
+  (error? (let*-values (((x) (values 1 2))) x))
+  (error? (let*-values (((x y z) (values 1 2))) x))
+  (error? (let*-values (((x y z . w) (values 1 2))) x))
+  (error? (let*-values ((() 1)) 7))
+  (error? (let*-values (((x y) 1)) x))
+  (error? (let*-values (((x y z) 1)) x))
+  (error? (let*-values (((x y . w) 1)) x))
+  (error? (let*-values (((x x . w) (values 1 2 3))) (list x w)))
+  (equal?
+    (let*-values (((x) 3)) x)
+    3)
+  (equal?
+    (let*-values (((x y) (values 3 4))) (list x y))
+    '(3 4))
+  (equal?
+    (let*-values (((x . y) (values 3 4))) (list x y))
+    '(3 (4)))
+  (equal?
+    (let*-values ((x (values 3 4))) x)
+    '(3 4))
+  (equal?
+    (let*-values ((x 3)) x)
+    '(3))
+  (equal?
+    (let*-values (((x . y) (values 1 2 3)) ((z) (values 4))) (list x y z))
+    '(1 (2 3) 4))
+  (equal?
+    (let ()
+      (define split
+        (lambda (ls)
+          (if (or (null? ls) (null? (cdr ls)))
+              (values ls '())
+              (let*-values (((odds evens) (split (cddr ls))))
+                (values (cons (car ls) odds)
+                        (cons (cadr ls) evens))))))
+       (call-with-values
+         (lambda () (split '(a b c d e f)))
+         vector))
+    '#((a c e) (b d f)))
+  (equal?
+    (let ()
+      (define f
+        (lambda (a b c)
+          (let*-values (((d e) (let ((x values)) (x 1 2))))
+            (list a b c d e))))
+      (f 3 4 5))
+    '(3 4 5 1 2))
+  (equal?
+    (let ()
+      (define f1
+        (lambda (x) (apply values (vector->list x))))
+      (define f2
+        (lambda (a b)
+          (let*-values ([(d) (f1 a)]
+                       [(e . f) (f1 b)]
+                       [(g h i) (f1 b)]
+                       [j (f1 b)])
+            (list d e f g h i j))))
+      (f2 '#(a) '#(b c d)))
+    '(a b (c d) b c d (b c d)))
+  (eqv?
+    (letrec ((z 2)
+             (f (lambda () (values 1 z)))
+             (g (lambda (x y) (values x y z))))
+      (let*-values ([(c d e) (let*-values ([(z b) (f)]) (g z b))])
+        (+ c d e z)))
+    7)
+  (equal?
+    (let ([a 3])
+      (let*-values ([(a b) (values (+ a 1) (+ a 2))]
+                    [(c) (values (+ a 3))])
+        (list a b c)))
+    '(4 5 7))
+ ; make sure pattern variables and ellipses on RHS don't screw us up
+  (eqv?
+    (let ()
+      (define-syntax q
+        (lambda (x)
+          (syntax-case x ()
+            [(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
+      (let*-values ([(a) (q ...)]) a))
+    3)
+  (equal?
+    (syntax-case '(a b c) ()
+      [(x ...) (let*-values ([(args) #'(x ...)]) args)])
+    '(a b c))
+)
diff --git a/mats/4.ms b/mats/4.ms
new file mode 100644
index 0000000..d66ca7c
--- /dev/null
+++ b/mats/4.ms
@@ -0,0 +1,3982 @@
+;;; 4.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; section 4-1:
+
+(mat apply
+   (equal? (apply cons '(1 2)) '(1 . 2))
+   (equal? (apply list '(1 2 3 4 5)) '(1 2 3 4 5))
+   (equal? (apply (lambda (x . y) (list x y)) '(1 2 3 4 5)) '(1 (2 3 4 5)))
+   (equal? (apply list '(1 2 3)) '(1 2 3))
+   (equal? (apply list 1 '(2 3)) '(1 2 3))
+   (equal? (apply list 1 2 '(3)) '(1 2 3))
+   (equal? (apply list 1 2 3 '()) '(1 2 3))
+   (error? (apply))
+   (error? (apply list))
+   (error? (apply list 3))
+   (error? (apply list 3 4))
+   (error? (apply list 3 4 5 6 7 8 9))
+   (error? (apply list 3 '(4 . 5)))
+   (error? (apply list 3 4 5 6 7 8 9 '(10 . 11)))
+   (error? (apply + '#1=(1 2 . #1#)))
+   (equivalent-expansion?
+     (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
+                    [#%$suppress-primitive-inlining #f]
+                    [optimize-level 2])
+       (expand/optimize
+         `(let ()
+            (import scheme)
+            (apply + ',(make-list 1000 3)))))
+     3000)
+ )
+
+;;; section 4-2:
+
+(mat quote
+   (equal? '() (cdr '(a)))
+   (equal? '(a b c) (list 'a 'b 'c))
+   (equal? '#(a b c) (vector 'a 'b 'c))
+   (equal? 'a (string->symbol "a")))
+
+(mat quasiquote ; adapted from The Scheme Programming Language
+   (equal? `(+ 2 3) '(+ 2 3))
+   (equal? `(+ 2 ,(* 3 4)) '(+ 2 12))
+   (equal? `(a b (,(+ 2 3) c) d) '(a b (5 c) d))
+   (equal? `(a b ,(reverse '(c d e)) f g) '(a b (e d c) f g))
+   (equal? `(+ ,@(cdr '(* 2 3))) '(+ 2 3))
+   (equal? `(a b ,@(reverse '(c d e)) f g) '(a b e d c f g))
+   (equal? '`,(cons 'a 'b) (list 'quasiquote (list 'unquote '(cons 'a 'b))))
+   (equal? `',(cons 'a 'b) ''(a . b))
+   (equal? `#(+ 2 3) '#(+ 2 3))
+   (equal? `#(+ 2 ,(* 3 4)) '#(+ 2 12))
+   (equal? `#(a b (,(+ 2 3) c) d) '#(a b (5 c) d))
+   (equal? `#(a b ,(reverse '(c d e)) f g) '#(a b (e d c) f g))
+   (equal? `#(+ ,@(cdr '(* 2 3))) '#(+ 2 3))
+   (equal? `#(a b ,@(reverse '(c d e)) f g) '#(a b e d c f g))
+   (equal? `#(10 5 ,@'(4 3)) '#(10 5 4 3))
+   (equal? (let ((x 1) (y 2))
+             `(foo (,x ,y)
+                   `(bar ,@(baz ,y))))
+           '(foo (1 2) `(bar ,@(baz 2))))
+   (equal? `#&(10 5 ,@'(4 3)) '#&(10 5 4 3))
+   (equal? `#&,cons (box cons))
+  ; test Bawden's extensions to quasiquote
+   (equal? `(a (unquote-splicing '(b) '(c)) d) '(a b c d))
+   (equal? `(a (unquote '(b) '(c)) d) '(a (b) (c) d))
+   (begin
+     (begin (define x '(m n)) (define m '(b c)) (define n '(d e)))
+     (equal?
+       (list (eval ``(a ,@,@x f) (interaction-environment))
+             (eval ``(a ,@,@x) (interaction-environment)))
+       '((a b c d e f) (a b c d e))))
+  ; test to make sure we leave bare unquote alone in vectors
+   (equal? `#((+ 1 2) unquote)
+           '#((+ 1 2) unquote))
+   (equal? `#((+ 1 2) unquote (+ 3 4))
+           '#((+ 1 2) unquote (+ 3 4)))
+   (equal? `#((+ 1 2) unquote (list 3 4))
+           '#((+ 1 2) unquote (list 3 4)))
+   (equal? `#((+ 1 2) unquote (+ 2 3) (+ 3 4))
+           '#((+ 1 2) unquote (+ 2 3) (+ 3 4)))
+   (equal? `#(unquote)
+           '#(unquote))
+   (equal? `#(unquote (+ 3 4))
+           '#(unquote (+ 3 4)))
+   (equal? `#(unquote (list 3 4))
+           '#(unquote (list 3 4)))
+   (equal? `#(unquote (+ 2 3) (+ 3 4))
+           '#(unquote (+ 2 3) (+ 3 4)))
+  ; new tests to exercise reimplementation
+   (let ([f (lambda () (import scheme) `(,'a . ,'b))])
+     (not (eq? (f) (f))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(,a . ,b)))
+    (if (= (optimize-level) 3)
+        '(#3%cons a b)
+        '(#2%cons a b)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(,a ,c . ,b)))
+    (if (= (optimize-level) 3)
+        '(#3%list* a c b)
+        '(#2%list* a c b)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a ,@b ,c d ,e f)))
+    (if (= (optimize-level) 3)
+        '(#3%cons 'a (#3%append b (#3%list* c 'd e '(f))))
+        '(#2%cons 'a (#2%append b (#2%list* c 'd e '(f))))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(,'a ,'c . ,'b)))
+    (if (= (optimize-level) 3)
+        '(#3%list* 'a 'c 'b)
+        '(#2%list* 'a 'c 'b)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b c)))
+    ''(a b c))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b ,c)))
+    (if (= (optimize-level) 3)
+        '(#3%list 'a 'b c)
+        '(#2%list 'a 'b c)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(,'a ,@c ,'b)))
+    (if (= (optimize-level) 3)
+        '(#3%cons 'a (#3%append c (#3%list 'b)))
+        '(#2%cons 'a (#2%append c (#2%list 'b)))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a ,@'() c)))
+    (if (= (optimize-level) 3)
+        '(#3%cons 'a (#3%append '() '(c)))
+        '(#2%cons 'a (#2%append '() '(c)))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote) d)))
+    ''(a b d))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote c1) d)))
+    (if (= (optimize-level) 3)
+        '(#3%list* 'a 'b c1 '(d))
+        '(#2%list* 'a 'b c1 '(d))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote c1 c2) d)))
+    (if (= (optimize-level) 3)
+        '(#3%list* 'a 'b c1 c2 '(d))
+        '(#2%list* 'a 'b c1 c2 '(d))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote c1) ,d)))
+    (if (= (optimize-level) 3)
+        '(#3%list 'a 'b c1 d)
+        '(#2%list 'a 'b c1 d)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote c1 c2) ,d)))
+    (if (= (optimize-level) 3)
+        '(#3%list 'a 'b c1 c2 d)
+        '(#2%list 'a 'b c1 c2 d)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote-splicing) d)))
+    ''(a b d))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote-splicing c1) d)))
+    (if (= (optimize-level) 3)
+        '(#3%list* 'a 'b (#3%append c1 '(d)))
+        '(#2%list* 'a 'b (#2%append c1 '(d)))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a b (unquote-splicing c1 c2) d)))
+    (if (= (optimize-level) 3)
+        '(#3%list* 'a 'b (#3%append c1 c2 '(d)))
+        '(#2%list* 'a 'b (#2%append c1 c2 '(d)))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b c)))
+    ''#(a b c))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(,c d)))
+    (if (= (optimize-level) 3)
+        '(#3%vector c 'd)
+        '(#2%vector c 'd)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b ,c)))
+    (if (= (optimize-level) 3)
+        '(#3%vector 'a 'b c)
+        '(#2%vector 'a 'b c)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b ,c d)))
+    (if (= (optimize-level) 3)
+        '(#3%vector 'a 'b c 'd)
+        '(#2%vector 'a 'b c 'd)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b ,@c d)))
+    (if (= (optimize-level) 3)
+        '(#3%list->vector (#3%list* 'a 'b (#3%append c '(d))))
+        '(#2%list->vector (#2%list* 'a 'b (#2%append c '(d))))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b (unquote) d)))
+    ''#(a b d))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b (unquote c1) d)))
+    (if (= (optimize-level) 3)
+        '(#3%vector 'a 'b c1 'd)
+        '(#2%vector 'a 'b c1 'd)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b (unquote c1 c2) d)))
+    (if (= (optimize-level) 3)
+        '(#3%vector 'a 'b c1 c2 'd)
+        '(#2%vector 'a 'b c1 c2 'd)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b (unquote-splicing) d)))
+    ''#(a b d))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b (unquote-splicing c1) d)))
+    (if (= (optimize-level) 3)
+        '(#3%list->vector (#3%list* 'a 'b (#3%append c1 '(d))))
+        '(#2%list->vector (#2%list* 'a 'b (#2%append c1 '(d))))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`#(a b (unquote-splicing c1 c2) d)))
+    (if (= (optimize-level) 3)
+        '(#3%list->vector (#3%list* 'a 'b (#3%append c1 c2 '(d))))
+        '(#2%list->vector (#2%list* 'a 'b (#2%append c1 c2 '(d))))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '`(a `(b0 ,(b1 ,@b2 ,@b3)) (unquote c1 c2) ,d)))
+    (if (= (optimize-level) 3)
+        '(#3%list 'a
+           (#3%list 'quasiquote
+             (#3%list 'b0
+               (#3%list 'unquote (#3%cons 'b1 (#3%append b2 b3)))))
+           c1 c2 d)
+        '(#2%list 'a
+           (#2%list 'quasiquote
+             (#2%list 'b0
+               (#2%list 'unquote (#2%cons 'b1 (#2%append b2 b3)))))
+           c1 c2 d)))
+ )
+
+;;; section 4-3:
+
+(mat begin
+   (error? (or (begin) #t)) ;just see if (begin) is allowed
+   (begin (eq? 'a 'a))
+   (let ([x 'a]) (begin (set! x 'b) (eq? x 'b)))
+   (let ([x 'a])
+      (begin
+         (set! x 'b)
+         (set! x (cons x x))
+         (equal? x '(b . b))))
+ )
+
+;;; section 4-4:
+
+(mat if
+   (let ([x 'a])
+      (set! x 'b)
+      (and
+         (eq? (if (eq? x 'a) 'a 'b) 'b)
+         (eq? (if (eq? x 'b) 'a 'b) 'a)))
+   (let ([x 'a])
+      (if (eq? x 'a) (set! x 'b))
+      (if (eq? x 'a) (set! x 'c))
+      (eq? x 'b))
+
+   (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (not (not (f x))) e1 e2)))
+     '(if (f x) e1 e2))
+
+   (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #f #t)) e1 e2)))
+     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) e2 e1)))
+
+  (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #f #f)) e1 e2)))
+     '(begin (set! x y) (set! z y) (#2%zero? h) e2))
+
+  (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #t #t)) e1 e2)))
+     '(begin (set! x y) (set! z y) (#2%zero? h) e1))
+  
+  (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #t #f)) e1 e2)))
+     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) e1 e2)))
+
+  (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #f))) e1 e2)))
+     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e1) (begin (set! l y) e2))))
+
+  (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #t))) e1 e2)))
+     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e1))
+
+  (equivalent-expansion?
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #f))) e1 e2)))
+     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e2))
+
+  (equivalent-expansion? 
+     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #t))) e1 e2)))
+     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e2) (begin (set! l y) e1))))
+
+ )
+
+(mat when
+   (= (let ((x 12)) (when (= x 12) (set! x 11) (set! x 1)) x) 1)
+   (= (let ((x 12)) (when (= x 11) (set! x 11) (set! x 1)) x) 12)
+ )
+
+(mat unless
+   (eq? (let ((y 'a)) (unless (eq? y 'b) (set! y 'c)) y) 'c)
+   (eq? (let ((y 'a)) (unless (eq? y 'a) (set! y 'c)) y) 'a)
+ )
+
+(mat not
+   (not #f)
+   (not (not #t))
+   (let ((x 3)) (set! x 4) (not (= x 3)))
+ )
+
+(mat and
+   (not (let ((x 'x)) (set! x #f) (and x #t #t)))
+   (eq? (let ((x 'x)) (and x (begin (set! x 'c) x) x)) 'c)
+ )
+
+(mat or
+   (equal? (let ((x 'x)) (set! x '()) (or (eq? x 'x) (cons x x) 3)) '(()))
+   (equal? (let ((x 'x)) (set! x '()) (or (eq? x 'x) (not (null? x)) 3)) 3)
+   (not (let ((x 'x)) (set! x '()) (or (eq? x 'x) (not (null? x)))))
+   ; make sure the following isn't incorrectly recognized as an or
+   (equal? (let ((x #f)) (if x x (cons x x))) '(#f . #f))
+ )
+
+(mat cond
+  (error? ; invalid syntax
+    (cond))
+   (let ((a 'a))
+      (and (begin (set! a 3)
+                  (cond ((= a 4) #f) ((= a 3) #t) (else #f)))
+           (begin (set! a 4)
+                  (cond ((= a 4) #t) ((= a 3) #f) (else #f)))
+           (begin (set! a 2)
+                  (cond ((= a 4) #f) ((= a 3) #f) (else #t)))
+           (begin (set! a 4)
+                  (cond ((= a 4)) ((= a 3) #f) (else #f)))
+           (begin (set! a 3)
+                  (cond ((= a 4) #f) ((= a 3) (= a 4) #t) (else #f)))))
+   (eq? 'b (cond ((assq 'a '((a . b))) => cdr) (else #f)))
+   (equal? '(b c) (cond ((memq 'b '(a b c))) (else #f)))
+  ; make sure cond requires procedure on RHS of =>
+   (error?
+     (let () ; aziz's strange example
+       (define-syntax x
+         (syntax-rules ()
+           ((_ t) (lambda (t) t))))
+       ((cond (#t => x)) 18)))
+ )
+
+(mat exclusive-cond
+   (error? ; invalid syntax
+     (exclusive-cond [a . b]))
+   (error? ; invalid syntax
+     (exclusive-cond))
+   (let ((a 'a))
+      (and (begin (set! a 3)
+                  (exclusive-cond ((= a 4) #f) ((= a 3) #t) (else #f)))
+           (begin (set! a 4)
+                  (exclusive-cond ((= a 4) #t) ((= a 3) #f) (else #f)))
+           (begin (set! a 2)
+                  (exclusive-cond ((= a 4) #f) ((= a 3) #f) (else #t)))
+           (begin (set! a 4)
+                  (exclusive-cond ((= a 4) => (lambda (x) x)) ((= a 3) #f) (else #f)))
+           (begin (set! a 3)
+                  (exclusive-cond ((= a 4) #f) ((= a 3) (= a 4) #t) (else #f)))))
+   (eq? 'b (exclusive-cond ((assq 'a '((a . b))) => cdr) (else #f)))
+   (equal? '(b c) (exclusive-cond ((memq 'b '(a b c)) => (lambda (x) x)) (else #f)))
+  ; make sure exclusive-cond requires procedure on RHS of =>
+   (error?
+     (let () ; aziz's strange example
+       (define-syntax x
+         (syntax-rules ()
+           ((_ t) (lambda (t) t))))
+       ((exclusive-cond (#t => x)) 18)))
+  ; verify that exclusive cond actually reorders with profile information available
+   (begin
+     (with-output-to-file "testfile.ss"
+       (lambda ()
+         (pretty-print
+           '(let ()
+              (define count1 0)
+              (define count2 0)
+              (define count3 0)
+              (define count4 0)
+              (define count5 0)
+              (define foo
+                (lambda (n)
+                  (exclusive-cond
+                    [(begin (set! count1 (+ count1 1)) (< n 5))
+                     (set! count3 (+ count3 1))]
+                    [(begin (set! count2 (+ count2 1)) (> n 5))
+                     (set! count4 (+ count4 1))]
+                    [else (set! count5 (+ count5 1))])))
+              (do ([i 10 (fx- i 1)])
+                ((fx= i 0))
+                (foo 10))
+              (foo 3)
+              (pretty-print (list count1 count2 count3 count4 count5)))))
+       'replace)
+     (profile-clear-database)
+     #t)
+   (equal?
+     (with-output-to-string
+       (lambda ()
+         ; make sure no collection occurs before profile data is dumped
+         (parameterize ([compile-profile #t] [collect-request-handler void])
+           (load "testfile.ss" compile)
+           (profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump))))
+         ; make sure collections are restarted
+         (collect)))
+     "(11 10 1 10 0)\n")
+   (begin
+     (profile-load-data "testfile.pd")
+     #t)
+   (equal?
+     (with-output-to-string
+       (lambda ()
+         (load "testfile.ss" compile)))
+     "(1 11 1 10 0)\n")
+   (begin
+     (profile-clear-database)
+     #t)
+   (begin
+     (profile-load-data "testfile.pd" "testfile.pd")
+     #t)
+   (equal?
+     (with-output-to-string
+       (lambda ()
+         (load "testfile.ss" compile)))
+     "(1 11 1 10 0)\n")
+   (begin
+     (profile-clear-database)
+     #t)
+ )
+
+(mat case
+  (error? ; invalid syntax
+    (case 3 [a . b]))
+  (eq? (case 'a [a 'yes] [b 'no]) 'yes)
+  (let ((a 'a))
+    (and
+      (begin (set! a 'a)
+        (case a (a #t) ((b c) #f))
+        (case a (a #t) ((b c) #f) (else #f)))
+      (begin (set! a 'b)
+        (case a (a #f) ((b c) #t))
+        (case a (a #f) ((b c) #t) (else #f)))
+      (begin (set! a 'c)
+        (case a (a #f) ((b c) #t))
+        (case a (a #f) ((b c) #t) (else #f)))
+      (begin (set! a 'd)
+        (case a (a #f) ((b c) #f) (else #t)))))
+  (let ([f (lambda (x)
+             (case x
+               (#\a 'case1)
+               (1/2 'case2)
+               (999999999999999 'case3)
+               (3.4 'case4)
+               (else 'oops)))])
+    (and (eq? (f (string-ref "abc" 0)) 'case1)
+         (eq? (f (exact 0.5)) 'case2)
+         (eq? (f (- 1000000000000000 1)) 'case3)
+         (eq? (f (+ 3.0 4/10)) 'case4)
+         (eq? (f 'b) 'oops)))
+  (case '() [() #f] [else #t])
+  (case '() [(()) #t] [else #f])
+  (case "meow" ["meow" #t] [else #f])
+  (case '(1 2 3) [((1 2 3) (3 2 1)) #t] [else #f])
+  (case 'a [1 6] ["meow" #f] [(a b c) #t])
+  (case #\: [1 6] ["meow" #f] [(a b c) #f] [(#\; #\9 #\: #\4) #t])
+  (case (/ 12.0 3.0) [(4 5 6) #f] [("bla") #f] [(a b c) #f] [(1 5.8 4.9 4.0) #t] [else #f])
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(define foo
+             (lambda (x)
+               (case x
+                 [("three" 4) 'B]
+                 [("three" 5) 'A]
+                 [else #f]))))
+        (pretty-print
+          '(begin
+             (do ([i 10 (fx- i 1)]) ((fx= i 0)) (write (foo 5)))
+             (write (foo "three")))))
+      'replace)
+    (profile-clear-database)
+    #t)
+  ; verify no reordering w/no profile information
+  (let ([x (let* ([ip (open-file-input-port "testfile.ss")]
+                  [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
+                  [ip (transcoded-port ip (native-transcoder))])
+             (let-values ([(x efp) (get-datum/annotations ip sfd 0)])
+               (close-port ip)
+               (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f]) (expand/optimize x))))])
+    ; redundant keys might or might not be pruned, so allow it both ways
+    (or (equivalent-expansion?
+          x
+          '(begin
+             (set! foo
+               (lambda (x)
+                 (let ([t x])
+                   (if (#2%member t '("three" 4))
+                       'B
+                       (if (#2%member t '("three" 5))
+                           'A
+                           #f)))))
+             (#2%void)))
+        (equivalent-expansion?
+          x
+          '(begin
+             (set! foo
+               (lambda (x)
+                 (let ([t x])
+                   (if (#2%member t '("three" 4))
+                       'B
+                       (if (#2%member t '(5))
+                           'A
+                           #f)))))
+             (#2%void)))))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (parameterize ([compile-profile #t]) (load "testfile.ss" compile))))
+    "AAAAAAAAAAB")
+  (begin
+    (profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump)))
+    (profile-load-data "testfile.pd")
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load "testfile.ss" compile)))
+    "AAAAAAAAAAB")
+  ; verify reordering based on profile information
+  (equivalent-expansion?
+    (let* ([ip (open-file-input-port "testfile.ss")]
+           [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
+           [ip (transcoded-port ip (native-transcoder))])
+      (let-values ([(x efp) (get-datum/annotations ip sfd 0)])
+        (close-port ip)
+        (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f]) (expand/optimize x))))
+    '(begin
+       (set! foo
+         (lambda (x)
+           (let ([t x])
+             (if (#2%member t '(5))
+                 'A
+                 (if (#2%member t '("three" 4))
+                     'B
+                     #f)))))
+       (#2%void)))
+  (begin
+    (profile-clear-database)
+    #t)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(lambda (x) (case x [(a b a 7) 'one] [(c a 7 9) 'two] [else 'three]))))
+    '(lambda (x)
+       (let ([t x])
+         (if (#2%member t '(a b 7))
+             'one
+             (if (#2%member t '(c 9))
+                 'two
+                 'three)))))
+  ; ensure we don't miss syntax errors through case discarding unreachable clause bodies
+  (error? ; invalid syntax (if)
+    (lambda (x)
+      (case x
+        [(a) 'one]
+        [(b c) 'two]
+        [(a b c) (if)]
+        [else #f])))
+  ; ensure expansion into cond doesn't cause => to "work" for case
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (case x
+        [(a b c) => values])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (case x
+        [(a b c) #f]
+        [(d e f) => values])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (case x
+        [(a b c) #f]
+        [(a b c) => values])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (case x
+        [(a b c) => values]
+        [else #f])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (case x
+        [(a b c) #f]
+        [(d e f) => values]
+        [else #f])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (case x
+        [(a b c) #f]
+        [(a b c) => values]
+        [else #f])))
+  (error? ; invalid syntax (case)
+    (case))
+)
+
+(mat r6rs:case
+  (error? ; invalid syntax
+    (let ()
+      (import (only (rnrs) case))
+      (case 'a [a 'yes] [b 'no])))
+  (error? ; invalid syntax
+    (let ()
+      (import (only (rnrs) case))
+      (case 'a [a 'yes] [b 'no])))
+  (let ((a 'a))
+    (import (only (rnrs) case))
+    (and
+      (begin (set! a 'a)
+        (case a ((a) #t) ((b c) #f))
+        (case a ((a) #t) ((b c) #f) (else #f)))
+      (begin (set! a 'b)
+        (case a ((a) #f) ((b c) #t))
+        (case a ((a) #f) ((b c) #t) (else #f)))
+      (begin (set! a 'c)
+        (case a ((a) #f) ((b c) #t))
+        (case a ((a) #f) ((b c) #t) (else #f)))
+      (begin (set! a 'd)
+        (case a ((a) #f) ((b c) #f) (else #t)))))
+  (let ([f (lambda (x)
+             (import (only (rnrs) case))
+             (case x
+               ((#\a) 'case1)
+               ((1/2) 'case2)
+               ((999999999999999) 'case3)
+               ((3.4) 'case4)
+               (else 'oops)))])
+    (and (eq? (f (string-ref "abc" 0)) 'case1)
+         (eq? (f (exact 0.5)) 'case2)
+         (eq? (f (- 1000000000000000 1)) 'case3)
+         (eq? (f (+ 3.0 4/10)) 'case4)
+         (eq? (f 'b) 'oops)))
+  (let ()
+    (import (only (rnrs) case))
+    (case '() [() #f] [else #t]))
+  (let ()
+    (import (only (rnrs) case))
+    (case '() [(()) #t] [else #f]))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(lambda (x)
+                          (import (only (rnrs) case))
+                          (case x [(a b a 7) 'one] [(c a 7 9) 'two] [else 'three]))))
+    '(lambda (x)
+       (let ([t x])
+         (if (#2%memv t '(a b 7))
+             'one
+             (if (#2%memv t '(c 9))
+                 'two
+                 'three)))))
+  ; ensure we don't miss syntax errors through case discarding unreachable clause bodies
+  (error? ; invalid syntax (if)
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a) 'one]
+        [(b c) 'two]
+        [(a b c) (if)]
+        [else #f])))
+  ; ensure expansion into cond doesn't cause => to "work" for case
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a b c) => values])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a b c) #f]
+        [(d e f) => values])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a b c) #f]
+        [(a b c) => values])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a b c) => values]
+        [else #f])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a b c) #f]
+        [(d e f) => values]
+        [else #f])))
+  (error? ; invalid syntax =>
+    (lambda (x)
+      (import (only (rnrs) case))
+      (case x
+        [(a b c) #f]
+        [(a b c) => values]
+        [else #f])))
+  (error? ; invalid syntax (case)
+    (let ()
+      (import (only (rnrs) case))
+      (case)))
+)
+
+(mat record-case
+   (record-case '(a b c)
+      [a (b c) (and (eq? b 'b) (eq? c 'c))]
+      [b x #f]
+      [c x #f]
+      [else #f])
+   (record-case (list #\a #\b #\c)
+      [#\a (b c) (and (eq? b #\b) (eq? c #\c))]
+      [#\b x #f]
+      [#\c x #f])
+   (record-case (list (/ 3 4) 'b 'c)
+      [1/2 x #f]
+      [3/4 x (equal? x '(b c))]
+      [5/8 x #f]
+      [else #f])
+   (record-case '(d a b c)
+      [a x (equal? x '(b c))]
+      [b x #f]
+      [c x #f]
+      [else #t])
+   (record-case '(a b c d e)
+      [a (x1 x2 x3 . x4) (equal? (list x1 x2 x3 x4) '(b c d (e)))]
+      [else #f])
+ )
+
+;;; section 4-5:
+
+(mat named-let
+   (eqv? (let f ((x 5)) (if (zero? x) 1 (* x (f (1- x))))) 120)
+   (let f ((x 10000)) (if (zero? x) #t (f (1- x))))
+   (let f ([x 10] [y 0]) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))
+   (eqv? (let f ([x 10]) (if (= x 0) 1 (+ (f (- x 1)) 1))) 11)
+   (eqv? (let ([base 20])
+            (let f ([x 10])
+               (if (= x 0) base
+                   (+ (f (- x 1)) 1))))
+         30)
+   ; this looks almost like a named let, but isn't, and is treated as
+   ; if the 4 were not present by some earlier verisons
+   (error? ((letrec ((x (lambda (x) x))) x) 3 4))
+ )
+
+(define ($destroy ls x)
+  (when (pair? ls)
+    ($destroy (cdr ls) x)
+    (set-cdr! ls x)))
+
+(mat map
+   (eqv? (map car '()) '())
+   (equal? (map 1+ '(1 2 3 4 5 6)) '(2 3 4 5 6 7))
+   (equal? (map 1+ '()) '())
+   (equal? (map cons '(1 2 3) '(4 5 6)) '((1 . 4) (2 . 5) (3 . 6)))
+   (let ((x 3))
+      (equal? (apply + (map (lambda (y) (set! x (1+ x)) x) '(a b c d)))
+              22))
+   (equal? (map (lambda (x y z) (+ x (+ y z)))
+                '(1 2 3 4 5)
+                '(11 12 13 14 15)
+                '(21 22 23 24 25))
+           '(33 36 39 42 45))
+   (begin
+     (define ($map-f1 p x1 x2 x3 x4 x5)
+       (list
+         (map p '())
+         (map p '() x1)
+         (map p '() x1 x2)
+         (map p '() x1 x2 x3)
+         (map p '() x1 x2 x3 x4)
+         (map p '() x1 x2 x3 x4 x5)
+         (map p x1 '())
+         (map p x1 '() x2)
+         (map p x1 '() x2 x3)
+         (map p x1 '() x2 x3 x4)
+         (map p x1 '() x2 x3 x4 x5)
+         (map p x1 x2 '())
+         (map p x1 x2 '() x3)
+         (map p x1 x2 '() x3 x4)
+         (map p x1 x2 '() x3 x4 x5)
+         (map p x1 x2 x3 '())
+         (map p x1 x2 x3 '() x4)
+         (map p x1 x2 x3 '() x4 x5)
+         (map p x1 x2 x3 x4 '())
+         (map p x1 x2 x3 x4 '() x5)
+         (map p x1 x2 x3 x4 x5 '())))
+     (procedure? $map-f1))
+   (equal?
+     ($map-f1 list '() '() '() '() '())
+     '(() () () () () () () () () () () () () () () () () ()
+       () () ()))
+   (begin
+     (define ($map-f1 p x1 x2 x3 x4 x5)
+       (list
+         (map p '(a))
+         (map p '(a) x1)
+         (map p '(a) x1 x2)
+         (map p '(a) x1 x2 x3)
+         (map p '(a) x1 x2 x3 x4)
+         (map p '(a) x1 x2 x3 x4 x5)
+         (map p x1 '(a))
+         (map p x1 '(a) x2)
+         (map p x1 '(a) x2 x3)
+         (map p x1 '(a) x2 x3 x4)
+         (map p x1 '(a) x2 x3 x4 x5)
+         (map p x1 x2 '(a))
+         (map p x1 x2 '(a) x3)
+         (map p x1 x2 '(a) x3 x4)
+         (map p x1 x2 '(a) x3 x4 x5)
+         (map p x1 x2 x3 '(a))
+         (map p x1 x2 x3 '(a) x4)
+         (map p x1 x2 x3 '(a) x4 x5)
+         (map p x1 x2 x3 x4 '(a))
+         (map p x1 x2 x3 x4 '(a) x5)
+         (map p x1 x2 x3 x4 x5 '(a))))
+     (procedure? $map-f1))
+   (equal?
+     ($map-f1 list '(1) '(4) '(d) '(g) '(7))
+     '(((a))
+       ((a 1))
+       ((a 1 4))
+       ((a 1 4 d))
+       ((a 1 4 d g))
+       ((a 1 4 d g 7))
+       ((1 a))
+       ((1 a 4))
+       ((1 a 4 d))
+       ((1 a 4 d g))
+       ((1 a 4 d g 7))
+       ((1 4 a))
+       ((1 4 a d))
+       ((1 4 a d g))
+       ((1 4 a d g 7))
+       ((1 4 d a))
+       ((1 4 d a g))
+       ((1 4 d a g 7))
+       ((1 4 d g a))
+       ((1 4 d g a 7))
+       ((1 4 d g 7 a))))
+   (begin
+     (define ($map-f1 p x1 x2 x3 x4 x5)
+       (list
+         (map p '(a b))
+         (map p '(a b) x1)
+         (map p '(a b) x1 x2)
+         (map p '(a b) x1 x2 x3)
+         (map p '(a b) x1 x2 x3 x4)
+         (map p '(a b) x1 x2 x3 x4 x5)
+         (map p x1 '(a b))
+         (map p x1 '(a b) x2)
+         (map p x1 '(a b) x2 x3)
+         (map p x1 '(a b) x2 x3 x4)
+         (map p x1 '(a b) x2 x3 x4 x5)
+         (map p x1 x2 '(a b))
+         (map p x1 x2 '(a b) x3)
+         (map p x1 x2 '(a b) x3 x4)
+         (map p x1 x2 '(a b) x3 x4 x5)
+         (map p x1 x2 x3 '(a b))
+         (map p x1 x2 x3 '(a b) x4)
+         (map p x1 x2 x3 '(a b) x4 x5)
+         (map p x1 x2 x3 x4 '(a b))
+         (map p x1 x2 x3 x4 '(a b) x5)
+         (map p x1 x2 x3 x4 x5 '(a b))))
+     (procedure? $map-f1))
+   (equal?
+     ($map-f1 list '(1 2) '(4 5) '(d e) '(g h) '(7 j))
+     '(((a) (b))
+       ((a 1) (b 2))
+       ((a 1 4) (b 2 5))
+       ((a 1 4 d) (b 2 5 e))
+       ((a 1 4 d g) (b 2 5 e h))
+       ((a 1 4 d g 7) (b 2 5 e h j))
+       ((1 a) (2 b))
+       ((1 a 4) (2 b 5))
+       ((1 a 4 d) (2 b 5 e))
+       ((1 a 4 d g) (2 b 5 e h))
+       ((1 a 4 d g 7) (2 b 5 e h j))
+       ((1 4 a) (2 5 b))
+       ((1 4 a d) (2 5 b e))
+       ((1 4 a d g) (2 5 b e h))
+       ((1 4 a d g 7) (2 5 b e h j))
+       ((1 4 d a) (2 5 e b))
+       ((1 4 d a g) (2 5 e b h))
+       ((1 4 d a g 7) (2 5 e b h j))
+       ((1 4 d g a) (2 5 e h b))
+       ((1 4 d g a 7) (2 5 e h b j))
+       ((1 4 d g 7 a) (2 5 e h j b))))
+   (begin
+     (define ($map-f1 p x1 x2 x3 x4 x5)
+       (list
+         (map p '(a b c))
+         (map p '(a b c) x1)
+         (map p '(a b c) x1 x2)
+         (map p '(a b c) x1 x2 x3)
+         (map p '(a b c) x1 x2 x3 x4)
+         (map p '(a b c) x1 x2 x3 x4 x5)
+         (map p x1 '(a b c))
+         (map p x1 '(a b c) x2)
+         (map p x1 '(a b c) x2 x3)
+         (map p x1 '(a b c) x2 x3 x4)
+         (map p x1 '(a b c) x2 x3 x4 x5)
+         (map p x1 x2 '(a b c))
+         (map p x1 x2 '(a b c) x3)
+         (map p x1 x2 '(a b c) x3 x4)
+         (map p x1 x2 '(a b c) x3 x4 x5)
+         (map p x1 x2 x3 '(a b c))
+         (map p x1 x2 x3 '(a b c) x4)
+         (map p x1 x2 x3 '(a b c) x4 x5)
+         (map p x1 x2 x3 x4 '(a b c))
+         (map p x1 x2 x3 x4 '(a b c) x5)
+         (map p x1 x2 x3 x4 x5 '(a b c))))
+     (procedure? $map-f1))
+   (equal?
+     ($map-f1 list '(1 2 3) '(4 5 6) '(d e f) '(g h i) '(7 j 9))
+     '(((a) (b) (c))
+       ((a 1) (b 2) (c 3))
+       ((a 1 4) (b 2 5) (c 3 6))
+       ((a 1 4 d) (b 2 5 e) (c 3 6 f))
+       ((a 1 4 d g) (b 2 5 e h) (c 3 6 f i))
+       ((a 1 4 d g 7) (b 2 5 e h j) (c 3 6 f i 9))
+       ((1 a) (2 b) (3 c))
+       ((1 a 4) (2 b 5) (3 c 6))
+       ((1 a 4 d) (2 b 5 e) (3 c 6 f))
+       ((1 a 4 d g) (2 b 5 e h) (3 c 6 f i))
+       ((1 a 4 d g 7) (2 b 5 e h j) (3 c 6 f i 9))
+       ((1 4 a) (2 5 b) (3 6 c))
+       ((1 4 a d) (2 5 b e) (3 6 c f))
+       ((1 4 a d g) (2 5 b e h) (3 6 c f i))
+       ((1 4 a d g 7) (2 5 b e h j) (3 6 c f i 9))
+       ((1 4 d a) (2 5 e b) (3 6 f c))
+       ((1 4 d a g) (2 5 e b h) (3 6 f c i))
+       ((1 4 d a g 7) (2 5 e b h j) (3 6 f c i 9))
+       ((1 4 d g a) (2 5 e h b) (3 6 f i c))
+       ((1 4 d g a 7) (2 5 e h b j) (3 6 f i c 9))
+       ((1 4 d g 7 a) (2 5 e h j b) (3 6 f i 9 c))))
+   (begin
+     (define ($map-f1 p x1 x2 x3 x4 x5)
+       (list
+         (map p '(a b c d))
+         (map p '(a b c d) x1)
+         (map p '(a b c d) x1 x2)
+         (map p '(a b c d) x1 x2 x3)
+         (map p '(a b c d) x1 x2 x3 x4)
+         (map p '(a b c d) x1 x2 x3 x4 x5)
+         (map p x1 '(a b c d))
+         (map p x1 '(a b c d) x2)
+         (map p x1 '(a b c d) x2 x3)
+         (map p x1 '(a b c d) x2 x3 x4)
+         (map p x1 '(a b c d) x2 x3 x4 x5)
+         (map p x1 x2 '(a b c d))
+         (map p x1 x2 '(a b c d) x3)
+         (map p x1 x2 '(a b c d) x3 x4)
+         (map p x1 x2 '(a b c d) x3 x4 x5)
+         (map p x1 x2 x3 '(a b c d))
+         (map p x1 x2 x3 '(a b c d) x4)
+         (map p x1 x2 x3 '(a b c d) x4 x5)
+         (map p x1 x2 x3 x4 '(a b c d))
+         (map p x1 x2 x3 x4 '(a b c d) x5)
+         (map p x1 x2 x3 x4 x5 '(a b c d))))
+     (procedure? $map-f1))
+   (equal?
+     ($map-f1 list '(1 2 3 4) '(f g h i) '(k l m n) '(p q r s) '(u v w x))
+     '(((a) (b) (c) (d)) ((a 1) (b 2) (c 3) (d 4))
+       ((a 1 f) (b 2 g) (c 3 h) (d 4 i))
+       ((a 1 f k) (b 2 g l) (c 3 h m) (d 4 i n))
+       ((a 1 f k p) (b 2 g l q) (c 3 h m r) (d 4 i n s))
+       ((a 1 f k p u) (b 2 g l q v) (c 3 h m r w) (d 4 i n s x))
+       ((1 a) (2 b) (3 c) (4 d))
+       ((1 a f) (2 b g) (3 c h) (4 d i))
+       ((1 a f k) (2 b g l) (3 c h m) (4 d i n))
+       ((1 a f k p) (2 b g l q) (3 c h m r) (4 d i n s))
+       ((1 a f k p u) (2 b g l q v) (3 c h m r w) (4 d i n s x))
+       ((1 f a) (2 g b) (3 h c) (4 i d))
+       ((1 f a k) (2 g b l) (3 h c m) (4 i d n))
+       ((1 f a k p) (2 g b l q) (3 h c m r) (4 i d n s))
+       ((1 f a k p u) (2 g b l q v) (3 h c m r w) (4 i d n s x))
+       ((1 f k a) (2 g l b) (3 h m c) (4 i n d))
+       ((1 f k a p) (2 g l b q) (3 h m c r) (4 i n d s))
+       ((1 f k a p u) (2 g l b q v) (3 h m c r w) (4 i n d s x))
+       ((1 f k p a) (2 g l q b) (3 h m r c) (4 i n s d))
+       ((1 f k p a u) (2 g l q b v) (3 h m r c w) (4 i n s d x))
+       ((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d))))
+   (begin
+     (define ($map-f1 p x1 x2 x3 x4 x5)
+       (list
+         (map p '(a b c d e))
+         (map p '(a b c d e) x1)
+         (map p '(a b c d e) x1 x2)
+         (map p '(a b c d e) x1 x2 x3)
+         (map p '(a b c d e) x1 x2 x3 x4)
+         (map p '(a b c d e) x1 x2 x3 x4 x5)
+         (map p x1 '(a b c d e))
+         (map p x1 '(a b c d e) x2)
+         (map p x1 '(a b c d e) x2 x3)
+         (map p x1 '(a b c d e) x2 x3 x4)
+         (map p x1 '(a b c d e) x2 x3 x4 x5)
+         (map p x1 x2 '(a b c d e))
+         (map p x1 x2 '(a b c d e) x3)
+         (map p x1 x2 '(a b c d e) x3 x4)
+         (map p x1 x2 '(a b c d e) x3 x4 x5)
+         (map p x1 x2 x3 '(a b c d e))
+         (map p x1 x2 x3 '(a b c d e) x4)
+         (map p x1 x2 x3 '(a b c d e) x4 x5)
+         (map p x1 x2 x3 x4 '(a b c d e))
+         (map p x1 x2 x3 x4 '(a b c d e) x5)
+         (map p x1 x2 x3 x4 x5 '(a b c d e))))
+     (procedure? $map-f1))
+   (equal?
+     ($map-f1 list '(1 2 3 4 5) '(f g h i j) '(k l m n o) '(p q r s t) '(u v w x y))
+     '(((a) (b) (c) (d) (e)) ((a 1) (b 2) (c 3) (d 4) (e 5))
+       ((a 1 f) (b 2 g) (c 3 h) (d 4 i) (e 5 j))
+       ((a 1 f k) (b 2 g l) (c 3 h m) (d 4 i n) (e 5 j o))
+       ((a 1 f k p) (b 2 g l q) (c 3 h m r) (d 4 i n s) (e 5 j o t))
+       ((a 1 f k p u) (b 2 g l q v) (c 3 h m r w) (d 4 i n s x) (e 5 j o t y))
+       ((1 a) (2 b) (3 c) (4 d) (5 e))
+       ((1 a f) (2 b g) (3 c h) (4 d i) (5 e j))
+       ((1 a f k) (2 b g l) (3 c h m) (4 d i n) (5 e j o))
+       ((1 a f k p) (2 b g l q) (3 c h m r) (4 d i n s) (5 e j o t))
+       ((1 a f k p u) (2 b g l q v) (3 c h m r w) (4 d i n s x) (5 e j o t y))
+       ((1 f a) (2 g b) (3 h c) (4 i d) (5 j e))
+       ((1 f a k) (2 g b l) (3 h c m) (4 i d n) (5 j e o))
+       ((1 f a k p) (2 g b l q) (3 h c m r) (4 i d n s) (5 j e o t))
+       ((1 f a k p u) (2 g b l q v) (3 h c m r w) (4 i d n s x) (5 j e o t y))
+       ((1 f k a) (2 g l b) (3 h m c) (4 i n d) (5 j o e))
+       ((1 f k a p) (2 g l b q) (3 h m c r) (4 i n d s) (5 j o e t))
+       ((1 f k a p u) (2 g l b q v) (3 h m c r w) (4 i n d s x) (5 j o e t y))
+       ((1 f k p a) (2 g l q b) (3 h m r c) (4 i n s d) (5 j o t e))
+       ((1 f k p a u) (2 g l q b v) (3 h m r c w) (4 i n s d x) (5 j o t e y))
+       ((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d) (5 j o t y e))))
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (map x)))
+  (error? ; nonprocedure
+    (map 3 '()))
+  (error? ; nonprocedure
+    (map 3 '() '()))
+  (error? ; nonprocedure
+    (map 3 '(a b c)))
+  (error? ; nonprocedure
+    (parameterize ([optimize-level 3])
+      (eval '(#2%map 3 '(a b c)))))
+  (error? ; nonprocedure
+    (parameterize ([optimize-level 3])
+      (eval
+        '(let ()
+           (define (f p b)
+             (unbox b)
+             (#2%map p (if (box? b) '() '(1 2 3)))
+             (list p (procedure? p)))
+           (f 7 (box 0))))))
+  (error? ; improper list
+    (map pretty-print 'a))
+  (error? ; improper list
+    (map pretty-print '(a . b)))
+  (error? ; cyclic list
+    (map pretty-print '#1=(a . #1#)))
+  (error? ; length mismatch
+    (map list '(a b) '(p q r)))
+  (error? ; length mismatch
+    (map list '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (map list 'a '(a b)))
+  (error? ; improper list
+    (map list '(a b) 'a))
+  (error? ; improper list
+    (map list '(a . b) '(a b)))
+  (error? ; improper list
+    (map list '(a b) '(a . b)))
+  (error? ; cyclic list
+    (map list '#1# '(a b c)))
+  (error? ; cyclic list
+    (map list '(a b c) '#1#))
+  (error? ; improper list
+    (map list 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (map list '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (map list '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (map list '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (map list '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (map list '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (map list '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (map list '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (map list '(a b c) '(1 2 3) '#1#))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (map (lambda (x) ($destroy l 1) (* x x)) l))
+    '(1 4 9 16))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (map (lambda (x y) ($destroy l y) (cons x y)) l '(a b c d)))
+    '((1 . a) (2 . b) (3 . c) (4 . d)))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (map (lambda (x y) ($destroy l '()) (cons x y)) l '(a b c d)))
+    '((1 . a) (2 . b) (3 . c) (4 . d)))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (map (lambda (x y) ($destroy l y) (cons x y)) '(a b c d) l))
+    '((a . 1) (b . 2) (c . 3) (d . 4)))
+  (equal?
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (map (lambda (x y z) ($destroy l '()) (list z x y))
+           l
+           '(a b c d e f g)
+           '(p q r s t u v)))
+    '((p 1 a) (q 2 b) (r 3 c) (s 4 d) (t 5 e) (u 6 f) (v 7 g)))
+  (equal?
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (map (lambda (x y z) ($destroy l '()) (list z x y))
+           '(a b c d e f g)
+           l
+           '(p q r s t u v)))
+    '((p a 1) (q b 2) (r c 3) (s d 4) (t e 5) (u f 6) (v g 7)))
+  (equal?
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (map (lambda (x y z) ($destroy l '()) (list z x y))
+           '(a b c d e f g)
+           '(p q r s t u v)
+           l))
+    '((1 a p) (2 b q) (3 c r) (4 d s) (5 e t) (6 f u) (7 g v)))
+  (let ([orig-ls #f] [orig-cars #f] [orig-cdrs #f] [next #f])
+    (define (copy-spine ls)
+      (if (null? ls)
+          '()
+          (cons ls (copy-spine (cdr ls)))))
+    (let ([n 100])
+      (let ([ls (map (lambda (x) (cons (call/cc values) x)) (iota n))])
+        (if orig-ls
+            (begin
+              (unless (andmap eq? orig-ls orig-cars)
+                (errorf #f "original map cars mutated"))
+              (unless (andmap eq? (copy-spine orig-ls) orig-cdrs)
+                (errorf #f "original map cdrs mutated")))
+            (begin
+              (set! orig-ls ls)
+              (set! orig-cars (list-copy ls))
+              (set! orig-cdrs (copy-spine ls))
+              (set! next 0)))
+        (let ([m next])
+          (unless (= m n)
+            (set! next (fx+ next 1)) 
+            (let ([p (list-ref orig-ls m)])
+              (unless (eqv? (cdr p) m)
+                (errorf #f "unexpected cdr value (~s instead of ~s)" (cdr p) m))
+              ((car p) n)))))
+      (eqv? next n)))
+  (equal?
+    (let ([x 3])
+      (let ([y (map (begin (set! x 14) cons) '())])
+        (list x y)))
+    '(14 ()))
+  (equal?
+    (let ([x 3])
+      (let ([y (map (begin (set! x 14) list) '() '() '())])
+        (list x y)))
+    '(14 ()))
+  ;; cp0 optimizations for map
+  ;; mapping over empty list(s) always returns '()
+  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
+  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
+  (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
+  (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
+  ;; if map is called only for effects, remove the expression only if the procedure
+  ;; has the correct arity and can't raise an error
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+      (expand/optimize
+        '(begin (#3%map list '(5 4 3 2 1 0)) 7)))
+    7)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+      (expand/optimize
+        '(begin (#3%map box? '(5 4 3 2 1 0)) 7)))
+    7)
+  (not (equivalent-expansion?
+         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+           (expand/optimize
+             '(begin (#3%map unbox '(5 4 3 2 1 0)) 7)))
+           7))
+  (not (equivalent-expansion?
+         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+           (expand/optimize
+             '(begin (#3%map cons '(5 4 3 2 1 0)) 7)))
+           7))
+  ;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
+  ;; avoid creating each list and doing the actual map
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           (list 1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(#2%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           (list 1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(#3%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(#2%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(#3%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(#2%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(#3%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(map (lambda (x y z)
+                (string->symbol
+                  (apply
+                    string-append
+                    (map symbol->string (list x y z)))))
+              (list 'a 't 'x)
+              (list 'b 'u 'y)
+              (list 'c 'v 'z))))
+    '(#2%list
+       (#2%string->symbol (#2%string-append "a" "b" "c"))
+       (#2%string->symbol (#2%string-append "t" "u" "v"))
+       (#2%string->symbol (#2%string-append "x" "y" "z"))))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(map (lambda (x y z)
+                (string->symbol
+                  (apply
+                    string-append
+                    (map symbol->string (list x y z)))))
+              (list 'a 't 'x)
+              (list 'b 'u 'y)
+              (list 'c 'v 'z))))
+    '(#3%list
+       (#3%string->symbol (#3%string-append "a" "b" "c"))
+       (#3%string->symbol (#3%string-append "t" "u" "v"))
+       (#3%string->symbol (#3%string-append "x" "y" "z"))))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (begin (write 'ab) (lambda (x y) (cons x y)))
+                        (begin (write 'a) (list (begin (write 'b) 'c)))
+                        (begin (write 'a) (list (begin (write 'b) 'd)))))))
+    "ababab((c . d))\n")
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y) (cons x y))
+                        (list (begin (write 'a) 'c) (begin (write 'b) 'd))
+                        (list (begin (write 'x) 'e) (begin (write 'y) 'f))))))
+    ; lots of valid possibilities, but make sure we don't interleave and get, e.g., axby
+    '("abxy((c . e) (d . f))\n"
+      "abyx((c . e) (d . f))\n"
+      "baxy((c . e) (d . f))\n"
+      "bayx((c . e) (d . f))\n"
+      "xyab((c . e) (d . f))\n"
+      "yxab((c . e) (d . f))\n"
+      "xyba((c . e) (d . f))\n"
+      "yxba((c . e) (d . f))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+                        (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+                        (begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'ab) '(g j))
+                        (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+                        (begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+                        (begin (write 'cd) '(h k))
+                        (begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+                        (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+                        (begin (write 'ef) '(i l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
+ )
+
+(mat fold-left
+ ; next several are from r6rs
+  (eqv? (fold-left + 0 '(1 2 3 4 5)) 15)
+  (equal?
+    (fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5))
+    '(5 4 3 2 1))
+  (eqv?
+    (fold-left
+      (lambda (count x) (if (odd? x) (+ count 1) count))
+      0
+      '(3 1 4 1 5 9 2 6 5 3))
+    7)
+  (eqv?
+    (fold-left
+      (lambda (max-len s) (max max-len (string-length s)))
+      0
+      '("longest" "long" "longer"))
+    7)
+  (equal?
+    (fold-left cons '(q) '(a b c))
+    '((((q) . a) . b) . c))
+  (eqv? 
+    (fold-left + 0 '(1 2 3) '(4 5 6))
+    21)
+  (procedure? (lambda (x) (fold-left x)))
+  (procedure? (lambda (x) (fold-left x y)))
+  (error? ; nonprocedure
+    (fold-left 3 0 '()))
+  (error? ; nonprocedure
+    (fold-left 3 0 '() '()))
+  (error? ; nonprocedure
+    (fold-left 3 0 '(a b c)))
+  (error? ; improper list
+    (fold-left cons 0 'a))
+  (error? ; improper list
+    (fold-left cons 0 '(a . b)))
+  (error? ; cyclic list
+    (fold-left cons 0 '#1=(a . #1#)))
+  (error? ; length mismatch
+    (fold-left list 0 '(a b) '(p q r)))
+  (error? ; length mismatch
+    (fold-left list 0 '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (fold-left list 0 'a '(a b)))
+  (error? ; improper list
+    (fold-left list 0 '(a b) 'a))
+  (error? ; improper list
+    (fold-left list 0 '(a . b) '(a b)))
+  (error? ; improper list
+    (fold-left list 0 '(a b) '(a . b)))
+  (error? ; cyclic list
+    (fold-left list 0 '#1# '(a b c)))
+  (error? ; cyclic list
+    (fold-left list 0 '(a b c) '#1#))
+  (error? ; improper list
+    (fold-left list 0 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (fold-left list 0 '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (fold-left list 0 '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (fold-left list 0 '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (fold-left list 0 '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (fold-left list 0 '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (fold-left list 0 '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (fold-left list 0 '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (fold-left list 0 '(a b c) '(1 2 3) '#1#))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4)))
+      (fold-left (lambda (a x) ($destroy l 1) (+ x a)) 0 l)))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4)))
+      (fold-left (lambda (a x y) ($destroy l 'q) (list* a x y)) 0 l '(a b c d))))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4)))
+      (fold-left (lambda (a x y) ($destroy l 'q) (cons x y)) 0 l '(a b c d))))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4)))
+      (fold-left (lambda (a x y) ($destroy l 'q) (cons x y)) 0 '(a b c d) l)))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (fold-left (lambda (a x y z) ($destroy l 'q) (list z x y))
+        0
+        l
+        '(a b c d e f g)
+        '(p q r s t u v))))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (fold-left (lambda (a x y z) ($destroy l 'q) (list z x y))
+        0
+        '(a b c d e f g)
+        l
+        '(p q r s t u v))))
+  (error? ; list altered
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (fold-left (lambda (a x y z) ($destroy l 'q) (list z x y))
+        0
+        '(a b c d e f g)
+        '(p q r s t u v)
+        l)))
+ )
+
+(mat fold-right
+ ; next several are from r6rs
+  (eqv? (fold-right + 0 '(1 2 3 4 5)) 15)
+  (equal?
+    (fold-right cons '() '(1 2 3 4 5))
+    '(1 2 3 4 5))
+  (equal?
+    (fold-right
+      (lambda (x l) (if (odd? x) (cons x l) l))
+      '()
+      '(3 1 4 1 5 9 2 6 5))
+    '(3 1 1 5 9 5))
+  (equal?
+    (fold-right cons '(q) '(a b c))
+    '(a b c q))
+  (eqv? (fold-right + 0 '(1 2 3) '(4 5 6)) 21)
+  (eqv? (fold-right list 75 '()) 75)
+  (equal?
+    (let ([x 3])
+      (let ([y (fold-right (begin (set! x 14) cons) 75 '())])
+        (list x y)))
+    '(14 75))
+  (equal?
+    (let ([x 3])
+      (let ([y (fold-right (begin (set! x 14) list) 75 '() '() '())])
+        (list x y)))
+    '(14 75))
+  (equal?
+    (fold-right
+      (lambda (a b) (cons (1+ a) b))
+      'q
+      '(1 2 3 4 5 6))
+    '(2 3 4 5 6 7 . q))
+  (equal?
+    (fold-right list* 'q '(1 2 3 4) '(5 6 7 8) '(9 10 11 12))
+    '(1 5 9 2 6 10 3 7 11 4 8 12 . q))
+  (equal?
+    (let ((x 3))
+      (fold-right (lambda (y a) (set! x (1+ x)) (+ x a)) '5 '(a b c d)))
+    27)
+  (equal?
+    (fold-right (lambda (x y z a) (cons (+ x (+ y z)) a)) 'q
+      '(1 2 3 4 5) '(11 12 13 14 15) '(21 22 23 24 25))
+    '(33 36 39 42 45 . q))
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (fold-right x)))
+  (procedure? (lambda (x) (fold-right x y)))
+  (error? ; nonprocedure
+    (fold-right 3 0 '()))
+  (error? ; nonprocedure
+    (fold-right 3 0 '() '()))
+  (error? ; nonprocedure
+    (fold-right 3 0 '(a b c)))
+  (error? ; improper list
+    (fold-right list 0 'a))
+  (error? ; improper list
+    (fold-right list 0 '(a . b)))
+  (error? ; cyclic list
+    (fold-right list 0 '#1=(a . #1#)))
+  (error? ; length mismatch
+    (fold-right list 0 '(a b) '(p q r)))
+  (error? ; length mismatch
+    (fold-right list 0 '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (fold-right list 0 'a '(a b)))
+  (error? ; improper list
+    (fold-right list 0 '(a b) 'a))
+  (error? ; improper list
+    (fold-right list 0 '(a . b) '(a b)))
+  (error? ; improper list
+    (fold-right list 0 '(a b) '(a . b)))
+  (error? ; cyclic list
+    (fold-right list 0 '#1# '(a b c)))
+  (error? ; cyclic list
+    (fold-right list 0 '(a b c) '#1#))
+  (error? ; improper list
+    (fold-right list 0 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (fold-right list 0 '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (fold-right list 0 '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (fold-right list 0 '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (fold-right list 0 '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (fold-right list 0 '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (fold-right list 0 '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (fold-right list 0 '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (fold-right list 0 '(a b c) '(1 2 3) '#1#))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (fold-right (lambda (x a) ($destroy l 1) (cons (* x x) a)) 'q l))
+    '(1 4 9 16 . q))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (fold-right
+        (lambda (x y a) ($destroy l y) (cons (cons x y) a))
+        'q
+        l
+        '(a b c d)))
+    '((1 . a) (2 . b) (3 . c) (4 . d) . q))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (fold-right
+        (lambda (x y a) ($destroy l '()) (cons (cons x y) a))
+        'q
+        l
+        '(a b c d)))
+    '((1 . a) (2 . b) (3 . c) (4 . d) . q))
+  (equal?
+    (let ((l (list 1 2 3 4)))
+      (fold-right
+        (lambda (x y a) ($destroy l y) (cons (cons x y) a))
+        'q
+        '(a b c d)
+        l))
+    '((a . 1) (b . 2) (c . 3) (d . 4) . q))
+  (equal?
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (fold-right (lambda (x y z a) ($destroy l '()) (cons (list z x y) a))
+           'q
+           l
+           '(a b c d e f g)
+           '(p q r s t u v)))
+    '((p 1 a) (q 2 b) (r 3 c) (s 4 d) (t 5 e) (u 6 f) (v 7 g) . q))
+  (equal?
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (fold-right (lambda (x y z a) ($destroy l '()) (cons (list z x y) a))
+           'q
+           '(a b c d e f g)
+           l
+           '(p q r s t u v)))
+    '((p a 1) (q b 2) (r c 3) (s d 4) (t e 5) (u f 6) (v g 7) . q))
+  (equal?
+    (let ((l (list 1 2 3 4 5 6 7)))
+      (fold-right (lambda (x y z a) ($destroy l '()) (cons (list z x y) a))
+           'q
+           '(a b c d e f g)
+           '(p q r s t u v)
+           l))
+    '((1 a p) (2 b q) (3 c r) (4 d s) (5 e t) (6 f u) (7 g v) . q))
+ )
+
+(mat for-each
+   (let ((x 0))
+      (for-each (lambda (y) (set! x (1- x))) '(1 2 3 4 5 6 7))
+      (= x -7))
+   (let ((x 0))
+      (for-each (lambda (y) (set! x (1- x))) '())
+      (= x 0))
+   (let ((x '()))
+      (for-each (lambda (y) (set! x (cons y x))) '(a b c d))
+      (equal? x '(d c b a)))
+   (let ((x 0))
+      (for-each
+         (lambda (y z) (set! x (+ x (- y z))))
+         '(4 5 6)
+         '(3 2 1))
+      (= x 9))
+   (let ((x 0))
+      (for-each
+         (lambda (y z w) (set! x (+ x (+ y (- z w)))))
+         '(-1 -2 -3)
+         '(4 5 6)
+         '(3 2 1))
+      (= x 3))
+   (let ((x 0))
+      (for-each
+         (lambda (y z w) (set! x (+ x (+ y (- z w)))))
+         '()
+         '()
+         '())
+      (= x 0))
+ ; check for proper tail recursion
+   (equal?
+     (list
+       (let ([s (statistics)])
+         (let ([k 100000] [ls '(a b c)])
+           (let ([n k] [m 0])
+             (define (f) (unless (fx= n 0) (for-each foo ls)))
+             (define (foo x)
+               (set! m (+ m 1))
+               (when (eq? x (car (last-pair ls)))
+                 (set! n (- n 1))
+                 (f)
+                 17)) ; blow tail recursion here
+             (f)
+             (list (> (sstats-bytes (sstats-difference (statistics) s))
+                      10000)
+                   (eqv? n 0)
+                   (eqv? m (* k (length ls)))))))
+       (let ([s (statistics)])
+         (let ([k 100000] [ls '(a b c)])
+           (let ([n k] [m 0])
+             (define (f) (unless (fx= n 0) (for-each foo ls)))
+             (define (foo x)
+               (set! m (+ m 1))
+               (when (eq? x (car (last-pair ls)))
+                 (set! n (- n 1))
+                 (f)))
+             (f)
+             (list (<= 0
+                      (sstats-bytes (sstats-difference (statistics) s))
+                      1000)
+                   (eqv? n 0)
+                   (eqv? m (* k (length ls))))))))
+     '((#t #t #t) (#t #t #t)))
+   (eqv?
+     (for-each (lambda (x y) (+ x y)) '(1 2 3) '(4 5 6))
+     9)
+   (let-values ([() (for-each
+                      (lambda (x y) (if (eqv? x 3) (values) (+ x y)))
+                      '(1 2 3)
+                      '(4 5 6))])
+     #t)
+   (equal?
+     (let-values ([(a b) (for-each
+                           (lambda (x y) (if (eqv? x 3) (values x y) (+ x y)))
+                           '(1 2 3)
+                           '(4 5 6))])
+       (list a b))
+     '(3 6))
+
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (for-each x)))
+  (error? ; nonprocedure
+    (for-each 3 '()))
+  (error? ; nonprocedure
+    (for-each 3 '() '()))
+  (error? ; nonprocedure
+    (for-each 3 '(a b c)))
+  (error? ; nonprocedure
+    (parameterize ([optimize-level 3])
+      (eval '(#2%for-each 3 '(a b c)))))
+  (error? ; nonprocedure
+    (parameterize ([optimize-level 3])
+      (eval
+        '(let ()
+           (define (f p b)
+             (unbox b)
+             (#2%for-each p (if (box? b) '() '(1 2 3)))
+             (list p (procedure? p)))
+           (f 7 (box 0))))))
+  (error? ; improper list
+    (for-each pretty-print 'a))
+  (error? ; improper list
+    (for-each pretty-print '(a . b)))
+  (error? ; cyclic list
+    (for-each pretty-print '#1=(a . #1#)))
+  (error? ; length mismatch
+    (for-each (lambda (x y) (write (list x y))) '(a b) '(p q r)))
+  (error? ; length mismatch
+    (for-each (lambda (x y z) (write (list x y z))) '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (for-each values 'a '(a b)))
+  (error? ; improper list
+    (for-each values '(a b) 'a))
+  (error? ; improper list
+    (for-each values '(a . b) '(a b)))
+  (error? ; improper list
+    (for-each values '(a b) '(a . b)))
+  (error? ; cyclic list
+    (for-each values '#1# '(a b c)))
+  (error? ; cyclic list
+    (for-each values '(a b c) '#1#))
+  (error? ; improper list
+    (for-each values 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (for-each values '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (for-each values '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (for-each values '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (for-each values '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (for-each values '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (for-each values '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (for-each values '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (for-each values '(a b c) '(1 2 3) '#1#))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x) (set-cdr! (cdr l) 1)) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x) (set-cdr! (cddr l) 1)) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y) (set-cdr! (cdr l) y)) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y) (set-cdr! (cddr l) y)) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y) (set-cdr! (cdr l) y)) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y) (set-cdr! (cddr l) y)) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y z) (set-cdr! (cdr l) '())) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y z) (set-cdr! (cddr l) '())) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y z) (set-cdr! (cdr l) '())) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y z) (set-cdr! (cddr l) '())) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y z) (set-cdr! (cdr l) '())) '(a b c d) '(p q r s) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-each (lambda (x y z) (set-cdr! (cddr l) '())) '(a b c d) '(p q r s) l)))
+  (begin
+    (define ($for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (for-each p '())
+        (for-each p '() x1)
+        (for-each p '() x1 x2)
+        (for-each p '() x1 x2 x3)
+        (for-each p '() x1 x2 x3 x4)
+        (for-each p '() x1 x2 x3 x4 x5)
+        (for-each p x1 '())
+        (for-each p x1 '() x2)
+        (for-each p x1 '() x2 x3)
+        (for-each p x1 '() x2 x3 x4)
+        (for-each p x1 '() x2 x3 x4 x5)
+        (for-each p x1 x2 '())
+        (for-each p x1 x2 '() x3)
+        (for-each p x1 x2 '() x3 x4)
+        (for-each p x1 x2 '() x3 x4 x5)
+        (for-each p x1 x2 x3 '())
+        (for-each p x1 x2 x3 '() x4)
+        (for-each p x1 x2 x3 '() x4 x5)
+        (for-each p x1 x2 x3 x4 '())
+        (for-each p x1 x2 x3 x4 '() x5)
+        (for-each p x1 x2 x3 x4 x5 '())))
+    (procedure? $for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($for-each-f1 q '() '() '() '() '())
+      (reverse ls))
+    '())
+  (begin
+    (define ($for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (for-each p '(a))
+        (for-each p '(a) x1)
+        (for-each p '(a) x1 x2)
+        (for-each p '(a) x1 x2 x3)
+        (for-each p '(a) x1 x2 x3 x4)
+        (for-each p '(a) x1 x2 x3 x4 x5)
+        (for-each p x1 '(a))
+        (for-each p x1 '(a) x2)
+        (for-each p x1 '(a) x2 x3)
+        (for-each p x1 '(a) x2 x3 x4)
+        (for-each p x1 '(a) x2 x3 x4 x5)
+        (for-each p x1 x2 '(a))
+        (for-each p x1 x2 '(a) x3)
+        (for-each p x1 x2 '(a) x3 x4)
+        (for-each p x1 x2 '(a) x3 x4 x5)
+        (for-each p x1 x2 x3 '(a))
+        (for-each p x1 x2 x3 '(a) x4)
+        (for-each p x1 x2 x3 '(a) x4 x5)
+        (for-each p x1 x2 x3 x4 '(a))
+        (for-each p x1 x2 x3 x4 '(a) x5)
+        (for-each p x1 x2 x3 x4 x5 '(a))))
+    (procedure? $for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($for-each-f1 q '(1) '(f) '(k) '(p) '(u))
+      (reverse ls))
+    '((a) (1 a) (f 1 a) (k f 1 a) (p k f 1 a) (u p k f 1 a)
+      (a 1) (f a 1) (k f a 1) (p k f a 1) (u p k f a 1)
+      (a f 1) (k a f 1) (p k a f 1) (u p k a f 1) (a k f 1)
+      (p a k f 1) (u p a k f 1) (a p k f 1) (u a p k f 1)
+      (a u p k f 1)))
+  (begin
+    (define ($for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (for-each p '(a b))
+        (for-each p '(a b) x1)
+        (for-each p '(a b) x1 x2)
+        (for-each p '(a b) x1 x2 x3)
+        (for-each p '(a b) x1 x2 x3 x4)
+        (for-each p '(a b) x1 x2 x3 x4 x5)
+        (for-each p x1 '(a b))
+        (for-each p x1 '(a b) x2)
+        (for-each p x1 '(a b) x2 x3)
+        (for-each p x1 '(a b) x2 x3 x4)
+        (for-each p x1 '(a b) x2 x3 x4 x5)
+        (for-each p x1 x2 '(a b))
+        (for-each p x1 x2 '(a b) x3)
+        (for-each p x1 x2 '(a b) x3 x4)
+        (for-each p x1 x2 '(a b) x3 x4 x5)
+        (for-each p x1 x2 x3 '(a b))
+        (for-each p x1 x2 x3 '(a b) x4)
+        (for-each p x1 x2 x3 '(a b) x4 x5)
+        (for-each p x1 x2 x3 x4 '(a b))
+        (for-each p x1 x2 x3 x4 '(a b) x5)
+        (for-each p x1 x2 x3 x4 x5 '(a b))))
+    (procedure? $for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($for-each-f1 q '(1 2) '(f g) '(k l) '(p q) '(u v))
+      (reverse ls))
+    '((a) (b) (1 a) (2 b) (f 1 a) (g 2 b) (k f 1 a)
+      (l g 2 b) (p k f 1 a) (q l g 2 b) (u p k f 1 a)
+      (v q l g 2 b) (a 1) (b 2) (f a 1) (g b 2) (k f a 1)
+      (l g b 2) (p k f a 1) (q l g b 2) (u p k f a 1)
+      (v q l g b 2) (a f 1) (b g 2) (k a f 1) (l b g 2)
+      (p k a f 1) (q l b g 2) (u p k a f 1) (v q l b g 2)
+      (a k f 1) (b l g 2) (p a k f 1) (q b l g 2)
+      (u p a k f 1) (v q b l g 2) (a p k f 1) (b q l g 2)
+      (u a p k f 1) (v b q l g 2) (a u p k f 1)
+      (b v q l g 2)))
+  (begin
+    (define ($for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (for-each p '(a b c))
+        (for-each p '(a b c) x1)
+        (for-each p '(a b c) x1 x2)
+        (for-each p '(a b c) x1 x2 x3)
+        (for-each p '(a b c) x1 x2 x3 x4)
+        (for-each p '(a b c) x1 x2 x3 x4 x5)
+        (for-each p x1 '(a b c))
+        (for-each p x1 '(a b c) x2)
+        (for-each p x1 '(a b c) x2 x3)
+        (for-each p x1 '(a b c) x2 x3 x4)
+        (for-each p x1 '(a b c) x2 x3 x4 x5)
+        (for-each p x1 x2 '(a b c))
+        (for-each p x1 x2 '(a b c) x3)
+        (for-each p x1 x2 '(a b c) x3 x4)
+        (for-each p x1 x2 '(a b c) x3 x4 x5)
+        (for-each p x1 x2 x3 '(a b c))
+        (for-each p x1 x2 x3 '(a b c) x4)
+        (for-each p x1 x2 x3 '(a b c) x4 x5)
+        (for-each p x1 x2 x3 x4 '(a b c))
+        (for-each p x1 x2 x3 x4 '(a b c) x5)
+        (for-each p x1 x2 x3 x4 x5 '(a b c))))
+    (procedure? $for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($for-each-f1 q '(1 2 3) '(f g h) '(k l m) '(p q r) '(u v w))
+      (reverse ls))
+    '((a) (b) (c) (1 a) (2 b) (3 c) (f 1 a) (g 2 b) (h 3 c)
+      (k f 1 a) (l g 2 b) (m h 3 c) (p k f 1 a) (q l g 2 b)
+      (r m h 3 c) (u p k f 1 a) (v q l g 2 b) (w r m h 3 c)
+      (a 1) (b 2) (c 3) (f a 1) (g b 2) (h c 3) (k f a 1)
+      (l g b 2) (m h c 3) (p k f a 1) (q l g b 2) (r m h c 3)
+      (u p k f a 1) (v q l g b 2) (w r m h c 3) (a f 1)
+      (b g 2) (c h 3) (k a f 1) (l b g 2) (m c h 3)
+      (p k a f 1) (q l b g 2) (r m c h 3) (u p k a f 1)
+      (v q l b g 2) (w r m c h 3) (a k f 1) (b l g 2)
+      (c m h 3) (p a k f 1) (q b l g 2) (r c m h 3)
+      (u p a k f 1) (v q b l g 2) (w r c m h 3) (a p k f 1)
+      (b q l g 2) (c r m h 3) (u a p k f 1) (v b q l g 2)
+      (w c r m h 3) (a u p k f 1) (b v q l g 2)
+      (c w r m h 3)))
+  (begin
+    (define ($for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (for-each p '(a b c d))
+        (for-each p '(a b c d) x1)
+        (for-each p '(a b c d) x1 x2)
+        (for-each p '(a b c d) x1 x2 x3)
+        (for-each p '(a b c d) x1 x2 x3 x4)
+        (for-each p '(a b c d) x1 x2 x3 x4 x5)
+        (for-each p x1 '(a b c d))
+        (for-each p x1 '(a b c d) x2)
+        (for-each p x1 '(a b c d) x2 x3)
+        (for-each p x1 '(a b c d) x2 x3 x4)
+        (for-each p x1 '(a b c d) x2 x3 x4 x5)
+        (for-each p x1 x2 '(a b c d))
+        (for-each p x1 x2 '(a b c d) x3)
+        (for-each p x1 x2 '(a b c d) x3 x4)
+        (for-each p x1 x2 '(a b c d) x3 x4 x5)
+        (for-each p x1 x2 x3 '(a b c d))
+        (for-each p x1 x2 x3 '(a b c d) x4)
+        (for-each p x1 x2 x3 '(a b c d) x4 x5)
+        (for-each p x1 x2 x3 x4 '(a b c d))
+        (for-each p x1 x2 x3 x4 '(a b c d) x5)
+        (for-each p x1 x2 x3 x4 x5 '(a b c d))))
+    (procedure? $for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($for-each-f1 q '(1 2 3 4) '(f g h i) '(k l m n) '(p q r s) '(u v w x))
+      (reverse ls))
+    '((a) (b) (c) (d) (1 a) (2 b) (3 c) (4 d) (f 1 a)
+      (g 2 b) (h 3 c) (i 4 d) (k f 1 a) (l g 2 b) (m h 3 c)
+      (n i 4 d) (p k f 1 a) (q l g 2 b) (r m h 3 c)
+      (s n i 4 d) (u p k f 1 a) (v q l g 2 b) (w r m h 3 c)
+      (x s n i 4 d) (a 1) (b 2) (c 3) (d 4) (f a 1) (g b 2)
+      (h c 3) (i d 4) (k f a 1) (l g b 2) (m h c 3) (n i d 4)
+      (p k f a 1) (q l g b 2) (r m h c 3) (s n i d 4)
+      (u p k f a 1) (v q l g b 2) (w r m h c 3) (x s n i d 4)
+      (a f 1) (b g 2) (c h 3) (d i 4) (k a f 1) (l b g 2)
+      (m c h 3) (n d i 4) (p k a f 1) (q l b g 2) (r m c h 3)
+      (s n d i 4) (u p k a f 1) (v q l b g 2) (w r m c h 3)
+      (x s n d i 4) (a k f 1) (b l g 2) (c m h 3) (d n i 4)
+      (p a k f 1) (q b l g 2) (r c m h 3) (s d n i 4)
+      (u p a k f 1) (v q b l g 2) (w r c m h 3) (x s d n i 4)
+      (a p k f 1) (b q l g 2) (c r m h 3) (d s n i 4)
+      (u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
+      (a u p k f 1) (b v q l g 2) (c w r m h 3)
+      (d x s n i 4)))
+  (begin
+    (define ($for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (for-each p '(a b c d e))
+        (for-each p '(a b c d e) x1)
+        (for-each p '(a b c d e) x1 x2)
+        (for-each p '(a b c d e) x1 x2 x3)
+        (for-each p '(a b c d e) x1 x2 x3 x4)
+        (for-each p '(a b c d e) x1 x2 x3 x4 x5)
+        (for-each p x1 '(a b c d e))
+        (for-each p x1 '(a b c d e) x2)
+        (for-each p x1 '(a b c d e) x2 x3)
+        (for-each p x1 '(a b c d e) x2 x3 x4)
+        (for-each p x1 '(a b c d e) x2 x3 x4 x5)
+        (for-each p x1 x2 '(a b c d e))
+        (for-each p x1 x2 '(a b c d e) x3)
+        (for-each p x1 x2 '(a b c d e) x3 x4)
+        (for-each p x1 x2 '(a b c d e) x3 x4 x5)
+        (for-each p x1 x2 x3 '(a b c d e))
+        (for-each p x1 x2 x3 '(a b c d e) x4)
+        (for-each p x1 x2 x3 '(a b c d e) x4 x5)
+        (for-each p x1 x2 x3 x4 '(a b c d e))
+        (for-each p x1 x2 x3 x4 '(a b c d e) x5)
+        (for-each p x1 x2 x3 x4 x5 '(a b c d e))))
+    (procedure? $for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($for-each-f1 q '(1 2 3 4 5) '(f g h i j) '(k l m n o) '(p q r s t) '(u v w x y))
+      (reverse ls))
+    '((a) (b) (c) (d) (e) (1 a) (2 b) (3 c) (4 d) (5 e)
+      (f 1 a) (g 2 b) (h 3 c) (i 4 d) (j 5 e) (k f 1 a)
+      (l g 2 b) (m h 3 c) (n i 4 d) (o j 5 e) (p k f 1 a)
+      (q l g 2 b) (r m h 3 c) (s n i 4 d) (t o j 5 e)
+      (u p k f 1 a) (v q l g 2 b) (w r m h 3 c) (x s n i 4 d)
+      (y t o j 5 e) (a 1) (b 2) (c 3) (d 4) (e 5) (f a 1)
+      (g b 2) (h c 3) (i d 4) (j e 5) (k f a 1) (l g b 2)
+      (m h c 3) (n i d 4) (o j e 5) (p k f a 1) (q l g b 2)
+      (r m h c 3) (s n i d 4) (t o j e 5) (u p k f a 1)
+      (v q l g b 2) (w r m h c 3) (x s n i d 4) (y t o j e 5)
+      (a f 1) (b g 2) (c h 3) (d i 4) (e j 5) (k a f 1)
+      (l b g 2) (m c h 3) (n d i 4) (o e j 5) (p k a f 1)
+      (q l b g 2) (r m c h 3) (s n d i 4) (t o e j 5)
+      (u p k a f 1) (v q l b g 2) (w r m c h 3) (x s n d i 4)
+      (y t o e j 5) (a k f 1) (b l g 2) (c m h 3) (d n i 4)
+      (e o j 5) (p a k f 1) (q b l g 2) (r c m h 3)
+      (s d n i 4) (t e o j 5) (u p a k f 1) (v q b l g 2)
+      (w r c m h 3) (x s d n i 4) (y t e o j 5) (a p k f 1)
+      (b q l g 2) (c r m h 3) (d s n i 4) (e t o j 5)
+      (u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
+      (y e t o j 5) (a u p k f 1) (b v q l g 2) (c w r m h 3)
+      (d x s n i 4) (e y t o j 5)))
+  ;; cp0 optimizations for for-each
+  ;; for-each with an empty list(s) always (void)
+  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(for-each (lambda (x) x) '()) '(#2%void)))
+  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(for-each add1 '() '() '() '()) '(#2%void)))
+  (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(for-each (lambda (x) x) '()) '(#2%void)))
+  (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (test-cp0-expansion equal? '(for-each add1 '() '() '() '()) '(#2%void)))
+  ;; remove for-each the expression only if the procedure
+  ;; has the correct arity and can't raise an error
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+      (expand/optimize
+        '(#3%for-each list '(5 4 3 2 1 0))))
+    '(#2%void))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+      (expand/optimize
+        '(#3%for-each box? '(5 4 3 2 1 0))))
+    '(#2%void))
+  (not (equivalent-expansion?
+         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+           (expand/optimize
+             '(#3%for-each unbox '(5 4 3 2 1 0))))
+           '(#2%void)))
+  (not (equivalent-expansion?
+         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+           (expand/optimize
+             '(#3%for-each cons '(5 4 3 2 1 0))))
+           '(#2%void)))
+  ;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
+  ;; avoid creating each list and doing the actual for-each
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           (list 1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           (list 1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (for-each (begin (write 'ab) (lambda (x y) (write (cons x y))))
+          (begin (write 'a) (list (begin (write 'b) 'c)))
+          (begin (write 'a) (list (begin (write 'b) 'd))))))
+    "ababab(c . d)")
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y) (write (cons x y)))
+          (list (begin (write 'a) 'c) (begin (write 'b) 'd))
+          (list (begin (write 'x) 'e) (begin (write 'y) 'f)))))
+    ; lots of valid possibilities, but make sure we don't interleave and get, e.g., axby
+    '("abxy(c . e)(d . f)"
+      "abyx(c . e)(d . f)"
+      "baxy(c . e)(d . f)"
+      "bayx(c . e)(d . f)"
+      "xyab(c . e)(d . f)"
+      "yxab(c . e)(d . f)"
+      "xyba(c . e)(d . f)"
+      "yxba(c . e)(d . f)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+          (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+          (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'ab) '(g j))
+          (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+          (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+          (begin (write 'cd) '(h k))
+          (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+          (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+          (begin (write 'ef) '(i l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+ )
+
+(mat ormap
+   (ormap symbol? '(a b c d))
+   (ormap symbol? '(a 1 2 3))
+   (ormap symbol? '(1 2 3 a))
+   (not (ormap symbol? '()))
+   (not (ormap symbol? '(1 2 3 4)))
+   (ormap = '(1 2 3 4) '(1.1 2.0 3.1 4.1))
+   (not (ormap = '(1 2 3 4) '(1.1 2.2 3.3 4.4)))
+   (eqv? (ormap 1+ '(1 2 3 4)) 2)
+   (eqv? (ormap + '(1 2 3) '(3 4 5)) 4)
+   (ormap (lambda (x y z) (= (+ x y) z))
+          '(1 2 3 4)
+          '(1.2 2.3 3.4 4.5)
+          '(2.3 4.4 6.4 8.6))
+   (not (ormap (lambda (x y z) (= (+ x y) z))
+               '(1 2 3 4)
+               '(1.2 2.3 3.4 4.5)
+               '(2.3 4.4 6.5 8.6)))
+   (not (ormap (lambda (x y z) #t) '() '() '()))
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (ormap x)))
+  (error? ; nonprocedure
+    (ormap 3 '()))
+  (error? ; nonprocedure
+    (ormap 3 '() '()))
+  (error? ; nonprocedure
+    (ormap 3 '(a b c)))
+  (error? ; improper list
+    (ormap not 'a))
+  (error? ; improper list
+    (ormap not '(a . b)))
+  (error? ; cyclic list
+    (ormap not '#1=(a . #1#)))
+  (error? ; length mismatch
+    (ormap (lambda (x y) #f) '(a b) '(p q r)))
+  (error? ; length mismatch
+    (ormap (lambda (x y z) #f) '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (ormap (lambda (x y) #f) 'a '(a b)))
+  (error? ; improper list
+    (ormap (lambda (x y) #f) '(a b) 'a))
+  (error? ; improper list
+    (ormap (lambda (x y) #f) '(a . b) '(a b)))
+  (error? ; improper list
+    (ormap (lambda (x y) #f) '(a b) '(a . b)))
+  (error? ; cyclic list
+    (ormap (lambda (x y) #f) '#1# '(a b c)))
+  (error? ; cyclic list
+    (ormap (lambda (x y) #f) '(a b c) '#1#))
+  (error? ; improper list
+    (ormap (lambda (x y z) #f) 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (ormap (lambda (x y z) #f) '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (ormap (lambda (x y z) #f) '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (ormap (lambda (x y z) #f) '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (ormap (lambda (x y z) #f) '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (ormap (lambda (x y z) #f) '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (ormap (lambda (x y z) #f) '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (ormap (lambda (x y z) #f) '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (ormap (lambda (x y z) #f) '(a b c) '(1 2 3) '#1#))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x) (set-cdr! (cdr l) 1) #f) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x) (set-cdr! (cddr l) 1) #f) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y) (set-cdr! (cdr l) y) #f) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y) (set-cdr! (cddr l) y) #f) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y) (set-cdr! (cdr l) y) #f) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y) (set-cdr! (cddr l) y) #f) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y z) (set-cdr! (cdr l) '()) #f) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y z) (set-cdr! (cddr l) '()) #f) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) '(p q r s) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (ormap (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) '(p q r s) l)))
+ )
+
+(mat andmap
+   (andmap symbol? '(a b c d))
+   (not (andmap symbol? '(a 1 2 3)))
+   (not (andmap symbol? '(1 2 3 a)))
+   (andmap symbol? '())
+   (not (andmap symbol? '(1 2 3 4)))
+   (andmap = '(1 2 3 4) '(1.0 2.0 3.0 4.0))
+   (not (andmap = '(1 2 3 4) '(1.0 2.0 3.3 4.0)))
+   (eqv? (andmap 1+ '(1 2 3 4)) 5)
+   (eqv? (andmap + '(1 2 3) '(3 4 5)) 8)
+   (andmap (lambda (x y z) (= (+ x y) z))
+          '(1 2 3 4)
+          '(1.2 2.3 3.4 4.5)
+          '(2.2 4.3 6.4 8.5))
+   (not (andmap (lambda (x y z) (= (+ x y) z))
+               '(1 2 3 4)
+               '(1.2 2.3 3.4 4.5)
+               '(2.2 4.3 6.5 8.5)))
+   (eq? (andmap (lambda (x y z) #t) '() '() '()) #t)
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (andmap x)))
+  (error? ; nonprocedure
+    (andmap 3 '()))
+  (error? ; nonprocedure
+    (andmap 3 '() '()))
+  (error? ; nonprocedure
+    (andmap 3 '(a b c)))
+  (error? ; improper list
+    (andmap values 'a))
+  (error? ; improper list
+    (andmap values '(a . b)))
+  (error? ; cyclic list
+    (andmap values '#1=(a . #1#)))
+  (error? ; length mismatch
+    (andmap (lambda (x y) #t) '(a b) '(p q r)))
+  (error? ; length mismatch
+    (andmap (lambda (x y z) #t) '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (andmap (lambda (x y) #t) 'a '(a b)))
+  (error? ; improper list
+    (andmap (lambda (x y) #t) '(a b) 'a))
+  (error? ; improper list
+    (andmap (lambda (x y) #t) '(a . b) '(a b)))
+  (error? ; improper list
+    (andmap (lambda (x y) #t) '(a b) '(a . b)))
+  (error? ; cyclic list
+    (andmap (lambda (x y) #t) '#1# '(a b c)))
+  (error? ; cyclic list
+    (andmap (lambda (x y) #t) '(a b c) '#1#))
+  (error? ; improper list
+    (andmap (lambda (x y z) #t) 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (andmap (lambda (x y z) #t) '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (andmap (lambda (x y z) #t) '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (andmap (lambda (x y z) #t) '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (andmap (lambda (x y z) #t) '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (andmap (lambda (x y z) #t) '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (andmap (lambda (x y z) #t) '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (andmap (lambda (x y z) #t) '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (andmap (lambda (x y z) #t) '(a b c) '(1 2 3) '#1#))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x) (set-cdr! (cdr l) 1) #t) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x) (set-cdr! (cddr l) 1) #t) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y) (set-cdr! (cdr l) y) #t) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y) (set-cdr! (cddr l) y) #t) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y) (set-cdr! (cdr l) y) #t) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y) (set-cdr! (cddr l) y) #t) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y z) (set-cdr! (cdr l) '()) #t) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y z) (set-cdr! (cddr l) '()) #t) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) '(p q r s) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (andmap (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) '(p q r s) l)))
+ )
+
+(mat exists
+   (exists symbol? '(a b c d))
+   (exists symbol? '(a 1 2 3))
+   (exists symbol? '(1 2 3 a))
+   (not (exists symbol? '()))
+   (not (exists symbol? '(1 2 3 4)))
+   (exists = '(1 2 3 4) '(1.1 2.0 3.1 4.1))
+   (not (exists = '(1 2 3 4) '(1.1 2.2 3.3 4.4)))
+   (eqv? (exists 1+ '(1 2 3 4)) 2)
+   (eqv? (exists + '(1 2 3) '(3 4 5)) 4)
+   (exists (lambda (x y z) (= (+ x y) z))
+          '(1 2 3 4)
+          '(1.2 2.3 3.4 4.5)
+          '(2.3 4.4 6.4 8.6))
+   (not (exists (lambda (x y z) (= (+ x y) z))
+               '(1 2 3 4)
+               '(1.2 2.3 3.4 4.5)
+               '(2.3 4.4 6.5 8.6)))
+   (not (exists (lambda (x y z) #t) '() '() '()))
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (exists x)))
+  (error? ; nonprocedure
+    (exists 3 '()))
+  (error? ; nonprocedure
+    (exists 3 '() '()))
+  (error? ; nonprocedure
+    (exists 3 '(a b c)))
+  (error? ; improper list
+    (exists not 'a))
+  (error? ; improper list
+    (exists not '(a . b)))
+  (error? ; cyclic list
+    (exists not '#1=(a . #1#)))
+  (error? ; length mismatch
+    (exists (lambda (x y) #f) '(a b) '(p q r)))
+  (error? ; length mismatch
+    (exists (lambda (x y z) #f) '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (exists (lambda (x y) #f) 'a '(a b)))
+  (error? ; improper list
+    (exists (lambda (x y) #f) '(a b) 'a))
+  (error? ; improper list
+    (exists (lambda (x y) #f) '(a . b) '(a b)))
+  (error? ; improper list
+    (exists (lambda (x y) #f) '(a b) '(a . b)))
+  (error? ; cyclic list
+    (exists (lambda (x y) #f) '#1# '(a b c)))
+  (error? ; cyclic list
+    (exists (lambda (x y) #f) '(a b c) '#1#))
+  (error? ; improper list
+    (exists (lambda (x y z) #f) 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (exists (lambda (x y z) #f) '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (exists (lambda (x y z) #f) '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (exists (lambda (x y z) #f) '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (exists (lambda (x y z) #f) '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (exists (lambda (x y z) #f) '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (exists (lambda (x y z) #f) '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (exists (lambda (x y z) #f) '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (exists (lambda (x y z) #f) '(a b c) '(1 2 3) '#1#))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x) (set-cdr! (cdr l) 1) #f) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x) (set-cdr! (cddr l) 1) #f) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y) (set-cdr! (cdr l) y) #f) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y) (set-cdr! (cddr l) y) #f) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y) (set-cdr! (cdr l) y) #f) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y) (set-cdr! (cddr l) y) #f) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y z) (set-cdr! (cdr l) '()) #f) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y z) (set-cdr! (cddr l) '()) #f) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) '(p q r s) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (exists (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) '(p q r s) l)))
+ )
+
+(mat for-all
+   (for-all symbol? '(a b c d))
+   (not (for-all symbol? '(a 1 2 3)))
+   (not (for-all symbol? '(1 2 3 a)))
+   (for-all symbol? '())
+   (not (for-all symbol? '(1 2 3 4)))
+   (for-all = '(1 2 3 4) '(1.0 2.0 3.0 4.0))
+   (not (for-all = '(1 2 3 4) '(1.0 2.0 3.3 4.0)))
+   (eqv? (for-all 1+ '(1 2 3 4)) 5)
+   (eqv? (for-all + '(1 2 3) '(3 4 5)) 8)
+   (for-all (lambda (x y z) (= (+ x y) z))
+          '(1 2 3 4)
+          '(1.2 2.3 3.4 4.5)
+          '(2.2 4.3 6.4 8.5))
+   (not (for-all (lambda (x y z) (= (+ x y) z))
+               '(1 2 3 4)
+               '(1.2 2.3 3.4 4.5)
+               '(2.2 4.3 6.5 8.5)))
+   (eq? (for-all (lambda (x y z) #t) '() '() '()) #t)
+ ; make sure compiler doesn't bomb w/two few args
+  (procedure? (lambda (x) (for-all x)))
+  (error? ; nonprocedure
+    (for-all 3 '()))
+  (error? ; nonprocedure
+    (for-all 3 '() '()))
+  (error? ; nonprocedure
+    (for-all 3 '(a b c)))
+  (error? ; improper list
+    (for-all values 'a))
+  (error? ; improper list
+    (for-all values '(a . b)))
+  (error? ; cyclic list
+    (for-all values '#1=(a . #1#)))
+  (error? ; length mismatch
+    (for-all (lambda (x y) #t) '(a b) '(p q r)))
+  (error? ; length mismatch
+    (for-all (lambda (x y z) #t) '(1 2) '(a b) '(p q r)))
+  (error? ; improper list
+    (for-all (lambda (x y) #t) 'a '(a b)))
+  (error? ; improper list
+    (for-all (lambda (x y) #t) '(a b) 'a))
+  (error? ; improper list
+    (for-all (lambda (x y) #t) '(a . b) '(a b)))
+  (error? ; improper list
+    (for-all (lambda (x y) #t) '(a b) '(a . b)))
+  (error? ; cyclic list
+    (for-all (lambda (x y) #t) '#1# '(a b c)))
+  (error? ; cyclic list
+    (for-all (lambda (x y) #t) '(a b c) '#1#))
+  (error? ; improper list
+    (for-all (lambda (x y z) #t) 'a '(a b) '(1 2)))
+  (error? ; improper list
+    (for-all (lambda (x y z) #t) '(a b) 'a '(1 2)))
+  (error? ; improper list
+    (for-all (lambda (x y z) #t) '(a b) '(1 2) 'a))
+  (error? ; improper list
+    (for-all (lambda (x y z) #t) '(a . b) '(a b) '(1 2)))
+  (error? ; improper list
+    (for-all (lambda (x y z) #t) '(a b) '(a . b) '(1 2)))
+  (error? ; improper list
+    (for-all (lambda (x y z) #t) '(a b) '(1 2) '(a . b)))
+  (error? ; cyclic list
+    (for-all (lambda (x y z) #t) '#1# '(a b c) '(1 2 3)))
+  (error? ; cyclic list
+    (for-all (lambda (x y z) #t) '(a b c) '#1# '(1 2 3)))
+  (error? ; cyclic list
+    (for-all (lambda (x y z) #t) '(a b c) '(1 2 3) '#1#))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x) (set-cdr! (cdr l) 1) #t) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x) (set-cdr! (cddr l) 1) #t) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y) (set-cdr! (cdr l) y) #t) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y) (set-cdr! (cddr l) y) #t) l '(a b c d))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y) (set-cdr! (cdr l) y) #t) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y) (set-cdr! (cddr l) y) #t) '(a b c d) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y z) (set-cdr! (cdr l) '()) #t) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y z) (set-cdr! (cddr l) '()) #t) l '(a b c d) '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) l '(p q r s))))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) '(p q r s) l)))
+  (error? ; input list mutated
+    (let ((l (list 1 2 3 4)))
+      (for-all (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) '(p q r s) l)))
+ )
+
+(mat do
+   (do ((i 5 (1- i)) (j 1 (* i j))) ((zero? i) (= j 120)))
+   (do ((a 3) (i 20 (1- i))) ((zero? i) (= a 23)) (set! a (1+ a)))
+ )
+
+;;; section 4-6:
+
+(mat call/cc
+   (call/cc procedure?)
+   (equal? (call/cc (lambda (x) (+ 3 (x "hi")))) "hi")
+   (eq? (let ([l (call/cc
+                    (lambda (ret)
+                        (call/cc (lambda (l) (ret l)))
+                        (lambda (x) 'hi)))])
+            (l #f))
+        'hi)
+   (((call/cc call/cc) (lambda (x) x)) #t)
+   (let () 
+     (define f
+       (lambda (n)
+         (let f ((n n))
+           (or (fx= n 0) 
+               (and (call/cc (lambda (k) k))
+                    (f (fx- n 1)))))))
+     (f 100000))
+   (let () 
+     (define f
+       (lambda (n)
+         (let f ((n n))
+           (or (fx= n 0) 
+               (and (call/cc (lambda (k) (k k)))
+                    (f (fx- n 1)))))))
+     (f 100000))
+   (let f ((n 100000))
+     (or (= n 0)
+         (call/cc (lambda (k) (f (- n 1))))))
+   (eqv? (let f ((n 1000) (ks '()))
+           (if (= n 0)
+               ((list-ref (reverse ks) 317) 0)
+               (call/cc (lambda (k) (- (f (- n 1) (cons k ks)) 1)))))
+         -317)
+   (call/cc (lambda (k) (call/cc (lambda (k1) (eq? k1 k)))))
+   (let f ((n 1000) (k #f))
+     (or (= n 0)
+         (call/cc
+           (lambda (k1)
+             (and (eq? k1 (or k k1))
+                  (f (- n 1) k1))))))
+   (eqv? (let ()
+           (define (ctak-aux k x y z)
+             (cond ((not (< y x))  ;xy
+                    (k z))
+                   (else (call-with-current-continuation
+                          (ctak-aux
+                           k
+                           (call-with-current-continuation
+                            (lambda (k)
+                              (ctak-aux k (- x 1) y z)))
+                           (call-with-current-continuation
+                            (lambda (k)
+                              (ctak-aux k (- y 1) z x)))
+                           (call-with-current-continuation
+                            (lambda (k)
+                              (ctak-aux k (- z 1) x y))))))))
+           (define (ctak x y z)
+             (call-with-current-continuation
+              (lambda (k)
+                (ctak-aux k x y z))))
+           (ctak 18 12 6))
+         7)
+  (eqv? (call-with-current-continuation
+          (lambda (exit)
+            (for-each
+              (lambda (x) (if (negative? x) (exit x)))
+              '(54 0 37 -3 245 19))
+            #t))
+        -3)
+  (equal?
+    (let ()
+      (define list-length
+        (lambda (obj)
+          (call-with-current-continuation
+            (lambda (return)
+              (letrec ([r
+                        (lambda (obj)
+                          (cond
+                            [(null? obj) 0]
+                            [(pair? obj) (+ (r (cdr obj)) 1)]
+                            [else (return #f)]))])
+                (r obj))))))
+      (list (list-length '(1 2 3 4)) (list-length '(a b . c))))
+    '(4 #f))
+  (let ()
+    (define (next-leaf-generator obj eot)
+      (letrec ([return #f]
+               [cont
+                (lambda (x)
+                  (recur obj)
+                  (set! cont (lambda (x) (return eot)))
+                  (cont #f))]
+               [recur
+                (lambda (obj)
+                  (if (pair? obj)
+                      (for-each recur obj)
+                      (call-with-current-continuation
+                        (lambda (c) (set! cont c) (return obj)))))])
+        (lambda ()
+          (call-with-current-continuation
+            (lambda (ret) (set! return ret) (cont #f))))))
+    (define (leaf-eq? x y)
+      (let* ([eot (list 'eot)]
+             [xf (next-leaf-generator x eot)]
+             [yf (next-leaf-generator y eot)])
+        (letrec ([loop
+                  (lambda (x y)
+                    (cond
+                      [(not (eq? x y)) #f]
+                      [(eq? eot x) #t]
+                      [else (loop (xf) (yf))]))])
+          (loop (xf) (yf)))))
+    (and (eq? (leaf-eq? '(a (b (c))) '((a) b c)) #t)
+         (eq? (leaf-eq? '(a (b (c))) '((a) b c d)) #f)))
+ )
+ 
+(mat dynamic-wind
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (dynamic-wind
+                    (lambda () (set! x 4))
+                    (lambda () x)
+                    (lambda () (set! x 10)))
+                 4)
+           (eqv? x 10)))
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (call/cc
+                    (lambda (l)
+                       (dynamic-wind
+                          (lambda () (set! x 4))
+                          (lambda () (l x))
+                          (lambda () (set! x 10)))
+                       (set! x 20)))
+                 4)
+           (eqv? x 10)))
+    (equal? (let* ([x 3]
+                   [l (call/cc
+                         (lambda (ret)
+                            (dynamic-wind
+                               (lambda () (set! x (1+ x)))
+                               (lambda ()
+                                  (call/cc (lambda (l) (ret l)))
+                                  (let ([y x]) (lambda (n) (list n y))))
+                               (lambda () (set! x (1- x))))))])
+               (l x))
+            '(3 4))
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (dynamic-wind
+                           (lambda () #f)
+                           (lambda () (k2 0))
+                           (lambda () (k1 0)))))
+                  1)))
+         0)
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (dynamic-wind
+                           (lambda () #f)
+                           (lambda () (k1 0))
+                           (lambda () (k2 0)))))
+                  1)))
+         1)
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (dynamic-wind
+                           (lambda () (k2 0))
+                           (lambda () (k2 10))
+                           (lambda () (k2 20)))))
+                  1)))
+         1)
+   (equal?
+     (let ((p (open-output-string)))
+       (if (call/cc
+             (lambda (k)
+               (dynamic-wind
+                 (lambda () (display "E" p))
+                 (lambda () (call/cc (lambda (k1) (set! *k1 k1) (k #t))))
+                 (lambda () (display "I" p)))))
+           (*k1 #f)
+           (display "O" p))
+       (get-output-string p))
+     "EIEIO")
+
+ ; once again for critical dynamic wind
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (dynamic-wind #t
+                    (lambda () (set! x 4))
+                    (lambda () x)
+                    (lambda () (set! x 10)))
+                 4)
+           (eqv? x 10)))
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (call/cc
+                    (lambda (l)
+                       (dynamic-wind #t
+                          (lambda () (set! x 4))
+                          (lambda () (l x))
+                          (lambda () (set! x 10)))
+                       (set! x 20)))
+                 4)
+           (eqv? x 10)))
+    (equal? (let* ([x 3]
+                   [l (call/cc
+                         (lambda (ret)
+                            (dynamic-wind #t
+                               (lambda () (set! x (1+ x)))
+                               (lambda ()
+                                  (call/cc (lambda (l) (ret l)))
+                                  (let ([y x]) (lambda (n) (list n y))))
+                               (lambda () (set! x (1- x))))))])
+               (l x))
+            '(3 4))
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (dynamic-wind #t
+                           (lambda () #f)
+                           (lambda () (k2 0))
+                           (lambda () (k1 0)))))
+                  1)))
+         0)
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (dynamic-wind #t
+                           (lambda () #f)
+                           (lambda () (k1 0))
+                           (lambda () (k2 0)))))
+                  1)))
+         1)
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (dynamic-wind #t
+                           (lambda () (k2 0))
+                           (lambda () (k2 10))
+                           (lambda () (k2 20)))))
+                  1)))
+         1)
+   (equal?
+     (let ((p (open-output-string)))
+       (if (call/cc
+             (lambda (k)
+               (dynamic-wind #t
+                 (lambda () (display "E" p))
+                 (lambda () (call/cc (lambda (k1) (set! *k1 k1) (k #t))))
+                 (lambda () (display "I" p)))))
+           (*k1 #f)
+           (display "O" p))
+       (get-output-string p))
+     "EIEIO")
+
+ ; make sure interrupts are enabled with error in critical dynamic wind
+  (error? (dynamic-wind #t (lambda () gook) void void))
+  (and (= (disable-interrupts) 1)
+       (= (enable-interrupts) 0))
+  (error? (dynamic-wind #t void void (lambda () gook)))
+  (and (= (disable-interrupts) 1)
+       (= (enable-interrupts) 0))
+  (error? ((call/cc
+             (lambda (k)
+               (let ([first? #t])
+                 (dynamic-wind #t
+                   (lambda () (if first? (set! first? #f) gook))
+                   (lambda () (call/cc k))
+                   void))))))
+  (and (= (disable-interrupts) 1)
+       (= (enable-interrupts) 0))
+  (error? (call/cc
+            (lambda (k)
+              (let ([first? #t])
+                (dynamic-wind #t
+                  void
+                  k
+                  (lambda () gook))))))
+  (and (= (disable-interrupts) 1)
+       (= (enable-interrupts) 0))
+ )
+
+(mat r6rs:dynamic-wind
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (r6rs:dynamic-wind
+                    (lambda () (set! x 4))
+                    (lambda () x)
+                    (lambda () (set! x 10)))
+                 4)
+           (eqv? x 10)))
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (call/cc
+                    (lambda (l)
+                       (r6rs:dynamic-wind
+                          (lambda () (set! x 4))
+                          (lambda () (l x))
+                          (lambda () (set! x 10)))
+                       (set! x 20)))
+                 4)
+           (eqv? x 10)))
+    (equal? (let* ([x 3]
+                   [l (call/cc
+                         (lambda (ret)
+                            (r6rs:dynamic-wind
+                               (lambda () (set! x (1+ x)))
+                               (lambda ()
+                                  (call/cc (lambda (l) (ret l)))
+                                  (let ([y x]) (lambda (n) (list n y))))
+                               (lambda () (set! x (1- x))))))])
+               (l x))
+            '(3 4))
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (r6rs:dynamic-wind
+                           (lambda () #f)
+                           (lambda () (k2 0))
+                           (lambda () (k1 0)))))
+                  1)))
+         0)
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (r6rs:dynamic-wind
+                           (lambda () #f)
+                           (lambda () (k1 0))
+                           (lambda () (k2 0)))))
+                  1)))
+         1)
+   (eqv? (call/cc
+            (lambda (k1)
+               (+ (call/cc
+                     (lambda (k2)
+                        (r6rs:dynamic-wind
+                           (lambda () (k2 0))
+                           (lambda () (k2 10))
+                           (lambda () (k2 20)))))
+                  1)))
+         1)
+   (equal?
+     (let ((p (open-output-string)))
+       (if (call/cc
+             (lambda (k)
+               (r6rs:dynamic-wind
+                 (lambda () (display "E" p))
+                 (lambda () (call/cc (lambda (k1) (set! *k1 k1) (k #t))))
+                 (lambda () (display "I" p)))))
+           (*k1 #f)
+           (display "O" p))
+       (get-output-string p))
+     "EIEIO")
+ )
+
+(mat call/1cc
+   (call/1cc procedure?)
+   (equal? (call/cc (lambda (x) (+ 3 (x "hi")))) "hi")
+   (((call/1cc call/cc) (lambda (x) x)) #t)
+   (((call/cc call/1cc) (lambda (x) x)) #t)
+   (error?
+     (parameterize ((collect-request-handler void))
+       ((let f ((n 100))
+          (if (= n 0)
+              (call/1cc
+                (lambda (k)
+                  (rec me
+                    (case-lambda
+                      [() me]
+                      [(x) (k x)]))))
+              ((call/1cc (lambda (k) (f (- n 1)))))))
+        (rec me
+          (case-lambda
+            [() me]
+            [(x) #t])))))
+   (parameterize ((collect-request-handler void))
+     ((let f ((n 100))
+        (if (= n 0)
+            (call/cc
+              (lambda (k)
+                (rec me
+                  (case-lambda
+                    [() me]
+                    [(x) (k x)]))))
+            ((call/1cc (lambda (k) (f (- n 1)))))))
+      (rec me
+        (case-lambda
+          [() me]
+          [(x) #t]))))
+   (let () 
+     (define f
+       (lambda (n)
+         (let f ((n n))
+           (or (fx= n 0) 
+               (and (call/cc (lambda (k) (k k)))
+                    (f (fx- n 1)))))))
+     (f 100000))
+   (let f ((n 100000))
+     (or (= n 0)
+         (call/1cc (lambda (k) (f (- n 1))))))
+   (eqv? (let f ((n 1000) (ks '()))
+           (if (= n 0)
+               ((list-ref (reverse ks) 317) 0)
+               (call/1cc (lambda (k) (- (f (- n 1) (cons k ks)) 1)))))
+         -317)
+   (call/1cc (lambda (k) (call/1cc (lambda (k1) (eq? k1 k)))))
+   (call/1cc (lambda (k) (call/cc (lambda (k1) (eq? k1 k)))))
+   (call/cc (lambda (k) (call/1cc (lambda (k1) (eq? k1 k)))))
+   (let f ((n 1000) (k #f))
+     (or (= n 0)
+         (call/1cc
+           (lambda (k1)
+             (and (eq? k1 (or k k1))
+                  (f (- n 1) k1))))))
+   (eqv? (let ()
+           (define (ctak-aux k x y z)
+             (cond ((not (< y x))  ;xy
+                    (k z))
+                   (else (call/1cc
+                          (ctak-aux
+                           k
+                           (call/1cc
+                            (lambda (k)
+                              (ctak-aux k (- x 1) y z)))
+                           (call/1cc
+                            (lambda (k)
+                              (ctak-aux k (- y 1) z x)))
+                           (call/1cc
+                            (lambda (k)
+                              (ctak-aux k (- z 1) x y))))))))
+           (define (ctak x y z)
+             (call/1cc
+              (lambda (k)
+                (ctak-aux k x y z))))
+           (ctak 18 12 6))
+         7)
+   (let ([x 3])
+      (and (eqv? x 3)
+           (eqv? (call/1cc
+                    (lambda (l)
+                       (dynamic-wind
+                          (lambda () (set! x 4))
+                          (lambda () (l x))
+                          (lambda () (set! x 10)))
+                       (set! x 20)))
+                 4)
+           (eqv? x 10)))
+    (equal? (let* ([x 3]
+                   [l (call/cc
+                         (lambda (ret)
+                            (dynamic-wind
+                               (lambda () (set! x (1+ x)))
+                               (lambda ()
+                                  (call/1cc (lambda (l) (ret l)))
+                                  (let ([y x]) (lambda (n) (list n y))))
+                               (lambda () (set! x (1- x))))))])
+               (l x))
+            '(3 4))
+   (eqv? (call/1cc
+            (lambda (k1)
+               (+ (call/1cc
+                     (lambda (k2)
+                        (dynamic-wind
+                           (lambda () #f)
+                           (lambda () (k2 0))
+                           (lambda () (k1 0)))))
+                  1)))
+         0)
+   (eqv? (call/1cc
+            (lambda (k1)
+               (+ (call/1cc
+                     (lambda (k2)
+                        (dynamic-wind
+                           (lambda () #f)
+                           (lambda () (k1 0))
+                           (lambda () (k2 0)))))
+                  1)))
+         1)
+   (eqv? (call/1cc
+            (lambda (k1)
+               (+ (call/1cc
+                     (lambda (k2)
+                        (dynamic-wind
+                           (lambda () (k2 0))
+                           (lambda () (k2 10))
+                           (lambda () (k2 20)))))
+                  1)))
+         1)
+   (equal?
+     (let ((p (open-output-string)))
+       (if (call/cc
+             (lambda (k)
+               (dynamic-wind
+                 (lambda () (display "E" p))
+                 (lambda () (call/1cc (lambda (k1) (set! *k1 k1) (k #t))))
+                 (lambda () (display "I" p)))))
+           (*k1 #f)
+           (display "O" p))
+       (get-output-string p))
+     "EIEIO")
+ )
+ 
+;;; section 4-7:
+
+(mat engine
+   (letrec ([ee (make-engine
+                   (lambda ()
+                      (map 1+ '(1 2 3 4 5 6 7 8 9))))]
+            [foo (lambda (n e)
+                    (if (zero? n)
+                        '()
+                        (e n
+                           (lambda (x y) (foo (1- n) ee))
+                           (lambda (e) (foo n e)))))]
+            [goo (lambda (n)
+                    (if (zero? n)
+                        'okay
+                        (begin (foo n ee) (goo (1- n)))))])
+        (eq? (goo 20) 'okay))
+    (let ([e (make-engine (lambda () (engine-block) (engine-return 'hi)))])
+       (e 10000
+          (lambda (x y) #f)
+          (lambda (e1)
+             (e1 10000
+                 (lambda (t x) (eq? x 'hi))
+                 (lambda (e) #f)))))
+    (equal? (let ([e (make-engine (lambda () (engine-block) (values 1 2 3)))])
+              (e 10000
+                 (lambda (x . y) #f)
+                 (lambda (e1)
+                    (e1 10000
+                        (lambda (t . x) x)
+                        (lambda (e) #f)))))
+            '(1 2 3))
+  (eqv?
+    (let ([e (make-engine (lambda () (raise 'hello)))])
+      (guard (c [else c])
+        (e 1000 list values)))
+    'hello)
+  (eqv?
+    (let ([e (make-engine (lambda () (raise-continuable 'hello)))])
+      (with-exception-handler
+        (lambda (c) 17)
+        (lambda () (e 1000 (lambda (x y) y) values))))
+    17)
+  (eqv?
+    (let ([e (make-engine
+               (lambda ()
+                 (let ([x (raise-continuable 'hello)])
+                   (define fib
+                     (lambda (x)
+                       (if (<= x 1)
+                           1
+                           (+ (fib (- x 1)) (fib (- x 2))))))
+                   (cons x (fib 20)))))])
+      (with-exception-handler
+        (lambda (c) (and (eq? c 'hello) 17))
+        (lambda ()
+          (e 1000 (lambda (x y) y) (lambda (x) 'stalled)))))
+    'stalled)
+  (equal?
+    (let ([e (make-engine
+               (lambda ()
+                 (let ([x (raise-continuable 'hello)])
+                   (define fib
+                     (lambda (x)
+                       (if (<= x 1)
+                           1
+                           (+ (fib (- x 1)) (fib (- x 2))))))
+                   (cons x (fib 20)))))])
+      (with-exception-handler
+        (lambda (c) (and (eq? c 'hello) 17))
+        (lambda ()
+          (e 1000
+             (lambda (x y) 'oops1)
+             (lambda (e)
+               (e 1000
+                 (lambda (x y) 'oops2)
+                 (lambda (e)
+                   (e 1000000
+                     (lambda (x y) y)
+                     values))))))))
+    '(17 . 10946))
+  (equal?
+    (let* ([e0 (make-engine
+                 (lambda ()
+                   (define fib
+                     (lambda (x)
+                       (if (<= x 1)
+                           1
+                           (+ (fib (- x 1)) (fib (- x 2))))))
+                   (let ([n (fib 20)])
+                     (cons n (raise-continuable 'hello)))))]
+           [e1 (with-exception-handler
+                 (lambda (c) 'stuff1)
+                 (lambda ()
+                   (e0 1000
+                     (lambda (x y) 'oops1)
+                     (lambda (e) e))))]
+           [e2 (with-exception-handler
+                 (lambda (c) 'stuff2)
+                 (lambda ()
+                   (e1 1000
+                     (lambda (x y) 'oops2)
+                     (lambda (e) e))))])
+      (with-exception-handler
+        (lambda (c) 'stuff3)
+        (lambda ()
+          (e2 1000000
+            (lambda (x y) y)
+            (lambda (e) e)))))
+    '(10946 . stuff3))
+  (let ()
+    (define spin
+      (letrec ((spin
+                (lambda (n m)
+                  (cond
+                    ((= n 0) m)
+                    (else (spin (- n 1) (+ m 1)))))))
+        (lambda (n)
+          (spin n 0))))
+    (define test6B/counter
+      (lambda (ticks th)
+        (define bytes (bytes-allocated))
+        (define counter 0)
+        (let loop ([e (make-engine th)])
+          (call-with-values
+            (lambda () (e ticks values values))
+            (case-lambda
+              [(left v) v]
+              [(e)
+               (set! counter (add1 counter))
+               (when (zero? (remainder counter 100000))
+                 (collect (collect-maximum-generation))
+                 (let ([% 20] [new-bytes (bytes-allocated)])
+                   (when (> new-bytes (* bytes (+ 1 (/ % 100))))
+                     (errorf 'test6B/counter "bytes allocated has grown by more than ~s% from ~s to ~s"
+                       % bytes new-bytes))))
+               (loop e)])))))
+    (let ([n 100000000])
+      (eqv?
+        (test6B/counter 125 (lambda () (spin n)))
+        n)))
+)
+
+;;; section 4-8:
+
+(mat delay-force ;;; from The Scheme Programming Language
+   (letrec ([stream-car
+             (lambda (s)
+                (car (force s)))]
+            [stream-cdr
+             (lambda (s)
+                (cdr (force s)))]
+            [stream-add
+             (lambda (s1 s2)
+                (delay
+                   (cons (+ (stream-car s1) (stream-car s2))
+                         (stream-add (stream-cdr s1) (stream-cdr s2)))))])
+      (let ([counters
+             (let next ([n 1])
+                (delay (cons n (next (+ n 1)))))])
+         (and (eqv? (stream-car counters) 1)
+              (eqv? (stream-car (stream-cdr counters)) 2)
+              (let ([even-counters (stream-add counters counters)])
+                 (and (eqv? (stream-car even-counters) 2)
+                      (eqv? (stream-car (stream-cdr even-counters)) 4))))))
+   (equal? (let ([x 0])
+             (let ([y (delay (begin (set! x 1) (values)))])
+               (let ([z x])
+                 (force y)
+                 (list x z))))
+           '(1 0))
+  ; test for common delay/force bug posted to comp.lang.scheme; we had
+  ; this for a short while after delay/force were extended to handle
+  ; multiple values
+   (eq? (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+                 (c #f))
+          (force p))
+        3)
+ )
+
+;;; no section ...
+
+(mat make-guardian
+   (procedure? make-guardian)
+   (with-interrupts-disabled
+      (let ([x (make-guardian)])
+         (and (not (x))
+              (begin (x (cons 'a 'b)) (not (x)))
+              (begin (collect) (equal? (x) '(a . b)))
+              (not (x)))))
+   (with-interrupts-disabled
+      (let ([x1 (make-guardian)])
+         ; counting on a little compiler cleanliness here...
+         (let ([x2 (make-guardian)])
+            (x1 x2)
+            (x2 x2))
+         (collect)
+         (let ([x2 (x1)])
+            (and (equal? (x2) x2)
+                 (not (x1))
+                 (not (x2))))))
+   (parameterize ([collect-trip-bytes (expt 2 24)])
+     (let ([k 1000000])
+       (let ([g (make-guardian)])
+         (let f ([n k])
+           (unless (= n 0)
+             (g (cons 3 4))
+             (let f () (cond [(g) => (lambda (x) (g x) (f))]))
+             (f (- n 1))))
+         (let f ([n k])
+           (unless (= n 0)
+             (cond
+               [(g) => (lambda (x) (f (- n 1)))]
+               [else (collect) (f n)])))
+         #t)))
+   (with-interrupts-disabled
+      (let ([x (make-guardian)])
+         (and (not (x))
+              (begin (x (cons 'a 'b) 'calvin) (not (x)))
+              (begin (collect) (equal? (x) 'calvin))
+              (not (x)))))
+   (with-interrupts-disabled
+      (let ([x (make-guardian)])
+         (and (not (x))
+              (begin (x (cons 'a 'b) (cons 'calvin 'hobbes)) (not (x)))
+              (begin (collect) (equal? (x) '(calvin . hobbes)))
+              (not (x)))))
+   (with-interrupts-disabled
+      (let ([x (make-guardian)])
+         (and (not (x))
+              (begin (x (cons 'a 'b) 17) (not (x)))
+              (begin (collect) (equal? (x) '17))
+              (not (x)))))
+   (equal?
+     (with-interrupts-disabled
+       (let ([g1 (make-guardian)] [g2 (make-guardian)])
+         (let ([p (list 'a 'b)])
+           (g1 p g2)
+           (g2 (list 'c 'd))
+           (collect 0 0)
+           (let ([p (cdr p)])
+             (collect 0 0)
+             (list ((g1)) p)))))
+     '((c d) (b)))
+
+   (eq? (with-interrupts-disabled
+          (let* ([g (make-guardian)] [x (list 'a 'b)])
+            (g x)
+            (collect 0 0)
+            (#%$keep-live x)
+            (g)))
+        #f)
+
+   (or (not (threaded?))
+       (equal?
+         (parameterize ([collect-request-handler void])
+           (let ([g (make-guardian)])
+             (fork-thread (lambda () (g (list 'a 'b))))
+             (let f () (when (> (length (#%$thread-list)) 1) (f)))
+             (collect)
+             (g)))
+         '(a b)))
+
+   (parameterize ([collect-request-handler void] [enable-object-counts #t])
+     (define-record-type fraz (fields zle))
+     (define g (make-guardian))
+     (define x (make-fraz 17))
+     (g x)
+     (collect 0 0)
+     (unless (let ([a (assq 'guardian (object-counts))])
+               (and a (assq 0 (cdr a))))
+       (error #f "no generation 0 guardian in object-counts list"))
+     (unless (let ([a (assq (record-type-descriptor fraz) (object-counts))])
+               (and a (assq 0 (cdr a))))
+       (error #f "no generation 0 fraz in object-counts list"))
+     (collect (collect-maximum-generation))
+     (unless (let ([a (assq 'guardian (object-counts))])
+               (and a (assq (collect-maximum-generation) (cdr a))))
+       (error #f "no maximum-generation guardian in object-counts list"))
+     (unless (let ([a (assq (record-type-descriptor fraz) (object-counts))])
+               (and a (assq (collect-maximum-generation) (cdr a))))
+       (error #f "no maximum-generation fraz in object-counts list"))
+     (collect (collect-maximum-generation) 'static)
+     (when (let ([a (assq 'guardian (object-counts))])
+               (and a (assq 'static (cdr a))))
+       (error #f "static-generation guardian in object-counts list"))
+     (unless (let ([a (assq (record-type-descriptor fraz) (object-counts))])
+               (and a (assq 'static (cdr a))))
+       (error #f "no static-generation fraz in object-counts list"))
+     (pretty-print (cons g x)) ; keep 'em live
+     #t)
+
+   (parameterize ([collect-request-handler void])
+     (define (get-all g) (let ([q (g)]) (if q (cons q (get-all g)) '())))
+     (module (insist)
+       (define ($insist e? expr expected got)
+         (unless (e? got expected)
+           (errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
+       (define-syntax insist
+         (syntax-rules ()
+           [(_ ?e? ?expr ?expected)
+            ($insist ?e? '?expr ?expected ?expr)])))
+     (let ([g1 (make-guardian)] [g2 (make-guardian)])
+       (let ([x (box (cons 'a 'b))] [y (box (cons 'c 'd))])
+         (insist eq? (unregister-guardian g1) '())
+         (insist eq? (unregister-guardian g2) '())
+         (g1 (unbox x))
+         (g1 (unbox y))
+         (g2 (unbox x))
+         (g1 (unbox y))
+         (g1 (unbox x))
+         (collect 0 0)
+         (g2 (unbox x))
+         (g1 (cons 'e 'f))
+         (g2 (unbox x))
+         (g1 (unbox x))
+         (g2 (cons 'g 'h))
+         (insist eq? (get-all g1) '())
+         (insist eq? (get-all g2) '())
+         (let ([q (unregister-guardian g2)])
+           (unless (and (= (length q) 4) (equal? (remove '(g . h) q) (list (unbox x) (unbox x) (unbox x))))
+             (errorf #f "expected (unregister-guardian g2) to contain x = (a . b), x = (a . b), and (g . h), got ~s" q)))
+         (insist eq? (unregister-guardian g2) '())
+         (insist eq? (get-all g1) '())
+         (insist eq? (get-all g2) '())
+         (collect 0 0)
+         (insist equal? (get-all g1) '((e . f)))
+         (insist eq? (get-all g2) '())
+         (g2 (unbox x))
+         (set-box! x #f)
+         (collect 0 0)
+         (insist equal? (get-all g1) '((a . b) (a . b) (a . b)))
+         (insist equal? (get-all g2) '((a . b)))
+         (insist equal? (unregister-guardian g1) '((c . d) (c . d)))
+         (insist eq? (unregister-guardian g2) '())
+         (pretty-print (list g1 g2 x y)))) ; keep 'em live
+     #t)
+ )
+
+(mat refcount-guardians
+  (error? ; unrecognized ftype
+    (ftype-guardian NO!))
+  (error? ; first element must be a word-sized integer with native endianness
+    (let ()
+      (define-ftype A (struct))
+      (ftype-guardian A)))
+  (error? ; first element must be a word-sized integer with native endianness
+    (let ()
+      (define-ftype A (union [u1 (struct (refcount char))] [u2 (struct (foo (* A)))]))
+      (ftype-guardian A)))
+  (error? ; invalid ftype-guardian argument
+    (let ()
+      (define-ftype A (struct (refcount iptr) (x int)))
+      (define g (ftype-guardian A))
+      (g (cons 'ka 'blooie))))
+  (error? ; invalid ftype-guardian argument
+    (let ()
+      (define-ftype A (struct (refcount iptr) (x int)))
+      (define g (ftype-guardian A))
+      (g (make-ftype-pointer iptr 0))))
+  (eq?
+    (let ()
+      (define-ftype A (struct (refcount iptr) (x int)))
+      (define g (ftype-guardian iptr))
+      (g (make-ftype-pointer A 0)))
+    (void))
+  (with-interrupts-disabled
+    (let ()
+      (define-ftype A (struct (refcount iptr) (x int)))
+      (define g (ftype-guardian A))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (ftype-set! A (refcount) a 0)
+      (assert (not (ftype-locked-incr! A (refcount) a)))
+      (assert (eqv? (ftype-ref A (refcount) a) 1))
+      (g a)
+      (set! a #f)
+      (collect 0 0)
+      (assert (eqv? (ftype-ref A (refcount) (g)) 0))
+      (assert (not (g)))
+      #t))
+  (with-interrupts-disabled
+    (let ()
+      (define-ftype A (struct (refcount uptr) (x int)))
+      (define g (ftype-guardian A))
+      (define addr (foreign-alloc (ftype-sizeof A)))
+      (define a1 (make-ftype-pointer A addr))
+      (define a2 (make-ftype-pointer A addr))
+      (define wpa1 (weak-cons a1 '()))
+      (define wpa2 (weak-cons a2 '()))
+      (ftype-set! A (refcount) a1 0)
+      (ftype-set! A (x) a1 17)
+      (assert (eqv? (ftype-ref A (x) a1) 17))
+      (assert (eqv? (ftype-ref A (x) a2) 17))
+      (assert (eqv? (ftype-ref A (refcount) a1) 0))
+      (assert (eqv? (ftype-ref A (refcount) a2) 0))
+      (assert (not (ftype-locked-incr! A (refcount) a1)))
+      (assert (not (ftype-locked-incr! A (refcount) a2)))
+      (assert (eqv? (ftype-ref A (refcount) a1) 2))
+      (assert (eqv? (ftype-ref A (refcount) a2) 2))
+      (g a1)
+      (g a2)
+      (collect 0 0)
+      (assert (not (g)))
+      (set! a1 #f)
+      (collect 0 0)
+      (assert (not (g)))
+      (set! a2 #f)
+      (collect 0 0)
+      (set! a2 (g))
+      (assert (eq? (car wpa2) a2))
+      (assert (not (g)))
+      (assert (eqv? (ftype-ref A (refcount) a2) 0))
+      #t))
+  (with-interrupts-disabled
+    (let ()
+      (define-ftype A (struct (refcount iptr) (x int)))
+      (define g (ftype-guardian A))
+      (define regular-g (make-guardian))
+      (define addr (foreign-alloc (ftype-sizeof A)))
+      (define a (make-ftype-pointer A addr))
+      (ftype-set! A (refcount) a 0)
+      (assert (not (ftype-locked-incr! A (refcount) a)))
+      (assert (eqv? (ftype-ref A (refcount) a) 1))
+      (regular-g a)
+      (g a)
+      (regular-g a)
+      (set! a #f)
+      (collect 0 0)
+      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
+      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
+      (assert (eqv? (ftype-ref A (refcount) (g)) 0))
+      (assert (not (regular-g)))
+      (assert (not (g)))
+      #t))
+  (with-interrupts-disabled
+    (let ()
+      (define-ftype A (struct (refcount uptr) (x int)))
+      (define g (ftype-guardian A))
+      (define regular-g (make-guardian))
+      (define addr (foreign-alloc (ftype-sizeof A)))
+      (define a (make-ftype-pointer A addr))
+      (ftype-set! A (refcount) a 0)
+      (assert (not (ftype-locked-incr! A (refcount) a)))
+      (assert (not (ftype-locked-incr! A (refcount) a)))
+      (assert (eqv? (ftype-ref A (refcount) a) 2))
+      (regular-g a)
+      (g a)
+      (regular-g a)
+      (set! a #f)
+      (collect 0 0)
+      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
+      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
+      (assert (not (regular-g)))
+      (assert (not (g)))
+      #t))
+  (with-interrupts-disabled
+    (let ()
+      (define-ftype A (struct (refcount iptr) (x int)))
+      (define g (ftype-guardian A))
+      (define regular-g (make-guardian))
+      (define addr (foreign-alloc (ftype-sizeof A)))
+      (define a (make-ftype-pointer A addr))
+      (ftype-set! A (refcount) a 0)
+      (assert (not (ftype-locked-incr! A (refcount) a)))
+      (assert (not (ftype-locked-incr! A (refcount) a)))
+      (assert (eqv? (ftype-ref A (refcount) a) 2))
+      (regular-g a)
+      (g a)
+      (g a)
+      (regular-g a)
+      (set! a #f)
+      (collect 0 0)
+      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
+      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
+      (assert (eqv? (ftype-ref A (refcount) (g)) 0))
+      (assert (not (regular-g)))
+      (assert (not (g)))
+      #t))
+
+   (parameterize ([collect-request-handler void])
+     (define-ftype A (struct (refcount iptr) (uid int)))
+     (define (get-all g)
+       (let ([a (g)])
+         (if a
+             (begin
+               (unless (eqv? (ftype-ref A (refcount) a) 0)
+                 (errorf 'get-all "nonzero refcount ~s, uid ~s" (ftype-ref A (refcount) a) (ftype-ref A (uid) a)))
+               (cons a (get-all g)))
+             '())))
+     (module (insist)
+       (define ($insist e? expr expected got)
+         (unless (e? got expected)
+           (errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
+       (define-syntax insist
+         (syntax-rules ()
+           [(_ ?e? ?expr ?expected)
+            ($insist ?e? '?expr ?expected ?expr)])))
+     (define (get-uid a) (ftype-ref A (uid) a))
+     (define (fritter addr refcount uid)
+       (let ([a (make-ftype-pointer A addr)])
+         (ftype-set! A (refcount) a refcount)
+         (ftype-set! A (uid) a uid)
+         (box a)))
+     (let ([x-addr (foreign-alloc (ftype-sizeof A))] [y-addr (foreign-alloc (ftype-sizeof A))] [z-addr (foreign-alloc (ftype-sizeof A))])
+       (let ([x1 (fritter x-addr 6 73)] [x2 (box (make-ftype-pointer A x-addr))] [y (fritter y-addr 2 57)] [z (fritter z-addr 2 91)])
+         (let ([g1 (ftype-guardian A)] [g2 (ftype-guardian A)])
+           (insist eq? (unregister-guardian g1) '())
+           (insist eq? (unregister-guardian g2) '())
+           (g1 (unbox x1))
+           (g2 (unbox x1))
+           (g1 (unbox x1))
+           (g1 (unbox x2))
+           (g2 (unbox x1))
+           (g1 (unbox y))
+           (g1 (unbox y))
+           (g2 (unbox z))
+           (g1 (unbox z))
+           (insist eq? (get-all g1) '())
+           (insist eq? (get-all g2) '())
+           (let ([q (unregister-guardian g2)])
+             (define (decr-refcount! a) (ftype-locked-decr! A (refcount) a))
+             (unless (and (= (length q) 3) (memq (unbox x1) (memq (unbox x1) q)) (memq (unbox z) q))
+               (errorf #f "expected (unregister-guardian g2) to contain x/uid 73, x/uid 73, and z/uid 91, got ~s" (map get-uid q)))
+             (map decr-refcount! q))
+           (insist eq? (unregister-guardian g2) '())
+           (insist eq? (get-all g1) '())
+           (insist eq? (get-all g2) '())
+           (pretty-print z) ; keep it live
+           (set-box! z #f)
+           (collect 0 0)
+           (insist equal? (map get-uid (get-all g1)) '(91))
+           (insist eq? (get-all g2) '())
+           (g2 (unbox x1))
+           (pretty-print x1) ; keep it live
+           (set-box! x1 #f)
+           (collect 0 0)
+           (insist eq? (get-all g1) '())
+           (insist eq? (get-all g2) '())
+           (insist eq? (unregister-guardian g2) '())
+           (insist eqv? (ftype-ref A (refcount) (unbox x2)) 1)
+           (pretty-print x2) ; keep it live
+           (set-box! x2 #f)
+           (collect 0 0)
+           (insist equal? (map get-uid (get-all g1)) '(73))
+           (insist equal? (map get-uid (get-all g2)) '())
+           (insist eq? (unregister-guardian g2) '())
+           (pretty-print y) ; keep it live
+           (set-box! y #f)
+           (collect 0 0)
+           (insist equal? (map get-uid (get-all g1)) '(57))
+           (insist equal? (map get-uid (get-all g2)) '())
+           (insist eq? (unregister-guardian g1) '())
+           (insist eq? (unregister-guardian g2) '())
+           (pretty-print (list g1 g2 x y)))) ; keep 'em live
+       (foreign-free x-addr)
+       (foreign-free y-addr)
+       (foreign-free z-addr))
+     #t)
+  )
+
+(mat weak-cons
+   (procedure? weak-cons)
+   (procedure? weak-pair?)
+   (with-interrupts-disabled
+      (let ([x (weak-cons (cons 'a 'b) 'c)])
+         (and (equal? (car x) '(a . b))
+              (begin (collect) (bwp-object? (car x)))
+              (begin (set-car! x (cons 'd 'e)) (equal? (car x) '(d . e)))
+              (begin (collect (collect-maximum-generation))
+                     (bwp-object? (car x))))))
+ )
+
+(mat ephemeron
+   (begin
+     (define ephemeron-key car)
+     (define ephemeron-value cdr)
+     
+     (define gdn (make-guardian))
+     #t)
+
+   (ephemeron-pair? (ephemeron-cons 1 2))
+
+   (begin
+     ;; ----------------------------------------
+     ;; Check that the ephemeron value doesn't retain
+     ;; itself as an epehemeron key
+     (define-values (es wps saved)
+       (let loop ([n 1000] [es '()] [wps '()] [saved '()])
+         (cond
+          [(zero? n)
+           (values es wps saved)]
+          [else
+           (let ([k1 (gensym)]
+                 [k2 (gensym)])
+             (gdn k2)
+             (loop (sub1 n)
+                   (cons (ephemeron-cons k1 (box k1))
+                         (cons (ephemeron-cons k2 (box k2))
+                               es))
+                   (weak-cons k1 (weak-cons k2 wps))
+                   (cons k1 saved)))])))
+     
+     (collect (collect-maximum-generation))
+
+     ;; All now waiting to be reported by the guardian
+     (let loop ([es es] [wps wps] [saved saved])
+       (cond
+        [(null? saved) #t]
+        [else
+         (and
+          (eq? (car saved) (car wps))
+          (eq? (car saved) (ephemeron-key (car es)))
+          (eq? (car saved) (unbox (ephemeron-value (car es))))
+          (eq? (cadr wps) (ephemeron-key (cadr es)))
+          (eq? (cadr wps) (unbox (ephemeron-value (cadr es))))
+          (loop (cddr es) (cddr wps) (cdr saved)))])))
+
+   (begin
+     ;; Report each from the guardian:
+     (let loop ([saved saved])
+       (unless (null? saved)
+         (gdn)
+         (loop (cdr saved))))
+
+     (collect (collect-maximum-generation))
+
+     (let loop ([es es] [wps wps] [saved saved])
+       (cond
+        [(null? saved) #t]
+        [else
+         (and
+          (eq? (car saved) (car wps))
+          (eq? (car saved) (ephemeron-key (car es)))
+          (eq? (car saved) (unbox (ephemeron-value (car es))))
+          (eq? #!bwp (cadr wps))
+          (eq? #!bwp (ephemeron-key (cadr es)))
+          (eq? #!bwp (ephemeron-value (cadr es)))
+          (loop (cddr es) (cddr wps) (cdr saved)))])))
+
+   ;; ----------------------------------------
+   ;; Stress test to check that the GC doesn't suffer from quadratic
+   ;; behavior
+   (let ()
+     (define (wrapper v) (list 1 2 3 4 5 v))
+     
+     ;; Create a chain of ephemerons where we have all
+     ;; the the ephemerons immediately in a list,
+     ;; but we discover the keys one at a time
+     (define (mk n prev-key es)
+       (cond
+        [(zero? n)
+         (values prev-key es)]
+        [else
+         (let ([key (gensym)])
+           (mk (sub1 n)
+               key
+               (cons (ephemeron-cons key (wrapper prev-key))
+                     es)))]))
+
+     ;; Create a chain of ephemerons where we have all
+     ;; of the keys immediately in a list,
+     ;; but we discover the ephemerons one at a time
+     (define (mk* n prev-e keys)
+       (cond
+        [(zero? n)
+         (values prev-e keys)]
+        [else
+         (let ([key (gensym)])
+           (mk* (sub1 n)
+                (ephemeron-cons key (wrapper prev-e))
+                (cons key
+                      keys)))]))
+
+     (define (measure-time n keep-alive)
+       ;; Hang the discover-keys-one-at-a-time chain
+       ;; off the end of the discover-ephemerons-one-at-a-time
+       ;; chain, which is the most complex case for avoiding
+       ;; quadratic GC times
+       (parameterize ([collect-request-handler void] [collect-maximum-generation (max (collect-maximum-generation) 2)])
+         (collect 2)
+         (let*-values ([(key es) (mk n (gensym) '())]
+                       [(root holds) (mk* n key es)])
+           (let ([start (current-time)])
+             (collect 0 1)
+             (collect 1 2)
+             (collect 2 2)
+             (let ([delta (time-difference (current-time) start)])
+               ;; Sanity check on ephemerons
+               (for-each (lambda (e)
+                           (when (eq? #!bwp (ephemeron-key e))
+                             (error 'check "oops")))
+                         es)
+               ;; Keep `root` and `holds` live:
+               (keep-alive (cons root holds))
+               ;; Return duration:
+               delta)))))
+
+     (define N 10000)
+
+     ;; The first time should be roughy x10 the second (not x100)
+     (let loop ([tries 3])
+       (define dummy #f)
+       (define (keep-alive v) (set! dummy (cons dummy v)))
+       (define t1 (measure-time (* 10 N) keep-alive))
+       (define dummy2 (set! dummy #f))
+       (define t2 (measure-time N keep-alive))
+       (define (duration->inexact t) (+ (* (time-second t) 1e9)
+                                        (inexact (time-nanosecond t))))
+       (set! dummy #f)
+       (let ([t1 (duration->inexact t1)] [t2 (duration->inexact t2)])
+         (or (< (/ t1 t2) 20)
+           (begin
+             (printf "t1 = ~s, t2 = ~s, t1/t2 = ~s\n" t1 t2 (/ t1 t2))
+             (and (positive? tries)
+               (loop (sub1 tries))))))))
+
+   ;; ----------------------------------------
+   ;; Check interaction of mutation and generations
+   
+   ;; This check disables interrupts so that a garbage collection
+   ;; happens only for the explicit `collect` request.
+   (with-interrupts-disabled
+     (let ([e (ephemeron-cons (gensym) 'ok)])
+       (collect 0) ; => `e` is moved to generation 1
+       (and
+         (eq? #!bwp (ephemeron-key e))
+         (eq? #!bwp (ephemeron-value e))
+         (let ([s (gensym)])
+           (set-car! e s)
+           (set-cdr! e 'ok-again)
+           (collect 0) ; => `s` is moved to generation 1
+           (and
+             (eq? s (ephemeron-key e))
+             (eq? 'ok-again (ephemeron-value e))
+             (begin
+               (set! s #f)
+               (collect 1) ; collect former `s`
+               (and
+                 (eq? #!bwp (ephemeron-key e))
+                 (eq? #!bwp (ephemeron-value e)))))))))
+
+   ;; ----------------------------------------
+   ;; Check interaction of mutation and incremental generation promotion
+
+   (parameterize ([collect-request-handler void] [collect-maximum-generation (max (collect-maximum-generation) 2)])
+    (let ([key "key"])
+      (let ([e (ephemeron-cons key #f)])
+        (collect 0 1 1)
+        (let ([key2 (gensym key)])
+          ;; e is gen 1, key2 is gen 0:
+          (set-car! e key2)
+          (collect 1 1 2)
+          ;; Now, e is gen 1, key2 is gen 0
+          (and (eq? (car e) key2)
+               (begin
+                 (collect 1 2 2)
+                 ;; Check that the GC update the reference to `key2` in `e`:
+                 (eq? (car e) key2)))))))
+
+   ;; ----------------------------------------
+   ;; Check fasl:
+   (let ([s (gensym)])
+     (define-values (o get) (open-bytevector-output-port))
+     (fasl-write (list s
+                       (ephemeron-cons s 'ok))
+                 o)
+     (let* ([l (fasl-read (open-bytevector-input-port (get)))]
+            [e (cadr l)])
+       (and
+        (eq? (car l) (ephemeron-key e))
+        (eq? 'ok (ephemeron-value e))
+        (begin
+          (set! s #f)
+          (set! l #f)
+          (collect (collect-maximum-generation))
+          (and
+           (eq? #!bwp (ephemeron-key e))
+           (eq? #!bwp (ephemeron-value e))))))))
+
+(mat $primitive
+   (procedure? #%car)
+   (procedure? #2%car)
+   (procedure? #3%car)
+   (equal? '#%car '($primitive car))
+   (equal? '#2%car '($primitive 2 car))
+   (equal? '#3%car '($primitive 3 car))
+   (equal? (#%list 1 2 3) '(1 2 3))
+   (eqv? (#2%+ 1 2 3) 6)
+   (error? (#2%fx+ 'a))
+   (error? #3%fubar)
+   (error? (#2%car 'a 'b))
+   (error? (#2%car 3)))
diff --git a/mats/5_1.ms b/mats/5_1.ms
new file mode 100644
index 0000000..aa2fc4c
--- /dev/null
+++ b/mats/5_1.ms
@@ -0,0 +1,918 @@
+;;; 5-1.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat eq?
+    (eq? 'a 'a)
+    (let ((x 203840238409238402384)) (eq? x x))
+    (let ((x (cons 3 4))) (eq? x x))
+    (not (eq? "hi there" (string-append "hi " "there")))
+    (not (eq? (cons '() '()) (cons '() '())))
+ )
+
+(mat eqv?
+    (eqv? 'a 'a)
+    (not (eqv? '(a b (c)) "hi"))
+    (not (eqv? '(a b (c)) (list 'a 'b '(c))))
+    (not (eqv? 3.4 3.5))
+    (eqv? 3.4 3.4)
+    (eqv? 3/4 3/4)
+    (not (eqv? 3/4 4/5))
+    (not (eqv? 2.0 2))
+    (not (eqv? 4.5 9/2))
+    (eqv? 123124211123 123124211123)
+    (not (eqv? 123124211123 123124211124))
+    (not (eqv? "hi there" (string-append "hi " "there")))
+    (not (eqv? (vector 1 2 (vector 3 4) 5) '#(1 2 #(3 4) 5)))
+    (eqv? +nan.0 +nan.0)
+    (eqv? +inf.0 +inf.0)
+    (eqv? -inf.0 -inf.0)
+    (not (eqv? -inf.0 +inf.0))
+    (eqv? +0.0 +0.0)
+    (eqv? -0.0 -0.0)
+    (not (eqv? +0.0 -0.0))
+    (eqv? 3.0+0.0i 3.0+0.0i)
+    (eqv? 3.0-0.0i 3.0-0.0i)
+    (not (eqv? 3.0+0.0i 3.0-0.0i))
+    (not (eqv? 3.0+0.0i 3.0))
+    (not (eqv? 3.0 3))
+    (not (eqv? 3.0+4.0i 3+4i))
+    (not (eqv? 3 3.0))
+    (not (eqv? 3+4i 3.0+4.0i))
+ )
+
+(mat equal?
+    (equal? 'a 'a)
+    (not (equal? '(a b (c)) "hi"))
+    (equal? '(a b (c)) (list 'a 'b '(c)))
+    (not (equal? '(a b (c)) '(a b (d))))
+    (equal? 123124211123 123124211123)
+    (not (equal? 123124211123 123124211124))
+    (equal? "hi there" (string-append "hi " "there"))
+    (not (equal? "hi there " "hi there"))
+    (equal? (vector 1 2 (vector 3 4) 5) '#(1 2 #(3 4) 5))
+    (not (equal? (vector 1 2 (vector 3 4) 5) '#(1 2 3 4 5)))
+    (equal? +nan.0 +nan.0)
+    (equal? +inf.0 +inf.0)
+    (equal? -inf.0 -inf.0)
+    (not (equal? -inf.0 +inf.0))
+    (equal? +0.0 +0.0)
+    (equal? -0.0 -0.0)
+    (not (equal? +0.0 -0.0))
+    (equal? 3.0+0.0i 3.0+0.0i)
+    (equal? 3.0-0.0i 3.0-0.0i)
+    (not (equal? 3.0+0.0i 3.0-0.0i))
+    (not (equal? 3.0+0.0i 3.0))
+    (not (equal? 3.0 3))
+    (not (equal? 3.0+4.0i 3+4i))
+    (not (equal? 3 3.0))
+    (not (equal? 3+4i 3.0+4.0i))
+ )
+
+(mat new-equal? ; includes dag and cycle checks
+  (time (equal? '(a b c) '(a b c)))
+  (equal? '#1=(a b c . #1#) '#2=(a b c . #2#))
+  (not (equal? '#3=(a b c . #3#) '#4=(a b . #4#)))
+  (equal? '#5=(a b c . #5#) '#6=(a b c a b c . #6#))
+  (equal? '#7=(a b c . #7#) '(a b c a b c . #7#))
+  (not (equal? '#8=(a b c . #8#) '#9=(a b c a c . #9#)))
+  (andmap eq?
+    (let ([ls1 '#10=(a #10# c #10# d #11# f)]
+          [ls2 '#11=(a (a #11# c #10# d #11# f) c #10# d #11# f)])
+      (list (equal? ls1 ls1)
+            (equal? ls2 ls2)
+            (equal? ls1 ls2)
+            (equal? ls2 ls1)
+            (equal? (cadr ls1) ls2)
+            (equal? (cons 'g ls1) ls1)
+            (equal? (append ls1 '(g)) ls1)
+            (equal? (cdr ls1) (cdddr ls1))
+            (equal? (cdr ls1) (cdr (cadr ls2)))))
+    '(#t #t #t #t #t #f #f #f #t))
+  (andmap eq?
+    (let ([leaf1 (list "As a tree, I am huge.")]
+          [leaf2 (list "As a dag, I am small.")])
+      (let ([tr1 (let f ([n 100])
+                   (if (= n 0)
+                       leaf1
+                       (let ([tr (f (- n 1))])
+                         (cons tr tr))))]
+            [tr2 (let f ([n 100])
+                   (if (= n 0)
+                       leaf2
+                       (let ([tr (f (- n 1))])
+                         (cons tr tr))))])
+        (let ([ls (list (equal? tr1 tr1)
+                        (equal? tr2 tr2)
+                        (equal? tr1 tr2)
+                        (equal? tr1 (car tr1)))])
+          (set-car! leaf1 (car leaf2))
+          (cons* (equal? tr1 tr1)
+                 (equal? tr2 tr2)
+                 (equal? tr1 tr2)
+                 (equal? tr1 (cdr tr1))
+                 ls))))
+    '(#t #t #t #f #t #t #f #f))
+
+  (time (equal? '#(a b c) '#(a b c)))
+  (equal? '#101=#(a b c #1#) '#102=#(a b c #2#))
+  (not (equal? '#103=#(a b c #103#) '#104=#(a b #104#)))
+  (equal? '#105=#(a b c #105#) '#106=#(a b c #(a b c #106#)))
+  (equal? '#107=#(a b c #107#) '#(a b c #(a b c #107#)))
+  (not (equal? '#108=#(a b c #108#) '#109=#(a b c #(a c #109#))))
+  (andmap eq?
+    (let ([v1 '#110=#(a #110# c #110# d #111# f)]
+          [v2 '#111=#(a #(a #111# c #110# d #111# f) c #110# d #111# f)]
+          [v3 '#112=#(a #(a #112# c #110# d #112# f) c #110# d #112# g)])
+      (list (equal? v1 v1)
+            (equal? v2 v2)
+            (equal? v3 v3)
+            (equal? v1 v2)
+            (equal? v2 v1)
+            (equal? v1 v3)
+            (equal? v2 v3)
+            (equal? v3 v1)
+            (equal? v3 v2)
+            (equal? (vector-ref v1 1) v2)))
+    '(#t #t #t #t #t #f #f #f #f #t))
+  (andmap eq?
+    (let ([leaf1 (vector "As a tree, I am huge.")]
+          [leaf2 (vector "As a dag, I am small.")])
+      (let ([tr1 (let f ([n 100])
+                   (if (= n 0)
+                       leaf1
+                       (let ([tr (f (- n 1))])
+                         (vector tr tr))))]
+            [tr2 (let f ([n 100])
+                   (if (= n 0)
+                       leaf2
+                       (let ([tr (f (- n 1))])
+                         (vector tr tr))))])
+        (let ([ls (list (equal? tr1 tr1)
+                        (equal? tr2 tr2)
+                        (equal? tr1 tr2)
+                        (equal? tr1 (vector-ref tr1 0)))])
+          (vector-set! leaf1 0 (vector-ref leaf2 0))
+          (cons* (equal? tr1 tr1)
+                 (equal? tr2 tr2)
+                 (equal? tr1 tr2)
+                 (equal? tr1 (vector-ref tr1 1))
+                 ls))))
+    '(#t #t #t #f #t #t #f #f))
+
+  (let ([ls1 (make-list 100000 'a)]
+        [ls2 (make-list 100000 'a)])
+    (time
+      (let f ([n 1000])
+        (or (fx= n 0) (and (equal? ls1 ls2) (f (fx- n 1)))))))
+
+  (let ([v1 (make-vector 10000 (make-vector 100 'a))]
+        [v2 (make-vector 10000 (make-vector 100 'a))])
+    (time 
+      (let f ([n 100])
+        (or (fx= n 0) (and (equal? v1 v2) (f (fx- n 1)))))))
+
+  (time
+    (let () ; w/sharing
+      (define (consup1 n)
+        (case n
+          [(0) '()]
+          [(1) 'a]
+          [(2) 3/4]
+          [(3) 3.416]
+          [else
+           (case (logand n 7)
+             [(0) (let ([x (consup1 (ash n -3))]) (cons x x))]
+             [(1) (make-vector 10 (consup1 (ash n -3)))]
+             [(2) (let ([x (cons #f (consup1 (ash n -3)))]) (set-car! x x) x)]
+             [(3) (let ([x (consup1 (ash n -3))]) (vector x 'a x))]
+             [(4) (cons (consup1 (ash n -3)) (consup1 (ash n -3)))]
+             [(5) (cons (string-copy "hello") (consup1 (ash n -3)))]
+             [(6) (list (consup1 (ash n -3)))]
+             [(7) (box (consup2 (ash n -3)))])]))
+      (define (consup2 n)
+        (case n
+          [(0) '()]
+          [(1) 'a]
+          [(2) 3/4]
+          [(3) 3.416]
+          [else
+           (case (logand n 7)
+             [(0) (cons (consup2 (ash n -3)) (consup2 (ash n -3)))]
+             [(1) (let ([x (make-vector 10 (consup1 (ash n -3)))])
+                    (vector-set! x 5 (consup1 (ash n -3)))
+                    x)]
+             [(2) (let ([x (cons #f (consup2 (ash n -3)))]) (set-car! x x) x)]
+             [(3) (let ([x (consup2 (ash n -3))]) (vector x 'a x))]
+             [(4) (let ([x (consup2 (ash n -3))]) (cons x x))]
+             [(5) (cons (string-copy "hello") (consup2 (ash n -3)))]
+             [(6) (list (consup2 (ash n -3)))]
+             [(7) (box (consup1 (ash n -3)))])]))
+      (define (consup3 n)
+        (case n
+          [(0) 'a]
+          [(1) '()]
+          [(2) 3.416]
+          [(3) 3/4]
+          [else
+           (case (logand n 7)
+             [(0) (cons (consup3 (ash n -3)) (consup3 (ash n -3)))]
+             [(1) (let ([x (make-vector 10 (consup3 (ash n -3)))])
+                    (vector-set! x 5 (consup3 (ash n -3)))
+                    x)]
+             [(2) (let ([x (cons #f (consup3 (ash n -3)))]) (set-car! x x) x)]
+             [(3) (let ([x (consup3 (ash n -3))]) (vector x 'a x))]
+             [(4) (let ([x (consup3 (ash n -3))]) (cons x x))]
+             [(5) (cons (string-copy "hello") (consup3 (ash n -3)))]
+             [(6) (list (consup3 (ash n -3)))]
+             [(7) (box (consup3 (ash n -3)))])]))
+      (let loop ([n 10000])
+        (unless (fx= n 0)
+          (let ([rn (random (ash 1 50))])
+            (let ([x1 (consup1 rn)] [x2 (consup2 rn)] [x3 (consup3 rn)])
+              (define-syntax test
+                (syntax-rules ()
+                  [(_ e) (unless e (errorf #f "~s failed for rn = ~s" 'e rn))]))
+              (test (equal? x1 x1))
+              (test (equal? x2 x2))
+              (test (equal? x3 x3))
+              (test (equal? x1 x2))
+              (test (equal? x2 x1))
+              (test (not (equal? x1 x3)))
+              (test (not (equal? x3 x1)))
+              (test (not (equal? x2 x3)))
+              (test (not (equal? x3 x2)))))
+          (loop (fx- n 1))))
+      #t))
+
+  (time
+    (let () ; w/o sharing
+      (define (consup1 n)
+        (case n
+          [(0) '(#() 1389222281905413113340958870929048921229855260389703462234642106526635063669)]
+          [(1) '#(a #vfx(3 4 5))]
+          [(2) '(3/4 . #e3e100+4i)]
+          [(3) '(3.416 . -7.5+.05i)]
+          [else
+           (case (logand n 3)
+             [(0) (cons (consup1 (ash n -2)) (consup1 (ash n -3)))]
+             [(1) (vector (consup1 (ash n -2)) (consup1 (ash n -3)))]
+             [(2) (cons "hello" (consup1 (ash n -2)))]
+             [(3) (box (consup2 (ash n -2)))])]))
+      (define (consup2 n)
+        (case n
+          [(0) '(#() 1389222281905413113340958870929048921229855260389703462234642106526635063669)]
+          [(1) '#(a #vfx(3 4 5))]
+          [(2) '(3/4 . #e3e100+4i)]
+          [(3) '(3.416 . -7.5+.05i)]
+          [else
+           (case (logand n 3)
+             [(0) (cons (consup2 (ash n -2)) (consup2 (ash n -3)))]
+             [(1) (vector (consup2 (ash n -2)) (consup2 (ash n -3)))]
+             [(2) (cons "hello" (consup2 (ash n -2)))]
+             [(3) (box (consup1 (ash n -2)))])]))
+      (define (consup3 n)
+        (case n
+          [(0) '(#() 1389222281905413113340958870929048921229855260289703462234642106526635063669)]
+          [(1) '#(a #vfx(3 4 6))]
+          [(2) '(3/4 . #e3e100+5i)]
+          [(3) '(3.417 . -7.5+.05i)]
+          [else
+           (case (logand n 3)
+             [(0) (cons (consup3 (ash n -2)) (consup3 (ash n -3)))]
+             [(1) (vector (consup3 (ash n -2)) (consup3 (ash n -3)))]
+             [(2) (cons "hello" (consup3 (ash n -2)))]
+             [(3) (box (consup3 (ash n -2)))])]))
+      (let loop ([n 10000])
+        (unless (fx= n 0)
+          (let ([rn (random (ash 1 25))])
+            (let ([x1 (consup1 rn)] [x2 (consup2 rn)] [x3 (consup3 rn)])
+              (define-syntax test
+                (syntax-rules ()
+                  [(_ e) (unless e (errorf #f "~s failed for rn = ~s" 'e rn))]))
+              (test (equal? x1 x1))
+              (test (equal? x2 x2))
+              (test (equal? x3 x3))
+              (test (equal? x1 x2))
+              (test (equal? x2 x1))
+              (test (not (equal? x1 x3)))
+              (test (not (equal? x3 x1)))
+              (test (not (equal? x2 x3)))
+              (test (not (equal? x3 x2)))))
+          (loop (fx- n 1))))
+      #t))
+
+  (time
+    (let () ; w/sharing
+      (define (consup n)
+        (define cache
+          (let ([ls '()] [n 0] [vk 1000])
+            (case-lambda
+              [()
+               (and (> n 0)
+                 (let f ([i (random n)] [ls ls])
+                   (if (fx< i vk)
+                       (vector-ref (car ls) i)
+                       (f (fx- i vk) (cdr ls)))))]
+              [(x)
+               (let ([i (fxmodulo n vk)])
+                 (if (fx= i 0)
+                     (set! ls (append ls (list (make-vector vk x))))
+                     (vector-set! (list-ref ls (fxquotient n vk)) i x)))
+               (set! n (fx+ n 1))])))
+        (let f ([n n])
+          (if (= n 0)
+              (or (cache) (cons '() '()))
+              (case (logand n 3)
+                [(0) (let ([p1 (cons #f #f)] [p2 (cons #f #f)])
+                       (let ([p (cons p1 p2)])
+                         (cache p)
+                         (let ([p (f (ash n -2))])
+                           (set-car! p1 (car p))
+                           (set-car! p2 (cdr p)))
+                         (let ([p (f (ash n -2))])
+                           (set-cdr! p1 (car p))
+                           (set-cdr! p2 (cdr p)))
+                         p))]
+                [(1) (let ([m (random 10)])
+                       (let ([v1 (make-vector m #f)] [v2 (make-vector m #f)])
+                         (let ([p (cons v1 v2)])
+                           (cache p)
+                           (do ([i 0 (fx+ i 1)])
+                               ((fx= i m))
+                             (let ([p (f (ash n -2))])
+                               (vector-set! v1 i (car p))
+                               (vector-set! v2 i (cdr p))))
+                           p)))]
+                [(2) (let ([p1 (f (ash n -2))]
+                           [p2 (f (ash n -2))])
+                       (cons (cons (cdr p1) (cdr p2))
+                             (cons (car p1) (car p2))))]
+                [(3) (or (cache) (f (ash n -2)))]))))
+      (let loop ([n 5000])
+        (unless (fx= n 0)
+          (let ([rn (* (random 1000) (expt 2 (random 10)))])
+            (let ([p (consup rn)])
+              (let ([x1 (car p)] [x2 (cdr p)])
+                (define-syntax test
+                  (syntax-rules ()
+                    [(_ e) (unless e (errorf #f "~s failed for rn = ~s" 'e rn))]))
+                (test (equal? x1 x1))
+                (test (equal? x2 x2))
+                (test (equal? x1 x2))
+                (test (equal? x2 x1)))))
+          (loop (fx- n 1))))
+      #t))
+
+ ; srfi 85 examples
+  (equal? '() '())
+  (equal? (vector 34.5 34.5) '#(34.5 34.5))
+  (andmap eq?
+    (let* ([x (list 'a)] [y (list 'a)] [z (list x y)])
+      (list (equal? z (list y x)) (equal? z (list x x))))
+    '(#t #t))
+  (andmap eq?
+    (let ([x (list 'a 'b 'c 'a)]
+          [y (list 'a 'b 'c 'a 'b 'c 'a)])
+      (set-cdr! (list-tail x 2) x)
+      (set-cdr! (list-tail y 5) y)
+      (list
+        (equal? x x)
+        (equal? x y)
+        (equal? (list x y 'a) (list y x 'b))))
+    '(#t #t #f))
+
+ ; tests that break original SRFI 85 implementation
+  (let ()
+    (define x
+      (let ([x1 (vector 'h)]
+            [x2 (let ([x (list #f)]) (set-car! x x) x)])
+        (vector x1 (vector 'h) x1 (vector 'h) x1 x2)))
+    (define y
+      (let ([y1 (vector 'h)]
+            [y2 (vector 'h)]
+            [y3 (let ([x (list #f)]) (set-car! x x) x)])
+        (vector (vector 'h) y1 y1 y2 y2 y3)))
+    (equal? x y))
+  (let ()
+    (define x
+      (let ([x0 (vector #f #f #f)]
+            [x1 (vector #f #f #f)]
+            [x2 (vector #f #f #f)])
+         (vector-fill! x0 x0)
+         (vector-fill! x1 x1)
+         (vector-fill! x2 x2)
+         (vector x0 x1 x0 x2 x0)))
+    (define y
+      (let ([y0 (vector #f #f #f)]
+            [y1 (vector #f #f #f)]
+            [y2 (vector #f #f #f)])
+         (vector-fill! y0 y0)
+         (vector-fill! y1 y1)
+         (vector-fill! y2 y2)
+         (vector y0 y1 y1 y2 y2)))
+    (equal? x y))
+  (let ()
+    (define x
+      (let ([x (cons (cons #f 'a) 'a)])
+        (set-car! (car x) x)
+        x))
+    (define y
+      (let ([y (cons (cons #f 'a) 'a)])
+        (set-car! (car y) (car y))
+        y))
+    (equal? x y))
+  (let ()
+    (define x
+      (let* ([x3 (cons 'x3 'x3)]
+             [x2 (cons 'x2 x3)]
+             [x1 (cons x2 'x1)])
+        (set-car! x3 x3)
+        (set-cdr! x3 x3)
+        (set-car! x2 x2)
+        (set-cdr! x1 x1)
+        x1))
+    (define y
+      (let* ([y2 (cons 'y1 'y1)]
+             [y1 (cons y2 y2)])
+        (set-car! y2 y1)
+        (set-cdr! y2 y1)
+        y1))
+    (equal? x y))
+  (let ()
+    (define x
+      (let* ([x3 (cons 'x3 'x3)]
+             [x2 (cons 'x2 x3)]
+             [x1 (cons x2 'x1)])
+        (set-car! x3 x3)
+        (set-cdr! x3 x3)
+        (set-car! x2 x2)
+        (set-cdr! x1 x1)
+        x1))
+    (define y
+      (let* ([y2 (cons 'y1 'y1)]
+             [y1 (cons y2 y2)])
+        (set-car! y2 y1)
+        (set-cdr! y2 y1)
+        y1))
+    (equal? x y))
+  (let ()
+    (define (make-x k)
+      (let ([x1 (cons 
+                  (let f ([n k])
+                    (if (= n 0)
+                        (let ([x0 (cons #f #f)])
+                          (set-car! x0 x0)
+                          (set-cdr! x0 x0)
+                          x0)
+                        (let ([xi (cons #f (f (- n 1)))])
+                          (set-car! xi xi)
+                          xi)))
+                  #f)])
+        (set-cdr! x1 x1)
+        x1))
+    (define y
+      (let* ([y2 (cons #f #f)] [y1 (cons y2 y2)])
+        (set-car! y2 y1)
+        (set-cdr! y2 y1)
+        y1))
+    (time (equal? (make-x 100) y)))
+
+ ; tests that stress corrected SRFI 85 implementation
+ (or (equal?
+       (let ([v1 '#200=(#200#)] [v2 '#201=(#201#)])
+         (let ([t0 (current-time 'time-process)])
+           (let ([ans (let f ([i 1000] [x #t])
+                        (if (fx= i 0)
+                            x
+                            (f (fx- i 1) (and x (equal? v1 v2)))))])
+             (list
+               ans
+               (let ([t (current-time 'time-process)])
+                 (< (+ (* (- (time-second t) (time-second t0)) 1000000000)
+                       (- (time-nanosecond t) (time-nanosecond t0)))
+                    30000000))))))
+       '(#t #t))
+      (#%$enable-check-heap))
+
+  (or (equal?
+        (let ([v1 (make-vector 95000 (make-vector 95000 0))]
+              [v2 (make-vector 95000 (make-vector 95000 0))])
+          (let ([t0 (current-time 'time-process)])
+            (let ([ans (equal? v1 v2)])
+              (list
+                ans
+                (let ([t (current-time 'time-process)])
+                  (> (+ (* (- (time-second t) (time-second t0)) 1000000000)
+                        (- (time-nanosecond t) (time-nanosecond t0)))
+                     100000000))))))
+        '(#t #f))
+      (#%$enable-check-heap))
+
+  (or (equal?
+        (let ([n 100000])
+          (let ([f (lambda (n)
+                     (let ([ls (make-list n 0)])
+                       (set-cdr! (last-pair ls) ls)
+                       ls))])
+            (let ([v1 (f n)] [v2 (f (- n 1))])
+              (let ([t0 (current-time 'time-process)])
+                (let ([ans (equal? v1 v2)])
+                  (let ([t (current-time 'time-process)])
+                    (list
+                      ans
+                      (< (+ (* (- (time-second t) (time-second t0)) 1000000000)
+                            (- (time-nanosecond t) (time-nanosecond t0)))
+                         200000000))))))))
+        '(#t #t))
+      (#%$enable-check-heap))
+)
+
+(mat boolean?
+    (boolean? #t)
+    (boolean? #f)
+    (not (boolean? 't))
+    (not (boolean? 'f))
+    (not (boolean? 'nil))
+    (not (boolean? '(a b c)))
+    (not (boolean? #\a))
+)
+
+(mat null?
+    (null? '())
+    (not (null? #f))
+    (not (null? #t))
+    (not (null? 3))
+    (not (null? 'a))
+ )
+
+(mat pair?
+    (pair? '(a b c))
+    (pair? '(a . b))
+    (pair? (cons 3 4))
+    (not (pair? '()))
+    (not (pair? 3))
+    (not (pair? 'a))
+    (not (pair? "hi"))
+ )
+
+(mat list?
+    (list? '(a b c))
+    (not (list? '(a . b)))
+    (not (list? (cons 3 4)))
+    (list? '())
+    (not (list? 3))
+    (not (list? 'a))
+    (not (list? "hi"))
+    (let ([a (make-list 100)])
+       (set-cdr! (last-pair a) a)
+       (not (list? a)))
+ )
+
+(mat atom?
+    (not (atom? '(a b c)))
+    (not (atom? '(a . b)))
+    (not (atom? (cons 3 4)))
+    (atom? '())
+    (atom? 3)
+    (atom? 'a)
+    (atom? "hi")
+ )
+   
+(mat number?
+    (number? 3)
+    (number? 23048230482304)
+    (number? 203480234802384/23049821)
+    (number? -3/4)
+    (number? -1)
+    (number? 0)
+    (number? -12083)
+    (number? 3.5)
+    (number? 1.8e-10)
+    (number? -3e5)
+    (number? -1231.2344)
+    (not (number? 'a))
+    (not (number? "hi"))
+    (not (number? (cons 3 4)))
+    (number? 5.0-0.0i)
+    (number? 5.0+0.0i)
+    (number? 5.0+4.0i)
+    (number? +inf.0)
+    (number? -inf.0)
+    (number? +nan.0)
+ )
+
+(mat complex?
+    (complex? 3)
+    (complex? 23048230482304)
+    (complex? 203480234802384/23049821)
+    (complex? -3/4)
+    (complex? -1)
+    (complex? 0)
+    (complex? -12083)
+    (complex? 3.5)
+    (complex? 1.8e-10)
+    (complex? -3e5)
+    (complex? -1231.2344)
+    (not (complex? 'a))
+    (not (complex? "hi"))
+    (not (complex? (cons 3 4)))
+    (complex? 5.0-0.0i)
+    (complex? 5.0+0.0i)
+    (complex? 5.0+4.0i)
+    (complex? +inf.0)
+    (complex? -inf.0)
+    (complex? +nan.0)
+ )
+
+(mat real?
+    (real? 3)
+    (real? 23048230482304)
+    (real? 203480234802384/23049821)
+    (real? -3/4)
+    (real? -1)
+    (real? 0)
+    (real? -12083)
+    (real? 3.5)
+    (real? 1.8e-10)
+    (real? -3e5)
+    (real? -1231.2344)
+    (not (real? 'a))
+    (not (real? "hi"))
+    (not (real? (cons 3 4)))
+    (not (real? 5.0-0.0i))
+    (not (real? 5.0+0.0i))
+    (not (real? 5.0+4.0i))
+    (real? +inf.0)
+    (real? -inf.0)
+    (real? +nan.0)
+ )
+
+(mat real-valued?
+    (real-valued? 3)
+    (real-valued? 23048230482304)
+    (real-valued? 203480234802384/23049821)
+    (real-valued? -3/4)
+    (real-valued? -1)
+    (real-valued? 0)
+    (real-valued? -12083)
+    (real-valued? 3.5)
+    (real-valued? 1.8e-10)
+    (real-valued? -3e5)
+    (real-valued? -1231.2344)
+    (not (real-valued? 'a))
+    (not (real-valued? "hi"))
+    (not (real-valued? (cons 3 4)))
+    (real-valued? 5.0-0.0i)
+    (real-valued? 5.0+0.0i)
+    (not (real-valued? 8.0+3.0i))
+    (real-valued? +inf.0)
+    (real-valued? -inf.0)
+    (real-valued? +nan.0)
+ )
+
+(mat rational?
+    (rational? 3)
+    (rational? 23048230482304)
+    (rational? 203480234802384/23049821)
+    (rational? -3/4)
+    (rational? -1)
+    (rational? 0)
+    (rational? -12083)
+    (rational? 3.5)
+    (rational? 1.8e-10)
+    (rational? -3e5)
+    (rational? -1231.2344)
+    (not (rational? 'a))
+    (not (rational? "hi"))
+    (not (rational? (cons 3 4)))
+    (not (rational? 5.0-0.0i))
+    (not (rational? 5.0+0.0i))
+    (not (rational? 8.0+3.0i))
+    (not (rational? +inf.0))
+    (not (rational? -inf.0))
+    (not (rational? +nan.0))
+ )
+
+(mat rational-valued?
+    (rational-valued? 3)
+    (rational-valued? 23048230482304)
+    (rational-valued? 203480234802384/23049821)
+    (rational-valued? -3/4)
+    (rational-valued? -1)
+    (rational-valued? 0)
+    (rational-valued? -12083)
+    (rational-valued? 3.5)
+    (rational-valued? 1.8e-10)
+    (rational-valued? -3e5)
+    (rational-valued? -1231.2344)
+    (not (rational-valued? 'a))
+    (not (rational-valued? "hi"))
+    (not (rational-valued? (cons 3 4)))
+    (rational-valued? 5.0-0.0i)
+    (rational-valued? 5.0+0.0i)
+    (not (rational-valued? 8.0+3.0i))
+    (not (rational-valued? +inf.0))
+    (not (rational-valued? -inf.0))
+    (not (rational-valued? +nan.0))
+    (not (rational-valued? +inf.0+0.0i))
+    (not (rational-valued? +inf.0-0.0i))
+    (not (rational-valued? -inf.0+0.0i))
+    (not (rational-valued? -inf.0-0.0i))
+    (not (rational-valued? +nan.0+0.0i))
+    (not (rational-valued? +nan.0-0.0i))
+ )
+
+(mat integer?
+    (integer? 3)
+    (integer? 23048230482304)
+    (not (integer? 203480234802384/23049821))
+    (not (integer? -3/4))
+    (integer? -1)
+    (integer? 0)
+    (integer? -12083)
+    (integer? 4.0)
+    (not (integer? 3.5))
+    (not (integer? 1.8e-10))
+    (integer? 1.8e10)
+    (integer? -3e5)
+    (not (integer? -1231.2344))
+    (not (integer? 'a))
+    (not (integer? "hi"))
+    (not (integer? (cons 3 4)))
+    (not (integer? 3.0-0.0i))
+    (not (integer? 3.0+0.0i))
+    (not (integer? 3.0+1.0i))
+    (integer? #i1)
+    (not (integer? +inf.0))
+    (not (integer? -inf.0))
+    (not (integer? +nan.0))
+ )
+
+(mat integer-valued?
+    (integer-valued? 3)
+    (integer-valued? 23048230482304)
+    (not (integer-valued? 203480234802384/23049821))
+    (not (integer-valued? -3/4))
+    (integer-valued? -1)
+    (integer-valued? 0)
+    (integer-valued? -12083)
+    (integer-valued? 4.0)
+    (not (integer-valued? 3.5))
+    (not (integer-valued? 1.8e-10))
+    (integer-valued? 1.8e10)
+    (integer-valued? -3e5)
+    (not (integer-valued? -1231.2344))
+    (not (integer-valued? 'a))
+    (not (integer-valued? "hi"))
+    (not (integer-valued? (cons 3 4)))
+    (integer-valued? 3.0-0.0i)
+    (integer-valued? 3.0+0.0i)
+    (not (integer-valued? 3.0+1.0i))
+    (integer-valued? #i1)
+    (not (integer-valued? +inf.0))
+    (not (integer-valued? -inf.0))
+    (not (integer-valued? +nan.0))
+ )
+
+(mat char?
+    (char? #\a)
+    (char? #\3)
+    (char? (string-ref "hi" 0))
+    (not (char? "a"))
+    (not (char? 'a))
+    (not (char? '(a b c)))
+ )
+
+(mat string?
+    (string? "hi")
+    (string? (string-append "hi " "there"))
+    (string? (string #\a #\b #\c #\c))
+    (not (string? #\a))
+    (not (string? 'a))
+    (not (string? '(a b c)))
+    (not (string? 3))
+ )
+
+(mat vector?
+    (vector? '#(a b c))
+    (vector? (vector 1 2 3 4))
+    (not (vector? '(a b c)))
+    (not (vector? "hi there"))
+    (not (vector? 234234))
+ )
+
+(mat fxvector?
+    (fxvector? #vfx(1 2 3))
+    (fxvector? (fxvector 1 2 3 4))
+    (not (fxvector? '(1 2 3)))
+    (not (fxvector? '#(1 2 3)))
+    (not (fxvector? '#vu8(1 2 3)))
+    (not (fxvector? "hi there"))
+    (not (fxvector? 234234))
+ )
+
+(mat bytevector?
+    (bytevector? '#vu8(1 2 3))
+    (bytevector? (bytevector 1 2 3 4))
+    (not (bytevector? '(1 2 3)))
+    (not (bytevector? '#(1 2 3)))
+    (not (bytevector? '#vfx(1 2 3)))
+    (not (bytevector? "hi there"))
+    (not (bytevector? 234234))
+ )
+
+(mat symbol?
+    (symbol? 'a)
+    (symbol? '|(a b c)|)
+    (symbol? (string->symbol "hi there"))
+    (symbol? (gensym "hi there"))
+    (not (symbol? "hi there"))
+    (not (symbol? 3))
+ )
+
+(mat box?
+    (box? '#&(a b c))
+    (box? (box 3))
+    (not (box? '()))
+    (not (box? 3))
+    (not (box? '(a b c)))
+    (not (box? 'a))
+    (not (box? "hi"))
+ )
+
+(mat input-port?
+    (input-port? (current-input-port))
+    (not (input-port? (open-output-string)))
+ )
+
+(mat output-port?
+    (output-port? (current-output-port))
+    (not (output-port? (open-input-string "hello")))
+    (output-port? (trace-output-port))
+ )
+
+(mat procedure?
+    (procedure? car)
+    (procedure? (lambda (x) x))
+    (not (procedure? 3))
+    (not (procedure? '#(1 b c)))
+    (not (procedure? '(a b c)))
+ )
+
+(mat boolean=?
+  (error? (boolean=?))
+  (error? (boolean=? #f))
+  (error? (boolean=? 3 #t))
+  (error? (boolean=? #t 3))
+  (error? (boolean=? 3 #f #t))
+  (error? (boolean=? #t 3 #t))
+  (error? (boolean=? #t #f 3))
+  (error? (boolean=? 3 #t #f #t))
+  (error? (boolean=? #f 3 #f #t))
+  (error? (boolean=? #t #t 3 #t))
+  (error? (boolean=? #f #t #f 3))
+  (eqv? (boolean=? #t #t) #t)
+  (eqv? (boolean=? #f #t) #f)
+  (eqv? (boolean=? #t #f) #f)
+  (eqv? (boolean=? #f #f) #t)
+  (eqv? (boolean=? #f #f #t) #f)
+  (eqv? (boolean=? #f #f #f #f #f #t) #f)
+  (eqv? (boolean=? #t #t #t #t #t #f) #f)
+  (eqv? (boolean=? #t #t #t #t #t #t) #t)
+  (eqv? (boolean=? #f #f #f #f #f #f) #t)
+)
+
+(mat symbol=?
+  (error? (symbol=?))
+  (error? (symbol=? 'f))
+  (error? (symbol=? 3 't))
+  (error? (symbol=? 't 3))
+  (error? (symbol=? 3 'f 't))
+  (error? (symbol=? 't 3 't))
+  (error? (symbol=? 't 'f 3))
+  (error? (symbol=? 3 't 'f 't))
+  (error? (symbol=? 'f 3 'f 't))
+  (error? (symbol=? 't 't 3 't))
+  (error? (symbol=? 'f 't 'f 3))
+  (eqv? (symbol=? 't 't) #t)
+  (eqv? (symbol=? 'f 't) #f)
+  (eqv? (symbol=? 't 'f) #f)
+  (eqv? (symbol=? 'f 'f) #t)
+  (eqv? (symbol=? 'f 'f 't) #f)
+  (eqv? (symbol=? 'f 'f 'f 'f 'f 't) #f)
+  (eqv? (symbol=? 't 't 't 't 't 'f) #f)
+  (eqv? (symbol=? 't 't 't 't 't 't) #t)
+  (eqv? (symbol=? 'f 'f 'f 'f 'f 'f) #t)
+)
diff --git a/mats/5_2.ms b/mats/5_2.ms
new file mode 100644
index 0000000..8410009
--- /dev/null
+++ b/mats/5_2.ms
@@ -0,0 +1,1340 @@
+;;; 5-2.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define (make-cyclic-list)
+  (let ((ls (list 'a 'b)))
+    (set-cdr! (last-pair ls) ls)
+    ls))
+(define cyclic-list (make-cyclic-list))
+(define cyclic-alist
+  (let ((ls (list '(a . 1) '(b . 2) '(3.2 . 3) '("a" . 4))))
+    (set-cdr! (last-pair ls) ls)
+    ls))
+
+(mat cons
+    (equal? (cons 3 4) '(3 . 4))
+    (equal? (cons 3 '(a)) '(3 a))
+    (not (equal? (cons 2 3) (cons 3 2)))
+ )
+
+(mat car
+    (eq? (car '(a b c)) 'a)
+    (eq? (car (cons 'a 'b)) 'a)
+    (error? (car "hi"))
+ )
+
+(mat cdr
+    (equal? (cdr '(a b c)) '(b c))
+    (eq? (cdr (cons 'a 'b)) 'b)
+    (null? (cdr (cons 'a '())))
+    (error? (cdr 3))
+ )   
+
+(mat set-car!
+    (let ((x (list 'a 'b))) (set-car! x 3) (equal? x '(3 b)))
+    (error? (set-car! 'a 'b))
+ )
+
+(mat set-cdr!
+    (let ((x (list 'a 'b))) (set-cdr! x 3) (equal? x '(a . 3)))
+    (error? (set-cdr! 'a 'b))
+ )
+
+(set! bush
+   (lambda (n)
+      (let f ((n n) (x '()))
+          (if (zero? n)
+              x
+              (cons (f (1- n) (cons 'a x)) (f (1- n) (cons 'd x)))))))
+(set! b2 (bush 2))
+(set! b3 (bush 3))
+(set! b4 (bush 4))
+(mat c....r
+    ;first, get some confidence in bush
+    (equal? b2 '(((a a) d a) (a d) d d))
+    (equal? (caar b2) '(a a))
+    (equal? (cadr b2) '(a d))
+    (equal? (cdar b2) '(d a))
+    (equal? (cddr b2) '(d d))
+    (equal? (caaar b3) '(a a a))
+    (equal? (caadr b3) '(a a d))
+    (equal? (cadar b3) '(a d a))
+    (equal? (caddr b3) '(a d d))
+    (equal? (cdaar b3) '(d a a))
+    (equal? (cdadr b3) '(d a d))
+    (equal? (cddar b3) '(d d a))
+    (equal? (cdddr b3) '(d d d))
+    (equal? (caaaar b4) '(a a a a))
+    (equal? (caaadr b4) '(a a a d))
+    (equal? (caadar b4) '(a a d a))
+    (equal? (caaddr b4) '(a a d d))
+    (equal? (cadaar b4) '(a d a a))
+    (equal? (cadadr b4) '(a d a d))
+    (equal? (caddar b4) '(a d d a))
+    (equal? (cadddr b4) '(a d d d))
+    (equal? (cdaaar b4) '(d a a a))
+    (equal? (cdaadr b4) '(d a a d))
+    (equal? (cdadar b4) '(d a d a))
+    (equal? (cdaddr b4) '(d a d d))
+    (equal? (cddaar b4) '(d d a a))
+    (equal? (cddadr b4) '(d d a d))
+    (equal? (cdddar b4) '(d d d a))
+    (equal? (cddddr b4) '(d d d d))
+)
+
+(define a.b '(a . b))
+
+(mat c....r-errors
+    (error? (caar a.b))
+    (error? (cadr a.b))
+    (error? (cdar a.b))
+    (error? (cddr a.b))
+    (error? (caaar a.b))
+    (error? (caadr a.b))
+    (error? (cadar a.b))
+    (error? (caddr a.b))
+    (error? (cdaar a.b))
+    (error? (cdadr a.b))
+    (error? (cddar a.b))
+    (error? (cdddr a.b))
+    (error? (caaaar a.b))
+    (error? (caaadr a.b))
+    (error? (caadar a.b))
+    (error? (caaddr a.b))
+    (error? (cadaar a.b))
+    (error? (cadadr a.b))
+    (error? (caddar a.b))
+    (error? (cadddr a.b))
+    (error? (cdaaar a.b))
+    (error? (cdaadr a.b))
+    (error? (cdadar a.b))
+    (error? (cdaddr a.b))
+    (error? (cddaar a.b))
+    (error? (cddadr a.b))
+    (error? (cdddar a.b))
+    (error? (cddddr a.b))
+)
+
+(mat make-list
+    (equal? (length (make-list 15)) 15)
+    (equal? (make-list 3 'a) '(a a a))
+    (null? (make-list 0 0))
+ )
+
+(mat list
+    (equal? (list 1 2 3 4) '(1 2 3 4))
+    (null? (list))
+ )
+
+(mat list*
+    (error? (list*))
+    (equal? (list* 1) 1)
+    (equal? (list* (list 1 2 3)) '(1 2 3))
+    (equal? (list* 1 2 3 4) '(1 2 3 . 4))
+    (equal?
+      (list* 1 2 (list* 3 4 5) (list* 6 7 8))
+      '(1 2 (3 4 . 5) 6 7 . 8))
+    (not (list* #f))
+    (eq? (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2]) (expand/optimize '(not (list* #f)))) #t)
+ )
+
+(mat cons*
+    (error? (cons*))
+    (equal? (cons* 1) 1)
+    (equal? (cons* (list 1 2 3)) '(1 2 3))
+    (equal? (cons* 1 2 3 4) '(1 2 3 . 4))
+    (equal?
+      (cons* 1 2 (list* 3 4 5) (list* 6 7 8))
+      '(1 2 (3 4 . 5) 6 7 . 8))
+    (not (cons* #f))
+    (eq? (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2]) (expand/optimize '(not (cons* #f)))) #t)
+ )
+
+(mat length
+    (= (length '(1 2 3 4 5)) 5)
+    (= (length '()) 0)
+    ; check that expand-primitives doesn't generate incorrect code.
+    ; we don't check that it optimizes, however.
+    (let ([ls* (map make-list '(0 1 2 3 4 5 8 9 10 99 100 101 1000))])
+      (define-syntax test1
+        (syntax-rules ()
+          [(_ prim)
+           (let ()
+             (define (f x)
+               (and
+                 (prim (#3%length x))
+                 (prim (#3%length x))))
+             (andmap
+               (lambda (x)
+                 (let ([n (length x)])
+                   (equal?
+                     (f x)
+                     (prim n))))
+               ls*))]))
+      (define-syntax test2
+        (syntax-rules ()
+          [(_ prim)
+           (let ()
+             (define (f x)
+               (list
+                 (prim (#3%length x) 0)
+                 (prim 0 (#3%length x))
+                 (prim (#3%length x) 1)
+                 (prim 1 (#3%length x))
+                 (prim (#3%length x) 4)
+                 (prim 4 (#3%length x))
+                 (prim (#3%length x) 9)
+                 (prim 9 (#3%length x))
+                 (prim (#3%length x) 100)
+                 (prim 100 (#3%length x))))
+             (andmap
+               (lambda (x)
+                 (let ([n (length x)])
+                   (equal?
+                     (f x)
+                     (list
+                       (prim n 0)
+                       (prim 0 n)
+                       (prim n 1)
+                       (prim 1 n)
+                       (prim n 4)
+                       (prim 4 n)
+                       (prim n 9)
+                       (prim 9 n)
+                       (prim n 100)
+                       (prim 100 n)))))
+               ls*))]))
+      (and
+        (test1 zero?)
+        (test1 positive?)
+        (test1 nonnegative?)
+        (test1 negative?)
+        (test1 nonpositive?)
+        (test1 fxzero?)
+        (test1 fxpositive?)
+        (test1 fxnonnegative?)
+        (test1 fxnegative?)
+        (test1 fxnonpositive?)
+        (test2 eq?)
+        (test2 eqv?)
+        (test2 equal?)
+        (test2 <)
+        (test2 <=)
+        (test2 =)
+        (test2 >=)
+        (test2 >)
+        (test2 r6rs:<)
+        (test2 r6rs:<=)
+        (test2 r6rs:=)
+        (test2 r6rs:>=)
+        (test2 r6rs:>)
+        (test2 r6rs:<)
+        (test2 r6rs:<=)
+        (test2 r6rs:=)
+        (test2 r6rs:>=)
+        (test2 r6rs:>)
+        (test2 fx<)
+        (test2 fx<=)
+        (test2 fx=)
+        (test2 fx>=)
+        (test2 fx>)
+        (test2 fx=?)
+        (test2 fx>?)
+        (test2 #%$fxu<)))
+ )
+
+(mat list-ref
+    (eq? (list-ref '(a b c d e) 3) 'd)
+    (eq? (list-ref '(a b c d e) 4) 'e)
+    (eq? (list-ref '(a b) 0) 'a)
+    (eq? (list-ref '(a b . c) 1) 'b)
+    (eq? (list-ref cyclic-list 20) 'a)
+    (eq? (list-ref cyclic-list 21) 'b)
+    (eq? (list-ref cyclic-list 10000) 'a)
+    (eq? (list-ref cyclic-list 10001) 'b)
+    (eq? (list-ref cyclic-list (expt 2 1000)) 'a)
+    (eq? (list-ref cyclic-list (+ (expt 2 1000) 1)) 'b)
+    (eq? (list-ref `(1 2 . ,cyclic-list) 20) 'a)
+    (eq? (list-ref `(1 2 . ,cyclic-list) 21) 'b)
+    (eq? (list-ref `(1 2 . ,cyclic-list) 10000) 'a)
+    (eq? (list-ref `(1 2 . ,cyclic-list) 10001) 'b)
+    (eq? (list-ref `(1 2 . ,cyclic-list) (expt 2 1000)) 'a)
+    (eq? (list-ref `(1 2 . ,cyclic-list) (+ (expt 2 1000) 1)) 'b)
+    (error? (list-ref 'a 0))
+    (error? (list-ref '(a b . c) 4))
+    (error? (list-ref '(a b) 4))
+    (error? (list-ref '(a b c) 4))
+    (error? (list-ref '(a b c d) 4))
+    (error? (list-ref '(a b c . e) 4))
+    (error? (list-ref '(a b c d . e) 4))
+    (error? (list-ref '(a b c d) 5))
+    (error? (list-ref '(a b c d e) 5))
+    (error? (list-ref '(a b c d e . f) 5))
+    (error? (list-ref '(a b . c) 10000))
+    (error? (list-ref '(a b c) 10000))
+    (error? (list-ref '(a b . c) 444444444444444444444444444444444444444444))
+    (error? (list-ref '(a b c) 444444444444444444444444444444444444444444))
+    (error? (list-ref '(a b c) -1))
+    (error? (list-ref '(a b c) -4444444444444444444444))
+    (error? (list-ref '(a b c) 'a))
+ )
+
+(mat list-tail
+    (let ((x '(d e f))) (eq? (list-tail (list* 'a 'b x) 2) x))
+    (let ((x '(d e f))) (eq? (list-tail (list* 'a 'b x) 3) (cdr x)))
+    (let ((x '(a b c))) (eq? (list-tail x 0) x))
+    (null? (list-tail '(a b c) 3))
+    (eq? (list-tail '(a b . c) 2) 'c)
+    (eq? (list-tail cyclic-list 20) cyclic-list)
+    (eq? (list-tail cyclic-list 21) (cdr cyclic-list))
+    (eq? (list-tail cyclic-list 10000) cyclic-list)
+    (eq? (list-tail cyclic-list 10001) (cdr cyclic-list))
+    (eq? (list-tail cyclic-list (expt 2 1000)) cyclic-list)
+    (eq? (list-tail cyclic-list (+ (expt 2 1000) 1)) (cdr cyclic-list))
+    (eq? (list-tail `(1 2 . ,cyclic-list) 20) cyclic-list)
+    (eq? (list-tail `(1 2 . ,cyclic-list) 21) (cdr cyclic-list))
+    (eq? (list-tail `(1 2 . ,cyclic-list) 10000) cyclic-list)
+    (eq? (list-tail `(1 2 . ,cyclic-list) 10001) (cdr cyclic-list))
+    (eq? (list-tail `(1 2 . ,cyclic-list) (expt 2 1000)) cyclic-list)
+    (eq? (list-tail `(1 2 . ,cyclic-list) (+ (expt 2 1000) 1))
+         (cdr cyclic-list))
+    (eq? (list-tail 'a 0) 'a)
+    (error? (list-tail '(a b . c) 4))
+    (error? (list-tail '(a b c . d) 4))
+    (error? (list-tail '(a b . c) 5))
+    (error? (list-tail '(a b c . d) 5))
+    (error? (list-tail '(a b c d . e) 5))
+    (error? (list-tail '(a) 4))
+    (error? (list-tail '(a b) 4))
+    (error? (list-tail '(a b c) 4))
+    (error? (list-tail '(a b) 5))
+    (error? (list-tail '(a b c) 5))
+    (error? (list-tail '(a b c d) 5))
+    (error? (list-tail '(a b . c) 10000))
+    (error? (list-tail '(a b c) 10000))
+    (error? (list-tail '(a b . c) 444444444444444444444444444444444444444444))
+    (error? (list-tail '(a b c) 444444444444444444444444444444444444444444))
+    (error? (list-tail '(a b c) -1))
+    (error? (list-tail '(a b c) -4444444444444444444444))
+    (error? (list-tail '(a b c) 'a))
+ )
+
+(mat list-head
+    (equal? (list-head '(a b c) 3) '(a b c))
+    (equal? (list-head '(a b . c) 2) '(a b))
+    (equal? (list-head cyclic-list 0) '())
+    (equal? (list-head cyclic-list 1) '(a))
+    (equal? (list-head cyclic-list 2) '(a b))
+    (equal? (list-head cyclic-list 20) '(a b a b a b a b a b a b a b a b a b a b))
+    (equal? (list-head cyclic-list 21) '(a b a b a b a b a b a b a b a b a b a b a))
+    (equal?
+      (let ([ls (list-head cyclic-list 10000)])
+        (list (length ls)
+              (length (remq 'a ls))
+              (length (remq 'b ls))
+              (last-pair ls)))
+      '(10000 5000 5000 (b)))
+    (equal?
+      (let ([ls (list-head cyclic-list 10001)])
+        (list (length ls)
+              (length (remq 'a ls))
+              (length (remq 'b ls))
+              (last-pair ls)))
+      '(10001 5000 5001 (a)))
+    (error? (list-head '(a . b) 3))
+    (error? (list-head '(a b . c) 3))
+    (equal? (list-head '(a b c . d) 3) '(a b c))
+    (error? (list-head '(a b . c) 4))
+    (error? (list-head '(a b c . d) 4))
+    (equal? (list-head '(a b c d . e) 4) '(a b c d))
+    (error? (list-head '(a b . c) 10000))
+    (error? (list-head '(a b c) 4))
+    (error? (list-head '(a b c) 5))
+    (error? (list-head '(a b c d) 5))
+    (error? (list-head '(a b c d) 6))
+    (error? (list-head '(a b c) 10000))
+    (error? (list-head '(a b c) 10001))
+    (error? (list-head '(a b c d) 10000))
+    (error? (list-head '(a b c d) 10001))
+    (error? (list-head '(a b c) -1))
+    (error? (list-head '(a b c) -2))
+    (error? (list-head '(a b c) 4444444444444444444444))
+    (error? (list-head '(a b c) -4444444444444444444445))
+    (error? (list-head '(a b c) 'a))
+    (error? (list-head '(a b c) 2.0))
+ )
+
+(mat last-pair
+   (let ([x '(d e f)])
+      (eq? (last-pair x) (cddr x)))
+   (let ([x (cons 'c 'd)])
+      (let ([y (list* 'a 'b x)])
+         (eq? (last-pair y) x)))
+   (error? (last-pair cyclic-list))
+   (error? (last-pair (cdr cyclic-list)))
+   (error? (last-pair `(a b c . ,cyclic-list)))
+)
+
+(mat list-copy
+    (eq? (list-copy '()) '())
+    (equal? (list-copy '(a b c)) '(a b c))
+    (let* ((p1 '(a b c)) (p2 (cdr p1)) (p3 (cdr p2)))
+        (let ((c1 (list-copy p1)))
+            (not
+                (or (memq c1 (list p1 p2 p3))
+                    (memq (cdr c1) (list p1 p2 p3))
+                    (memq (cddr c1) (list p1 p2 p3))))))
+   (error? (list-copy '#(a b c)))
+   (error? (list-copy '(a b . c)))
+   (error? (list-copy cyclic-list))
+   (error? (list-copy (cdr cyclic-list)))
+   (error? (list-copy `(a b c . ,cyclic-list)))
+ )
+
+(mat append
+    (null? (append))
+    (equal? (append '(a b c)) '(a b c))
+    (let ((x '(a b c)) (y '(d e f)))
+        (let ((z (append x y)))
+            (and (equal? x '(a b c))
+                 (equal? y '(d e f))
+                 (equal? z '(a b c d e f)))))
+    (let ((x '(a b c)))
+       (equal? (append '(a b c) '()) '(a b c)))
+    (let ((x '(d e f)))
+       (eq? (list-tail (append '(a b c) x) 3) x))
+    (equal? (append '(a b) '(c d) '(e f)) '(a b c d e f))
+    (error? (append cyclic-list '()))
+    (error? (append (cdr cyclic-list) '()))
+    (error? (append '(a b . c) '()))
+    (error? (append `(c d . ,cyclic-list) '()))
+    (error? (append '(a b) cyclic-list '()))
+    (error? (append '(a b) (cdr cyclic-list) '()))
+    (error? (append '(a b) `(c d . ,cyclic-list) '()))
+    (error? (append '(a b) '(a b . c) '()))
+    (error? (append '(1) '(a b) cyclic-list '()))
+    (error? (append '(1) '(a b) (cdr cyclic-list) '()))
+    (error? (append '() '(a b) `(c d . ,cyclic-list) '()))
+    (error? (append '(1) '(a b) '(a b . c) '()))
+    (not (append #f))
+    (eq? (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2]) (expand/optimize '(not (append #f)))) #t)
+ )
+
+(mat append!
+    (null? (append!))
+    (equal? (append! (list 'a 'b 'c)) '(a b c))
+    (let ((x (list 'a 'b 'c)) (y (list 'd 'e 'f)))
+        (and (eq? x (append! x y)) (eq? y (list-tail x 3))))
+    (equal? (append! (list 'a 'b 'c) '()) '(a b c))
+    (equal? (append! '() '(a b c)) '(a b c))
+    (equal? (append! (list 'a 'b) (list 'c 'd) '(e f)) '(a b c d e f))
+    (error? (append! cyclic-list '()))
+    (error? (append! (cdr (make-cyclic-list)) '()))
+    (error? (append! (cons* 'c 'd (make-cyclic-list)) '()))
+    (error? (append! (cons* 'a 'b 'c) '()))
+    (error? (append! (list 'a 'b) (make-cyclic-list) '()))
+    (error? (append! (list 'a 'b) (cdr (make-cyclic-list)) '()))
+    (error? (append! (list 'a 'b) (cons* 'c 'd (make-cyclic-list)) '()))
+    (error? (append! (list 'a 'b) (cons* 'a 'b 'c) '()))
+    (error? (append! (list 1) (list 'a 'b) (make-cyclic-list) '()))
+    (error? (append! (list 1) (list 'a 'b) (cdr (make-cyclic-list)) '()))
+    (error? (append! (list 1) (list 'a 'b) (cons* 'c 'd (make-cyclic-list)) '()))
+    (error? (append! (list 1) (list 'a 'b) (cons* 'a 'b 'c) '()))
+    (not (append! #f))
+    (eq? (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2]) (expand/optimize '(not (append! #f)))) #t)
+ )
+
+(mat reverse
+    (let* ((x '(a b c d)) (y (reverse x)))
+        (and (equal? x '(a b c d)) (equal? y '(d c b a))))
+    (eq? (reverse '()) '())
+    (equal? (reverse '(a)) '(a))
+    (error? (reverse))
+    (error? (reverse 'a))
+    (error? (reverse '(a b . c)))
+    (error? (reverse cyclic-list))
+    (error? (reverse (cdr cyclic-list)))
+    (error? (reverse `(a b . ,cyclic-list)))
+ )
+
+(mat reverse!
+    (let* ((x (list 'a 'b 'c 'd)) (y (reverse! x)))
+        (and (not (equal? x '(a b c d))) (equal? y '(d c b a))))
+    (let ([memq? (lambda (x ls) (and (memq x ls) #t))])
+      (let* ((p1 (list 'a 'b 'c)) (p2 (cdr p1)) (p3 (cdr p2)))
+          (let* ((r1 (reverse! p1)) (r2 (cdr r1)) (r3 (cdr r2)))
+              (let ((p-pairs (list p1 p2 p3)))
+                  (and (memq? r1 p-pairs) (memq? r2 p-pairs) (memq? r3 p-pairs))))))
+    (eq? (reverse! '()) '())
+    (let ((x '(a))) (eq? (reverse! x) x))
+    (error? (reverse!))
+    (error? (reverse! 'a))
+    (error? (reverse! (cons* 'a 'b 'c)))
+    (error? (reverse! (make-cyclic-list)))
+    (error? (reverse! (cdr (make-cyclic-list))))
+    (error? (reverse! (cons* 'a 'b (make-cyclic-list))))
+ )
+
+(mat memp
+  (not (memp (lambda (x) #t) '()))
+  (let ([x '(a b c)])
+    (and (equal? (memp (lambda (x) (eq? x 'a)) x) x)
+         (equal? (memp (lambda (x) (eq? x 'b)) x) (cdr x))
+         (equal? (memp (lambda (x) (eq? x 'c)) x) (cddr x))
+         (not (memp (lambda (x) (eq? x 'd)) x))))
+  (let ([x '(1 -2 3)])
+    (and (equal? (memp negative? x) (cdr x))
+         (equal? (memp positive? x) x)
+         (not (memp pair? x))))
+  (equal? (memp (lambda (x) (eq? x 'a)) (cdr cyclic-list)) cyclic-list)
+  (error? ; cyclic list
+    (memp (lambda (x) #f) cyclic-list))
+  (error? ; improper list
+    (memp (lambda (x) #f) '(a b . c)))
+  (error? ; not a procedure
+    (memp 'a '(a b c)))
+ )
+
+(mat find
+  (not (find (lambda (x) #t) '()))
+  (let ([x '(a b c)])
+    (and (equal? (find (lambda (x) (eq? x 'a)) x) 'a)
+         (equal? (find (lambda (x) (eq? x 'b)) x) 'b)
+         (equal? (find (lambda (x) (eq? x 'c)) x) 'c)
+         (not (find (lambda (x) (eq? x 'd)) x))))
+  (let ([x '(1 -2 3)])
+    (and (equal? (find negative? x) -2)
+         (equal? (find positive? x) 1)
+         (not (find pair? x))))
+  (equal? (find (lambda (x) (eq? x 'a)) (cdr cyclic-list)) 'a)
+  (error? ; cyclic list
+    (find (lambda (x) #f) cyclic-list))
+  (error? ; improper list
+    (find (lambda (x) #f) '(a b . c)))
+  (error? ; improper list
+    (find (lambda (x) #f) '(a b c . d)))
+  (error? ; not a procedure
+    (find 'a '(a b c)))
+ )
+
+(mat memq
+    (eq? (memq 'a '()) #f)
+    (let ((x '(a b c c b a)))
+        (and (eq? (memq 'a x) x)
+             (eq? (memq 'b x) (cdr x))
+             (eq? (memq 'c x) (cddr x))
+             (eq? (memq 'd x) #f)))
+    (let ((x '(1 1/2 .5 (a . b))))
+        (and (eq? (memq 1 x) x)
+             (eq? (memq 1/2 x) #f)
+             (eq? (memq .5 x) #f)
+             (eq? (memq (cons 'a 'b) x) #f)
+             (eq? (memq .7 x) #f)))
+    (let* ((x (list 'a)) (y (list '(a) x 'b x)))
+        (eq? (memq x y) (cdr y)))
+    (let ((x (list (string #\h #\i) (string #\i #\h))))
+        (and (eq? (memq "hi" x) #f) (eq? (memq "ih" x) #f)))
+    (let ((x (list (list 'a) (list 'b) (list 'c) (list 'a))))
+        (and (eq? (memq '(a) x) #f)
+             (eq? (memq '(b) x) #f)
+             (eq? (memq '(c) x) #f)
+             (eq? (memq '(d) x) #f)))
+    (eq? (memq 'a cyclic-list) cyclic-list)
+    (eq? (memq 'b cyclic-list) (cdr cyclic-list))
+    (let ([x `(c d . ,cyclic-list)])
+      (eq? (memq 'd x) (cdr x)))
+    (let ([x '(a b . c)])
+      (and (eq? (memq 'a x) x) (eq? (memq 'b x) (cdr x))))
+    (error? (memq))
+    (error? (memq 'c))
+    (error? (memq 'c 'a))
+    (error? (memq 'c cyclic-list))
+    (error? (memq 'c '(a b . c)))
+ )
+
+(mat memv
+    (eq? (memv 'a '()) #f)
+    (let ((x '(a b c c b a)))
+        (and (eq? (memv 'a x) x)
+             (eq? (memv 'b x) (cdr x))
+             (eq? (memv 'c x) (cddr x))
+             (eq? (memv 'd x) #f)))
+    (let ((x '(1 1/2 .5 12314122441)))
+        (and (eq? (memv 1 x) x)
+             (eq? (memv 1/2 x) (cdr x))
+             (eq? (memv .5 x) (cddr x))
+             (eq? (memv 12314122441 x) (cdddr x))
+             (eq? (memv .7 x) #f)))
+    (let* ((x (list 'a)) (y (list '(a) x 'b x)))
+        (eq? (memv x y) (cdr y)))
+    (let ((x (list (string #\h #\i) (string #\i #\h))))
+        (and (eq? (memv "hi" x) #f) (eq? (memv "ih" x) #f)))
+    (let ((x (list (list 'a) (list 'b) (list 'c) (list 'a))))
+        (and (eq? (memv '(a) x) #f)
+             (eq? (memv '(b) x) #f)
+             (eq? (memv '(c) x) #f)
+             (eq? (memv '(d) x) #f)))
+    (eq? (memv 'a cyclic-list) cyclic-list)
+    (eq? (memv 'b cyclic-list) (cdr cyclic-list))
+    (let ([x `(c d . ,cyclic-list)])
+      (eq? (memv 'd x) (cdr x)))
+    (let ([x '(a b . c)])
+      (and (eq? (memv 'a x) x) (eq? (member 'b x) (cdr x))))
+    (error? (memv))
+    (error? (memv 'c))
+    (error? (memv 'c 'a))
+    (error? (memv 'c cyclic-list))
+    (error? (memv 'c '(a b . c)))
+    (eq?
+      (memv 2 '#0=(1 2 3 . #0#))
+      (cdr '#0#))
+ )
+
+(mat member
+    (eq? (member 'a '()) #f)
+    (let ((x '(a b c c b a)))
+        (and (eq? (member 'a x) x)
+             (eq? (member 'b x) (cdr x))
+             (eq? (member 'c x) (cddr x))
+             (eq? (member 'd x) #f)))
+    (let ((x '(1 1/2 .5 12314122441)))
+        (and (eq? (member 1 x) x)
+             (eq? (member 1/2 x) (cdr x))
+             (eq? (member .5 x) (cddr x))
+             (eq? (member 12314122441 x) (cdddr x))
+             (eq? (member .7 x) #f)))
+    (let* ((x (list 'a)) (y (list '(a) x 'b x)))
+        (eq? (member x y) y))
+    (let ((x (list 'hi (string #\h #\i) (string #\i #\h))))
+        (and (eq? (member "hi" x) (cdr x))
+             (eq? (member "ih" x) (cddr x))))
+    (let ((x '("hi" "ih" "hi")))
+        (and (eq? (member "hi" x) x) (eq? (member "ih" x) (cdr x))))
+    (let ((x (list (list 'a) (list 'b) (list 'c) (list 'a))))
+        (and (eq? (member '(a) x) x)
+             (eq? (member '(b) x) (cdr x))
+             (eq? (member '(c) x) (cddr x))
+             (eq? (member '(d) x) #f)))
+    (eq? (member 'a cyclic-list) cyclic-list)
+    (eq? (member 'b cyclic-list) (cdr cyclic-list))
+    (let ([x `(c d . ,cyclic-list)])
+      (eq? (member 'd x) (cdr x)))
+    (let ([x '(a b . c)])
+      (and (eq? (member 'a x) x) (eq? (member 'b x) (cdr x))))
+    (error? (member))
+    (error? (member 'c))
+    (error? (member 'c 'a))
+    (error? (member 'c cyclic-list))
+    (error? (member 'c '(a b . c)))
+ )
+
+(mat partition
+  (equal?
+    (let-values ([x (partition negative? '())]) x)
+    '(() ()))
+  (let ((x (list -1 2 -3 -3 1 -5 2 6)))
+    (define-syntax valequal?
+      (syntax-rules ()
+        [(_ e v ...)
+         (let-values ([ls e]) (equal? ls (list v ...)))]))
+    (and (valequal? (partition pair? x) '() '(-1 2 -3 -3 1 -5 2 6))
+         (valequal? (partition negative? x) '(-1 -3 -3 -5) '(2 1 2 6))
+         (equal? x '(-1 2 -3 -3 1 -5 2 6))))
+  (error? ; improper list
+    (partition values cyclic-list))
+  (error? ; improper list
+    (partition values (cons 'x cyclic-list)))
+  (error? ; improper list
+    (partition values 'q))
+  (error? ; not a procedure
+    (partition 'q '()))
+  (eqv?
+    (let loop ([n 100])
+      (when (>= n 0)
+        (let ([ls (map (lambda (x) (random 20)) (make-list n))])
+          (let-values ([(odds evens) (partition odd? ls)])
+            (let-values ([(evens1 odds1) (partition even? ls)])
+              (unless (and (equal? odds1 odds) (equal? evens1 evens))
+                (printf "partition error 1: ~s\n" ls)
+                (errorf #f "partition test 1 failed")))
+            (let ([odds2 (filter odd? ls)] [evens2 (remp odd? ls)])
+              (unless (and (equal? odds2 odds) (equal? evens2 evens))
+                (printf "partition error 2: ~s\n" ls)
+                (errorf #f "partition test 2 failed")))
+            (let ([odds3 (remp even? ls)] [evens3 (filter even? ls)])
+              (unless (and (equal? odds3 odds) (equal? evens3 evens))
+                (printf "partition error 3: ~s\n" ls)
+                (errorf #f "partition test 3 failed")))
+            (let ([odds4 (fold-right (lambda (x ls) (if (odd? x) (cons x ls) ls)) '() ls)]
+                  [evens4 (fold-right (lambda (x ls) (if (odd? x) ls (cons x ls))) '() ls)])
+              (unless (and (equal? odds4 odds) (equal? evens4 evens))
+                (printf "partition error 4: ~s\n" ls)
+                (errorf #f "partition test 4 failed")))
+            (let ([odds5 (reverse (fold-left (lambda (ls x) (if (odd? x) (cons x ls) ls)) '() ls))]
+                  [evens5 (reverse (fold-left (lambda (ls x) (if (odd? x) ls (cons x ls))) '() ls))])
+              (unless (and (equal? odds5 odds) (equal? evens5 evens))
+                (printf "partition error 5: ~s\n" ls)
+                (errorf #f "partition test 5 failed")))))
+        (loop (- n 1))))
+    (void))
+)
+
+(mat filter
+  (equal?
+    (let ([x 3])
+      (let ([y (filter (begin (set! x 55) (lambda (x) #f)) '())])
+        (list x y)))
+    '(55 ()))
+  (equal?
+    (let ([x 3])
+      (let ([y (filter (begin (set! x (+ x 35)) (lambda (x) #f))
+                       (begin (set! x (+ x 7)) '()))])
+        (list x y)))
+    '(45 ()))
+  (eq? (filter negative? '()) '())
+  (let ((x (list -1 2 -3 -3 1 -5 2 6)))
+    (and (equal? (filter pair? x) '())
+         (equal? (filter negative? x) '(-1 -3 -3 -5))
+         (equal? x '(-1 2 -3 -3 1 -5 2 6))))
+  (error? ; improper list
+    (filter values cyclic-list))
+  (error? ; improper list
+    (filter values (cons 'x cyclic-list)))
+  (error? ; improper list
+    (filter values 'q))
+  (error? ; not a procedure
+    (filter 'q '()))
+)
+
+(mat remp
+  (eqv? (remp (lambda (x) #t) '()) '())
+  (equal?
+    (let ([x 3])
+      (let ([y (remp (begin (set! x 55) (lambda (x) #t)) '())])
+        (list x y)))
+    '(55 ()))
+  (equal?
+    (let ([x 3])
+      (let ([y (remp (begin (set! x (+ x 35)) (lambda (x) #t))
+                     (begin (set! x (+ x 7)) '()))])
+        (list x y)))
+    '(45 ()))
+  (let ([x (list 1 -2 3)])
+    (and (equal? (remp negative? x) '(1 3))
+         (equal? x '(1 -2 3))))
+  (let ([x (list 1 -2 3)])
+    (and (equal? (remp positive? x) '(-2))
+         (equal? x '(1 -2 3))))
+  (error? ; improper list
+    (remp values cyclic-list))
+  (error? ; improper list
+    (remp values (cons 'x cyclic-list)))
+  (error? ; improper list
+    (remp values 'q))
+  (error? ; not a procedure
+    (remp 'q '()))
+ )
+
+(mat remq
+    (eq? (remq 'a '()) '())
+    (eq? (remq 'a '(a)) '())
+    (equal? (remq 'a '(b c)) '(b c))
+    (let* ((x (string #\a #\b)) (l (list 'a x "ab" 'c x "ab")))
+        (equal? (remq x l) '(a "ab" c "ab")))
+    (let* ((x (list 3)) (l (list 'a 'b x 'c '(3) 'd x 'e x)))
+        (equal? (remq x l) '(a b c (3) d e)))
+    (error? (remq "c" cyclic-list))
+    (error? (let ((s "c")) (remq "c" (cons s cyclic-list))))
+    (error? (remq "c" 'a))
+ )
+
+(mat remq!
+    (eq? (remq! 'a '()) '())
+    (eq? (remq! 'a '(a)) '())
+    (equal? (remq! 'a '(b c)) '(b c))
+    (let* ((x (string #\a #\b)) (l (list 'a x "ab" 'c x "ab")))
+        (equal? (remq! x l) '(a "ab" c "ab")))
+    (let* ((x (list 3)) (l (list 'a 'b x 'c '(3) 'd x 'e x)))
+        (equal? (remq! x l) '(a b c (3) d e)))
+    (let* ((p1 (list 'a 'b 'c)) (p3 (cddr p1)))
+        (let* ((r1 (remq! 'b p1)) (r2 (cdr r1)))
+            (and (eq? p1 r1) (eq? r2 p3) (equal? p1 '(a c)))))
+    (error? (remq! "c" 'a))
+    (error? (remq! "c" (make-cyclic-list)))
+ )
+
+(mat remv
+    (eq? (remv 'a '()) '())
+    (eq? (remv 'a '(a)) '())
+    (equal? (remv 'a '(b c)) '(b c))
+    (let* ((x (string #\a #\b)) (l (list 'a x "ab" 'c x "ab")))
+        (equal? (remv x l) '(a "ab" c "ab")))
+    (let* ((x (list 3)) (l (list 'a 'b x 'c '(3) 'd x 'e x)))
+        (equal? (remv x l) '(a b c (3) d e)))
+    (error? (remv "c" cyclic-list))
+    (error? (let ((s "c")) (remv "c" (cons s cyclic-list))))
+    (error? (remv "c" 'a))
+ )
+
+(mat remv!
+    (eq? (remv! 'a '()) '())
+    (eq? (remv! 'a '(a)) '())
+    (equal? (remv! 'a '(b c)) '(b c))
+    (let* ((x (string #\a #\b)) (l (list 'a x "ab" 'c x "ab")))
+        (equal? (remv! x l) '(a "ab" c "ab")))
+    (let* ((x (list 3)) (l (list 'a 'b x 'c '(3) 'd x 'e x)))
+        (equal? (remv! x l) '(a b c (3) d e)))
+    (let* ((p1 (list 'a 'b 'c)) (p3 (cddr p1)))
+        (let* ((r1 (remv! 'b p1)) (r2 (cdr r1)))
+            (and (eq? r1 p1) (eq? r2 p3) (equal? p1 '(a c)))))
+    (error? (remv! "c" (make-cyclic-list)))
+    (error? (remv! "c" 'a))
+ )
+
+(mat remove
+    (eq? (remove 'a '()) '())
+    (eq? (remove 'a '(a)) '())
+    (equal? (remove 'a '(b c)) '(b c))
+    (let* ((x (string #\a #\b)) (l (list 'a x "ab" 'c x "ab")))
+        (equal? (remove x l) '(a c)))
+    (let* ((x (list 3)) (l (list 'a 'b x 'c '(3) 'd x 'e x)))
+        (equal? (remove x l) '(a b c d e)))
+    (error? (remove "c" cyclic-list))
+    (error? (let ((s "c")) (remove "c" (cons s cyclic-list))))
+    (error? (remove "c" 'a))
+ )
+
+(mat remove!
+    (eq? (remove! 'a '()) '())
+    (eq? (remove! 'a '(a)) '())
+    (equal? (remove! 'a '(b c)) '(b c))
+    (let* ((x (string #\a #\b)) (l (list 'a x "ab" 'c x "ab")))
+        (equal? (remove! x l) '(a c)))
+    (let* ((x (list 3)) (l (list 'a 'b x 'c '(3) 'd x 'e x)))
+        (equal? (remove! x l) '(a b c d e)))
+    (let* ((p1 (list 'a 'b 'c)) (p3 (cddr p1)))
+        (let* ((r1 (remove! 'b p1)) (r2 (cdr r1)))
+            (and (eq? r1 p1) (eq? r2 p3) (equal? p1 '(a c)))))
+    (error? (remove! "c" (make-cyclic-list)))
+ )
+
+(mat substq
+    (equal? (substq 1 'b '((b c) b a)) '((1 c) 1 a))
+    (equal? (substq 1 'd '((b c) b a)) '((b c) b a))
+    (equal? (substq 1/3 1/2 '((1/2 c) 1/2 a)) '((1/2 c) 1/2 a))
+    (let* ([x (cons 'a 'b)] [y (cons (cons 'a 'b) x)])
+       (equal? (substq 'boo x y) '((a . b) . boo)))
+    (let ((x '((b c) b a)))
+        (eq? x (substq 1 'd x)))
+ )
+
+(mat substq!
+    (equal? (substq! 1 'b '((b c) b a)) '((1 c) 1 a))
+    (equal? (substq! 1 'd '((b c) b a)) '((b c) b a))
+    (equal? (substq! 1/3 1/2 '((1/2 c) 1/2 a)) '((1/2 c) 1/2 a))
+    (let* ([x (cons 'a 'b)] [y (cons (cons 'a 'b) x)])
+       (equal? (substq! 'boo x y) '((a . b) . boo)))
+    (let ((x '((b c) b a)))
+        (eq? x (substq! 1 'd x)))
+    (let ((x '((b c) b a)))
+        (eq? x (substq! 1 'b x)))
+ )
+
+(mat substv
+    (equal? (substv 1 'b '((b c) b a)) '((1 c) 1 a))
+    (equal? (substv 1 'd '((b c) b a)) '((b c) b a))
+    (equal? (substv 1/3 1/2 '((1/2 c) 1/2 a)) '((1/3 c) 1/3 a))
+    (let* ([x (cons 'a 'b)] [y (cons (cons 'a 'b) x)])
+       (equal? (substv 'boo x y) '((a . b) . boo)))
+    (let ((x '((b c) b a)))
+       (eq? x (substv 1 'd x)))
+ )
+
+(mat substv!
+    (equal? (substv! 1 'b '((b c) b a)) '((1 c) 1 a))
+    (equal? (substv! 1 'd '((b c) b a)) '((b c) b a))
+    (equal? (substv! 1/3 1/2 '((1/2 c) 1/2 a)) '((1/3 c) 1/3 a))
+    (let* ([x (cons 'a 'b)] [y (cons (cons 'a 'b) x)])
+       (equal? (substv! 'boo x y) '((a . b) . boo)))
+    (let ((x '((b c) b a)))
+        (eq? x (substv! 1 'd x)))
+    (let ((x '((b c) b a)))
+        (eq? x (substv! 1 'b x)))
+ )
+
+(mat subst
+    (equal? (subst 1 'b '((b c) b a)) '((1 c) 1 a))
+    (equal? (subst 1 'd '((b c) b a)) '((b c) b a))
+    (equal? (subst 1/3 1/2 '((1/2 c) 1/2 a)) '((1/3 c) 1/3 a))
+    (let* ([x (cons 'a 'b)] [y (cons (cons 'a 'b) x)])
+       (equal? (subst 'boo x y) '(boo . boo)))
+    (let ((x '((b c) b a)))
+        (eq? x (subst 1 'd x)))
+ )
+
+(mat subst!
+    (equal? (subst! 1 'b '((b c) b a)) '((1 c) 1 a))
+    (equal? (subst! 1 'd '((b c) b a)) '((b c) b a))
+    (equal? (subst! 1/3 1/2 '((1/2 c) 1/2 a)) '((1/3 c) 1/3 a))
+    (let* ([x (cons 'a 'b)] [y (cons (cons 'a 'b) x)])
+       (equal? (subst! 'boo x y) '(boo . boo)))
+    (let ((x '((b c) b a)))
+        (eq? x (subst! 1 'd x)))
+    (let ((x '((b c) b a)))
+        (eq? x (subst! 1 'b x)))
+ )
+
+(mat assp
+  (not (assp (lambda (x) #t) '()))
+  (let ([a (list -1)] [b (list 2)] [c (list 3)])
+    (let ([l (list a b c)])
+      (and (equal? (assp negative? l) a)
+           (equal? (assp positive? l) b)
+           (equal? (assp (lambda (x) (= x 3)) l) c)
+           (not (assp pair? l)))))
+  (eq? (cdr (assp (lambda (x) (eq? x 'a)) cyclic-alist)) 1)
+  (eq? (cdr (assp (lambda (x) (eq? x 'a)) (cdr cyclic-alist))) 1)
+  (eq? (cdr (assp (lambda (x) (eqv? x 3.2)) cyclic-alist)) 3)
+  (eq? (cdr (assp (lambda (x) (equal? x "a")) cyclic-alist)) 4)
+  (error? ; cyclic alist
+    (assp (lambda (x) #f) cyclic-alist))
+  (error? ; improper alist
+    (assp (lambda (x) #f) '((a . 1) . c)))
+  (error? ; improper alist
+    (assp (lambda (x) #f) 17))
+  (error? ; not a procedure
+    (assp 'a '((a . 1) (b . 2))))
+ )
+
+(mat assq
+    (eq? (assq 'a '()) #f)
+    (let ((a (list 'a)) (b (list 'b)) (c (list 'c)))
+        (let ((l (list a b '(c) c b a)))
+            (and (eq? (assq 'a l) a)
+                 (eq? (assq 'b l) b)
+                 (not (eq? (assq 'c l) c))
+                 (eq? (assq 'd l) #f))))
+    (let* ((x (list 'a)) (l `(((a)) ((b)) (,x) ((c)))))
+        (eq? (assq x l) (caddr l)))
+    (eq? (cdr (assq 'a cyclic-alist)) 1)
+    (error? (assq 3.2 cyclic-alist))
+    (error? (assq "a" cyclic-alist))
+    (error? (assq 'c cyclic-alist))
+    (error? (assq "s" cyclic-alist))
+ )
+
+(mat assv
+    (eq? (assv 'a '()) #f)
+    (let ((a (list 'a)) (b (list 'b)) (c (list 'c)))
+        (let ((l (list a b '(c) c b a)))
+            (and (eq? (assv 'a l) a)
+                 (eq? (assv 'b l) b)
+                 (not (eq? (assv 'c l) c))
+                 (eq? (assv 'd l) #f))))
+    (let* ((x (list 'a)) (l `(((a)) ((b)) (,x) ((c)))))
+        (eq? (assv x l) (caddr l)))
+    (eq? (cdr (assv 'a cyclic-alist)) 1)
+    (eq? (cdr (assv 3.2 cyclic-alist)) 3)
+    (error? (assv "a" cyclic-alist))
+    (error? (assv 1/2 cyclic-alist))
+    (error? (assv "s" cyclic-alist))
+ )
+
+(mat assoc
+    (eq? (assoc 'a '()) #f)
+    (let ((a (list 'a)) (b (list 'b)) (c (list 'c)))
+        (let ((l (list a b '(c) c b a)))
+            (and (eq? (assoc 'a l) a)
+                 (eq? (assoc 'b l) b)
+                 (not (eq? (assoc 'c l) c))
+                 (eq? (assoc 'd l) #f))))
+    (let* ((x (list 'a)) (l `(((a)) ((b)) (,x) ((c)))))
+        (eq? (assoc x l) (car l)))
+    (eq? (cdr (assoc 'a cyclic-alist)) 1)
+    (eq? (cdr (assoc 3.2 cyclic-alist)) 3)
+    (eq? (cdr (assoc "a" cyclic-alist)) 4)
+    (error? (assoc 1/2 cyclic-alist))
+    (error? (assoc "s" cyclic-alist))
+ )
+
+(define $merge-sort
+  (lambda (lt? ls)
+    (define merge
+      (lambda (ls1 ls2)
+        (if (null? ls1)
+            ls2
+            (if (null? ls2)
+                ls1
+                (if (lt? (car ls1) (car ls2))
+                    (cons (car ls1) (merge (cdr ls1) ls2))
+                    (cons (car ls2) (merge ls1 (cdr ls2))))))))
+    (define sort
+      (lambda (ls n)
+        (if (fx<= n 1)
+            ls
+            (let ([mid (quotient n 2)])
+              (merge
+                (sort (list-head ls mid) mid)
+                (sort (list-tail ls mid) (fx- n mid)))))))
+    (sort ls (length ls))))
+
+(mat sort
+  (error? ; invalid number of arguments
+    (sort))
+  (error? ; invalid number of arguments
+    (sort >))
+  (error? ; invalid number of arguments
+    (sort '(a b c)))
+  (error? ; invalid number of arguments
+    (sort > '(1 2 3) #t))
+  (error? ; 3 is not a proper list
+    (sort > 3))
+  (error? ; #(1 2 3) is not a proper list
+    (sort > '#(1 2 3)))
+  (error? ; (1 2 . 3) is not a proper list
+    (sort > '(1 2 . 3)))
+  (error? ; cyclic list
+    (sort (lambda (x y) (stringstring x) (symbol->string y)))
+          cyclic-list))
+  (error? ; cyclic list
+    (sort (lambda (x y) (stringstring x) (symbol->string y)))
+          (cdr cyclic-list)))
+  (error? ; cyclic list
+    (sort (lambda (x y) (stringstring x) (symbol->string y)))
+          `(q p . ,cyclic-list)))
+  (error? ; (a b c) is not a procedure
+    (sort '(a b c) '(a b c)))
+  (error? ; b is not a real number
+    (sort > '(1 b 3)))
+  (equal? (sort > '()) '())
+  (let ([v (list 3 2 1)])
+    (and
+      (equal? (sort > v) '(3 2 1))
+      (equal? v '(3 2 1))))
+  (let ([v (list 1 2 3)])
+    (and
+      (equal? (sort > v) '(3 2 1))
+      (equal? v '(1 2 3))))
+  (let ([v (list 2 3 1)])
+    (and
+      (equal? (sort > v) '(3 2 1))
+      (equal? v '(2 3 1))))
+  (let ([v (list -2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5)])
+    (and
+      (equal?
+        (sort < v)
+        '(-43 -11 -7 -5 -2 0 3.0 3 5 8 8.0 9 9))
+      (equal? v '(-2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5))))
+  (let ([v (list 2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9)])
+    (and
+      (equal?
+        (sort (lambda (x y) (< (abs x) (abs y))) v)
+        '(1 -1 2 2 -3 3 4 5 -5 8 8 -8 9 -9 10))
+      (equal? v '(2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9))))
+  (let ([v (list 1 3 2 4)])
+    (and
+      (equal? (sort < v) '(1 2 3 4))
+      (equal? v '(1 3 2 4))))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (do ([n 1000 (fx- n 5)])
+            ((fx= n 0))
+          (write-char #\.)
+          (flush-output-port)
+          (do ([k 25 (fx- k 1)])
+              ((fx= k 0))
+            (let* ([ls (map (lambda (x) (random k)) (make-list n))]
+                   [copy (map values ls)])
+              (unless (and
+                        (equal? (sort < ls) ($merge-sort < copy))
+                        (equal? ls copy))
+                (fprintf (console-output-port) "\n~s\n" ls)
+                (errorf #f "failed")))))))
+    (make-string 200 #\.))
+)
+
+(mat list-sort
+  (error? ; invalid number of arguments
+    (list-sort))
+  (error? ; invalid number of arguments
+    (list-sort >))
+  (error? ; invalid number of arguments
+    (list-sort '(a b c)))
+  (error? ; invalid number of arguments
+    (list-sort > '(1 2 3) #t))
+  (error? ; 3 is not a proper list
+    (list-sort > 3))
+  (error? ; #(1 2 3) is not a proper list
+    (list-sort > '#(1 2 3)))
+  (error? ; (1 2 . 3) is not a proper list
+    (list-sort > '(1 2 . 3)))
+  (error? ; cyclic list
+    (list-sort (lambda (x y) (stringstring x) (symbol->string y)))
+          cyclic-list))
+  (error? ; cyclic list
+    (list-sort (lambda (x y) (stringstring x) (symbol->string y)))
+          (cdr cyclic-list)))
+  (error? ; cyclic list
+    (list-sort (lambda (x y) (stringstring x) (symbol->string y)))
+          `(q p . ,cyclic-list)))
+  (error? ; (a b c) is not a procedure
+    (list-sort '(a b c) '(a b c)))
+  (error? ; b is not a real number
+    (list-sort > '(1 b 3)))
+  (equal? (list-sort > '()) '())
+  (let ([v (list 3 2 1)])
+    (and
+      (equal? (list-sort > v) '(3 2 1))
+      (equal? v '(3 2 1))))
+  (let ([v (list 1 2 3)])
+    (and
+      (equal? (list-sort > v) '(3 2 1))
+      (equal? v '(1 2 3))))
+  (let ([v (list 2 3 1)])
+    (and
+      (equal? (list-sort > v) '(3 2 1))
+      (equal? v '(2 3 1))))
+  (let ([v (list -2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5)])
+    (and
+      (equal?
+        (list-sort < v)
+        '(-43 -11 -7 -5 -2 0 3.0 3 5 8 8.0 9 9))
+      (equal? v '(-2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5))))
+  (let ([v (list 2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9)])
+    (and
+      (equal?
+        (list-sort (lambda (x y) (< (abs x) (abs y))) v)
+        '(1 -1 2 2 -3 3 4 5 -5 8 8 -8 9 -9 10))
+      (equal? v '(2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9))))
+  (let ([v (list 1 3 2 4)])
+    (and
+      (equal? (list-sort < v) '(1 2 3 4))
+      (equal? v '(1 3 2 4))))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (do ([n 1000 (fx- n 5)])
+            ((fx= n 0))
+          (write-char #\.)
+          (flush-output-port)
+          (do ([k 25 (fx- k 1)])
+              ((fx= k 0))
+            (let* ([ls (map (lambda (x) (random k)) (make-list n))]
+                   [copy (map values ls)])
+              (unless (and
+                        (equal? (list-sort < ls) ($merge-sort < copy))
+                        (equal? ls copy))
+                (fprintf (console-output-port) "\n~s\n" ls)
+                (errorf #f "failed")))))))
+    (make-string 200 #\.))
+)
+
+(mat sort!
+  (error? ; invalid number of arguments
+    (sort!))
+  (error? ; invalid number of arguments
+    (sort! >))
+  (error? ; invalid number of arguments
+    (sort! '(a b c)))
+  (error? ; invalid number of arguments
+    (sort! > '(1 2 3) #t))
+  (error? ; 3 is not a proper list
+    (sort! > 3))
+  (error? ; #(1 2 3) is not a proper list
+    (sort! > '#(1 2 3)))
+  (error? ; (1 2 . 3) is not a proper list
+    (sort! > (cons* 1 2 3)))
+  (error? ; cyclic list
+    (sort! (lambda (x y) (stringstring x) (symbol->string y)))
+           (make-cyclic-list)))
+  (error? ; cyclic list
+    (sort! (lambda (x y) (stringstring x) (symbol->string y)))
+           (cdr (make-cyclic-list))))
+  (error? ; cyclic list
+    (sort! (lambda (x y) (stringstring x) (symbol->string y)))
+           `(q p . ,(make-cyclic-list))))
+  (error? ; (a b c) is not a procedure
+    (sort! '(a b c) '(a b c)))
+  (error? ; b is not a real number
+    (sort! > '(1 b 3)))
+  (equal? (sort! > '()) '())
+  (let ([v (list 3 2 1)])
+    (equal? (sort! > v) '(3 2 1)))
+  (let ([v (list 1 2 3)])
+    (equal? (sort! > v) '(3 2 1)))
+  (let ([v (list 2 3 1)])
+    (equal? (sort! > v) '(3 2 1)))
+  (let ([v (list -2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5)])
+    (equal?
+      (sort! < v)
+      '(-43 -11 -7 -5 -2 0 3.0 3 5 8 8.0 9 9)))
+  (let ([v (list 2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9)])
+    (equal?
+      (sort! (lambda (x y) (< (abs x) (abs y))) v)
+      '(1 -1 2 2 -3 3 4 5 -5 8 8 -8 9 -9 10)))
+  (let ([v (list 1 3 2 4)])
+    (equal? (sort! < v) '(1 2 3 4)))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (do ([n 1000 (fx- n 5)])
+            ((fx= n 0))
+          (write-char #\.)
+          (flush-output-port)
+          (do ([k 25 (fx- k 1)])
+              ((fx= k 0))
+            (let* ([ls (map (lambda (x) (random k)) (make-list n))]
+                   [copy (map values ls)])
+              (unless (equal? (sort! < ls) ($merge-sort < copy))
+                (fprintf (console-output-port) "\n~s\n" copy)
+                (errorf #f "failed")))))))
+    (make-string 200 #\.))
+)
+
+(mat merge
+   (equal? (merge < '() '()) '())
+   (equal? (merge < '(1) '()) '(1))
+   (equal? (merge < '() '(2)) '(2))
+   (equal? (merge < '(1) '(2)) '(1 2))
+   (equal? (merge < '(2) '(1)) '(1 2))
+   (equal? (merge < '(1 3 5 7 9) '(2 4 6 8 10)) '(1 2 3 4 5 6 7 8 9 10))
+   (equal? (merge < '(1 2 5 7 8) '(3 4 6 9 10)) '(1 2 3 4 5 6 7 8 9 10))
+   (equal?
+       (merge (lambda (x y) (< (abs x) (abs y)))
+           '(-1 1 4 -4)
+           '(1 -3 3 8 9 -9))
+       '(-1 1 1 -3 3 4 -4 8 9 -9))
+   (let ((l1 (list 1 3 5 7 9)) (l2 (list 2 4 6 8 10)))
+       (and (equal? (merge < l1 l2) '(1 2 3 4 5 6 7 8 9 10))
+           (equal? l1 '(1 3 5 7 9))
+           (equal? l2 '(2 4 6 8 10))))
+  (error? ; (1 2 . 3) is not a proper list
+    (merge > '(5 -1 2) '(1 2 . 3)))
+  (error? ; (1 2 . 3) is not a proper list
+    (merge > '(1 2 . 3) '(5 -1 2)))
+  (error? ; cyclic list
+    (merge (lambda (x y) (stringstring x) (symbol->string y)))
+           '(p b q) cyclic-list))
+  (error? ; cyclic list
+    (merge (lambda (x y) (stringstring x) (symbol->string y)))
+           cyclic-list '(p b q)))
+  (error? ; cyclic list
+    (merge (lambda (x y) (stringstring x) (symbol->string y)))
+           '(p b c) (cdr cyclic-list)))
+  (error? ; cyclic list
+    (merge (lambda (x y) (stringstring x) (symbol->string y)))
+           (cdr cyclic-list) '(p b c)))
+  (error? ; cyclic list
+    (merge (lambda (x y) (stringstring x) (symbol->string y)))
+           '(p b c) `(q p . ,cyclic-list)))
+  (error? ; cyclic list
+    (merge (lambda (x y) (stringstring x) (symbol->string y)))
+           `(q p . ,cyclic-list) '(p b c)))
+ )
+
+(mat merge!
+   (equal? (merge! < '() '()) '())
+   (equal? (merge! < '(1) '()) '(1))
+   (equal? (merge! < '() '(2)) '(2))
+   (equal? (merge! < '(1) '(2)) '(1 2))
+   (equal? (merge! < '(2) '(1)) '(1 2))
+   (equal? (merge! < '(1 3 5 7 9) '(2 4 6 8 10)) '(1 2 3 4 5 6 7 8 9 10))
+   (equal? (merge! < '(1 2 5 7 8) '(3 4 6 9 10)) '(1 2 3 4 5 6 7 8 9 10))
+   (equal?
+       (merge! (lambda (x y) (< (abs x) (abs y)))
+           '(-1 1 4 -4)
+           '(1 -3 3 8 9 -9))
+       '(-1 1 1 -3 3 4 -4 8 9 -9))
+  (error? ; (1 2 . 3) is not a proper list
+    (merge! > (list 5 -1 2) (cons* 1 2 3)))
+  (error? ; (1 2 . 3) is not a proper list
+    (merge! > (cons* 1 2 3) (list 5 -1 2)))
+  (error? ; cyclic list
+    (merge! (lambda (x y) (stringstring x) (symbol->string y)))
+           (list 'p 'b 'q) (make-cyclic-list)))
+  (error? ; cyclic list
+    (merge! (lambda (x y) (stringstring x) (symbol->string y)))
+           (make-cyclic-list) (list 'p 'b 'q)))
+  (error? ; cyclic list
+    (merge! (lambda (x y) (stringstring x) (symbol->string y)))
+           (list 'p 'b 'q) (cdr (make-cyclic-list))))
+  (error? ; cyclic list
+    (merge! (lambda (x y) (stringstring x) (symbol->string y)))
+           (cdr (make-cyclic-list)) (list 'p 'b 'q)))
+  (error? ; cyclic list
+    (merge! (lambda (x y) (stringstring x) (symbol->string y)))
+           (list 'p 'b 'q) (cons* 'q 'p (make-cyclic-list))))
+  (error? ; cyclic list
+    (merge! (lambda (x y) (stringstring x) (symbol->string y)))
+           (cons* 'q 'p (make-cyclic-list)) (list 'p 'b 'q)))
+ )
+
+(mat iota
+  (error? ; not a nonnegative fixnum
+    (iota 'a))
+  (error? ; not a nonnegative fixnum
+    (iota -1))
+  (error? ; not a nonnegative fixnum
+    (iota #e1e30))
+  (error? ; not a nonnegative fixnum
+    (iota 3/4))
+  (error? ; wrong number of arguments
+    (iota))
+  (error? ; wrong number of arguments
+    (iota 3 17))
+  (equal? (iota 7) '(0 1 2 3 4 5 6))
+  (equal? (iota 6) '(0 1 2 3 4 5))
+  (equal? (iota 0) '())
+  (equal? (iota 1) '(0))
+  (equal? (iota 2) '(0 1))
+  (equal? (iota 3) '(0 1 2))
+  (equal? (iota 4) '(0 1 2 3))
+  (let ([ls (iota 100)])
+    (and
+      (= (length ls) 100)
+      (equal? ls (sort < ls))
+      (eqv? (car ls) 0)
+      (eqv? (apply + ls) 4950)))
+)
+
+(mat enumerate
+  (error? ; not a proper list
+    (enumerate 'a))
+  (error? ; not a proper list
+    (enumerate '(a . b)))
+  (error? ; not a proper list
+    (enumerate (let ([ls (list 'a 'b 'c)]) (set-cdr! (cdr ls) ls) ls)))
+  (error? ; wrong number of arguments
+    (enumerate))
+  (error? ; wrong number of arguments
+    (enumerate '(a b c) '(d e f)))
+  (equal? (enumerate '(a b c d e f g)) '(0 1 2 3 4 5 6))
+  (equal? (enumerate '(a b c d e f)) '(0 1 2 3 4 5))
+  (equal? (enumerate '()) '())
+  (equal? (enumerate '(1)) '(0))
+  (equal? (enumerate '(3 2)) '(0 1))
+  (equal? (enumerate '(5 4 3)) '(0 1 2))
+  (equal? (enumerate '(q p (d o l) l)) '(0 1 2 3))
+  (let ([ls (enumerate (make-list 100))])
+    (and
+      (= (length ls) 100)
+      (equal? ls (sort < ls))
+      (eqv? (car ls) 0)
+      (eqv? (apply + ls) 4950)))
+)
diff --git a/mats/5_3.ms b/mats/5_3.ms
new file mode 100644
index 0000000..4805bb4
--- /dev/null
+++ b/mats/5_3.ms
@@ -0,0 +1,7074 @@
+;;; 5_3.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define interesting-numbers
+  (list 0 0.0 1 1.0 -1 -1.0 9007199254740992 9007199254740992.0 9007199254740993.0 9007199254740993 9007199254740992000 9007199254740992000.0 9007199254740993000.0 9007199254740993000 4.5035996273704996e-13 4.5035996273704994e-13 45035996273704996/100000000000000000000000000000 45035996273704994/100000000000000000000000000000))
+(define-syntax test-transitive
+  (syntax-rules ()
+    [(_ ?op ?x ?y ?z)
+     (let ([x ?x][y ?y][z ?z])
+       (let ([xy (?op x y)]
+             [yz (?op y z)])
+         (if (and xy yz)
+             (and (?op x z)
+                  (?op x y z))
+             #t)))]))
+(define (test-transitive-permutations op)
+  (andmap (lambda (x)
+            (andmap (lambda (y)
+                      (andmap (lambda (z)
+                                (test-transitive op x y z))
+                        interesting-numbers))
+              interesting-numbers))
+    interesting-numbers))
+
+(mat number-syntax
+   (eqv? 0 (- (most-positive-fixnum) (most-positive-fixnum)))
+   (eqv? 3 (1+ (1+ (1+ 0))))
+   (eqv? 9 (* 3 3))
+   (eqv? 27 (* 3 9))
+   (eqv? +99 99)
+   (eqv? -99 (- 99))
+   (eqv? -19683 (expt -27 3))
+   (eqv? #e32 32)
+   (eqv? #E-32 -32)
+   (eqv? #12r-3b -47)
+   (eqv? #12R3b 47)
+   (eqv? #i+32 (inexact 32))
+   (eqv? #I32 (inexact 32))
+   (eqv? #b+101 5)
+   (eqv? #B-101 -5)
+   (eqv? #o-75 -61)
+   (eqv? #O75 61)
+   (eqv? #d91 91)
+   (eqv? #D-91 -91)
+   (eqv? #x-7f -127)
+   (eqv? #X+7f 127)
+   (eqv? #e#x-1e -30)
+   (eqv? #i321 (inexact 321))
+   (eqv? #i#b011 (inexact 3))
+   (eqv? #e#o-76 -62)
+   (eqv? #e#D+29 29)
+   (eqv? #e#x-abcd -43981)
+   (eqv? #i#32r+21 (inexact 65))
+   (eqv? #i#32R-21 (inexact -65))
+   (eqv? #20r#e10 20)
+   (eqv? #x#iabc (inexact 2748))
+   (eqv? .321
+         (inexact (/ 321 1000)))
+   (eqv? -20/317
+         (/ 20 -317))
+   (symbol? 'a)
+   (symbol? '+)
+   (eqv? +.91 .91)
+   (eqv? -.257 (- .257))
+   (symbol? '-a)
+   (eqv? 98.21
+         (* .9821 100))
+   (eqv? 98## 9800.0)
+   (eqv? #e98## 9800)
+   (eqv? 27e10 270000000000.0)
+   (fl~= -1e-9 (- (/ 1e9)))
+   (fl~= -1e-30 (- (/ 1e30)))
+   (eqv? #e27e10 270000000000)
+   (symbol? '1+)
+   (eqv? 23. (inexact 23))
+   (eqv? #e23. 23)
+   (eqv? 2.e3 2000.)
+   (eqv? 2s3 2000.)
+   (eqv? 2.0f3 2000.)
+   (eqv? 2.###d3 2000.)
+   (eqv? 2#.#l2 2000.)
+   (eqv? 2/1E3 2000.)
+   (eqv? 1/5S4 2000.)
+   (eqv? -1/5F4 -2000.)
+   (eqv? .2D4 2000.)
+   (eqv? 1##/5##L4 2000.)
+   (symbol? '2.a)
+   (eqv? 21#/2## (inexact 21/20))
+   (symbol? '21##.321)
+   (eqv? 21##e-2 21.)
+   (symbol? '98##9)
+   (symbol? '32/)
+   (symbol? '32/#)
+   (eqv? #i32/7 (inexact 32/7))
+   (symbol? '32/23#0)
+   (symbol? '...)
+   (eqv? #e.231 231/1000)
+   (eqv? #e.231## 231/1000)
+   (eqv? #e21##.#### 2100)
+   (symbol? '.231.)
+   (eqv? 2.3#E-2 .023)
+   (symbol? '-2.3e)
+   (eqv? #I#10r-32############.#e-12
+         -32.0)
+   (symbol? '-2/3ex)
+   (symbol? '2.1e-)
+   (symbol? '2e-1.0i)
+   (eqv? #e2/3e4 20000/3)
+   (symbol? '2.0e10a)
+   (eqv? +1.0i (make-rectangular 0 1.0))
+   (eqv? -1.0i (make-rectangular 0.0 -1))
+   (eqv? +1i (make-rectangular 0 1))
+   (eqv? -1i (make-rectangular 0 -1))
+   (symbol? 'i)
+   (eqv? -221.0i (make-rectangular 0.0 -221))
+   (eqv? +201.0i (make-rectangular 0.0 201))
+   (symbol? '201i)
+   (eqv? 3.0+1.0i (make-rectangular 3 1.0))
+   (eqv? -3-1.0i (make-rectangular -3.0 -1))
+   (eqv? 3.2-2/3i (make-rectangular 3.2 (inexact -2/3)))
+   (eqv? 1/2@1/3 (make-polar 1/2 1/3))
+   (eqv? 3+1i (make-rectangular 3 1))
+   (eqv? -3-1i (make-rectangular -3 -1))
+   (eqv? 3/2-2/3i (make-rectangular 3/2 -2/3))
+   (symbol? '2@3@4)
+   (symbol? '2@3+4i)
+; check for float read bug introduced into 3.0:
+   (< -.039 -.038413 -.038)
+ )
+
+(mat string->number
+  ; error cases
+   (error? (string->number 'a))
+   (error? (string->number "a" 0))
+   (error? (string->number "a" 37))
+   (error? (string->number "a" 'a))
+   (error? (string->number "a" 10 10))
+  ; one argument case
+   (not (string->number ""))
+   (eqv? (string->number "0") (- (most-positive-fixnum) (most-positive-fixnum)))
+   (eqv? (string->number "3") (1+ (1+ (1+ (string->number "0")))))
+   (eqv? (string->number "9") (* (string->number "3") (string->number "3")))
+   (eqv? (string->number "27") (* (string->number "3") (string->number "9")))
+   (eqv? (string->number "+99") (string->number "99"))
+   (eqv? (string->number "-99") (- (string->number "99")))
+   (eqv? (string->number "-19683") (expt (string->number "-27") 3))
+   (eqv? (string->number "#e32") (string->number "32"))
+   (eqv? (string->number "#E-32") (string->number "-32"))
+   (not (string->number "#"))
+   (eqv? (string->number "#12r-3b") (string->number "-47"))
+   (eqv? (string->number "#12R3b") (string->number "47"))
+   (eqv? (string->number "#i+32") (inexact (string->number "32")))
+   (eqv? (string->number "#I32") (inexact (string->number "32")))
+   (eqv? (string->number "#b+101") (string->number "5"))
+   (eqv? (string->number "#B-101") (string->number "-5"))
+   (eqv? (string->number "#o-75") (string->number "-61"))
+   (eqv? (string->number "#O75") (string->number "61"))
+   (eqv? (string->number "#d91") (string->number "91"))
+   (eqv? (string->number "#D-91") (string->number "-91"))
+   (eqv? (string->number "#x-7f") (string->number "-127"))
+   (eqv? (string->number "#X+7f") (string->number "127"))
+   (not (string->number "#a"))
+   (not (string->number "#32"))
+   (not (string->number "#32="))
+   (not (string->number "#47r0"))
+   (not (string->number "#110r0"))
+   (not (string->number "#e"))
+   (eqv? (string->number "#e#x-1e") (string->number "-30"))
+   (eqv? (string->number "#i321") (inexact (string->number "321")))
+   (not (string->number "#e#"))
+   (eqv? (string->number "#i#b011") (inexact (string->number "3")))
+   (eqv? (string->number "#e#o-76") (string->number "-62"))
+   (eqv? (string->number "#e#D+29") (string->number "29"))
+   (eqv? (string->number "#e#x-abcd") (string->number "-43981"))
+   (not (string->number "#e#*"))
+   (not (string->number "#i#32"))
+   (eqv? (string->number "#i#32r+21") (inexact (string->number "65")))
+   (eqv? (string->number "#i#32R-21") (inexact (string->number "-65")))
+   (not (string->number "#i#321r"))
+   (not (string->number "#e#39r"))
+   (not (string->number "#20r"))
+   (eqv? (string->number "#20r#e10") (string->number "20"))
+   (not (string->number "#20r#"))
+   (eqv? (string->number "#x#iabc") (inexact (string->number "2748")))
+   (not (string->number "#x##"))
+   (not (string->number "#e#x"))
+   (eqv? (string->number ".321")
+         (inexact (/ (string->number "321") (string->number "1000"))))
+   (eqv? (string->number "-20/317")
+         (/ (string->number "20") (string->number "-317")))
+   (not (string->number "a"))
+   (not (string->number "+"))
+   (eqv? (string->number "+.91") (string->number ".91"))
+   (eqv? (string->number "-.257") (- (string->number ".257")))
+   (not (string->number "-a"))
+   (eqv? (string->number "98.21")
+         (* (string->number ".9821") (string->number "100")))
+   (eqv? (string->number "98##") (string->number "9800.0"))
+   (eqv? (string->number "#e98##") (string->number "9800"))
+   (eqv? (string->number "27e10") (string->number "270000000000.0"))
+   (eqv? (string->number "#e27e10") (string->number "270000000000"))
+   (not (string->number "1+"))
+   (eqv? (string->number "23.") (inexact (string->number "23")))
+   (eqv? (string->number "#e23.") (string->number "23"))
+   (eqv? (string->number "2.e3") (string->number "2000."))
+   (eqv? (string->number "2s3") (string->number "2000."))
+   (eqv? (string->number "2.0f3") (string->number "2000."))
+   (eqv? (string->number "2.###d3") (string->number "2000."))
+   (eqv? (string->number "2#.#l2") (string->number "2000."))
+   (eqv? (string->number "2/1E3") (string->number "2000."))
+   (eqv? (string->number "1/5S4") (string->number "2000."))
+   (eqv? (string->number "-1/5F4") (string->number "-2000."))
+   (eqv? (string->number ".2D4") (string->number "2000."))
+   (eqv? (string->number "1##/5##L4") (string->number "2000."))
+   (not (string->number "2.a"))
+   (eqv? (string->number "21#/2##") (inexact (string->number "21/20")))
+   (not (string->number "21##.321"))
+   (eqv? (string->number "21##e-2") (string->number "21."))
+   (not (string->number "98##9"))
+   (not (string->number "32/"))
+   (not (string->number "32/#"))
+   (eqv? (string->number "#i32/7") (inexact (string->number "32/7")))
+   (not (string->number "32/23#0"))
+   (not (string->number "."))
+   (not (string->number "..."))
+   (eqv? (string->number "#e.231") (string->number "231/1000"))
+   (eqv? (string->number "#e.231##") (string->number "231/1000"))
+   (eqv? (string->number "#e21##.####") (string->number "2100"))
+   (not (string->number ".231."))
+   (eqv? (string->number "2.3#E-2") (string->number ".023"))
+   (not (string->number "-2.3e"))
+   (eqv? (string->number "#I#10r-32############.#e-12")
+         (string->number "-32.0"))
+   (not (string->number "-2/3ex"))
+   (not (string->number "2.1e-"))
+   (not (string->number "2e-i"))
+   (eqv? (string->number "#e2/3e4") (string->number "20000/3"))
+   (not (string->number "2.0e10a"))
+  ; complex cases
+   (equal? (string->number "+i") +i)
+   (equal? (string->number "-i") -i)
+   (not (string->number "i"))
+   (equal? (string->number "-221i") -221i)
+   (equal? (string->number "+201i") +201i)
+   (not (string->number "201i"))
+   (equal? (string->number "3+i") 3+i)
+   (equal? (string->number "-3+i") -3+i)
+   (equal? (string->number "3.2-2/3i") 3.2-2/3i)
+   (equal? (string->number "1/2@1/2") 1/2@1/2)
+   (not (string->number "2@3@4"))
+   (not (string->number "2@3+4i"))
+  ; two argument case
+   (eqv? (string->number "+101" 2) (string->number "5"))
+   (eqv? (string->number "#B-101" 7) (string->number "-5"))
+   (eqv? (string->number "-75" 8) (string->number "-61"))
+   (eqv? (string->number "#O75" 10) (string->number "61"))
+   (eqv? (string->number "91" 10) (string->number "91"))
+   (eqv? (string->number "#D-91" 16) (string->number "-91"))
+   (eqv? (string->number "-7f" 16) (string->number "-127"))
+   (eqv? (string->number "#X+7f" 35) (string->number "127"))
+   (eqv? (string->number "22" 35) (string->number "72"))
+   (eqv? (string->number "#35r22" 17) (string->number "72"))
+
+  ; getting division by zero right
+   (eqv? (string->number "0/0") #f)
+   (== (string->number "0/0#") +nan.0)
+   (eqv? (string->number "0#/0") #f)
+   (== (string->number "0/0e20") +nan.0)
+   (== (string->number "0/0#e20") +nan.0)
+   (== (string->number "0#/0#") +nan.0)
+   (== (string->number "#i0/0") +nan.0)
+   (== (string->number "#i0/0#") +nan.0)
+   (== (string->number "#i0#/0") +nan.0)
+   (== (string->number "#i0#/0#") +nan.0)
+   (== (string->number "#i0/0e20") +nan.0)
+   (== (string->number "#i0/0#e20") +nan.0)
+   (eqv? (string->number "#e0/0") #f)
+   (eqv? (string->number "#e0/0#") #f)
+   (eqv? (string->number "#e0#/0") #f)
+   (eqv? (string->number "#e0#/0#") #f)
+   (eqv? (string->number "#e0/0e20") #f)
+   (eqv? (string->number "#e0/0#e20") #f)
+   (eqv? (string->number "1/0") #f)
+   (eqv? (string->number "1/0#") +inf.0)
+   (eqv? (string->number "1#/0") #f)
+   (eqv? (string->number "1#/0#") +inf.0)
+   (eqv? (string->number "#i1/0") +inf.0)
+   (eqv? (string->number "#i1/0#") +inf.0)
+   (eqv? (string->number "#i1#/0") +inf.0)
+   (eqv? (string->number "#i1#/0#") +inf.0)
+   (eqv? (string->number "#e1/0") #f)
+   (eqv? (string->number "#e1/0#") #f)
+   (eqv? (string->number "#e1#/0") #f)
+   (eqv? (string->number "#e1#/0#") #f)
+   (eqv? (string->number "1/0+1.0i") #f)
+   (eqv? (string->number "1.0+1/0i") #f)
+   (== (string->number "1/0###+0/0###i") +inf.0+nan.0i)
+   (== (string->number "0/0###+1/0###i") +nan.0+inf.0i)
+   (== (string->number "0###/0###+1/0###i") +nan.0+inf.0i)
+   (eqv? (string->number "#e1e1000") (expt 10 1000))
+   (eqv? (string->number "#e1#e1000") (expt 10 1001))
+
+  ; same set, with minus signs
+   (eqv? (string->number "-0/0") #f)
+   (== (string->number "-0/0#") +nan.0)
+   (eqv? (string->number "-0#/0") #f)
+   (== (string->number "-0#/0#") +nan.0)
+   (== (string->number "#i-0/0") +nan.0)
+   (== (string->number "#i-0/0#") +nan.0)
+   (== (string->number "#i-0#/0") +nan.0)
+   (== (string->number "#i-0#/0#") +nan.0)
+   (eqv? (string->number "#e-0/0") #f)
+   (eqv? (string->number "#e-0/0#") #f)
+   (eqv? (string->number "#e-0#/0") #f)
+   (eqv? (string->number "#e-0#/0#") #f)
+   (eqv? (string->number "-1/0") #f)
+   (eqv? (string->number "-1/0#") -inf.0)
+   (eqv? (string->number "-1#/0") #f)
+   (eqv? (string->number "-1#/0#") -inf.0)
+   (eqv? (string->number "#i-1/0") -inf.0)
+   (eqv? (string->number "#i-1/0#") -inf.0)
+   (eqv? (string->number "#i-1#/0") -inf.0)
+   (eqv? (string->number "#i-1#/0#") -inf.0)
+   (eqv? (string->number "#e-1/0") #f)
+   (eqv? (string->number "#e-1/0#") #f)
+   (eqv? (string->number "#e-1#/0") #f)
+   (eqv? (string->number "#e-1#/0#") #f)
+   (eqv? (string->number "-1/0+1.0i") #f)
+   (eqv? (string->number "1.0-1/0i") #f)
+   (== (string->number "-1/0###-0/0###i") -inf.0+nan.0i)
+   (== (string->number "-0/0###-1/0###i") +nan.0-inf.0i)
+   (== (string->number "-0###/0###-1/0###i") +nan.0-inf.0i)
+   (eqv? (string->number "#e-1e1000") (- (expt 10 1000)))
+   (eqv? (string->number "#e-1#e1000") (- (expt 10 1001)))
+
+  ; same set, with plus signs
+   (eqv? (string->number "+0/0") #f)
+   (== (string->number "+0/0#") +nan.0)
+   (eqv? (string->number "+0#/0") #f)
+   (== (string->number "+0#/0#") +nan.0)
+   (== (string->number "#i+0/0") +nan.0)
+   (== (string->number "#i+0/0#") +nan.0)
+   (== (string->number "#i+0#/0") +nan.0)
+   (== (string->number "#i+0#/0#") +nan.0)
+   (eqv? (string->number "#e+0/0") #f)
+   (eqv? (string->number "#e+0/0#") #f)
+   (eqv? (string->number "#e+0#/0") #f)
+   (eqv? (string->number "#e+0#/0#") #f)
+   (eqv? (string->number "+1/0") #f)
+   (eqv? (string->number "+1/0#") +inf.0)
+   (eqv? (string->number "+1#/0") #f)
+   (eqv? (string->number "+1#/0#") +inf.0)
+   (eqv? (string->number "#i+1/0") +inf.0)
+   (eqv? (string->number "#i+1/0#") +inf.0)
+   (eqv? (string->number "#i+1#/0") +inf.0)
+   (eqv? (string->number "#i+1#/0#") +inf.0)
+   (eqv? (string->number "#e+1/0") #f)
+   (eqv? (string->number "#e+1/0#") #f)
+   (eqv? (string->number "#e+1#/0") #f)
+   (eqv? (string->number "#e+1#/0#") #f)
+   (eqv? (string->number "+1/0+1.0i") #f)
+   (eqv? (string->number "1.0+1/0i") #f)
+   (== (string->number "+1/0###+0/0###i") +inf.0+nan.0i)
+   (== (string->number "+0/0###+1/0###i") +nan.0+inf.0i)
+   (== (string->number "+0###/0###+1/0###i") +nan.0+inf.0i)
+   (eqv? (string->number "#e+1e1000") (expt 10 1000))
+   (eqv? (string->number "#e+1#e1000") (expt 10 1001))
+
+  ; misc. similar tests
+   (eqv? (string->number "1/0000") #f)
+   (eqv? (string->number "-1/0000") #f)
+   (eqv? (string->number "#e-1/0000") #f)
+   (eqv? (string->number "#i-1/0000") -inf.0)
+   (eqv? (string->number "#e1/0###") #f)
+   (eqv? (string->number "#e-1/0###") #f)
+   (eqv? (string->number "1/0###") +inf.0)
+   (eqv? (string->number "-1/0###") -inf.0)
+
+   (eqv? (string->number "1###/0") #f)
+   (eqv? (string->number "-1###/0") #f)
+   (eqv? (string->number "-1###/0###") -inf.0)
+
+   (eqv? (string->number "0/0000") #f)
+   (eqv? (string->number "-0/0000") #f)
+   (eqv? (string->number "#e-0/0000") #f)
+   (== (string->number "#i-0/0000") +nan.0)
+   (eqv? (string->number "#e0/0###") #f)
+   (eqv? (string->number "#e-0/0###") #f)
+   (== (string->number "0/0###") +nan.0)
+   (== (string->number "-0/0###") +nan.0)
+
+   (== (string->number "0/0e10") +nan.0)
+   (== (string->number "#i0/0e10") +nan.0)
+   (== (string->number "0/0###e10") +nan.0)
+   (eqv? (string->number "1/0e10") +inf.0)
+   (eqv? (string->number "#i1/0e10") +inf.0)
+   (eqv? (string->number "1/0###e10") +inf.0)
+   (eqv? (string->number "-1/0e10") -inf.0)
+   (eqv? (string->number "#i-1/0e10") -inf.0)
+   (eqv? (string->number "-1/0###e10") -inf.0)
+
+   (eqv? (string->number "-1/2e10000") -inf.0)
+   (eqv? (string->number "1/2e10000") +inf.0)
+   (eqv? (string->number "#e-1/2e10000") (* -1/2 (expt 10 10000)))
+   (eqv? (string->number "#e1/2e10000") (* 1/2 (expt 10 10000)))
+
+   (eqv? (string->number "0e25") 0.0)
+   (eqv? (string->number "-0e25") -0.0)
+   (eqv? (string->number "0/1e25") 0.0)
+   (eqv? (string->number "-0/1e25") -0.0)
+
+  ; can't have no exact nans and infinities
+   (eqv? (string->number "#e+nan.0") #f)
+   (eqv? (string->number "#e+inf.0") #f)
+   (eqv? (string->number "#e-inf.0") #f)
+
+  ; don't make no sense
+   (eqv? (string->number "3@4i") #f)
+   (eqv? (string->number "3@-i") #f)
+
+  ; zero with large exponent
+   (eqv? (string->number "0.0e3000") 0.0)
+   (eqv? (string->number "-0.0e3000") -0.0)
+
+  ; exact polar complex numbers.  r6rs says anything w/o radix point, exponent sign, or precision is exact.
+  ; we also include polar numbers w/o #e prefix that can't be represented exactly
+   (eqv? (string->number "0@0") 0)
+   (eqv? (string->number "1@0") 1)
+   (eqv? (string->number "0@1") 0)
+   (eqv? (string->number "1@1") (string->number "1.0@1.0"))
+   (not (string->number "#e1@1"))
+   (eqv? (string->number "#i1@1") (make-polar 1.0 1.0))
+   (eqv? (string->number "1.0@1") (make-polar 1.0 1.0))
+   (eqv? (string->number "1@1.0") (make-polar 1.0 1.0))
+   (eqv? (string->number "1.0@1.0") (make-polar 1.0 1.0))
+
+  ; filling in some cases shown missing by profiling
+   (eqv? (string->number "1e-5000000000") 0.0)
+   (eqv? (string->number "-1e-5000000000") -0.0)
+   (eqv? (string->number "#e0e2000") 0)
+   (eqv? (string->number "#e0e-2000") 0)
+   (eqv? (string->number "1/0@5") #f)
+   (eqv? (string->number "1/0+5") #f)
+   (eqv? (string->number "#e1e20@0") (expt 10 20))
+   (eqv? (string->number "+1/0+5i") #f)
+   (eqv? (string->number "-1/0+5i") #f)
+   (eqv? (string->number "+1/0i") #f)
+   (eqv? (string->number "-1/0i") #f)
+   (eqv? (string->number "#e+inf.0+1i") #f)
+   (eqv? (string->number "1|21") 1.0)
+   (eqv? (string->number "1.5|21") 1.5)
+   (eqv? (string->number "1.5e2|21") 150.)
+   (eqv? (string->number "1.5e2|21+2i") 150.0+2.0i)
+   (eqv? (string->number "1.5e2|") #f)
+   (eqv? (string->number "1.5e2@") #f)
+   (eqv? (string->number "1.5e2@.5") (make-polar 1.5e2 .5))
+   (eqv? (string->number "1.5e2@+.5") (make-polar 1.5e2 .5))
+   (eqv? (string->number "1.5e2@-.5") (make-polar 1.5e2 -.5))
+   (eqv? (string->number "+in") #f)
+   (eqv? (string->number "+inf") #f)
+   (eqv? (string->number "+inf.") #f)
+   (eqv? (string->number "-in") #f)
+   (eqv? (string->number "-inf") #f)
+   (eqv? (string->number "-inf.") #f)
+   (eqv? (string->number "+n") #f)
+   (eqv? (string->number "+na") #f)
+   (eqv? (string->number "+nan") #f)
+   (eqv? (string->number "+nan.") #f)
+   (eqv? (string->number "-n") #f)
+   (eqv? (string->number "-na") #f)
+   (eqv? (string->number "-nan") #f)
+   (eqv? (string->number "-nan.") #f)
+ )
+
+(mat r6rs:string->number
+  ; error cases
+   (error? (r6rs:string->number 'a))
+   (error? (r6rs:string->number "a" 0))
+   (error? (r6rs:string->number "a" 37))
+   (error? (r6rs:string->number "a" 3))
+   (error? (r6rs:string->number "a" 4))
+   (error? (r6rs:string->number "a" 12))
+   (error? (r6rs:string->number "a" 20))
+   (error? (r6rs:string->number "a" 32))
+   (error? (r6rs:string->number "a" 36))
+   (error? (r6rs:string->number "a" 'a))
+   (error? (r6rs:string->number "a" 10 10))
+
+  ; r6rs number syntax doesn't have # digits
+   (not (r6rs:string->number "-1/0###e10"))
+   (not (r6rs:string->number "1###"))
+   (not (r6rs:string->number "1/3###"))
+   (not (r6rs:string->number "1.3###"))
+   (not (r6rs:string->number ".1###"))
+   (not (r6rs:string->number "1#e17"))
+   (not (r6rs:string->number "98##"))
+   (not (r6rs:string->number "#e98##"))
+   (not (r6rs:string->number "#12r-3b"))
+   (not (r6rs:string->number "#12R3b"))
+   (not (r6rs:string->number "#i#32r+21"))
+   (not (r6rs:string->number "#i#32R-21"))
+   (not (r6rs:string->number "#20r#e10"))
+   (not (r6rs:string->number "2.###d3"))
+   (not (r6rs:string->number "2#.#l2"))
+   (not (r6rs:string->number "1##/5##L4"))
+   (not (r6rs:string->number "21#/2##"))
+   (not (r6rs:string->number "21##e-2"))
+   (not (r6rs:string->number "#e.231##"))
+   (not (r6rs:string->number "#e21##.####"))
+   (not (r6rs:string->number "2.3#E-2"))
+   (not (r6rs:string->number "#I#10r-32############.#e-12"))
+
+  ; one argument case
+   (not (r6rs:string->number ""))
+   (eqv? (r6rs:string->number "0") (- (most-positive-fixnum) (most-positive-fixnum)))
+   (eqv? (r6rs:string->number "3") (1+ (1+ (1+ (string->number "0")))))
+   (eqv? (r6rs:string->number "9") (* (string->number "3") (string->number "3")))
+   (eqv? (r6rs:string->number "27") (* (string->number "3") (string->number "9")))
+   (eqv? (r6rs:string->number "+99") (string->number "99"))
+   (eqv? (r6rs:string->number "-99") (- (string->number "99")))
+   (eqv? (r6rs:string->number "-19683") (expt (string->number "-27") 3))
+   (eqv? (r6rs:string->number "#e32") (string->number "32"))
+   (eqv? (r6rs:string->number "#E-32") (string->number "-32"))
+   (not (r6rs:string->number "#"))
+   (eqv? (r6rs:string->number "#i+32") (inexact (string->number "32")))
+   (eqv? (r6rs:string->number "#I32") (inexact (string->number "32")))
+   (eqv? (r6rs:string->number "#b+101") (string->number "5"))
+   (eqv? (r6rs:string->number "#B-101") (string->number "-5"))
+   (eqv? (r6rs:string->number "#o-75") (string->number "-61"))
+   (eqv? (r6rs:string->number "#O75") (string->number "61"))
+   (eqv? (r6rs:string->number "#d91") (string->number "91"))
+   (eqv? (r6rs:string->number "#D-91") (string->number "-91"))
+   (eqv? (r6rs:string->number "#x-7f") (string->number "-127"))
+   (eqv? (r6rs:string->number "#X+7f") (string->number "127"))
+   (not (r6rs:string->number "#a"))
+   (not (r6rs:string->number "#32"))
+   (not (r6rs:string->number "#32="))
+   (not (r6rs:string->number "#47r0"))
+   (not (r6rs:string->number "#110r0"))
+   (not (r6rs:string->number "#e"))
+   (eqv? (r6rs:string->number "#e#x-1e") (string->number "-30"))
+   (eqv? (r6rs:string->number "#i321") (inexact (string->number "321")))
+   (not (r6rs:string->number "#e#"))
+   (eqv? (r6rs:string->number "#i#b011") (inexact (string->number "3")))
+   (eqv? (r6rs:string->number "#e#o-76") (string->number "-62"))
+   (eqv? (r6rs:string->number "#e#D+29") (string->number "29"))
+   (eqv? (r6rs:string->number "#e#x-abcd") (string->number "-43981"))
+   (not (r6rs:string->number "#e#*"))
+   (not (r6rs:string->number "#i#32"))
+   (not (r6rs:string->number "#i#321r"))
+   (not (r6rs:string->number "#e#39r"))
+   (not (r6rs:string->number "#20r"))
+   (not (r6rs:string->number "#20r#"))
+   (eqv? (r6rs:string->number "#x#iabc") (inexact (string->number "2748")))
+   (not (r6rs:string->number "#x##"))
+   (not (r6rs:string->number "#e#x"))
+   (eqv? (r6rs:string->number ".321")
+         (inexact (/ (r6rs:string->number "321") (string->number "1000"))))
+   (eqv? (r6rs:string->number "-20/317")
+         (/ (r6rs:string->number "20") (string->number "-317")))
+   (not (r6rs:string->number "a"))
+   (not (r6rs:string->number "+"))
+   (eqv? (r6rs:string->number "+.91") (string->number ".91"))
+   (eqv? (r6rs:string->number "-.257") (- (string->number ".257")))
+   (not (r6rs:string->number "-a"))
+   (eqv? (r6rs:string->number "98.21")
+         (* (r6rs:string->number ".9821") (string->number "100")))
+   (eqv? (r6rs:string->number "27e10") (string->number "270000000000.0"))
+   (eqv? (r6rs:string->number "#e27e10") (string->number "270000000000"))
+   (not (r6rs:string->number "1+"))
+   (eqv? (r6rs:string->number "23.") (inexact (string->number "23")))
+   (eqv? (r6rs:string->number "#e23.") (string->number "23"))
+   (eqv? (r6rs:string->number "2.e3") (string->number "2000."))
+   (eqv? (r6rs:string->number "2s3") (string->number "2000."))
+   (eqv? (r6rs:string->number "2.0f3") (string->number "2000."))
+   (eqv? (r6rs:string->number "2/1E3") #f)
+   (eqv? (r6rs:string->number "1/5S4") #f)
+   (eqv? (r6rs:string->number "-1/5F4") #f)
+   (eqv? (r6rs:string->number ".2D4") (string->number "2000."))
+   (not (r6rs:string->number "2.a"))
+   (not (r6rs:string->number "21##.321"))
+   (not (r6rs:string->number "98##9"))
+   (not (r6rs:string->number "32/"))
+   (not (r6rs:string->number "32/#"))
+   (eqv? (r6rs:string->number "#i32/7") (inexact (string->number "32/7")))
+   (not (r6rs:string->number "32/23#0"))
+   (not (r6rs:string->number "."))
+   (not (r6rs:string->number "..."))
+   (eqv? (r6rs:string->number "#e.231") (string->number "231/1000"))
+   (not (r6rs:string->number ".231."))
+   (not (r6rs:string->number "-2.3e"))
+   (not (r6rs:string->number "-2/3ex"))
+   (not (r6rs:string->number "2.1e-"))
+   (not (r6rs:string->number "2e-i"))
+   (eqv? (r6rs:string->number "#e2/3e4") #f)
+   (not (r6rs:string->number "2.0e10a"))
+  ; complex cases
+   (equal? (r6rs:string->number "+i") +i)
+   (equal? (r6rs:string->number "-i") -i)
+   (not (r6rs:string->number "i"))
+   (equal? (r6rs:string->number "-221i") -221i)
+   (equal? (r6rs:string->number "+201i") +201i)
+   (not (r6rs:string->number "201i"))
+   (equal? (r6rs:string->number "3+i") 3+i)
+   (equal? (r6rs:string->number "-3+i") -3+i)
+   (equal? (r6rs:string->number "3.2-2/3i") 3.2-2/3i)
+   (equal? (r6rs:string->number "1/2@1/2") 1/2@1/2)
+   (not (r6rs:string->number "2@3@4"))
+   (not (r6rs:string->number "2@3+4i"))
+  ; two argument case
+   (eqv? (r6rs:string->number "+101" 2) (string->number "5"))
+   (eqv? (r6rs:string->number "-75" 8) (string->number "-61"))
+   (eqv? (r6rs:string->number "#O75" 10) (string->number "61"))
+   (eqv? (r6rs:string->number "91" 10) (string->number "91"))
+   (eqv? (r6rs:string->number "#D-91" 16) (string->number "-91"))
+   (eqv? (r6rs:string->number "-7f" 16) (string->number "-127"))
+
+  ; getting division by zero right
+   (eqv? (r6rs:string->number "0/0") #f)
+   (== (r6rs:string->number "#i0/0") +nan.0)
+   (eqv? (r6rs:string->number "#e0/0") #f)
+   (eqv? (r6rs:string->number "1/0") #f)
+   (eqv? (r6rs:string->number "1#/0") #f)
+   (eqv? (r6rs:string->number "#i1/0") +inf.0)
+   (eqv? (r6rs:string->number "#e1/0") #f)
+   (eqv? (r6rs:string->number "1/0+1.0i") #f)
+   (eqv? (r6rs:string->number "1.0+1/0i") #f)
+   (eqv? (r6rs:string->number "#e1e1000") (expt 10 1000))
+
+  ; same set, with minus signs
+   (eqv? (r6rs:string->number "-0/0") #f)
+   (== (r6rs:string->number "#i-0/0") +nan.0)
+   (eqv? (r6rs:string->number "#e-0/0") #f)
+   (eqv? (r6rs:string->number "-1/0") #f)
+   (eqv? (r6rs:string->number "#i-1/0") -inf.0)
+   (eqv? (r6rs:string->number "#e-1/0") #f)
+   (eqv? (r6rs:string->number "-1/0+1.0i") #f)
+   (eqv? (r6rs:string->number "1.0-1/0i") #f)
+   (eqv? (r6rs:string->number "#e-1e1000") (- (expt 10 1000)))
+
+  ; same set, with plus signs
+   (eqv? (r6rs:string->number "+0/0") #f)
+   (== (r6rs:string->number "#i+0/0") +nan.0)
+   (eqv? (r6rs:string->number "#e+0/0") #f)
+   (eqv? (r6rs:string->number "+1/0") #f)
+   (eqv? (r6rs:string->number "#i+1/0") +inf.0)
+   (eqv? (r6rs:string->number "#e+1/0") #f)
+   (eqv? (r6rs:string->number "+1/0+1.0i") #f)
+   (eqv? (r6rs:string->number "1.0+1/0i") #f)
+   (eqv? (r6rs:string->number "#e+1e1000") (expt 10 1000))
+
+  ; misc. similar tests
+   (eqv? (r6rs:string->number "1/0000") #f)
+   (eqv? (r6rs:string->number "-1/0000") #f)
+   (eqv? (r6rs:string->number "#e-1/0000") #f)
+   (eqv? (r6rs:string->number "#i-1/0000") -inf.0)
+
+
+   (eqv? (r6rs:string->number "0/0000") #f)
+   (eqv? (r6rs:string->number "-0/0000") #f)
+   (eqv? (r6rs:string->number "#e-0/0000") #f)
+   (== (r6rs:string->number "#i-0/0000") +nan.0)
+
+   (eqv? (r6rs:string->number "0/0e10") #f)
+   (eqv? (r6rs:string->number "#i0/0e10") #f)
+   (eqv? (r6rs:string->number "#e0/0e10") #f)
+   (eqv? (r6rs:string->number "1/0e10") #f)
+   (eqv? (r6rs:string->number "#i1/0e10") #f)
+   (eqv? (r6rs:string->number "#e1/0e10") #f)
+   (eqv? (r6rs:string->number "-1/0e10") #f)
+   (eqv? (r6rs:string->number "#i-1/0e10") #f)
+   (eqv? (r6rs:string->number "#e-1/0e10") #f)
+
+   (eqv? (r6rs:string->number "-1/2e10000") #f)
+   (eqv? (r6rs:string->number "1/2e10000") #f)
+   (eqv? (r6rs:string->number "#e-1/2e10000") #f)
+   (eqv? (r6rs:string->number "#e1/2e10000") #f)
+
+   (eqv? (r6rs:string->number "0e25") 0.0)
+   (eqv? (r6rs:string->number "-0e25") -0.0)
+   (eqv? (r6rs:string->number "0/1e25") #f)
+   (eqv? (r6rs:string->number "-0/1e25") #f)
+
+  ; can't have no exact nans and infinities
+   (eqv? (r6rs:string->number "#e+nan.0") #f)
+   (eqv? (r6rs:string->number "#e+inf.0") #f)
+   (eqv? (r6rs:string->number "#e-inf.0") #f)
+
+  ; don't make no sense
+   (eqv? (r6rs:string->number "3@4i") #f)
+   (eqv? (r6rs:string->number "3@-i") #f)
+
+  ; filling in some cases shown missing by profiling
+   (eqv? (r6rs:string->number "1e-5000000000") 0.0)
+   (eqv? (r6rs:string->number "-1e-5000000000") -0.0)
+   (eqv? (r6rs:string->number "#e0e2000") 0)
+   (eqv? (r6rs:string->number "#e0e-2000") 0)
+   (eqv? (r6rs:string->number "1/0@5") #f)
+   (eqv? (r6rs:string->number "1/0+5") #f)
+   (eqv? (r6rs:string->number "#e1e20@0") (expt 10 20))
+   (eqv? (r6rs:string->number "+1/0+5i") #f)
+   (eqv? (r6rs:string->number "-1/0+5i") #f)
+   (eqv? (r6rs:string->number "+1/0i") #f)
+   (eqv? (r6rs:string->number "-1/0i") #f)
+   (eqv? (r6rs:string->number "#e+inf.0+1i") #f)
+   (eqv? (r6rs:string->number "1|21") 1.0)
+   (eqv? (r6rs:string->number "1.5|21") 1.5)
+   (eqv? (r6rs:string->number "1.5e2|21") 150.)
+   (eqv? (r6rs:string->number "1.5e2|21+2i") 150.0+2.0i)
+   (eqv? (r6rs:string->number "1.5e2|") #f)
+   (eqv? (r6rs:string->number "1.5e2@") #f)
+   (eqv? (r6rs:string->number "1.5e2@.5") (make-polar 1.5e2 .5))
+   (eqv? (r6rs:string->number "1.5e2@+.5") (make-polar 1.5e2 .5))
+   (eqv? (r6rs:string->number "1.5e2@-.5") (make-polar 1.5e2 -.5))
+   (eqv? (r6rs:string->number "+in") #f)
+   (eqv? (r6rs:string->number "+inf") #f)
+   (eqv? (r6rs:string->number "+inf.") #f)
+   (eqv? (r6rs:string->number "-in") #f)
+   (eqv? (r6rs:string->number "-inf") #f)
+   (eqv? (r6rs:string->number "-inf.") #f)
+   (eqv? (r6rs:string->number "+n") #f)
+   (eqv? (r6rs:string->number "+na") #f)
+   (eqv? (r6rs:string->number "+nan") #f)
+   (eqv? (r6rs:string->number "+nan.") #f)
+   (eqv? (r6rs:string->number "-n") #f)
+   (eqv? (r6rs:string->number "-na") #f)
+   (eqv? (r6rs:string->number "-nan") #f)
+   (eqv? (r6rs:string->number "-nan.") #f)
+   (eqv? (r6rs:string->number "1.0e+5000") +inf.0)
+   (eqv? (r6rs:string->number "-1.0e+5000") -inf.0)
+   (eqv? (r6rs:string->number "0@1") 0)
+   (eqv? (r6rs:string->number "#e1@1") #f)
+ )
+
+(mat number->string
+  (error? ; not a number
+    (number->string 'a))
+  (error? ; not a number
+    (number->string 'a 24))
+  (error? ; not a number
+    (number->string 'a 16 24))
+  (error? ; invalid radix
+    (number->string 0.0 'a))
+  (error? ; invalid radix
+    (number->string 0.0 -1))
+  (error? ; invalid radix
+    (number->string 0.0 0))
+  (error? ; invalid radix
+    (number->string 0.0 1))
+  (error? ; invalid radix
+    (number->string 0.0 'a 24))
+  (error? ; invalid radix
+    (number->string 0.0 -1 24))
+  (error? ; invalid radix
+    (number->string 0.0 0 24))
+  (error? ; invalid radix
+    (number->string 0.0 1 24))
+  (error? ; invalid precision
+    (number->string 0.0 10 'a))
+  (error? ; invalid precision
+    (number->string 0.0 10 0))
+  (error? ; invalid precision
+    (number->string 0.0 10 -24))
+  (error? ; invalid precision
+    (number->string 0.0 10 (- (most-negative-fixnum) 1)))
+  (error? ; precision given w/exact number
+    (number->string 1 10 24))
+  (equal? (number->string 3) "3")
+  (equal? (number->string 3/4) "3/4")
+  (equal? (number->string 3.024) "3.024")
+  (eqv? (string->number (number->string #i2/3)) #i2/3)
+  (equal? (number->string 3.000) "3.0")
+  (equal? (number->string 3.2e20) "3.2e20")
+  (equal? (number->string 3.2e2) "320.0")
+  (equal? (number->string 3200000) "3200000")
+  (equal? (number->string 320000) "320000")
+  (equal? (number->string 3+4.0i) "3.0+4.0i")
+  (equal? (number->string 3-4.0i) "3.0-4.0i")
+  (equal? (number->string 1.003-4i) "1.003-4.0i")
+  (equal? (number->string 3+4i) "3+4i")
+  (equal? (number->string 3-4i) "3-4i")
+  (equal? (number->string (make-rectangular 3.0 4)) "3.0+4.0i")
+  (equal? (number->string (make-rectangular 3 4.0)) "3.0+4.0i")
+  (equal? (number->string (make-rectangular 3 4)) "3+4i")
+  (equal? (number->string 100.5 10 53) "100.5|53")
+  (equal? (number->string #x100 16) "100")
+  (equal? (number->string #x100 8) "400")
+  (equal? (number->string #x100 16) "100")
+)
+
+(mat r6rs:number->string
+  (error? ; not a number
+    (r6rs:number->string 'a))
+  (error? ; not a number
+    (r6rs:number->string 'a 24))
+  (error? ; not a number
+    (r6rs:number->string 'a 16 24))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 'a))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 -1))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 0))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 1))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 'a 24))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 -1 24))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 0 24))
+  (error? ; invalid radix
+    (r6rs:number->string 0.0 1 24))
+  (error? ; invalid precision
+    (r6rs:number->string 0.0 10 'a))
+  (error? ; invalid precision
+    (r6rs:number->string 0.0 10 0))
+  (error? ; invalid precision
+    (r6rs:number->string 0.0 10 -24))
+  (error? ; invalid precision
+    (r6rs:number->string 0.0 10 (- (most-negative-fixnum) 1)))
+  (error? ; precision given w/exact number
+    (r6rs:number->string 1 10 24))
+  (error? ; precision given radix other than 10
+    (r6rs:number->string 1 16 24))
+  (equal? (r6rs:number->string 3) "3")
+  (equal? (r6rs:number->string 3/4) "3/4")
+  (equal? (r6rs:number->string 3.024) "3.024")
+  (eqv? (string->number (r6rs:number->string #i2/3)) #i2/3)
+  (equal? (r6rs:number->string 3.000) "3.0")
+  (equal? (r6rs:number->string 3.2e20) "3.2e20")
+  (equal? (r6rs:number->string 3.2e2) "320.0")
+  (equal? (r6rs:number->string 3200000) "3200000")
+  (equal? (r6rs:number->string 320000) "320000")
+  (equal? (r6rs:number->string 3+4.0i) "3.0+4.0i")
+  (equal? (r6rs:number->string 3-4.0i) "3.0-4.0i")
+  (equal? (r6rs:number->string 1.003-4i) "1.003-4.0i")
+  (equal? (r6rs:number->string 3+4i) "3+4i")
+  (equal? (r6rs:number->string 3-4i) "3-4i")
+  (equal? (r6rs:number->string (make-rectangular 3.0 4)) "3.0+4.0i")
+  (equal? (r6rs:number->string (make-rectangular 3 4.0)) "3.0+4.0i")
+  (equal? (r6rs:number->string (make-rectangular 3 4)) "3+4i")
+  (equal? (r6rs:number->string 100.5 10 53) "100.5|53")
+  (equal? (r6rs:number->string #x100 16) "100")
+  (equal? (r6rs:number->string #x100 8) "400")
+  (equal? (r6rs:number->string #x100 16) "100")
+)
+
+(mat most-positive-fixnum
+    (procedure? most-positive-fixnum)
+    (fixnum? (most-positive-fixnum))
+    (not (bignum? (most-positive-fixnum)))
+    (fixnum? (1- (most-positive-fixnum)))
+    (not (bignum? (1- (most-positive-fixnum))))
+    (not (fixnum? (1+ (most-positive-fixnum))))
+    (bignum? (1+ (most-positive-fixnum)))
+ )
+
+(mat most-negative-fixnum
+    (fixnum? (most-negative-fixnum))
+    (not (bignum? (most-negative-fixnum)))
+    (fixnum? (1+ (most-negative-fixnum)))
+    (not (bignum? (1+ (most-negative-fixnum))))
+    (not (fixnum? (1- (most-negative-fixnum))))
+    (bignum? (1- (most-negative-fixnum)))
+ )
+
+(mat fixnum?
+    (fixnum? 3)
+    (fixnum? 18/2)
+    (fixnum? 1+0i)
+    (not (fixnum? 23084982309482034820348023423048230482304))
+    (not (fixnum? 203480234802384/23049821))
+    (not (fixnum? -3/4))
+    (fixnum? -1)
+    (fixnum? 0)
+    (fixnum? 1)
+    (fixnum? -12)
+    (fixnum? (most-positive-fixnum))
+    (not (fixnum? (1+ (most-positive-fixnum))))
+    (fixnum? (most-negative-fixnum))
+    (not (fixnum? (1- (most-negative-fixnum))))
+    (not (fixnum? 3.5))
+    (not (fixnum? 1.8e-10))
+    (not (fixnum? -3e5))
+    (not (fixnum? -1231.2344))
+    (not (fixnum? 3+5.0i))
+    (not (fixnum? 1.8e10@10))
+    (not (fixnum? -3e5+1.0i))
+    (not (fixnum? -1.0i))
+    (not (fixnum? +1.0i))
+    (not (fixnum? 'a))
+    (not (fixnum? "hi"))
+    (not (fixnum? (cons 3 4)))
+ )
+
+(mat bignum?
+    (not (bignum? 3))
+    (not (bignum? 18/2))
+    (not (bignum? 1+0i))
+    (bignum? 23084982309482034820348023423048230482304)
+    (not (bignum? 203480234802384/23049821))
+    (not (bignum? -3/4))
+    (not (bignum? -1))
+    (not (bignum? 0))
+    (not (bignum? -12))
+    (not (bignum? (most-positive-fixnum)))
+    (bignum? (1+ (most-positive-fixnum)))
+    (not (bignum? (most-negative-fixnum)))
+    (bignum? (1- (most-negative-fixnum)))
+    (not (bignum? 3.5))
+    (not (bignum? 1.8e-10))
+    (not (bignum? -3e5))
+    (not (bignum? -1231.2344))
+    (not (bignum? 3+5.0i))
+    (not (bignum? 1.8e10@10))
+    (not (bignum? -3e5+1.0i))
+    (not (bignum? -1.0i))
+    (not (bignum? +1.0i))
+    (not (bignum? 'a))
+    (not (bignum? "hi"))
+    (not (bignum? (cons 3 4)))
+ )
+
+(mat ratnum?
+    (not (ratnum? 3))
+    (not (ratnum? 18/2))
+    (not (ratnum? 1+0i))
+    (not (ratnum? 23084982309482034820348023423048230482304))
+    (ratnum? 203480234802384/23049821)
+    (ratnum? -3/4)
+    (not (ratnum? -1))
+    (not (ratnum? 0))
+    (not (ratnum? -12))
+    (not (ratnum? 3.5))
+    (not (ratnum? 1.8e-10))
+    (not (ratnum? -3e5))
+    (not (ratnum? -1231.2344))
+    (not (ratnum? 3+5.0i))
+    (not (ratnum? 1.8e10@10))
+    (not (ratnum? -3e5+1.0i))
+    (not (ratnum? -1.0i))
+    (not (ratnum? +1.0i))
+    (not (ratnum? 'a))
+    (not (ratnum? "hi"))
+    (not (ratnum? (cons 3 4)))
+    (not (ratnum? 3/2+2/3i))
+ )
+
+(mat flonum?
+    (not (flonum? 3))
+    (not (flonum? 18/2))
+    (not (flonum? 1+0i))
+    (not (flonum? 23084982309482034820348023423048230482304))
+    (not (flonum? 203480234802384/23049821))
+    (not (flonum? -3/4))
+    (not (flonum? -1))
+    (not (flonum? 0))
+    (not (flonum? -12))
+    (flonum? 3.5)
+    (flonum? 1.8e-10)
+    (flonum? -3e5)
+    (flonum? -1231.2344)
+    (not (flonum? 3+5.0i))
+    (not (flonum? 1.8e10@10))
+    (not (flonum? -3e5+1.0i))
+    (not (flonum? -1.0i))
+    (not (flonum? +1.0i))
+    (not (flonum? 'a))
+    (not (flonum? "hi"))
+    (not (flonum? (cons 3 4)))
+ )
+
+(mat exact?
+    (error? (exact? 'a))
+    (exact? 1)
+    (exact? 112310831023012)
+    (exact? 3/4)
+    (not (exact? 3.4))
+    (not (exact? 3+4.0i))
+    (exact? 3+4i)
+    (exact? 3+0i)
+ )
+
+(mat inexact?
+    (error? (inexact? '()))
+    (not (inexact? -1))
+    (not (inexact? -112310831023012))
+    (not (inexact? 3/4))
+    (inexact? 3.4)
+    (inexact? 3+4.0i)
+    (not (inexact? 3+4i))
+    (not (inexact? 3+0i))
+ )
+
+(mat =
+    (error? (=))
+    (error? (= 'a))
+    (error? (= 3 'a))
+    (error? (= 'a 3))
+    (error? (= 3 3 'a))
+    (error? (= 4 3 'a))
+    (error? (= 'a 3 4))
+    (error? (= 4 'a 3))
+    (error? (= 3 4 'a 5))
+    (= 3 3)
+    (not (= 3 4))
+    (= -3 -3)
+    (not (= -3 -4))
+    (= -2.3e10 -2.3e10)
+    (not (= -2.3e10 -2.3e9))
+    (= 3 3.0)
+    (not (= 3 2.9))
+    (= 7/3 7/3)
+    (not (= 7/3 8/3))
+    (= 1/2 0.5)
+    (not (= 1/2 0.4))
+    (= 2)
+    (= 1 1.0 1 1.0)
+    (= 1/2 0.5 1/2 0.5)
+    (not (= 1 1.1 1 1.0))
+    (not (= 1/2 0.5 1/3 0.5))
+    (not (= 1 99999999999999999999999999999))
+    (not (= -1 99999999999999999999999999999))
+    (not (= 1 -99999999999999999999999999999))
+    (not (= -1 -99999999999999999999999999999))
+    (not (= 99999999999999999999999999999 -99999999999999999999999999999))
+    (not (= -99999999999999999999999999999 99999999999999999999999999999))
+    (not (= 99999999999999999999999999999 99999999999999999999999999998))
+    (not (= 99999999999999999999999999998 99999999999999999999999999999))
+    (= 99999999999999999999999999999 99999999999999999999999999999)
+    (= 2.0+1.0i 2.0+1.0i)
+    (not (= 2.0+1.0i 2.0+1.1i))
+    (= 2-1/2i 2-1/2i)
+    (= 2-1/2i 2.0-0.5i)
+    (test-transitive = 1 1.0 1)
+    (test-transitive = 1 2 3)
+    (test-transitive = 1 2 1)
+    (test-transitive = (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive = 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive = 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations =)
+ )
+
+(mat <
+    (error? (<))
+    (error? (< 'a))
+    (error? (< 3 'a))
+    (error? (< 'a 3))
+    (error? (< 3 4 'a))
+    (error? (< 4 3 'a))
+    (error? (< 'a 3 4))
+    (error? (< 4 'a 3))
+    (error? (< 3 5 'a 4))
+    (error? (< 3+1i))
+    (error? (< 3+1i 4))
+    (error? (< 2 3+1i))
+    (error? (< 2 3 3+1i))
+    (error? (< 3.4+0.0i))
+    (error? (< 3.4+0.0i 3.5))
+    (error? (< 3.2 3.4+0.0i))
+    (error? (< 3.2 3.3 3.4+0.0i))
+    (not (< 3 3))
+    (< 3 4)
+    (not (< -3 -3))
+    (not (< -3 -4))
+    (not (< -2.3e10 -2.3e10))
+    (< -2.3e10 -2.3e9)
+    (not (< 3 3.0))
+    (not (< 3 2.9))
+    (not (< 7/3 7/3))
+    (< 7/3 8/3)
+    (not (< 1/2 0.5))
+    (not (< 1/2 0.4))
+    (< 1)
+    (< 1 2 3)
+    (< 1 2 3 4)
+    (not (< 1 2 2 4))
+    (not (< 4 3 2 1))
+    (not (< 4 2 2 1))
+    (not (< 1 3 2 4))
+    (< 1.0 3/2 2 2.5 1000000000023)
+    (< 1 99999999999999999999999999999)
+    (< -1 99999999999999999999999999999)
+    (not (< 1 -99999999999999999999999999999))
+    (not (< -1 -99999999999999999999999999999))
+    (not (< 99999999999999999999999999999 -99999999999999999999999999999))
+    (< -99999999999999999999999999999 99999999999999999999999999999)
+    (not (< 99999999999999999999999999999 99999999999999999999999999998))
+    (< 99999999999999999999999999998 99999999999999999999999999999)
+    (not (< 99999999999999999999999999999 99999999999999999999999999999))
+    (error? (< 2.0+1.0i 3.0))
+    (error? (< 2+i 3))
+    (error? (< 2 3+i))
+    (guard (c [#t #t]) (< (#3%length (error #f "oops")) 0))
+    (test-transitive < 1 1.0 1)
+    (test-transitive < 1 2 3)
+    (test-transitive < 1 2 1)
+    (test-transitive < (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive < 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive < 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations <)
+ )
+
+(mat <=
+    (error? (<=))
+    (error? (<= 'a))
+    (error? (<= 3 'a))
+    (error? (<= 'a 3))
+    (error? (<= 3 4 'a))
+    (error? (<= 4 3 'a))
+    (error? (<= 'a 3 4))
+    (error? (<= 4 'a 3))
+    (error? (<= 3 5 'a 4))
+    (error? (<= 3+1i))
+    (error? (<= 3+1i 4))
+    (error? (<= 2 3+1i))
+    (error? (<= 2 3 3+1i))
+    (error? (<= 3.4+0.0i))
+    (error? (<= 3.4+0.0i 3.5))
+    (error? (<= 3.2 3.4+0.0i))
+    (error? (<= 3.2 3.3 3.4+0.0i))
+    (<= 3 3)
+    (<= 3 4)
+    (<= -3 -3)
+    (not (<= -3 -4))
+    (<= -2.3e10 -2.3e10)
+    (<= -2.3e10 -2.3e9)
+    (<= 3 3.0)
+    (not (<= 3 2.9))
+    (<= 7/3 7/3)
+    (<= 7/3 8/3)
+    (<= 1/2 0.5)
+    (not (<= 1/2 0.4))
+    (<= 1)
+    (<= 1 2 3)
+    (<= 1 2 3 4)
+    (<= 1 2 2 4)
+    (not (<= 4 3 2 1))
+    (not (<= 4 2 2 1))
+    (not (<= 1 3 2 4))
+    (<= 1.0 3/2 2 2.5 1000000000023)
+    (<= 1 99999999999999999999999999999)
+    (<= -1 99999999999999999999999999999)
+    (not (<= 1 -99999999999999999999999999999))
+    (not (<= -1 -99999999999999999999999999999))
+    (not (<= 99999999999999999999999999999 -99999999999999999999999999999))
+    (<= -99999999999999999999999999999 99999999999999999999999999999)
+    (not (<= 99999999999999999999999999999 99999999999999999999999999998))
+    (<= 99999999999999999999999999998 99999999999999999999999999999)
+    (<= 99999999999999999999999999999 99999999999999999999999999999)
+    (error? (<= 2.0+1.0i 3.0))
+    (error? (<= 2+i 3))
+    (error? (<= 2 3+i))
+    (test-transitive <= 1 1.0 1)
+    (test-transitive <= 1 2 3)
+    (test-transitive <= 1 2 1)
+    (test-transitive <= (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive <= 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive <= 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations <=)
+ )
+
+(mat >
+    (error? (>))
+    (error? (> 'a))
+    (error? (> 3 'a))
+    (error? (> 'a 3))
+    (error? (> 3 4 'a))
+    (error? (> 4 3 'a))
+    (error? (> 'a 3 4))
+    (error? (> 4 'a 3))
+    (error? (> 3 5 'a 4))
+    (error? (> 3+1i))
+    (error? (> 3+1i 4))
+    (error? (> 2 3+1i))
+    (error? (> 2 3 3+1i))
+    (error? (> 3.4+0.0i))
+    (error? (> 3.4+0.0i 3.5))
+    (error? (> 3.2 3.4+0.0i))
+    (error? (> 3.2 3.3 3.4+0.0i))
+    (not (> 3 3))
+    (not (> 3 4))
+    (not (> -3 -3))
+    (> -3 -4)
+    (not (> -2.3e10 -2.3e10))
+    (not (> -2.3e10 -2.3e9))
+    (not (> 3 3.0))
+    (> 3 2.9)
+    (not (> 7/3 7/3))
+    (not (> 7/3 8/3))
+    (not (> 1/2 0.5))
+    (> 1/2 0.4)
+    (> 1)
+    (> 3 2 1)
+    (not (> 1 2 3 4))
+    (not (> 1 2 2 4))
+    (> 4 3 2 1)
+    (not (> 4 2 2 1))
+    (not (> 4 2 3 1))
+    (> 1000000000023 2.5 2 3/2 1.0)
+    (not (> 1 99999999999999999999999999999))
+    (not (> -1 99999999999999999999999999999))
+    (> 1 -99999999999999999999999999999)
+    (> -1 -99999999999999999999999999999)
+    (> 99999999999999999999999999999 -99999999999999999999999999999)
+    (not (> -99999999999999999999999999999 99999999999999999999999999999))
+    (> 99999999999999999999999999999 99999999999999999999999999998)
+    (not (> 99999999999999999999999999998 99999999999999999999999999999))
+    (not (> 99999999999999999999999999999 99999999999999999999999999999))
+    (error? (> 2.0+1.0i 3.0))
+    (error? (> 2+i 3))
+    (error? (> 2 3+i))
+    (test-transitive > 1 1.0 1)
+    (test-transitive > 1 2 3)
+    (test-transitive > 1 2 1)
+    (test-transitive > (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive > 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive > 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations >)
+ )
+
+(mat >=
+    (error? (>=))
+    (error? (>= 'a))
+    (error? (>= 3 'a))
+    (error? (>= 'a 3))
+    (error? (>= 3 4 'a))
+    (error? (>= 4 3 'a))
+    (error? (>= 'a 3 4))
+    (error? (>= 4 'a 3))
+    (error? (>= 3 5 'a 4))
+    (error? (>= 3+1i))
+    (error? (>= 3+1i 4))
+    (error? (>= 2 3+1i))
+    (error? (>= 2 3 3+1i))
+    (error? (>= 3.4+0.0i))
+    (error? (>= 3.4+0.0i 3.5))
+    (error? (>= 3.2 3.4+0.0i))
+    (error? (>= 3.2 3.3 3.4+0.0i))
+    (>= 3 3)
+    (not (>= 3 4))
+    (>= -3 -3)
+    (>= -3 -4)
+    (>= -2.3e10 -2.3e10)
+    (not (>= -2.3e10 -2.3e9))
+    (>= 3 3.0)
+    (>= 3 2.9)
+    (>= 7/3 7/3)
+    (not (>= 7/3 8/3))
+    (>= 1/2 0.5)
+    (>= 1/2 0.4)
+    (>= 1)
+    (>= 3 2 1)
+    (not (>= 1 2 3 4))
+    (not (>= 1 2 2 4))
+    (>= 4 3 2 1)
+    (>= 4 2 2 1)
+    (not (>= 4 2 3 1))
+    (>= 1000000000023 2.5 2 3/2 1.0)
+    (not (>= #x40000000 #x80000000))
+    (not (>= 1 99999999999999999999999999999))
+    (not (>= -1 99999999999999999999999999999))
+    (>= 1 -99999999999999999999999999999)
+    (>= -1 -99999999999999999999999999999)
+    (>= 99999999999999999999999999999 -99999999999999999999999999999)
+    (not (>= -99999999999999999999999999999 99999999999999999999999999999))
+    (>= 99999999999999999999999999999 99999999999999999999999999998)
+    (not (>= 99999999999999999999999999998 99999999999999999999999999999))
+    (>= 99999999999999999999999999999 99999999999999999999999999999)
+    (error? (>= 2.0+1.0i 3.0))
+    (error? (>= 2+i 3))
+    (error? (>= 2 3+i))
+    (guard (c [#t #t]) (not (>= (#3%length (error #f "oops")) 0)))
+    (test-transitive >= 1 1.0 1)
+    (test-transitive >= 1 2 3)
+    (test-transitive >= 1 2 1)
+    (test-transitive >= (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive >= 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive >= 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations >=)
+ )
+
+
+(mat r6rs:=
+    (error? (r6rs:=))
+    (error? (r6rs:= 3))
+    (error? (r6rs:= 3 'a))
+    (error? (r6rs:= 'a 3))
+    (error? (r6rs:= 3 3 'a))
+    (error? (r6rs:= 4 3 'a))
+    (error? (r6rs:= 'a 3 4))
+    (error? (r6rs:= 4 'a 3))
+    (error? (r6rs:= 3 4 'a 5))
+    (r6rs:= 3 3)
+    (not (r6rs:= 3 4))
+    (r6rs:= -3 -3)
+    (not (r6rs:= -3 -4))
+    (r6rs:= -2.3e10 -2.3e10)
+    (not (r6rs:= -2.3e10 -2.3e9))
+    (r6rs:= 3 3.0)
+    (not (r6rs:= 3 2.9))
+    (r6rs:= 7/3 7/3)
+    (not (r6rs:= 7/3 8/3))
+    (r6rs:= 1/2 0.5)
+    (not (r6rs:= 1/2 0.4))
+    (r6rs:= 1 1.0 1 1.0)
+    (r6rs:= 1/2 0.5 1/2 0.5)
+    (not (r6rs:= 1 1.1 1 1.0))
+    (not (r6rs:= 1/2 0.5 1/3 0.5))
+    (not (r6rs:= 1 99999999999999999999999999999))
+    (not (r6rs:= -1 99999999999999999999999999999))
+    (not (r6rs:= 1 -99999999999999999999999999999))
+    (not (r6rs:= -1 -99999999999999999999999999999))
+    (not (r6rs:= 99999999999999999999999999999 -99999999999999999999999999999))
+    (not (r6rs:= -99999999999999999999999999999 99999999999999999999999999999))
+    (not (r6rs:= 99999999999999999999999999999 99999999999999999999999999998))
+    (not (r6rs:= 99999999999999999999999999998 99999999999999999999999999999))
+    (r6rs:= 99999999999999999999999999999 99999999999999999999999999999)
+    (r6rs:= 2.0+1.0i 2.0+1.0i)
+    (not (r6rs:= 2.0+1.0i 2.0+1.1i))
+    (r6rs:= 2-1/2i 2-1/2i)
+    (r6rs:= 2-1/2i 2.0-0.5i)
+    (test-transitive r6rs:= 1 1.0 1)
+    (test-transitive r6rs:= 1 2 3)
+    (test-transitive r6rs:= 1 2 1)
+    (test-transitive r6rs:= (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive r6rs:= 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive r6rs:= 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations r6rs:=)
+ )
+
+(mat r6rs:<
+    (error? (r6rs:<))
+    (error? (r6rs:< 3))
+    (error? (r6rs:< 3 'a))
+    (error? (r6rs:< 'a 3))
+    (error? (r6rs:< 3 4 'a))
+    (error? (r6rs:< 4 3 'a))
+    (error? (r6rs:< 'a 3 4))
+    (error? (r6rs:< 4 'a 3))
+    (error? (r6rs:< 3 5 'a 4))
+    (not (r6rs:< 3 3))
+    (r6rs:< 3 4)
+    (not (r6rs:< -3 -3))
+    (not (r6rs:< -3 -4))
+    (not (r6rs:< -2.3e10 -2.3e10))
+    (r6rs:< -2.3e10 -2.3e9)
+    (not (r6rs:< 3 3.0))
+    (not (r6rs:< 3 2.9))
+    (not (r6rs:< 7/3 7/3))
+    (r6rs:< 7/3 8/3)
+    (not (r6rs:< 1/2 0.5))
+    (not (r6rs:< 1/2 0.4))
+    (r6rs:< 1 2 3)
+    (r6rs:< 1 2 3 4)
+    (not (r6rs:< 1 2 2 4))
+    (not (r6rs:< 4 3 2 1))
+    (not (r6rs:< 4 2 2 1))
+    (not (r6rs:< 1 3 2 4))
+    (r6rs:< 1.0 3/2 2 2.5 1000000000023)
+    (r6rs:< 1 99999999999999999999999999999)
+    (r6rs:< -1 99999999999999999999999999999)
+    (not (r6rs:< 1 -99999999999999999999999999999))
+    (not (r6rs:< -1 -99999999999999999999999999999))
+    (not (r6rs:< 99999999999999999999999999999 -99999999999999999999999999999))
+    (r6rs:< -99999999999999999999999999999 99999999999999999999999999999)
+    (not (r6rs:< 99999999999999999999999999999 99999999999999999999999999998))
+    (r6rs:< 99999999999999999999999999998 99999999999999999999999999999)
+    (not (r6rs:< 99999999999999999999999999999 99999999999999999999999999999))
+    (error? (r6rs:< 2.0+1.0i 3.0))
+    (error? (r6rs:< 2+i 3))
+    (error? (r6rs:< 2 3+i))
+    (test-transitive r6rs:< 1 1.0 1)
+    (test-transitive r6rs:< 1 2 3)
+    (test-transitive r6rs:< 1 2 1)
+    (test-transitive r6rs:< (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive r6rs:< 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive r6rs:< 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations r6rs:<)
+ )
+
+(mat r6rs:<=
+    (error? (r6rs:<=))
+    (error? (r6rs:<= 3))
+    (error? (r6rs:<= 3 'a))
+    (error? (r6rs:<= 'a 3))
+    (error? (r6rs:<= 3 4 'a))
+    (error? (r6rs:<= 4 3 'a))
+    (error? (r6rs:<= 'a 3 4))
+    (error? (r6rs:<= 4 'a 3))
+    (error? (r6rs:<= 3 5 'a 4))
+    (r6rs:<= 3 3)
+    (r6rs:<= 3 4)
+    (r6rs:<= -3 -3)
+    (not (r6rs:<= -3 -4))
+    (r6rs:<= -2.3e10 -2.3e10)
+    (r6rs:<= -2.3e10 -2.3e9)
+    (r6rs:<= 3 3.0)
+    (not (r6rs:<= 3 2.9))
+    (r6rs:<= 7/3 7/3)
+    (r6rs:<= 7/3 8/3)
+    (r6rs:<= 1/2 0.5)
+    (not (r6rs:<= 1/2 0.4))
+    (r6rs:<= 1 2 3)
+    (r6rs:<= 1 2 3 4)
+    (r6rs:<= 1 2 2 4)
+    (not (r6rs:<= 4 3 2 1))
+    (not (r6rs:<= 4 2 2 1))
+    (not (r6rs:<= 1 3 2 4))
+    (r6rs:<= 1.0 3/2 2 2.5 1000000000023)
+    (r6rs:<= 1 99999999999999999999999999999)
+    (r6rs:<= -1 99999999999999999999999999999)
+    (not (r6rs:<= 1 -99999999999999999999999999999))
+    (not (r6rs:<= -1 -99999999999999999999999999999))
+    (not (r6rs:<= 99999999999999999999999999999 -99999999999999999999999999999))
+    (r6rs:<= -99999999999999999999999999999 99999999999999999999999999999)
+    (not (r6rs:<= 99999999999999999999999999999 99999999999999999999999999998))
+    (r6rs:<= 99999999999999999999999999998 99999999999999999999999999999)
+    (r6rs:<= 99999999999999999999999999999 99999999999999999999999999999)
+    (error? (r6rs:<= 2.0+1.0i 3.0))
+    (error? (r6rs:<= 2+i 3))
+    (error? (r6rs:<= 2 3+i))
+    (test-transitive r6rs:<= 1 1.0 1)
+    (test-transitive r6rs:<= 1 2 3)
+    (test-transitive r6rs:<= 1 2 1)
+    (test-transitive r6rs:<= (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive r6rs:<= 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive r6rs:<= 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations r6rs:<=)
+ )
+
+(mat r6rs:>
+    (error? (r6rs:>))
+    (error? (r6rs:> 3))
+    (error? (r6rs:> 3 'a))
+    (error? (r6rs:> 'a 3))
+    (error? (r6rs:> 3 4 'a))
+    (error? (r6rs:> 4 3 'a))
+    (error? (r6rs:> 'a 3 4))
+    (error? (r6rs:> 4 'a 3))
+    (error? (r6rs:> 3 5 'a 4))
+    (not (r6rs:> 3 3))
+    (not (r6rs:> 3 4))
+    (not (r6rs:> -3 -3))
+    (r6rs:> -3 -4)
+    (not (r6rs:> -2.3e10 -2.3e10))
+    (not (r6rs:> -2.3e10 -2.3e9))
+    (not (r6rs:> 3 3.0))
+    (r6rs:> 3 2.9)
+    (not (r6rs:> 7/3 7/3))
+    (not (r6rs:> 7/3 8/3))
+    (not (r6rs:> 1/2 0.5))
+    (r6rs:> 1/2 0.4)
+    (r6rs:> 3 2 1)
+    (not (r6rs:> 1 2 3 4))
+    (not (r6rs:> 1 2 2 4))
+    (r6rs:> 4 3 2 1)
+    (not (r6rs:> 4 2 2 1))
+    (not (r6rs:> 4 2 3 1))
+    (r6rs:> 1000000000023 2.5 2 3/2 1.0)
+    (not (r6rs:> 1 99999999999999999999999999999))
+    (not (r6rs:> -1 99999999999999999999999999999))
+    (r6rs:> 1 -99999999999999999999999999999)
+    (r6rs:> -1 -99999999999999999999999999999)
+    (r6rs:> 99999999999999999999999999999 -99999999999999999999999999999)
+    (not (r6rs:> -99999999999999999999999999999 99999999999999999999999999999))
+    (r6rs:> 99999999999999999999999999999 99999999999999999999999999998)
+    (not (r6rs:> 99999999999999999999999999998 99999999999999999999999999999))
+    (not (r6rs:> 99999999999999999999999999999 99999999999999999999999999999))
+    (error? (r6rs:> 2.0+1.0i 3.0))
+    (error? (r6rs:> 2+i 3))
+    (error? (r6rs:> 2 3+i))
+    (test-transitive r6rs:> 1 1.0 1)
+    (test-transitive r6rs:> 1 2 3)
+    (test-transitive r6rs:> 1 2 1)
+    (test-transitive r6rs:> (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive r6rs:> 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive r6rs:> 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations r6rs:>)
+ )
+
+(mat r6rs:>=
+    (error? (r6rs:>=))
+    (error? (r6rs:>= 3))
+    (error? (r6rs:>= 3 'a))
+    (error? (r6rs:>= 'a 3))
+    (error? (r6rs:>= 3 4 'a))
+    (error? (r6rs:>= 4 3 'a))
+    (error? (r6rs:>= 'a 3 4))
+    (error? (r6rs:>= 4 'a 3))
+    (error? (r6rs:>= 3 5 'a 4))
+    (r6rs:>= 3 3)
+    (not (r6rs:>= 3 4))
+    (r6rs:>= -3 -3)
+    (r6rs:>= -3 -4)
+    (r6rs:>= -2.3e10 -2.3e10)
+    (not (r6rs:>= -2.3e10 -2.3e9))
+    (r6rs:>= 3 3.0)
+    (r6rs:>= 3 2.9)
+    (r6rs:>= 7/3 7/3)
+    (not (r6rs:>= 7/3 8/3))
+    (r6rs:>= 1/2 0.5)
+    (r6rs:>= 1/2 0.4)
+    (r6rs:>= 3 2 1)
+    (not (r6rs:>= 1 2 3 4))
+    (not (r6rs:>= 1 2 2 4))
+    (r6rs:>= 4 3 2 1)
+    (r6rs:>= 4 2 2 1)
+    (not (r6rs:>= 4 2 3 1))
+    (r6rs:>= 1000000000023 2.5 2 3/2 1.0)
+    (not (r6rs:>= #x40000000 #x80000000))
+    (not (r6rs:>= 1 99999999999999999999999999999))
+    (not (r6rs:>= -1 99999999999999999999999999999))
+    (r6rs:>= 1 -99999999999999999999999999999)
+    (r6rs:>= -1 -99999999999999999999999999999)
+    (r6rs:>= 99999999999999999999999999999 -99999999999999999999999999999)
+    (not (r6rs:>= -99999999999999999999999999999 99999999999999999999999999999))
+    (r6rs:>= 99999999999999999999999999999 99999999999999999999999999998)
+    (not (r6rs:>= 99999999999999999999999999998 99999999999999999999999999999))
+    (r6rs:>= 99999999999999999999999999999 99999999999999999999999999999)
+    (error? (r6rs:>= 2.0+1.0i 3.0))
+    (error? (r6rs:>= 2+i 3))
+    (error? (r6rs:>= 2 3+i))
+    (test-transitive r6rs:>= 1 1.0 1)
+    (test-transitive r6rs:>= 1 2 3)
+    (test-transitive r6rs:>= 1 2 1)
+    (test-transitive r6rs:>= (expt 2 66) (inexact (expt 2 66)) (expt 2 66))
+    (test-transitive r6rs:>= 9007199254740992 9007199254740993.0 9007199254740993)
+    (test-transitive r6rs:>= 9007199254740992000 9007199254740993000.0 9007199254740993000)
+    (test-transitive-permutations r6rs:>=)
+ )
+
+(mat +
+    (error? (+ 'a))
+    (error? (+ 'a 3))
+    (error? (+ 'a 3 4))
+    (error? (+ 3 5 'a 4))
+    (eqv? (+ 1 2) 3)
+    (fl~= (+ 1.0 2) 3.0)
+    (fl~= (+ 1 2.0) 3.0)
+    (eqv? (+ 3/5 2/5) 1)
+    (eqv? (+ 1/2 3) 7/2)
+    (eqv? (+ 2/3 5/3) 7/3)
+    (fl~= (+ 3.2 1/2) 3.7)
+    (fl~= (+ 3.2 -2.5) 0.7)
+    (eqv? (+) 0)
+    (eqv? (+ 2) 2)
+    (eqv? (+ 2 3 4) 9)
+    (eqv? (+ 2 3 4 5) 14)
+    (eqv? (+ 2/3 3/4 4/5 5/6) 61/20)
+    (cfl~= (+ 1.0+2.2i -3.7+5.3i) -2.7+7.5i)
+    (cfl~= (+ 1.0+2.2i -3.7) -2.7+2.2i)
+    (cfl~= (+ 1.0 -3.7+5.3i) -2.7+5.3i)
+    (cfl~= (+ 1.0+2.2i +5.3i) 1.0+7.5i)
+    (cfl~= (+ +2.2i -3.7+5.3i) -3.7+7.5i)
+    (let ([v '#(2 3.2 2/3 4-7i 2.1+4.2i)])
+       (let f ([i 0])
+          (or (= i (vector-length v))
+              (let g ([j 0])
+                 (if (= j (vector-length v))
+                     (f (+ i 1))
+                     (let ([x (vector-ref v i)] [y (vector-ref v j)])
+                        (and (~= (+ x y) (+ y x)) 
+                             (~= (- (+ x y) y) x)
+                             (if (exact? (+ x y))
+                                 (and (exact? x) (exact? y))
+                                 (or (inexact? x) (inexact? y)))
+                             (g (+ j 1)))))))))
+    (error? ; oops
+      (+ 'a 'b (error #f "oops")))
+    (error? ; oops
+      (+ 'a (error #f "oops") 'c))
+    (error? ; oops
+      (+ (error #f "oops") 'b 'c))
+    (error? ; #f is not a fixnum
+      (+ 3 #f))
+    (error? ; #f is not a fixnum
+      (+ #f 3))
+  ; see also misc.ms mat cp0-partial-folding
+  (eqv?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(+ 3 4 5 6)))
+    18)
+    (test-cp0-expansion eqv? '(+ 1 2) 3)
+    (test-cp0-expansion fl~= '(+ 1.0 2) 3.0)
+    (test-cp0-expansion fl~= '(+ 1 2.0) 3.0)
+    (test-cp0-expansion eqv? '(+ 3/5 2/5) 1)
+    (test-cp0-expansion eqv? '(+ 1/2 3) 7/2)
+    (test-cp0-expansion eqv? '(+ 2/3 5/3) 7/3)
+    (test-cp0-expansion fl~= '(+ 3.2 1/2) 3.7)
+    (test-cp0-expansion fl~= '(+ 3.2 -2.5) 0.7)
+    (test-cp0-expansion eqv? '(+) 0)
+    (test-cp0-expansion eqv? '(+ 2) 2)
+    (test-cp0-expansion eqv? '(+ 2 3 4) 9)
+    (test-cp0-expansion eqv? '(+ 2 3 4 5) 14)
+    (test-cp0-expansion eqv? '(+ 2/3 3/4 4/5 5/6) 61/20)
+    (test-cp0-expansion cfl~= '(+ 1.0+2.2i -3.7+5.3i) -2.7+7.5i)
+    (test-cp0-expansion cfl~= '(+ 1.0+2.2i -3.7) -2.7+2.2i)
+    (test-cp0-expansion cfl~= '(+ 1.0 -3.7+5.3i) -2.7+5.3i)
+    (test-cp0-expansion cfl~= '(+ 1.0+2.2i +5.3i) 1.0+7.5i)
+    (test-cp0-expansion cfl~= '(+ +2.2i -3.7+5.3i) -3.7+7.5i)
+ )
+
+(mat -
+    (error? (-))
+    (error? (- 'a))
+    (error? (- 'a 3))
+    (error? (- 'a 3 4))
+    (error? (- 3 5 'a 4))
+    (eqv? (- 1 2) -1)
+    (fl~= (- 1.0 2) -1.0)
+    (fl~= (- 1 2.0) -1.0)
+    (eqv? (- 3/5 2/5) 1/5)
+    (eqv? (- 1/2 3) -5/2)
+    (eqv? (- 2/3 5/3) -1)
+    (fl~= (- 3.2 1/2) 2.7)
+    (fl~= (- 3.2 -2.5) 5.7)
+    (eqv? (- 2) -2)
+    (eqv? (- 2 3 4) -5)
+    (eqv? (- 2 3 4 5) -10)
+    (eqv? (- 2/3 3/4 4/5 5/6) -103/60)
+    (cfl~= (- 1.0+2.2i -3.7+5.3i) 4.7-3.1i)
+    (cfl~= (- 1.0+2.2i -3.7) 4.7+2.2i)
+    (cfl~= (- 1.0 -3.7+5.3i) 4.7-5.3i)
+    (cfl~= (- 1.0+2.2i +5.3i) 1.0-3.1i)
+    (cfl~= (- +2.2i -3.7+5.3i) 3.7-3.1i)
+    (let ([v '#(100 32.23 22/33 44-79i 2.9+8.7i)])
+       (let f ([i 0])
+          (or (= i (vector-length v))
+              (let g ([j 0])
+                 (if (= j (vector-length v))
+                     (f (+ i 1))
+                     (let ([x (vector-ref v i)] [y (vector-ref v j)])
+                        (and (~= (+ (- x y) (- y x)) 0)
+                             (~= (+ (- x y) y) x)
+                             (if (exact? (- x y))
+                                 (and (exact? x) (exact? y))
+                                 (or (inexact? x) (inexact? y)))
+                             (g (+ j 1)))))))))
+    (error? ; #f is not a fixnum
+      (- 3 #f))
+    (error? ; #f is not a fixnum
+      (- #f 3))
+    ((lambda (x ls) (and (member x ls) #t))
+     (with-output-to-string
+       (lambda ()
+         (write (- (begin
+                     (write 'x)
+                     (+ (begin (write 'a) 3) (begin (write 'b) 4)))
+                   (begin
+                     (write 'y)
+                     (+ (begin (write 'c) 5) (begin (write 'd) 7)))))))
+     '("xabycd-5" "xbaycd-5" "xabydc-5" "xbaydc-5"
+       "ycdxab-5" "ycdxba-5" "ydcxab-5" "ydcxba-5"))
+    (test-cp0-expansion eqv? '(- 1 2) -1)
+    (test-cp0-expansion fl~= '(- 1.0 2) -1.0)
+    (test-cp0-expansion fl~= '(- 1 2.0) -1.0)
+    (test-cp0-expansion eqv? '(- 3/5 2/5) 1/5)
+    (test-cp0-expansion eqv? '(- 1/2 3) -5/2)
+    (test-cp0-expansion eqv? '(- 2/3 5/3) -1)
+    (test-cp0-expansion fl~= '(- 3.2 1/2) 2.7)
+    (test-cp0-expansion fl~= '(- 3.2 -2.5) 5.7)
+    (test-cp0-expansion eqv? '(- 2) -2)
+    (test-cp0-expansion eqv? '(- 2 3 4) -5)
+    (test-cp0-expansion eqv? '(- 2 3 4 5) -10)
+    (test-cp0-expansion eqv? '(- 2/3 3/4 4/5 5/6) -103/60)
+    (test-cp0-expansion cfl~= '(- 1.0+2.2i -3.7+5.3i) 4.7-3.1i)
+    (test-cp0-expansion cfl~= '(- 1.0+2.2i -3.7) 4.7+2.2i)
+    (test-cp0-expansion cfl~= '(- 1.0 -3.7+5.3i) 4.7-5.3i)
+    (test-cp0-expansion cfl~= '(- 1.0+2.2i +5.3i) 1.0-3.1i)
+    (test-cp0-expansion cfl~= '(- +2.2i -3.7+5.3i) 3.7-3.1i)
+ )
+
+(mat *
+    (error? (* 'a))
+    (error? (* 'a 3))
+    (error? (* 'a 3 4))
+    (error? (* 3 5 'a 4))
+    (eqv? (* 1 2) 2)
+    (eqv? (* 23170 23170) 536848900)
+    (eqv? (* 23170 -23170) -536848900)
+    (eqv? (* -23170 23170) -536848900)
+    (eqv? (* -23170 -23170) 536848900)
+    (eqv? (* 23171 23170) 536872070)
+    (eqv? (* 23171 -23170) -536872070)
+    (eqv? (* -23171 23170) -536872070)
+    (eqv? (* -23171 -23170) 536872070)
+    (eqv? (* 23171 23171) 536895241)
+    (eqv? (* 23171 -23171) -536895241)
+    (eqv? (* -23171 23171) -536895241)
+    (eqv? (* -23171 -23171) 536895241)
+    (eqv? (* #x3FFFFFFF #x3FFFFFFF) #xFFFFFFF80000001)
+    (eqv? (* #x3FFFFFFF #x-3FFFFFFF) #x-FFFFFFF80000001)
+    (eqv? (* #x-3FFFFFFF #x3FFFFFFF) #x-FFFFFFF80000001)
+    (eqv? (* #x-3FFFFFFF #x-3FFFFFFF) #xFFFFFFF80000001)
+    (eqv? (* #x40000000 #x3FFFFFFF) #xFFFFFFFC0000000)
+    (eqv? (* #x40000000 #x-3FFFFFFF) #x-FFFFFFFC0000000)
+    (eqv? (* #x-40000000 #x3FFFFFFF) #x-FFFFFFFC0000000)
+    (eqv? (* #x-40000000 #x-3FFFFFFF) #xFFFFFFFC0000000)
+    (eqv? (* #x40000000 #x40000000) #x1000000000000000)
+    (eqv? (* #x40000000 #x-40000000) #x-1000000000000000)
+    (eqv? (* #x-40000000 #x40000000) #x-1000000000000000)
+    (eqv? (* #x-40000000 #x-40000000) #x1000000000000000)
+    (fl~= (* 1.0 2) 2.0)
+    (fl~= (* 1 2.0) 2.0)
+    (eqv? (* 3/5 2/5) 6/25)
+    (eqv? (* 1/2 3) 3/2)
+    (eqv? (* 2/3 5/3) 10/9)
+    (fl~= (* 3.2 1/2) 1.6)
+    (fl~= (* 3.2 -2.5) -8.0)
+    (eqv? (*) 1)
+    (eqv? (* 2) 2)
+    (eqv? (* 2 3 4) 24)
+    (eqv? (* 2 3 4 5) 120)
+    (eqv? (* 2/3 3/4 4/5 5/6) 1/3)
+    (cfl~= (* 1.0+2.0i 3.0+4.0i) -5.0+10.0i)
+    (cfl~= (* 1.0+2.0i 3.0) 3.0+6.0i)
+    (cfl~= (* -2.0 3.0+4.0i) -6.0-8.0i)
+    (cfl~= (* 1.0+2.0i +4.0i) -8.0+4.0i)
+    (cfl~= (* +2.0i 3.0+4.0i) -8.0+6.0i)
+    (let ([v '#(18 3.23 2/33 4-79i 2.9+.7i)])
+       (let f ([i 0])
+          (or (= i (vector-length v))
+              (let g ([j 0])
+                 (if (= j (vector-length v))
+                     (f (+ i 1))
+                     (let ([x (vector-ref v i)] [y (vector-ref v j)])
+                        (and (~= (* x y) (* y x))
+                             (~= (/ (* x y) y) x)
+                             (if (exact? (* x y))
+                                 (and (exact? x) (exact? y))
+                                 (or (inexact? x) (inexact? y)))
+                             (g (+ j 1)))))))))
+    (error? ; #f is not a fixnum
+      (* 3 #f))
+    (error? ; #f is not a fixnum
+      (* #f 3))
+    (test-cp0-expansion eqv? '(* 1 2) 2)
+    (test-cp0-expansion fl~= '(* 1.0 2) 2.0)
+    (test-cp0-expansion fl~= '(* 1 2.0) 2.0)
+    (test-cp0-expansion eqv? '(* 3/5 2/5) 6/25)
+    (test-cp0-expansion eqv? '(* 1/2 3) 3/2)
+    (test-cp0-expansion eqv? '(* 2/3 5/3) 10/9)
+    (test-cp0-expansion fl~= '(* 3.2 1/2) 1.6)
+    (test-cp0-expansion fl~= '(* 3.2 -2.5) -8.0)
+    (test-cp0-expansion eqv? '(*) 1)
+    (test-cp0-expansion eqv? '(* 2) 2)
+    (test-cp0-expansion eqv? '(* 2 3 4) 24)
+    (test-cp0-expansion eqv? '(* 2 3 4 5) 120)
+    (test-cp0-expansion eqv? '(* 2/3 3/4 4/5 5/6) 1/3)
+    (test-cp0-expansion cfl~= '(* 1.0+2.0i 3.0+4.0i) -5.0+10.0i)
+    (test-cp0-expansion cfl~= '(* 1.0+2.0i 3.0) 3.0+6.0i)
+    (test-cp0-expansion cfl~= '(* -2.0 3.0+4.0i) -6.0-8.0i)
+    (test-cp0-expansion cfl~= '(* 1.0+2.0i +4.0i) -8.0+4.0i)
+    (test-cp0-expansion cfl~= '(* +2.0i 3.0+4.0i) -8.0+6.0i)
+ )
+
+(mat /
+    (error? (/))
+    (error? (/ 'a))
+    (error? (/ 'a 3))
+    (error? (/ 'a 3 4))
+    (error? (/ 3 5 'a 4))
+    (eqv? (/ 1 2) 1/2)
+    (eqv? (/ 1 -2) -1/2)
+    (eqv? (/ 1/2 -2) -1/4)
+    (eqv? (/ 1 -1/2) -2)
+    (fl~= (/ 1.0 2) 0.5)
+    (fl~= (/ 1 2.0) 0.5)
+    (eqv? (/ 3/5 2/5) 3/2)
+    (eqv? (/ -3/5 2/5) -3/2)
+    (eqv? (/ 3/5 -2/5) -3/2)
+    (eqv? (/ -3/5 -2/5) 3/2)
+    (eqv? (/ 1/2 3) 1/6)
+    (eqv? (/ 2/3 5/3) 2/5)
+    (fl~= (/ 3.2 1/2) 6.4)
+    (fl~= (/ 3.2 -2.5) -1.28)
+    (eqv? (/ 2) 1/2)
+    (eqv? (/ 2 3 4) 1/6)
+    (eqv? (/ 2 3 4 5) 1/30)
+    (eqv? (/ 2/3 3/4 4/5 5/6) 4/3)
+    (cfl~= (/ -5.0+10.0i 1.0+2.0i) 3.0+4.0i)
+    (cfl~= (/ -6.0-8.0i -2.0) 3.0+4.0i)
+    (cfl~= (/ 26.0 3.0-2.0i) 6.0+4.0i)
+    (cfl~= (/ -8.0+6.0i +2.0i) 3.0+4.0i)
+    (cfl~= (/ +26.0i 3.0+2.0i) 4.0+6.0i)
+    (let ([v '#(100 32.23 22/33 44-79i 2.9+8.7i)])
+       (let f ([i 0])
+          (or (= i (vector-length v))
+              (let g ([j 0])
+                 (if (= j (vector-length v))
+                     (f (+ i 1))
+                     (let ([x (vector-ref v i)] [y (vector-ref v j)])
+                        (and (~= (* (/ x y) (/ y x)) 1)
+                             (~= (* (/ x y) y) x)
+                             (if (exact? (/ x y))
+                                 (and (exact? x) (exact? y))
+                                 (or (inexact? x) (inexact? y)))
+                             (g (+ j 1)))))))))
+    (eqv? (/ 1.0 #e1e500) 0.0) ; catch bug found in 4.0a
+    ;; following returns incorrect result in all versions prior to 5.9b
+    (eq? (/ (most-negative-fixnum) (- (most-negative-fixnum))) -1)
+    (let ([x (/ 9 50000000000)])
+      (and (eqv? (numerator x) 9)
+           (eqv? (denominator x) 50000000000)))
+    (== (/ 3.5 0) +inf.0)
+    (== (/ -3.5 0) -inf.0)
+    (== (/ 0.0 0) (nan))
+    (test-cp0-expansion eqv? '(/ 1 2) 1/2)
+    (test-cp0-expansion eqv? '(/ 1 -2) -1/2)
+    (test-cp0-expansion eqv? '(/ 1/2 -2) -1/4)
+    (test-cp0-expansion eqv? '(/ 1 -1/2) -2)
+    (test-cp0-expansion fl~= '(/ 1.0 2) 0.5)
+    (test-cp0-expansion fl~= '(/ 1 2.0) 0.5)
+    (test-cp0-expansion eqv? '(/ 3/5 2/5) 3/2)
+    (test-cp0-expansion eqv? '(/ -3/5 2/5) -3/2)
+    (test-cp0-expansion eqv? '(/ 3/5 -2/5) -3/2)
+    (test-cp0-expansion eqv? '(/ -3/5 -2/5) 3/2)
+    (test-cp0-expansion eqv? '(/ 1/2 3) 1/6)
+    (test-cp0-expansion eqv? '(/ 2/3 5/3) 2/5)
+    (test-cp0-expansion fl~= '(/ 3.2 1/2) 6.4)
+    (test-cp0-expansion fl~= '(/ 3.2 -2.5) -1.28)
+    (test-cp0-expansion eqv? '(/ 2) 1/2)
+    (test-cp0-expansion eqv? '(/ 2 3 4) 1/6)
+    (test-cp0-expansion eqv? '(/ 2 3 4 5) 1/30)
+    (test-cp0-expansion eqv? '(/ 2/3 3/4 4/5 5/6) 4/3)
+    (test-cp0-expansion cfl~= '(/ -5.0+10.0i 1.0+2.0i) 3.0+4.0i)
+    (test-cp0-expansion cfl~= '(/ -6.0-8.0i -2.0) 3.0+4.0i)
+    (test-cp0-expansion cfl~= '(/ 26.0 3.0-2.0i) 6.0+4.0i)
+    (test-cp0-expansion cfl~= '(/ -8.0+6.0i +2.0i) 3.0+4.0i)
+    (test-cp0-expansion cfl~= '(/ +26.0i 3.0+2.0i) 4.0+6.0i)
+    (test-cp0-expansion == '(/ 3.5 0) +inf.0)
+    (test-cp0-expansion == '(/ -3.5 0) -inf.0)
+    (test-cp0-expansion == '(/ 0.0 0) (nan))
+ )
+
+(mat nan?
+  (error? (nan? 'a))
+  (error? (nan? 3+4i))
+  (error? (nan? 3.0-0.0i))
+  (not (nan? 3))
+  (not (nan? (* (most-positive-fixnum) 15)))
+  (not (nan? (/ 3 40)))
+  (nan? (nan))
+  (not (nan? 5.0))
+  (not (nan? +inf.0))
+  (not (nan? -inf.0))
+)
+
+(mat finite?
+  (error? (finite? 'a))
+  (error? (finite? 3+4i))
+  (error? (finite? 3.0-0.0i))
+  (finite? 3)
+  (finite? (* (most-positive-fixnum) 15))
+  (finite? (/ 3 40))
+  (not (finite? (nan)))
+  (finite? 5.0)
+  (not (finite? +inf.0))
+  (not (finite? -inf.0))
+ ; r6rs:
+  (not (finite? +inf.0))
+  (finite? 5.0)
+)
+
+(mat infinite?
+  (error? (infinite? 'a))
+  (error? (infinite? 3+4i))
+  (error? (infinite? 3.0-0.0i))
+  (not (infinite? 3))
+  (not (infinite? (* (most-positive-fixnum) 15)))
+  (not (infinite? (/ 3 40)))
+  (not (infinite? 5.0))
+  (infinite? +inf.0)
+  (infinite? -inf.0)
+ ; r6rs:
+  (not (infinite? 5.0))
+  (infinite? +inf.0)
+)
+
+(mat zero?
+    (error? (zero?))
+    (error? (zero? 0 1))
+    (error? (zero? 'a))
+    (zero? 0)
+    (zero? 0.0)
+    (zero? 0/5)
+    (not (zero? 234))
+    (not (zero? 23423423/234241211))
+    (not (zero? 23.4))
+    (not (zero? -1734234))
+    (not (zero? -2/3))
+    (not (zero? -0.1))
+ )
+
+(mat positive?
+    (error? (positive?))
+    (error? (positive? 0 1))
+    (error? (positive? 'a))
+    (error? (positive? 1+1.0i))
+    (error? (positive? 1+1i))
+    (error? (positive? 1.0+0.0i))
+    (not (positive? 0))
+    (not (positive? 0.0))
+    (not (positive? 0/5))
+    (positive? 234)
+    (positive? 23423423/234241211)
+    (positive? 23.4)
+    (not (positive? -1734234))
+    (not (positive? -2/3))
+    (not (positive? -0.1))
+ )
+
+(mat nonpositive?
+    (error? (nonpositive?))
+    (error? (nonpositive? 0 1))
+    (error? (nonpositive? 'a))
+    (error? (nonpositive? 1+1.0i))
+    (error? (nonpositive? 1+1i))
+    (error? (nonpositive? 1.0+0.0i))
+    (nonpositive? 0)
+    (nonpositive? 0.0)
+    (nonpositive? 0/5)
+    (not (nonpositive? 234))
+    (not (nonpositive? 23423423/234241211))
+    (not (nonpositive? 23.4))
+    (nonpositive? -1734234)
+    (nonpositive? -2/3)
+    (nonpositive? -0.1)
+ )
+
+(mat negative?
+    (error? (negative?))
+    (error? (negative? 0 1))
+    (error? (negative? 'a))
+    (error? (negative? 1+1.0i))
+    (error? (negative? 1+1i))
+    (error? (negative? 1.0+0.0i))
+    (not (negative? 0))
+    (not (negative? 0.0))
+    (not (negative? 0/5))
+    (not (negative? 234))
+    (not (negative? 23423423/234241211))
+    (not (negative? 23.4))
+    (negative? -1734234)
+    (negative? -2/3)
+    (negative? -0.1)
+ )
+
+(mat nonnegative?
+    (error? (nonnegative?))
+    (error? (nonnegative? 0 1))
+    (error? (nonnegative? 'a))
+    (error? (nonnegative? 1+1i))
+    (error? (nonnegative? 1.0+1.0i))
+    (error? (nonnegative? 1.0+0.0i))
+    (nonnegative? 0)
+    (nonnegative? 0.0)
+    (nonnegative? 0/5)
+    (nonnegative? 234)
+    (nonnegative? 23423423/234241211)
+    (nonnegative? 23.4)
+    (not (nonnegative? -1734234))
+    (not (nonnegative? -2/3))
+    (not (nonnegative? -0.1))
+ )
+
+(mat even?
+    (error? (even?))
+    (error? (even? 0 1))
+    (error? (even? 'a))
+    (not (even? -3))
+    (even? 2)
+    (not (even? 1208312083280477))
+    (even? 1208312083280478)
+    (even? 4.0)
+    (not (even? 3.0))
+    (error? (even? 3.2))
+    (error? (even? 3.0+1.0i))
+    (error? (even? 1+1i))
+    (error? (even? +inf.0))
+    (error? (even? +nan.0))
+ )
+
+(mat odd?
+    (error? (odd?))
+    (error? (odd? 0 1))
+    (error? (odd? 'a))
+    (odd? -3)
+    (not (odd? 2))
+    (odd? 1208312083280477)
+    (not (odd? 1208312083280478))
+    (not (odd? 4.0))
+    (odd? 3.0)
+    (error? (odd? 3.2))
+    (error? (odd? 3.0+1.0i))
+    (error? (odd? 3+1i))
+    (error? (odd? +inf.0))
+    (error? (odd? +nan.0))
+ )
+
+(mat 1+
+    (error? (1+))
+    (error? (1+ 0 1))
+    (error? (1+ 'a))
+    (eqv? (1+ 1) 2)
+    (eqv? (1+ -1 ) 0)
+    (eqv? (1+ 10231231208412) 10231231208413)
+    (eqv? (1+ -10231231208412) -10231231208411)
+    (eqv? (1+ 2/3) 5/3)
+    (fl~= (1+ -9.6) -8.6)
+    (eqv? (1+ 1+1.0i) 2+1.0i)
+    (eqv? (1+ 1+1i) 2+1i)
+ )
+
+(mat add1
+    (error? (add1))
+    (error? (add1 0 1))
+    (error? (add1 'a))
+    (eqv? (add1 1) 2)
+    (eqv? (add1 -1 ) 0)
+    (eqv? (add1 10231231208412) 10231231208413)
+    (eqv? (add1 -10231231208412) -10231231208411)
+    (eqv? (add1 2/3) 5/3)
+    (fl~= (add1 -9.6) -8.6)
+    (eqv? (add1 1+1.0i) 2+1.0i)
+    (eqv? (add1 1+1i) 2+1i)
+ )
+
+(mat 1-
+    (error? (1-))
+    (error? (1- 0 1))
+    (error? (1- 'a))
+    (eqv? (1- 1) 0)
+    (eqv? (1- -1 ) -2)
+    (eqv? (1- 10231231208412) 10231231208411)
+    (eqv? (1- -10231231208412) -10231231208413)
+    (eqv? (1- 2/3) -1/3)
+    (fl~= (1- -9.6) -10.6)
+    (eqv? (1- 1+1.0i) +1.0i)
+    (eqv? (1- 1+1i) +1i)
+ )
+
+(mat sub1
+    (error? (sub1))
+    (error? (sub1 0 1))
+    (error? (sub1 'a))
+    (eqv? (sub1 1) 0)
+    (eqv? (sub1 -1 ) -2)
+    (eqv? (sub1 10231231208412) 10231231208411)
+    (eqv? (sub1 -10231231208412) -10231231208413)
+    (eqv? (sub1 2/3) -1/3)
+    (fl~= (sub1 -9.6) -10.6)
+    (eqv? (sub1 1+1.0i) +1.0i)
+    (eqv? (sub1 1+1i) +1i)
+ )
+
+(mat -1+
+    (error? (-1+))
+    (error? (-1+ 0 1))
+    (error? (-1+ 'a))
+    (eqv? (-1+ 1) 0)
+    (eqv? (-1+ -1 ) -2)
+    (eqv? (-1+ 10231231208412) 10231231208411)
+    (eqv? (-1+ -10231231208412) -10231231208413)
+    (eqv? (-1+ 2/3) -1/3)
+    (fl~= (-1+ -9.6) -10.6)
+    (eqv? (-1+ 1+1.0i) +1.0i)
+    (eqv? (-1+ 1+1i) +1i)
+ )
+
+(mat quotient
+    (error? (quotient))
+    (error? (quotient 1))
+    (error? (quotient 1 0))
+    (error? (quotient 1 2 3))
+    (error? (quotient 'a 1))
+    (error? (quotient 1 'a))
+    (eqv? (quotient 1 2) 0)
+    (eqv? (quotient (most-positive-fixnum) -1) (- (most-positive-fixnum)))
+    (eqv? (quotient (most-negative-fixnum) -1) (- (most-negative-fixnum)))
+    (not (eqv? (quotient 1.0 2) 0))
+    (not (eqv? (quotient 1 2.0) 0))
+    (error? (quotient 3/5 2/5))
+    (error? (quotient 1/2 3))
+    (error? (quotient 2/3 5/3))
+    (error? (quotient 3.2 1/2))
+    (error? (quotient 3.2 -2.5))
+    (error? (quotient 3.2 2))
+    (error? (quotient 3 2.1))
+    (error? (quotient 3 2+i))
+    (error? (quotient 2+i 3))
+    (error? (quotient 2.0+i 3))
+    (fl= (quotient 4 2.0) 2.0)
+    (fl= (quotient 4.0 2) 2.0)
+    (fl= (quotient 4.0 2.0) 2.0)
+    (fl= (quotient 4.0 2.0) 2.0)
+    (fl= (quotient 3.0 -2.0) -1.0)
+    (fl= (quotient -3.0 -2.0) 1.0)
+    (fl= (quotient -3.0 2) -1.0)
+    ;; following returns incorrect result in all versions prior to 5.9b
+    (eq? (quotient (most-negative-fixnum) (- (most-negative-fixnum))) -1)
+ )
+
+(mat remainder
+    (error? (remainder))
+    (error? (remainder 1))
+    (error? (remainder 1 0))
+    (error? (remainder 1 2 3))
+    (error? (remainder 'a 1))
+    (error? (remainder 1 'a))
+    (eqv? (remainder 1 2) 1)
+    (not (eqv? (remainder 1.0 2) 1))
+    (not (eqv? (remainder 1 2.0) 1))
+    (fl= (remainder 1.0 2) 1.0)
+    (fl= (remainder 1 2.0) 1.0)
+    (error? (remainder 3/5 2/5))
+    (error? (remainder 1/2 3))
+    (error? (remainder 2/3 5/3))
+    (error? (remainder 3.2 1/2))
+    (error? (remainder 3.2 -2.5))
+    (error? (remainder -3.2 2.5))
+    (error? (remainder -3.2 2.5))
+    (error? (remainder -3+2i 2))
+    (fl= (remainder 5 2.0) 1.0)
+    (fl= (remainder 5.0 2) 1.0)
+    (fl= (remainder 5.0 2.0) 1.0)
+    (fl= (remainder 5.0 2.0) 1.0)
+    (fl= (remainder -5.0 3.0) -2.0)
+    (fl= (remainder 5.0 -3.0) 2.0)
+    (eqv? (remainder -4.0 2.0) 0.0)
+    (eqv? (remainder 4.0 -2.0) 0.0)
+    (eqv? (remainder 0 2.0) 0)
+    (fl= (remainder 5.842423430828094e+60 10) 4.0)
+    (fl= (remainder 5.842423430828094e+60 10.0) 4.0)
+    (fl= (remainder 5.842423430828094e+60 -10) 4.0)
+    (fl= (remainder 5.842423430828094e+60 -10.0) 4.0)
+    (fl= (remainder -5.842423430828094e+60 10) -4.0)
+    (fl= (remainder -5.842423430828094e+60 10.0) -4.0)
+    (fl= (remainder -5.842423430828094e+60 -10) -4.0)
+    (fl= (remainder -5.842423430828094e+60 -10.0) -4.0)
+    (fl= (remainder (exact 5.842423430828094e+60) 10.0) 4.0)
+    (fl= (remainder (exact 5.842423430828094e+60) -10.0) 4.0)
+    (fl= (remainder (exact -5.842423430828094e+60) 10.0) -4.0)
+    (fl= (remainder (exact -5.842423430828094e+60) -10.0) -4.0)
+    (eqv? (remainder (exact 5.842423430828094e+60) 10) 4)
+    (eqv? (remainder (exact 5.842423430828094e+60) -10) 4)
+    (eqv? (remainder (exact -5.842423430828094e+60) 10) -4)
+    (eqv? (remainder (exact -5.842423430828094e+60) -10) -4)
+    ;; following returns incorrect result with naive algorithm,
+    ;; i.e., remainder = (lambda (x,y) (- x (* (quotient x y) y)))
+    (fl= (remainder 1e194 10.0) 8.0)
+    ;; following returns incorrect result in all versions prior to 5.9b
+    (eq? (remainder (most-negative-fixnum) (- (most-negative-fixnum))) 0)
+ )
+
+(mat modulo
+    (error? (modulo))
+    (error? (modulo 1))
+    (error? (modulo 1 2 3))
+    (error? (modulo 'a 1))
+    (error? (modulo 1 'a))
+    (eqv? (modulo 1 2) 1)
+    (not (eqv? (modulo 1.0 2) 1))
+    (not (eqv? (modulo 1 2.0) 1))
+    (fl= (modulo 1.0 2) 1.0)
+    (fl= (modulo 1 2.0) 1.0)
+    (error? (modulo 3/5 2/5))
+    (error? (modulo 1/2 3))
+    (error? (modulo 2/3 5/3))
+    (error? (modulo 3.2 1/2))
+    (error? (modulo 3.2 -2.5))
+    (error? (modulo -3.2 2.5))
+    (error? (modulo -3+2i 2))
+    (fl= (modulo 5 2.0) 1.0)
+    (fl= (modulo 5.0 2) 1.0)
+    (fl= (modulo 5.0 2.0) 1.0)
+    (fl= (modulo 5.0 2.0) 1.0)
+    (eqv? (modulo -4.0 2.0) 0.0)
+    (eqv? (modulo 4.0 -2.0) 0.0)
+    (eqv? (modulo 0 2.0) 0)
+    (fl= (modulo 5.842423430828094e+60 10) 4.0)
+    (fl= (modulo 5.842423430828094e+60 10.0) 4.0)
+    (fl= (modulo -5.842423430828094e+60 10) 6.0)
+    (fl= (modulo -5.842423430828094e+60 10.0) 6.0)
+    (fl= (modulo 5.842423430828094e+60 -10) -6.0)
+    (fl= (modulo 5.842423430828094e+60 -10.0) -6.0)
+    (fl= (modulo -5.842423430828094e+60 -10) -4.0)
+    (fl= (modulo -5.842423430828094e+60 -10.0) -4.0)
+    (fl= (modulo (exact 5.842423430828094e+60) 10.0) 4.0)
+    (fl= (modulo (exact -5.842423430828094e+60) 10.0) 6.0)
+    (fl= (modulo (exact 5.842423430828094e+60) -10.0) -6.0)
+    (fl= (modulo (exact -5.842423430828094e+60) -10.0) -4.0)
+    (eqv? (modulo (exact 5.842423430828094e+60) 10) 4)
+    (eqv? (modulo (exact -5.842423430828094e+60) 10) 6)
+    (eqv? (modulo (exact 5.842423430828094e+60) -10) -6)
+    (eqv? (modulo (exact -5.842423430828094e+60) -10) -4)
+ )
+
+(mat truncate
+    (error? (truncate))
+    (error? (truncate 2 3))
+    (error? (truncate 'a))
+    (error? (truncate 2+1.0i))
+    (error? (truncate 2+1i))
+    (error? (truncate 2.0+0.0i))
+    (eqv? (truncate 19) 19)
+    (eqv? (truncate 2/3) 0)
+    (eqv? (truncate -2/3) 0)
+    (fl= (truncate 17.3) 17.0)
+    (eqv? (truncate -17/2) -8)
+    (fl= (truncate 2.5) 2.0)
+ )
+
+(mat floor
+    (error? (floor))
+    (error? (floor 2 3))
+    (error? (floor 'a))
+    (error? (floor 2+1.0i))
+    (error? (floor 2+1i))
+    (error? (floor 2.0+0.0i))
+    (eqv? (floor 19) 19)
+    (eqv? (floor 2/3) 0)
+    (eqv? (floor -2/3) -1)
+    (fl= (floor 17.3) 17.0)
+    (eqv? (floor -17/2) -9)
+    (fl= (floor 2.5) 2.0)
+ )
+
+(mat ceiling
+    (error? (ceiling))
+    (error? (ceiling 2 3))
+    (error? (ceiling 'a))
+    (error? (ceiling 2+1.0i))
+    (error? (ceiling -1.7+0.i))
+    (error? (ceiling 2.0+0.0i))
+    (eqv? (ceiling 19) 19)
+    (eqv? (ceiling 2/3) 1)
+    (eqv? (ceiling -2/3) 0)
+    (fl= (ceiling 17.3) 18.0)
+    (eqv? (ceiling -17/2) -8)
+    (fl= (ceiling 2.5) 3.0)
+ )
+
+(mat round
+    (error? (round))
+    (error? (round 2 3))
+    (error? (round 'a))
+    (error? (round 2+1.0i))
+    (error? (round 2+1i))
+    (error? (round 2.0+0.0i))
+    (eqv? (round 19) 19)
+    (eqv? (round 2/3) 1)
+    (eqv? (round -2/3) -1)
+    (fl= (round 17.3) 17.0)
+    (eqv? (round -17/2) -8)
+    (fl= (round 2.5) 2.0)
+    (fl= (round 0.5000000000000000) 0.0)
+    (fl= (round 0.5000000000000001) 1.0)
+ )
+
+(mat abs
+    (error? (abs))
+    (error? (abs 1 2))
+    (error? (abs 'a))
+    (eqv? (abs 1) 1)
+    (eqv? (abs -15) 15)
+    (eqv? (abs (most-negative-fixnum)) (- (most-negative-fixnum)))
+    (eqv? (abs (+ (most-positive-fixnum) 1)) (+ (most-positive-fixnum) 1))
+    (eqv? (abs (- (most-negative-fixnum) 1)) (- 1 (most-negative-fixnum)))
+    (eqv? (abs -3/4) 3/4)
+    (eqv? (abs -1152263041152514306628192408100392992507/32981512763495262007329078307916574411635755078241)
+          1152263041152514306628192408100392992507/32981512763495262007329078307916574411635755078241)
+    (error? (abs 3+4i))
+    (fl~= (abs 1.83) 1.83)
+    (fl~= (abs -0.093) 0.093)
+    (error? (abs 3.0+4.0i))
+ )
+
+(mat magnitude
+    (error? (magnitude))
+    (error? (magnitude 1 2))
+    (error? (magnitude 'a))
+    (eqv? (magnitude 1) 1)
+    (eqv? (magnitude -3/4) 3/4)
+    (eqv? (magnitude 3+4i) 5)
+    (fl~= (magnitude 1.83) 1.83)
+    (fl~= (magnitude -0.093) 0.093)
+    (fl~= (magnitude 3+4.0i) 5.0)
+    (fl~= (magnitude 0.0-0.093i) 0.093)
+    (fl~= (magnitude 1+1.0i) (sqrt 2.0))
+    (fl~= (magnitude 99.9+88.8i) (sqrt (+ (* 99.9 99.9) (* 88.8 88.8))))
+    (fl~= (magnitude 1e20+1.0i) 1e20)
+ )
+
+(mat max
+    (error? (max))
+    (error? (max 'a))
+    (error? (max 1 'a))
+    (error? (max 1 'a 2))
+    (error? (max 1 2 3 'a))
+    (error? (max 1 2 3 0+1.0i))
+    (error? (max 1 2 3 +1i))
+    (eqv? (max 1) 1)
+    (eqv? (max 3 -3) 3)
+    (fl= (max 3.2 1.0) 3.2)
+    (fl= (max 3.2 1.0) 3.2)
+    (fl= (max 1/2 0.5) 0.5)
+    (fl= (max 1/2 -0.5) 0.5)
+    (eqv? (max 3 5 1 4 6 2) 6)
+ )
+
+(mat min
+    (error? (min))
+    (error? (min 'a))
+    (error? (min 1 'a))
+    (error? (min 1 'a 2))
+    (error? (min 1 2 3 'a))
+    (error? (min 1 2 3 0+1.0i))
+    (error? (min 1 2 3 +1i))
+    (error? (min 3.0+0.0i))
+    (error? (min 2 3.0+0.0i))
+    (error? (min 2 3.0+0.0i 3))
+    (error? (min 1 2 2 3.0+0.0i))
+    (eqv? (min -17) -17)
+    (eqv? (min 3 -3) -3)
+    (eqv? (min 3.2 1.0) 1.0)
+    (fl= (min 3.2 1.0) 1.0)
+    (fl= (min 1/2 0.5) 0.5)
+    (fl= (min -1/2 0.5) -0.5)
+    (eqv? (min 3 5 1 4 6 2) 1)
+ )
+
+(mat gcd
+    (error? (gcd 'a))
+    (error? (gcd 3.4))
+    (error? (gcd 3/4))
+    (error? (gcd +inf.0))
+    (error? (gcd +nan.0))
+    (error? (gcd 1 3.4))
+    (error? (gcd 1 2/3 2))
+    (error? (gcd 1 2 3 'a))
+    (error? (gcd 1 2 3 1+1.0i))
+    (error? (gcd 1 2 3 1+1i))
+    (error? (gcd 3.0+0.0i))
+    (error? (gcd 2 3.0+0.0i))
+    (error? (gcd 2 3.0+0.0i 3))
+    (error? (gcd 1 2 2 3.0+0.0i))
+    (error? (gcd 0 +inf.0))
+    (error? (gcd -inf.0 0))
+    (error? (gcd 1 +inf.0))
+    (error? (gcd -inf.0 1))
+    (error? (gcd +inf.0 15 27))
+    (error? (gcd 15 +inf.0 27))
+    (error? (gcd 15 27 +inf.0))
+    (error? (gcd +nan.0 15 27))
+    (error? (gcd 15 +nan.0 27))
+    (error? (gcd 15 27 +nan.0))
+    (eqv? (gcd) 0)
+    (eqv? (gcd 1123123) 1123123)
+    (eqv? (gcd 33 15) 3)
+    (eqv? (gcd 28 -14) 14)
+    (eqv? (gcd 0 15) 15)
+    (fl= (gcd 0 15.0) 15.0)
+    (fl= (gcd 0.0 15) 15.0)
+    (fl= (gcd 0.0 15.0) 15.0)
+    (eqv? (gcd 0 0) 0)
+    (eqv? (gcd 2 4 8 16) 2)
+    (eqv? (gcd 12 6 15) 3)
+    (let f ([n 5])
+      (or (= n 0)
+          (and (let ((gcd-test
+                      (lambda (count seed size)
+                          (do ((x seed (+ y (* (1+ (random size)) x)))
+                               (y 0 x)
+                               (n count (1- n)))
+                              ((zero? n)
+                               (= (gcd x y) seed)
+                               #t)))))
+                 (and (gcd-test 100 73 100)
+                      (gcd-test 50 73 1000000)
+                      (gcd-test 50 73 100000000000)
+                      (gcd-test 25 73 #e1e200)))
+               (f (- n 1)))))
+    (eqv? (gcd 0 -333333333333333333) 333333333333333333)
+ )
+
+(mat lcm
+    (error? (lcm 'a))
+    (error? (lcm 3.4))
+    (error? (lcm 3/4))
+    (error? (lcm +inf.0))
+    (error? (lcm +nan.0))
+    (error? (lcm 1 3.4))
+    (error? (lcm 1 2/3 2))
+    (error? (lcm 1 2 3 'a))
+    (error? (lcm 1 2 3 1+1.0i))
+    (error? (lcm 1 2 3 1+1i))
+    (error? (lcm 1 +inf.0))
+    (error? (lcm -inf.0 1))
+    (error? (lcm +inf.0 15 27))
+    (error? (lcm 15 +inf.0 27))
+    (error? (lcm 15 27 +inf.0))
+    (error? (lcm +nan.0 15 27))
+    (error? (lcm 15 +nan.0 27))
+    (error? (lcm 15 27 +nan.0))
+    (error? (lcm +inf.0 0 27))
+    (error? (lcm 15 +inf.0 0))
+    (error? (lcm 0 27 +inf.0))
+    (error? (lcm +nan.0 0 27))
+    (error? (lcm 15 +nan.0 0))
+    (error? (lcm 0 27 +nan.0))
+    (eqv? (lcm) 1)
+    (eqv? (lcm 13) 13)
+    (eqv? (lcm -13) 13)
+    (eqv? (lcm 7 5) 35)
+    (eqv? (lcm -7 5) 35)
+    (eqv? (lcm 15 15) 15)
+    (eqv? (lcm 15 25) 75)
+    (fl= (lcm 15 25.0) 75.0)
+    (fl= (lcm 15.0 25) 75.0)
+    (fl= (lcm -15.0 25) 75.0)
+    (fl= (lcm 15.0 25.0) 75.0)
+    (eqv? (lcm 15 25 30) 150)
+    (eqv? (lcm 15 -25 30) 150)
+    (eqv? (lcm 0 0) 0)
+    (eqv? (lcm 10 0) 0)
+    (eqv? (lcm 0 10) 0)
+    (eqv? (lcm 0 0 0) 0)
+    (eqv? (lcm 10 0 0) 0)
+    (eqv? (lcm 0 10 0) 0)
+    (eqv? (lcm 0 0 10) 0)
+    (eqv? (lcm 0 6 10) 0)
+    (eqv? (lcm 6 0 10) 0)
+    (eqv? (lcm 6 10 0) 0)
+    (eqv? (lcm 0 0 0 10) 0)
+    (eqv? (lcm 10 0 0 0) 0)
+    (eqv? (lcm 0 6 7 10) 0)
+    (eqv? (lcm 10 6 7 0) 0)
+    (eqv? (lcm 0.0 0.0) 0.0)
+    (eqv? (lcm 10.0 0.0) 0.0)
+    (eqv? (lcm 0.0 10.0) 0.0)
+    (eqv? (lcm 0.0 0.0 0.0) 0.0)
+    (eqv? (lcm 10.0 0.0 0.0) 0.0)
+    (eqv? (lcm 0.0 10.0 0.0) 0.0)
+    (eqv? (lcm 0.0 0.0 10.0) 0.0)
+    (eqv? (lcm 0.0 6.0 10.0) 0.0)
+    (eqv? (lcm 6.0 0.0 10.0) 0.0)
+    (eqv? (lcm 6.0 10.0 0.0) 0.0)
+    (eqv? (lcm 0.0 0.0 0.0 10.0) 0.0)
+    (eqv? (lcm 10.0 0.0 0.0 0.0) 0.0)
+    (eqv? (lcm 0.0 6.0 7.0 10.0) 0.0)
+    (eqv? (lcm 10.0 6.0 7.0 0.0) 0.0)
+ )
+
+(mat expt
+    (error? (expt))
+    (error? (expt 5))
+    (error? (expt 3 4 5))
+    (error? (expt 'a 3))
+    (error? (expt 3 'a))
+    (error? (expt 0 -1))
+    (error? (expt 0 +1i))
+    (eqv? (expt 2+2i 4) -64)
+    (eqv? (expt 10.0 -20) 1e-20)
+    (eqv? (expt 2 10) 1024)
+    (eqv? (expt 0 0) 1)
+    (eqv? (expt 0 2) 0)
+    (eqv? (expt 100 0) 1)
+    (eqv? (expt 2 -10) 1/1024)
+    (eqv? (expt -1/2 5) -1/32)
+    (fl~= (expt 9 1/2) 3.0)
+    (fl~= (expt 3.0 3) 27.0)
+    (~= (expt -0.5 2) .25)
+    (~= (expt -0.5 -2) 4.0)
+    (~= (expt 3 2.5) (sqrt (* 3 3 3 3 3)))
+    (fl= (expt 0.0 2.0) 0.0)
+    (fl= (expt 0.0 0.0) 1.0)
+    (fl= (expt 2.0 0.0) 1.0)
+    (eqv? (expt -2/3 -3) -27/8)
+    (fl= (expt 10.0 -1000) 0.0)
+    (fl= (expt .1 1000) 0.0)
+    (cfl~= (expt -1 1/2) +1.0i)
+    (cfl~= (expt 2.4-.3i 3.0) (* 2.4-.3i 2.4-.3i 2.4-.3i))
+    (cfl~= (expt 2.4-.3i 3) (* 2.4-.3i 2.4-.3i 2.4-.3i))
+    (cfl~= (expt 7.7-11.11i -2.0) (* (/ 1.0 7.7-11.11i) (/ 1.0 7.7-11.11i)))
+    (~= (expt 11 1/2) (sqrt 11))
+    (fl~= (expt 1.5e-20 0.5) (sqrt 1.5e-20))
+   ; test cp0 handling of expt
+    (begin
+      (define $probably-should-not-use
+        (lambda () (expt 1000000 10000000000000000)))
+      (procedure? $probably-should-not-use))
+    (equal?
+      (let ([ls '(a b c)])
+        (let ([n (expt (begin (set! ls (append ls ls)) 2)
+                       (begin (set! ls (reverse ls)) 3))])
+          (cons n ls)))
+      '(8 c b a c b a))
+ )
+
+(mat expt-mod
+    (error? (expt-mod))
+    (error? (expt-mod 5))
+    (error? (expt-mod 4 5))
+    (error? (expt-mod 3 4 5 6))
+    (error? (expt-mod 'a 3 4))
+    (error? (expt-mod 1 -2 3))
+    (error? (expt-mod 1 -2 0))
+    (eqv? (expt-mod 2 4 3) 1)
+    (eqv? (expt-mod 2 76543 76543) 2)
+    (eqv? (expt-mod 2 10 7) 2)
+    (let ([x 3] [y 10] [z 8]) (eqv? (expt-mod x y z) (modulo (expt x y) z)))
+    (let ([x 3] [y 10] [z -8]) (eqv? (expt-mod x y z) (modulo (expt x y) z)))
+    (let ([x -3] [y 10] [z 8]) (eqv? (expt-mod x y z) (modulo (expt x y) z)))
+    (let ([x -3] [y 10] [z -8]) (eqv? (expt-mod x y z) (modulo (expt x y) z)))
+ )
+
+(mat random
+    (error? (random))
+    (error? (random +1i))
+    (error? (random 1 2))
+    (error? (random 'a))
+    (error? (random -3))
+    (error? (random 0))
+    (error? (random 'a))
+    (error? (random 0.0))
+    (error? (random -1.0))
+    (error? (random 1/2))
+    (error? (random 3.0+0.0i))
+    (let f ((n 1000))
+        (or (zero? n)
+            (and
+                (let ((r (random n)))
+                    (and (>= r 0) (< r n)))
+                (f (1- n)))))
+    (let f ((n 1000001000))
+        (or (= n 1000000000)
+            (and
+                (let ((r (random n)))
+                    (and (>= r 0) (< r n)))
+                (f (1- n)))))
+    (let f ((n 1000.0))
+        (or (<= n 0.0)
+            (and (let ((r (random n)))
+                    (and (>= r 0.0) (< r n)))
+                 (let ((r (random (+ n 1e30))))
+                    (and (>= r 0) (< r (+ n 1e30))))
+                 (f (- n (random 2.0))))))
+ )
+
+(mat random-seed
+    (integer? (random-seed))
+    (= (random-seed) (random-seed))
+    (error? (random-seed 'a))
+    (error? (random-seed 0))
+    (error? (random-seed -1))
+    (error? (random-seed (expt 2 32)))
+    (= 100 (begin (random-seed 100) (random-seed)))
+    (let ([r (random-seed)])
+      (let ([s (random 10)])
+        (random-seed r)
+        (= s (random 10))))
+    (begin     
+     ; test bug with return address saving in the assemblers; if this
+     ; fails to terminate, it's likely that return addresses are not
+     ; saved properly in the foreign-procedure (for random-seed) =>
+     ; dofretuns => get-room => (C)get_more_room call chain, 
+      (let f ((n 0))
+        (unless (>= (random-seed) (expt 2 29)) (f (random 2))))
+      (let f ((n 1000)) (unless (fx= n 0) (random-seed) (f (fx- n 1))))
+      #t)
+ )
+
+(mat inexact
+    (error? (inexact))
+    (error? (inexact 1 2))
+    (error? (inexact 'a))
+    (fl= (inexact 3.2) 3.2)
+    (fl= (inexact -1/2) -0.5)
+    (fl= (inexact 19) 19.0)
+    (fl~= (inexact 87000000000000000) 8.7e+16)
+    (cfl~= (inexact 3+1/2i) 3.0+.5i)
+ )
+
+(mat exact
+    (error? (exact))
+    (error? (exact 1 2))
+    (error? (exact 'a))
+    (eqv? (exact -15) -15)
+    (eqv? (exact 19/3) 19/3)
+    (rational? (exact 3.272))
+    (fl~= (inexact (exact 3.272)) 3.272)
+    (eqv? (exact 3.0+.5i) 3+1/2i)
+ )
+
+(mat rationalize
+    (error? (rationalize))
+    (error? (rationalize 3 4 5))
+    (error? (rationalize 3))
+    (error? (rationalize 'a 1))
+    (error? (rationalize 3.4 'a))
+    (error? (rationalize 3.4+0.0i 1))
+    (eqv? (rationalize -15 0) -15)
+    (eqv? (rationalize 19/3 1/10) 19/3)
+    (fl= (rationalize 3.272 0) 3.272)
+    (fluid-let ([*fuzz* .0001]) (fl~= (rationalize 3.272 0.0001) 3.272))
+    (eqv? (rationalize (exact 2/3) 1/10) 2/3)
+  ;; from r3.99rs
+    (eqv? (rationalize (exact .3) 1/10) 1/3)
+    (eqv? (rationalize .3 1/10) #i1/3)
+ )
+
+(mat numerator
+    (error? (numerator))
+    (error? (numerator 3 4)) 
+    (error? (numerator 'a))
+    (error? (numerator +1i))
+    (error? (numerator 2.2+1.1i))
+    (eqv? (numerator 3.25) 13.0)
+    (eqv? (numerator 9) 9)
+    (eqv? (numerator 2/3) 2)
+    (eqv? (numerator -9/4) -9)
+    (error? (numerator +inf.0))
+    (error? (numerator -inf.0))
+    (error? (numerator +nan.0))
+ )
+
+(mat denominator
+    (error? (denominator))
+    (error? (denominator 3 4)) 
+    (error? (denominator 'a))
+    (error? (denominator +1i))
+    (error? (denominator 2.2+1.1i))
+    (eqv? (denominator 3.25) 4.0)
+    (eqv? (denominator 9) 1)
+    (eqv? (denominator 2/3) 3)
+    (eqv? (denominator -9/4) 4)
+    (error? (denominator +inf.0))
+    (error? (denominator -inf.0))
+    (error? (denominator +nan.0))
+ )
+
+(mat real-part
+   (error? (real-part))
+   (error? (real-part 3 4))
+   (error? (real-part 'a))
+   (eqv? (real-part 3+4.0i) 3.0)
+   (eqv? (real-part 3.001-4.0i) 3.001)
+   (eqv? (real-part -.1+4.0i) -.1)
+   (eqv? (real-part 3+4i) 3)
+   (eqv? (real-part -1/10+4i) -1/10)
+ )
+
+(mat imag-part
+   (error? (imag-part))
+   (error? (imag-part 3 4))
+   (error? (imag-part 'a))
+   (eqv? (imag-part 3.0+4/3i) (inexact 4/3))
+   (eqv? (imag-part 3+4.01i) 4.01)
+   (eqv? (imag-part -.1-4e20i) -4e20)
+   (eqv? (imag-part 3+4i) 4)
+  ; r6rs says (real? -2.5) is #t and real? returns #t only when
+  ; imaginary part is exact 0, thus (imag-part -2.5) is 0
+   (eqv? (imag-part -2.5) 0)
+   (eqv? (imag-part -1-420/840i) -1/2)
+ )
+
+(mat make-rectangular
+   (error? (make-rectangular 3 'a))
+   (error? (make-rectangular 'b 4))
+   (error? (make-rectangular 3.4+0.0i 2.3))
+   (error? (make-rectangular 2.3 3.4+0.0i))
+   (eqv? (make-rectangular 3.0 -4) 3.0-4.0i)
+   (eqv? (make-rectangular 3 -4.0) 3.0-4.0i)
+   (eqv? (make-rectangular 3 -4) 3-4i)
+ )
+
+(mat make-polar
+   (error? (make-polar 3 'a))
+   (error? (make-polar 'b 4))
+   (error? (make-polar 3.4+0.0i 2.3))
+   (error? (make-polar 2.3 3.4+0.0i))
+   (eqv? (make-polar 3 -4) 3@-4)
+ )
+
+(mat angle
+   (error? (angle))
+   (error? (angle 3 4))
+   (error? (angle 'a))
+   (if (memq (machine-type) '(i3qnx ti3qnx))
+       (fl~= (angle 3.0@2.0) 2.0)
+       (fl= (angle 3.0@2.0) 2.0))
+   (let ([z 24.3-200.2i]) (cfl~= z (make-polar (magnitude z) (angle z))))
+   (= (angle 3+1i) (angle 3.0+1.0i))
+ )
+
+(mat sqrt
+    (error? (sqrt))
+    (error? (sqrt 3 4)) 
+    (error? (sqrt 'a))
+    (= (sqrt -1.0) 0.0+1.0i)
+    (eqv? (sqrt -1) +1i)
+    (= (sqrt 9) 3)
+    (= (sqrt 1/4) 1/2)
+    (~= (* (sqrt 189) (sqrt 189)) 189)
+    (fl~= (* (sqrt 2) (sqrt 2.0)) 2.0)
+    (cfl~= (* (sqrt 3+3.0i) (sqrt 3+3.0i)) 3+3.0i)
+    (let ([x 8-1.5i]) (~= (sqrt (* x x)) x))
+    (let ([x 8-3/2i]) (eqv? (sqrt (* x x)) x))
+    (~= (sqrt 5+12i) (sqrt 5.0+12.0i))
+    (~= (sqrt -5+12i) (sqrt -5.0+12.0i))
+    (~= (sqrt 5-12i) (sqrt 5.0-12.0i))
+    (~= (sqrt -5-12i) (sqrt -5.0-12.0i))
+    (~= (sqrt 1e38) (sqrt #e1e38))
+ )
+
+(mat isqrt
+    (error? (isqrt))
+    (error? (isqrt 3 4)) 
+    (error? (isqrt 1.1))
+    (error? (isqrt 'a))
+    (error? (isqrt -1))
+    (error? (isqrt 10.0+0.0i))
+    (eqv? (isqrt 1.0) 1.0)
+    (eqv? (isqrt 9.0) 3.0)
+    (eqv? (isqrt 9) 3)
+    (eqv? (isqrt 10) 3)
+    (eqv? (isqrt 1000) 31)
+    (let ([x 11111111111111111111111111111111111111111111111111111111111111111])
+       (let ([i (isqrt x)])
+          (and (<= (* i i) x) (> (* (+ i 1) (+ i 1)) x))))
+ )
+
+(mat exp
+    (error? (exp))
+    (error? (exp 3 4)) 
+    (error? (exp 'a))
+    (fl= (exp 0.0) 1.0)
+    (~= (* (exp 1) (exp 1)) (exp 2))
+    (fl~= (/ (exp 24.2) (exp 2)) (exp 22.2))
+    (fluid-let ([*fuzz* 1.1e-14])
+       (let ([x 24.2+3.1i] [y 2.1-2.0i])
+          (cfl~= (* (exp x) (exp y)) (exp (+ x y)))))
+    (cfl~= (exp 34.2+5.8i) (* (exp 34.2) (+ (cos 5.8) (* +1.0i (sin 5.8)))))
+ )
+
+(mat log
+    (error? (log))
+    (error? (log 'a))
+    (error? (log 0))
+    (= (log 1) 0)
+    (fl= (log 1.0) 0.0)
+    (~= (log (exp 7)) 7) 
+    (fl~= (log (exp 10.2)) 10.2)
+    (cfl~= (log -1) (* pi +1.0i))
+    (let ([x -1-2.0i]) (cfl~= (exp (log (* x x))) (exp (+ (log x) (log x)))))
+    (cfl~= (exp (log (exp +4.0i))) (exp +4.0i))
+    (cfl~= (exp (log (exp 34.2+5.8i))) (exp 34.2+5.8i))
+    (~= (log 1e30) (log #e1e30))
+    (cfl~= (log -1e30) (log #e-1e30))
+    (~= (/ (log (expt 10 500)) (log 10)) 500)
+    (~= (log 3/4) (log .75))
+    (~= (log 10 10) 1.0)
+    (~= (log 50 50) 1.0)
+    (~= (log -50 -50) 1.0+0.0i)
+    (~= (log 1000 10) 3)
+ )
+
+(mat sin
+    (and (> pi 3.14159265) (< pi 3.14159266))
+    (error? (sin))
+    (error? (sin 3 4)) 
+    (error? (sin 'a))
+    (fl~= (sin (/ pi 6)) 0.5)
+ )
+
+(mat cos
+    (error? (cos))
+    (error? (cos 3 4)) 
+    (error? (cos 'a))
+    (fl~= (cos (/ pi 3)) 0.5)
+    (let ([x 3.3])
+       (let ([s (sin x)] [c (cos x)])
+          (~= (+ (* s s) (* c c)) 1.0)))
+    (fluid-let ([*fuzz* 1e-13])
+      (let ([x 3.3+3.3i])
+         (let ([s (sin x)] [c (cos x)])
+            (cfl~= (+ (* s s) (* c c)) 1.0))))
+ )
+
+(mat tan
+    (error? (tan))
+    (error? (tan 3 4)) 
+    (error? (tan 'a))
+    (fl~= (tan (/ pi 4)) 1.0)
+    (let ([x 4.4]) (~= (tan x) (/ (sin x) (cos x))))
+    (fluid-let ([*fuzz* 3e-12])
+       (let ([x 4.4-5.5i]) (cfl~= (tan x) (/ (sin x) (cos x)))))
+ )
+
+(mat asin
+    (error? (asin))
+    (error? (asin 3 4)) 
+    (error? (asin 'a))
+    (fl~= (asin 1.0) (/ pi 2))
+    (let ([x 1.0]) (fl~= (asin (sin x)) x))
+    (let ([x 1.0+1.0i]) (cfl~= (asin (sin x)) x))
+    (let ([x 0.5]) (fl~= (asin (sin x)) x))
+    (let ([x 0.5+1.5i]) (cfl~= (asin (sin x)) x))
+    (let ([x 0.5-1.5i]) (cfl~= (asin (sin x)) x))
+    (let ([z 2.2-1.1i]) (cfl~= (asin z) (/ (asinh (* +1.0i z)) +1.0i)))
+ )
+
+(mat acos
+    (error? (acos))
+    (error? (acos 3 4)) 
+    (error? (acos 'a))
+    (fl~= (acos 0.5) (/ pi 3))
+    (let ([x 0.5]) (fl~= (acos (cos x)) x))
+    (let ([x 0.5+1.5i]) (cfl~= (acos (cos x)) x))
+    (let ([x 0.5-1.5i]) (cfl~= (acos (cos x)) x))
+    (fluid-let ([*fuzz* 2.4e-13])
+       (let ([z 99+.99i]) (cfl~= (cos (acos z)) z)))
+    (let ([z +9.0i])
+       (cfl~= (acos z)
+             (/ (* 2 (log (+ (sqrt (/ (+ 1 z) 2))
+                             (* +1.0i (sqrt (/ (- 1 z) 2))))))
+                +1.0i)))
+    (let ([x 10+10.0i]) (cfl~= (+ (asin x) (acos x)) (/ pi 2)))
+ )
+
+(mat atan
+    (error? (atan))
+    (error? (atan 3 4 5)) 
+    (error? (atan 'a))
+    (error? (atan 'a 3))
+    (error? (atan 3 'a))
+    (error? (atan +i))
+    (error? (atan -i))
+    (error? (atan 3.0+0.0i 3.2))
+    (fl~= (atan 1.0) (/ pi 4))
+    (fl~= (atan 2.0 2.0) (/ pi 4))
+    (let ([x 0.5]) (fl~= (atan (tan x)) x))
+    (let ([x 0.5+1.5i]) (cfl~= (atan (tan x)) x))
+    (let ([x 0.5-1.5i]) (cfl~= (atan (tan x)) x))
+    (let ([z 2.2-1.1i]) (cfl~= (atan z) (/ (atanh (* +1.0i z)) +1.0i)))
+    (let ([z 2.2-1.1i]) (cfl~= (atan z) (/ (atanh (* +1.0i z)) +1.0i)))
+    (fl~= (atan 10.0 -10.0) (angle -10+10i))
+    (fl~= (atan 10.0 -10.0) (angle -10.0+10.0i))
+    (fl~= (atan 10 -10.0) (atan 10.0 -10.0))
+    (fl~= (atan 10 -10.0) (atan 10.0 -10))
+ )
+
+(mat sinh
+   (let ([x 23]) (~= (sinh x) (* 1/2 (- (exp x) (exp (- x))))))
+   (let ([x 3-3.2i]) (~= (sinh x) (* 1/2 (- (exp x) (exp (- x))))))
+   (let ([x 50]) (~= (- (sinh x)) (sinh (- x))))
+   (let ([x 4-12i]) (~= (- (sinh x)) (sinh (- x))))
+   (let ([x 5.4+4.5i]) (~= (sinh (* +i x)) (* +i (sin x))))
+   (let ([x 5.4+4.5i])
+      (let ([s (sinh x)]) (~= (* s s) (* 1/2 (- (cosh (* 2 x)) 1)))))
+   (let ([x 5.4+4.5i])
+      (let ([s (sinh x)])
+         (~= (* s s s) (* 1/4 (+ (* -3 (sinh x)) (sinh (* 3 x)))))))
+ )
+
+(mat cosh
+   (let ([x 9]) (~= (cosh x) (* 1/2 (+ (exp x) (exp (- x))))))
+   (let ([x 4+4i]) (~= (cosh x) (* 1/2 (+ (exp x) (exp (- x))))))
+   (let ([x 50]) (~= (cosh x) (cosh (- x))))
+   (let ([x 4-12i]) (~= (cosh x) (cosh (- x))))
+   (fluid-let ([*fuzz* 1e-12])
+      (let ([x 5.4])
+         (let ([c (cosh x)] [s (sinh x)])
+            (~= (- (* c c) (* s s)) 1))))
+   (let ([x +4.5i])
+      (let ([c (cosh x)] [s (sinh x)]) (~= (- (* c c) (* s s)) 1)))
+   (fluid-let ([*fuzz* 1e-11])
+      (let ([x 5.4+4.5i])
+         (let ([c (cosh x)] [s (sinh x)]) (~= (- (* c c) (* s s)) 1))))
+   (let ([x 5.4+4.5i]) (~= (cosh (* +i x)) (cos x)))
+   (let ([x 5.4+4.5i])
+      (let ([c (cosh x)]) (~= (* c c) (* 1/2 (+ (cosh (* 2 x)) 1)))))
+   (let ([x 5.4+4.5i])
+      (let ([c (cosh x)])
+         (~= (* c c c) (* 1/4 (+ (* 3 (cosh x)) (cosh (* 3 x)))))))
+ )
+
+(mat tanh
+   (let ([x 50]) (~= (- (tanh x)) (tanh (- x))))
+   (let ([x 4-12i]) (~= (- (tanh x)) (tanh (- x))))
+   (let ([x -5]) (~= (tanh x) (/ (sinh x) (cosh x))))
+   (fluid-let ([*fuzz* 1e-13])
+     (let ([x 3-2i]) (~= (tanh x) (/ (sinh x) (cosh x)))))
+   (let ([x 5.4+4.5i]) (~= (tanh (* +i x)) (* +i (tan x))))
+ )
+
+
+(mat asinh
+    (error? (asinh))
+    (error? (asinh 3 4)) 
+    (error? (asinh 'a))
+    (fl~= (asinh (sinh 5.7)) 5.7)
+    (let ([x 0.5]) (fl~= (asinh (sinh x)) x))
+    (let ([x 0.5+1.5i]) (cfl~= (asinh (sinh x)) x))
+    (let ([x 0.5-1.5i]) (cfl~= (asinh (sinh x)) x))
+    (let ([z 3+3.0i]) (cfl~= (asinh z) (log (+ z (sqrt (+ 1 (* z z)))))))
+    (let ([z -3.1-9.9i]) (cfl~= (asinh z) (* -1.0i (asin (* +1.0i z)))))
+    (let ([z 10+999.0i]) (cfl~= (asinh z) (* -1.0i (asin (* +1.0i z)))))
+    (let ([z 9.5]) (cfl~= (asinh z) (* -1.0i (asin (* +1.0i z)))))
+ )
+
+(mat acosh
+    (error? (acosh))
+    (error? (acosh 3 4)) 
+    (error? (acosh 'a))
+    (fl~= (acosh (cosh 13.3)) 13.3)
+    (let ([x 0.5]) (fl~= (acosh (cosh x)) x))
+    (let ([x 0.5+1.5i]) (cfl~= (acosh (cosh x)) x))
+    (let ([x 0.5-1.5i]) (cfl~= (acosh (cosh x)) x))
+    (let ([z 3+3.0i])
+       (cfl~= (acosh z)
+             (* 2 (log (+ (sqrt (/ (+ z 1) 2)) (sqrt (/ (- z 1) 2)))))))
+    (let ([z -3.1-9.9i]) (cfl~= (acosh z) (* -1.0i (acos z))))
+    (let ([z 10+999.0i]) (cfl~= (acosh z) (* +1.0i (acos z))))
+ )
+
+(mat atanh
+    (error? (atanh))
+    (error? (atanh 3 4)) 
+    (error? (atanh 'a))
+    (error? (atanh -1))
+    (error? (atanh 1))
+    (fl~= (atanh (tanh 1.0)) 1.0)
+    (fl~= (atanh (tanh 1.0)) 1.0)
+    (let ([x 0.5]) (fl~= (atanh (tanh x)) x))
+    (let ([x 0.5+1.5i]) (cfl~= (atanh (tanh x)) x))
+    (let ([x 0.5-1.5i]) (cfl~= (atanh (tanh x)) x))
+    (let ([z 3+3.0i]) (cfl~= (atanh z) (/ (- (log (+ 1 z)) (log (- 1 z))) 2)))
+    (let ([z -3.1-9.9i]) (cfl~= (atanh z) (* -1.0i (atan (* +1.0i z)))))
+    (not (= (imag-part (atanh 2)) 0))
+    (not (= (imag-part (atanh -2)) 0))
+    (let ([z 3.2+2.3i]) (cfl~= (sinh z) (* (tanh z) (cosh z))))
+    (let ([z 100+99.0i]) (cfl~= (atanh z) (- (atanh (- z)))))
+    (let ([z 2.3-3.2i])
+       (let ([c (cosh z)] [s (sinh z)])
+          (cfl~= (- (* c c) (* s s)) 1.0)))
+ )
+
+(mat ash
+   (error? (ash))
+   (error? (ash 1))
+   (error? (ash 1 1 1))
+   (error? (ash .1 1))
+   (error? (ash 1 .1))
+   #;(error? (ash 1 (+ (most-positive-fixnum) 1)))
+   #;(error? (ash 1 (- (most-negative-fixnum) 1)))
+   (= (ash 234 0) 234)
+   (= (ash 1 4) 16)
+   (= (ash 8 -4) 0)
+   (= (ash (ash 4 4) -4) 4)
+   (= (ash 1 100) (expt 2 100))
+   (= (ash 1 -100) 0)
+   (= (ash (ash 1 100) -100) 1)
+   (= (ash 100 100) (* 100 (expt 2 100)))
+   (let ([x 11111111111111111111111111111111111111111111111] [n 10])
+      (= (ash x n) (* x (expt 2 n))))
+   (let ([x 11111111111111111111111111111111111111111111111] [n -10])
+      (= (ash x n) (floor (* x (expt 2 n)))))
+   (let ([x -11111111111111111111111111111111111111111111111] [n 10])
+      (= (ash x n) (* x (expt 2 n))))
+   (let ([x -11111111111111111111111111111111111111111111111] [n -10])
+      (= (ash x n) (floor (* x (expt 2 n)))))
+   (let ([x (- (expt 2 29))] [n -1])
+      (= (ash x n) (floor (* x (expt 2 n)))))
+   (let ([x (- (expt 2 30))] [n -1])
+      (= (ash x n) (floor (* x (expt 2 n)))))
+   (let ([x (most-negative-fixnum)] [n -1])
+      (= (ash x n) (floor (* x (expt 2 n)))))
+   (let ([x (- (most-negative-fixnum) 1)] [n -1])
+      (= (ash x n) (floor (* x (expt 2 n)))))
+   ; check for bugs with large negative shift counts
+   (= (ash 1 -32) 0)
+   (= (ash 1 -33) 0)
+   (= (ash 1 -96) 0)
+   (= (ash 987239487293874234 -1000) 0)
+   (= (ash -987239487293874234 -1000) -1)
+   (let f ([i -1000])
+     (or (fx= i 0)
+         (and (negative? (ash -232342342340033477676766821733948948594358 i))
+              (f (fx+ i 1)))))
+   (eqv? (ash #x-8000000000000000 -31) #x-100000000)
+   (eqv? (ash #x-8000000000000000 -32) #x-80000000)
+   (eqv? (ash #x-8000000000000000 -33) #x-40000000)
+   (begin
+     (define ($test-right-shift srl)
+       (define ($go q x n expected)
+         (let ([got (srl x n)])
+           (unless (eqv? got expected)
+             (syntax-error q (format "expected ~x, got ~x" expected got)))))
+       (define-syntax go
+         (lambda (q)
+           (syntax-case q ()
+             [(_ x n expected) #`($go #'#,q x n expected)])))
+       (let* ([$x (expt 2 1024)]
+              [$-x (- $x)]
+              [$x+1 (+ $x 1)]
+              [$-x-1 (- $x+1)]
+              [$x-1 (- $x 1)]
+              [$-x+1 (- $x-1)]
+              [$x+8 (+ $x 8)]
+              [$-x-8 (- $x+8)]
+              [$x+2^31 (+ $x (expt 2 32))]
+              [$-x-2^31 (- $x+2^31)]
+              [$x+2^32 (+ $x (expt 2 32))]
+              [$-x-2^32 (- $x+2^32)]
+              [$x+2^40 (+ $x (expt 2 40))]
+              [$-x-2^40 (- $x+2^40)]
+              [$x+2^63 (+ $x (expt 2 63))]
+              [$-x-2^63 (- $x+2^63)]
+              [$x+2^65 (+ $x (expt 2 65))]
+              [$-x-2^65 (- $x+2^65)]
+              [$x*3/2 (ash 3 1023)]
+              [$-x*3/2 (- $x*3/2)]
+              ; answers
+              [$2^64 (expt 2 64)]
+              [$-2^64 (- $2^64)]
+              [$-2^64-1 (- -1 $2^64)]
+              [$x>>64 (expt 2 (- 1024 64))]
+              [$-x>>64 (- $x>>64)]
+              [$-x>>64-1 (- -1 $x>>64)]
+              [$x>>64+2 (+ $x>>64 2)]
+              [$-x>>64-2 (- $x>>64+2 )]
+              [$x>>80 (expt 2 (- 1024 80))]
+              [$-x>>80 (- $x>>80)]
+              [$-x>>80-1 (- -1 $x>>80)]
+              )
+         (go $x 1024 1)
+         (go $-x 1024 -1)
+         (go $x 1025 0)
+         (go $-x 1025 -1)
+         (go $x+1 1024 1)
+         (go $-x-1 1024 -2)
+         (go $x+1 1025 0)
+         (go $-x-1 1025 -1)
+         (go $x (- 1024 64) $2^64)
+         (go $-x (- 1024 64) $-2^64)
+         (go $x+1 (- 1024 64) $2^64)
+         (go $-x-1 (- 1024 64) $-2^64-1)
+         (go $x+8 (- 1024 64) $2^64)
+         (go $-x-8 (- 1024 64) $-2^64-1)
+         (go $x+2^32 (- 1024 64) $2^64)
+         (go $-x-2^32 (- 1024 64) $-2^64-1)
+         (go $x+2^65 (- 1024 64) $2^64)
+         (go $-x-2^65 (- 1024 64) $-2^64-1)
+         (go $x 64 $x>>64)
+         (go $-x 64 $-x>>64)
+         (go $x+1 64 $x>>64)
+         (go $-x-1 64 $-x>>64-1)
+         (go $x+8 64 $x>>64)
+         (go $-x-8 64 $-x>>64-1)
+         (go $x+2^31 64 $x>>64)
+         (go $-x-2^31 64 $-x>>64-1)
+         (go $x+2^40 64 $x>>64)
+         (go $-x-2^40 64 $-x>>64-1)
+         (go $x+2^63 64 $x>>64)
+         (go $-x-2^63 64 $-x>>64-1)
+         (go $x+2^65 64 $x>>64+2)
+         (go $-x-2^65 64 $-x>>64-2)
+         (go $x 80 $x>>80)
+         (go $-x 80 $-x>>80)
+         (go $x+1 80 $x>>80)
+         (go $-x-1 80 $-x>>80-1)
+         (go $x+8 80 $x>>80)
+         (go $-x-8 80 $-x>>80-1)
+         (go $x+2^31 80 $x>>80)
+         (go $-x-2^31 80 $-x>>80-1)
+         (go $x+2^32 80 $x>>80)
+         (go $-x-2^32 80 $-x>>80-1)
+         (go $x+2^40 80 $x>>80)
+         (go $-x-2^40 80 $-x>>80-1)
+         (go $x+2^63 80 $x>>80)
+         (go $-x-2^63 80 $-x>>80-1)
+         (go $x+2^65 80 $x>>80)
+         (go $-x-2^65 80 $-x>>80-1)
+         (go $x*3/2 1023 3)
+         (go $-x*3/2 1023 -3)
+         (go $x*3/2 1024 1)
+         (go $-x*3/2 1024 -2)
+         (go $x*3/2 1025 0)
+         (go $-x*3/2 1025 -1)
+         )
+       #t)
+     #t)
+   ($test-right-shift (lambda (x n) (ash x (- n))))
+)
+
+(mat bitwise-arithmetic-shift
+   (error? (bitwise-arithmetic-shift))
+   (error? (bitwise-arithmetic-shift 1))
+   (error? (bitwise-arithmetic-shift 1 1 1))
+   (error? (bitwise-arithmetic-shift .1 1))
+   (error? (bitwise-arithmetic-shift 1 .1))
+   (= (bitwise-arithmetic-shift 234 0) 234)
+   (= (bitwise-arithmetic-shift 1 4) 16)
+   (= (bitwise-arithmetic-shift 8 -4) 0)
+   (= (bitwise-arithmetic-shift (bitwise-arithmetic-shift 4 4) -4) 4)
+   (= (bitwise-arithmetic-shift 1 100) (expt 2 100))
+   (= (bitwise-arithmetic-shift 1 -100) 0)
+   (= (bitwise-arithmetic-shift (bitwise-arithmetic-shift 1 100) -100) 1)
+   (= (bitwise-arithmetic-shift 100 100) (* 100 (expt 2 100)))
+   (let ([x 11111111111111111111111111111111111111111111111] [n 10])
+      (= (bitwise-arithmetic-shift x n) (* x (expt 2 n))))
+   (let ([x 11111111111111111111111111111111111111111111111] [n -10])
+      (= (bitwise-arithmetic-shift x n) (floor (* x (expt 2 n)))))
+   (let ([x -11111111111111111111111111111111111111111111111] [n 10])
+      (= (bitwise-arithmetic-shift x n) (* x (expt 2 n))))
+   (let ([x -11111111111111111111111111111111111111111111111] [n -10])
+      (= (bitwise-arithmetic-shift x n) (floor (* x (expt 2 n)))))
+   (let ([x (- (expt 2 29))] [n -1])
+      (= (bitwise-arithmetic-shift x n) (floor (* x (expt 2 n)))))
+   (let ([x (- (expt 2 30))] [n -1])
+      (= (bitwise-arithmetic-shift x n) (floor (* x (expt 2 n)))))
+   (let ([x (most-negative-fixnum)] [n -1])
+      (= (bitwise-arithmetic-shift x n) (floor (* x (expt 2 n)))))
+   (let ([x (- (most-negative-fixnum) 1)] [n -1])
+      (= (bitwise-arithmetic-shift x n) (floor (* x (expt 2 n)))))
+   ; check for bugs with large negative shift counts
+   (= (bitwise-arithmetic-shift 1 -32) 0)
+   (= (bitwise-arithmetic-shift 1 -33) 0)
+   (= (bitwise-arithmetic-shift 1 -96) 0)
+   (= (bitwise-arithmetic-shift 987239487293874234 -1000) 0)
+   (= (bitwise-arithmetic-shift -987239487293874234 -1000) -1)
+   (let f ([i -1000])
+     (or (fx= i 0)
+         (and (negative? (bitwise-arithmetic-shift -232342342340033477676766821733948948594358 i))
+              (f (fx+ i 1)))))
+   (eqv? (bitwise-arithmetic-shift #x-8000000000000000 -31) #x-100000000)
+   (eqv? (bitwise-arithmetic-shift #x-8000000000000000 -32) #x-80000000)
+   (eqv? (bitwise-arithmetic-shift #x-8000000000000000 -33) #x-40000000)
+   (eqv? (- (expt 16 232)) (bitwise-arithmetic-shift (- 307 (expt 16 240)) -32))
+   ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift x (- n))))
+)
+
+(mat bitwise-arithmetic-shift-left/right
+   (error? (bitwise-arithmetic-shift-left))
+   (error? (bitwise-arithmetic-shift-left 1))
+   (error? (bitwise-arithmetic-shift-left 1 1 1))
+   (error? (bitwise-arithmetic-shift-left .1 1))
+   (error? (bitwise-arithmetic-shift-left 1 .1))
+   (= (bitwise-arithmetic-shift-left 234 0) 234)
+   (= (bitwise-arithmetic-shift-left 1 4) 16)
+   (= (bitwise-arithmetic-shift-right 8 4) 0)
+   (= (bitwise-arithmetic-shift-right (bitwise-arithmetic-shift-left 4 4) 4) 4)
+   (= (bitwise-arithmetic-shift-left 1 100) (expt 2 100))
+   (= (bitwise-arithmetic-shift-right 1 100) 0)
+   (= (bitwise-arithmetic-shift-right (bitwise-arithmetic-shift-left 1 100) 100) 1)
+   (= (bitwise-arithmetic-shift-left 100 100) (* 100 (expt 2 100)))
+   (let ([x 11111111111111111111111111111111111111111111111] [n 10])
+      (= (bitwise-arithmetic-shift-left x n) (* x (expt 2 n))))
+   (let ([x 11111111111111111111111111111111111111111111111] [n -10])
+      (= (bitwise-arithmetic-shift-right x (- n)) (floor (* x (expt 2 n)))))
+   (let ([x -11111111111111111111111111111111111111111111111] [n 10])
+      (= (bitwise-arithmetic-shift-left x n) (* x (expt 2 n))))
+   (let ([x -11111111111111111111111111111111111111111111111] [n -10])
+      (= (bitwise-arithmetic-shift-right x (- n)) (floor (* x (expt 2 n)))))
+   (let ([x (- (expt 2 29))] [n -1])
+      (= (bitwise-arithmetic-shift-right x (- n)) (floor (* x (expt 2 n)))))
+   (let ([x (- (expt 2 30))] [n -1])
+      (= (bitwise-arithmetic-shift-right x (- n)) (floor (* x (expt 2 n)))))
+   (let ([x (most-negative-fixnum)] [n -1])
+      (= (bitwise-arithmetic-shift-right x (- n)) (floor (* x (expt 2 n)))))
+   (let ([x (- (most-negative-fixnum) 1)] [n -1])
+      (= (bitwise-arithmetic-shift-right x (- n)) (floor (* x (expt 2 n)))))
+   ; check for bugs with large negative shift counts
+   (= (bitwise-arithmetic-shift-right 1 32) 0)
+   (= (bitwise-arithmetic-shift-right 1 33) 0)
+   (= (bitwise-arithmetic-shift-right 1 96) 0)
+   (= (bitwise-arithmetic-shift-right 987239487293874234 1000) 0)
+   (= (bitwise-arithmetic-shift-right -987239487293874234 1000) -1)
+   (let f ([i -1000])
+     (or (fx= i 0)
+         (and (negative? (bitwise-arithmetic-shift-right -232342342340033477676766821733948948594358 (- i)))
+              (f (fx+ i 1)))))
+   (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 31) #x-100000000)
+   (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 32) #x-80000000)
+   (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 33) #x-40000000)
+   (eqv? (- (expt 16 232)) (bitwise-arithmetic-shift-right (- 307 (expt 16 240)) 32))
+   ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift-right x n)))
+)
+
+(mat bitwise-bit-field
+  (error? (bitwise-bit-field))
+  (error? (bitwise-bit-field 35))
+  (error? (bitwise-bit-field 35 5))
+  (error? (bitwise-bit-field 35 5 8 15))
+  (error? (bitwise-bit-field 35.0 5 8))
+  (error? (bitwise-bit-field 35 5.0 8))
+  (error? (bitwise-bit-field 35 5 8.0))
+  (error? (bitwise-bit-field 'a 5 8))
+  (error? (bitwise-bit-field 35 '(a b) 8))
+  (error? (bitwise-bit-field 35 5 "hello"))
+  (error? (bitwise-bit-field 35 -5 8))
+  (error? (bitwise-bit-field 35 5 -8))
+  (error? (bitwise-bit-field 35 5 3))
+  (error? (bitwise-bit-field 35 (+ (* (greatest-fixnum) 2) 10) (* (greatest-fixnum) 2)))
+  (eqv? (bitwise-bit-field 35 100 150) 0)
+  (eqv? (bitwise-bit-field -35 100 150) (- (expt 2 50) 1))
+  (do ([n 1000 (fx- n 1)])
+      ((fx= n 0) #t)
+    (let ([x (random (expt 10 1000))])
+      (let ([len (integer-length x)])
+        (let ([i (random len)] [j (random len)])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (= (bitwise-ior (bitwise-arithmetic-shift-left (bitwise-bit-field x i j) i)
+                                    (bitwise-arithmetic-shift-left (bitwise-bit-field x j len) j)
+                                    (bitwise-bit-field x 0 i))
+                       x)
+              (errorf #f "failed for ~s, ~s, ~s" x i j)))))))
+  (do ([n 1000 (fx- n 1)])
+      ((fx= n 0) #t)
+    (let ([x (- (random (expt 10 1000)))])
+      (let ([len (integer-length x)])
+        (let ([i (random len)] [j (random len)])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (= (bitwise-ior (bitwise-arithmetic-shift-left -1 len)
+                                    (bitwise-arithmetic-shift-left (bitwise-bit-field x i j) i)
+                                    (bitwise-arithmetic-shift-left (bitwise-bit-field x j len) j)
+                                    (bitwise-bit-field x 0 i))
+                       x)
+              (errorf #f "failed for ~s, ~s, ~s" x i j)))))))
+  (eqv?
+    (bitwise-bit-field 35 (* (greatest-fixnum) 2) (+ (* (greatest-fixnum) 2) 10))
+    0)
+  (eqv?
+    (bitwise-bit-field -35 (* (greatest-fixnum) 2) (+ (* (greatest-fixnum) 2) 10))
+    #b1111111111)
+  (eqv?
+    (bitwise-bit-field (+ (greatest-fixnum) 1) (* (greatest-fixnum) 2) (+ (* (greatest-fixnum) 2) 10))
+    0)
+  (eqv?
+    (bitwise-bit-field (- (least-fixnum) 1) (* (greatest-fixnum) 2) (+ (* (greatest-fixnum) 2) 10))
+    #b1111111111)
+)
+
+(mat bitwise-copy-bit-field
+  (error? (bitwise-copy-bit-field))
+  (error? (bitwise-copy-bit-field 0))
+  (error? (bitwise-copy-bit-field 0 0))
+  (error? (bitwise-copy-bit-field 0 0 0))
+  (error? (bitwise-copy-bit-field 0 0 0 0 0))
+  (error? (bitwise-copy-bit-field 'a 0 0 0))
+  (error? (bitwise-copy-bit-field 0 0.0 0 0))
+  (error? (bitwise-copy-bit-field 0 0 2.0 0))
+  (error? (bitwise-copy-bit-field 0 0 0 3/4))
+  (error? (bitwise-copy-bit-field 0 -1 0 0))
+  (error? (bitwise-copy-bit-field 0 (- (most-negative-fixnum) 1) 0 0))
+  (error? (bitwise-copy-bit-field 0 0 -5 0))
+  (error? (bitwise-copy-bit-field 0 0 (- (most-negative-fixnum) 1) 0))
+  (error? (bitwise-copy-bit-field 0 -10 -5 0))
+  (error? (bitwise-copy-bit-field 0 7 5 0))
+  (error? (bitwise-copy-bit-field 0 (+ (most-positive-fixnum) 1) (most-positive-fixnum) 0))
+  (error? (bitwise-copy-bit-field 0 (+ (most-positive-fixnum) 2) (+ (most-positive-fixnum) 1) 0))
+  (eqv? (bitwise-copy-bit-field 0 0 0 0) 0)
+  (eqv? (bitwise-copy-bit-field -1 0 0 0) -1)
+  (eqv? (bitwise-copy-bit-field #b101101011101111 2 7 #b10101010101010) #b101101010101011)
+  (eqv? (bitwise-copy-bit-field
+          #xabcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789
+          12 132
+          #xdcabe15629dcabe15629dcabe15629dcabe15629)
+        #xabcdef0123456789abcdef0123456789abcdef012345678dcabe15629dcabe15629dcabe15629789)
+  (let ()
+    (define (r6rs-bitwise-copy-bit-field ei1 ei2 ei3 ei4)
+      (let* ([to ei1]
+             [start ei2]
+             [end ei3]
+             [from ei4]
+             [mask1 (bitwise-arithmetic-shift-left -1 start)]
+             [mask2 (bitwise-not (bitwise-arithmetic-shift-left -1 end))]
+             [mask (bitwise-and mask1 mask2)])
+        (bitwise-if mask (bitwise-arithmetic-shift-left from start) to)))
+    (do ([n 500 (fx- n 1)])
+        ((fx= n 0) #t)
+      (let ([x (random (+ (most-positive-fixnum) 1))] [y (+ (most-positive-fixnum) 1)])
+        (let ([i (random (fixnum-width))] [j (random (fixnum-width))])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (and
+                      (= (bitwise-copy-bit-field x i j y)
+                         (r6rs-bitwise-copy-bit-field x i j y))
+                      (= (bitwise-copy-bit-field (- x) i j y)
+                         (r6rs-bitwise-copy-bit-field (- x) i j y))
+                      (= (bitwise-copy-bit-field x i j (- y))
+                         (r6rs-bitwise-copy-bit-field x i j (- y)))
+                      (= (bitwise-copy-bit-field (- x) i j (- y))
+                         (r6rs-bitwise-copy-bit-field (- x) i j (- y))))
+              (errorf #f "failed for ~s ~s ~s ~s" x i j y))))))
+    (do ([n 500 (fx- n 1)])
+        ((fx= n 0) #t)
+      (let ([x (random (expt 10 100))] [y (random (expt 10 1000))])
+        (let ([len (integer-length x)])
+          (let ([i (random len)] [j (random len)])
+            (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+              (unless (and
+                        (= (bitwise-copy-bit-field x i j y)
+                           (r6rs-bitwise-copy-bit-field x i j y))
+                        (= (bitwise-copy-bit-field (- x) i j y)
+                           (r6rs-bitwise-copy-bit-field (- x) i j y))
+                        (= (bitwise-copy-bit-field x i j (- y))
+                           (r6rs-bitwise-copy-bit-field x i j (- y)))
+                        (= (bitwise-copy-bit-field (- x) i j (- y))
+                           (r6rs-bitwise-copy-bit-field (- x) i j (- y))))
+                (errorf #f "failed for ~s ~s ~s ~s" x i j y))))))))
+)
+
+(mat bitwise-rotate-bit-field
+  (error? (bitwise-rotate-bit-field))
+  (error? (bitwise-rotate-bit-field 0))
+  (error? (bitwise-rotate-bit-field 0 0))
+  (error? (bitwise-rotate-bit-field 0 0 0))
+  (error? (bitwise-rotate-bit-field 0 0 0 0 0))
+  (error? (bitwise-rotate-bit-field 'a 0 0 0))
+  (error? (bitwise-rotate-bit-field 0 0.0 0 0))
+  (error? (bitwise-rotate-bit-field 0 0 2.0 0))
+  (error? (bitwise-rotate-bit-field 0 0 0 3/4))
+  (error? (bitwise-rotate-bit-field 0 -1 0 0))
+  (error? (bitwise-rotate-bit-field 0 (- (most-negative-fixnum) 1) 0 0))
+  (error? (bitwise-rotate-bit-field 0 0 -5 0))
+  (error? (bitwise-rotate-bit-field 0 0 (- (most-negative-fixnum) 1) 0))
+  (error? (bitwise-rotate-bit-field 0 0 0 -1))
+  (error? (bitwise-rotate-bit-field 0 -10 -5 0))
+  (error? (bitwise-rotate-bit-field 0 7 5 0))
+  (error? (bitwise-rotate-bit-field 0 (+ (most-positive-fixnum) 1) (most-positive-fixnum) 0))
+  (error? (bitwise-rotate-bit-field 0 (+ (most-positive-fixnum) 2) (+ (most-positive-fixnum) 1) 0))
+  (eqv? (bitwise-rotate-bit-field 0 0 0 0) 0)
+  (eqv? (bitwise-rotate-bit-field -1 0 0 0) -1)
+  (eqv?
+    (bitwise-rotate-bit-field #b101101011101111 2 7 3)
+    #b101101011111011)
+  (eqv?
+    (bitwise-rotate-bit-field #b101101011101111 2 7 153)
+    #b101101011111011)
+  (eqv?
+    (bitwise-rotate-bit-field #b101101011101111 2 7 (+ (expt 5 100) 3))
+    #b101101011111011)
+  (eqv?
+    (bitwise-rotate-bit-field
+      #xabcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789
+      12 132 20)
+    #xabcdef0123456789abcdef0123456789abcdef012345678ef0123456789abcdef01234569abcd789)
+  (let ()
+    (define (r6rs-bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
+      (let* ([n ei1]
+             [start ei2]
+             [end ei3]
+             [count ei4]
+             [width (- end start)])
+        (if (positive? width)
+            (let* ([count (mod count width)]
+                   [field0 (bitwise-bit-field n start end)]
+                   [field1 (bitwise-arithmetic-shift-left field0 count)]
+                   [field2 (bitwise-arithmetic-shift-right field0 (- width count))]
+                   [field (bitwise-ior field1 field2)])
+              (bitwise-copy-bit-field n start end field))
+            n)))
+    (do ([n 500 (fx- n 1)])
+        ((fx= n 0) #t)
+      (let ([x (random (+ (most-positive-fixnum) 1))])
+        (let ([i (random (fixnum-width))] [j (random (fixnum-width))] [k (random (most-positive-fixnum))])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (and
+                      (= (bitwise-rotate-bit-field x i j k)
+                         (r6rs-bitwise-rotate-bit-field x i j k))
+                      (= (bitwise-rotate-bit-field (- x) i j k)
+                         (r6rs-bitwise-rotate-bit-field (- x) i j k)))
+              (errorf #f "failed for ~s ~s ~s ~s" x i j k))))))
+    (do ([n 500 (fx- n 1)])
+        ((fx= n 0) #t)
+      (let ([x (random (expt 10 100))])
+        (let ([len (integer-length x)])
+          (let ([i (random len)] [j (random len)] [k (random (* (most-positive-fixnum) 2))])
+            (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+              (unless (and
+                        (= (bitwise-rotate-bit-field x i j k)
+                           (r6rs-bitwise-rotate-bit-field x i j k))
+                        (= (bitwise-rotate-bit-field (- x) i j k)
+                           (r6rs-bitwise-rotate-bit-field (- x) i j k)))
+                (errorf #f "failed for ~s ~s ~s ~s" x i j k))))))))
+)
+
+(mat bitwise-bit-field
+  (error? (bitwise-reverse-bit-field))
+  (error? (bitwise-reverse-bit-field 35))
+  (error? (bitwise-reverse-bit-field 35 5))
+  (error? (bitwise-reverse-bit-field 35 5 8 15))
+  (error? (bitwise-reverse-bit-field 35.0 5 8))
+  (error? (bitwise-reverse-bit-field 35 5.0 8))
+  (error? (bitwise-reverse-bit-field 35 5 8.0))
+  (error? (bitwise-reverse-bit-field 'a 5 8))
+  (error? (bitwise-reverse-bit-field 35 '(a b) 8))
+  (error? (bitwise-reverse-bit-field 35 5 "hello"))
+  (error? (bitwise-reverse-bit-field 35 -5 8))
+  (error? (bitwise-reverse-bit-field 35 5 -8))
+  (error? (bitwise-reverse-bit-field 35 5 3))
+  (error? (bitwise-reverse-bit-field 35 (+ (* (greatest-fixnum) 2) 10) (* (greatest-fixnum) 2)))
+  (eqv? (bitwise-reverse-bit-field 35 100 150) 35)
+  (eqv? (bitwise-reverse-bit-field -35 100 150) -35)
+  (eqv? (bitwise-reverse-bit-field 0 0 10) 0)
+  (eqv? (bitwise-reverse-bit-field -1 0 10) -1)
+  (eqv?
+    (bitwise-reverse-bit-field #b101101011101111 2 7)
+    #b101101011101111)
+  (eqv?
+    (bitwise-reverse-bit-field #b101101011101111 3 9)
+    #b101101101110111)
+  (eqv?
+    (bitwise-reverse-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1))
+    (greatest-fixnum))
+  (eqv?
+    (bitwise-reverse-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1))
+    (greatest-fixnum))
+  (eqv?
+    (bitwise-reverse-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1))
+    (least-fixnum))
+  (eqv?
+    (bitwise-reverse-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1))
+    (least-fixnum))
+  (eqv?
+    (bitwise-reverse-bit-field -1 0 (fx- (fixnum-width) 1))
+    -1)
+  (eqv?
+    (bitwise-reverse-bit-field -1 0 (fx- (fixnum-width) 1))
+    -1)
+  (let ()
+    (define (refimpl n start end)
+      (define (swap n i j)
+        (bitwise-copy-bit
+          (bitwise-copy-bit n i (bitwise-bit-field n j (+ j 1)))
+          j (bitwise-bit-field n i (+ i 1))))
+      (let ([end (- end 1)])
+        (if (>= start end)
+            n
+            (refimpl (swap n start end) (+ start 1) end))))
+    (do ([n 500 (- n 1)])
+        ((= n 0) #t)
+      (let* ([x (random (expt (greatest-fixnum) 10))]
+             [maxend (+ (bitwise-length x) 10)])
+        (let ([i (random maxend)] [j (random maxend)])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (and
+                      (= (bitwise-reverse-bit-field x i j)
+                         (refimpl x i j))
+                      (= (bitwise-reverse-bit-field (- x) i j)
+                         (refimpl (- x) i j)))
+              (errorf #f "failed for ~s ~s ~s" x i j)))))))
+)
+
+(mat exact-integer-sqrt
+  (error? (exact-integer-sqrt))
+  (error? (exact-integer-sqrt 3 4)) 
+  (error? (exact-integer-sqrt 1.0))
+  (error? (exact-integer-sqrt 'a))
+  (error? (exact-integer-sqrt -1))
+  (error? (exact-integer-sqrt 10.0+0.0i))
+  (begin
+    (define ($eispair x)
+      (call-with-values (lambda () (exact-integer-sqrt x)) cons))
+    #t)
+  (equal? ($eispair 1) '(1 . 0))
+  (equal? ($eispair 9) '(3 . 0))
+  (equal? ($eispair 10) '(3 . 1))
+  (equal? ($eispair 1000) '(31 . 39))
+  (do ([n 1000 (fx- n 1)])
+      ((fx= n 0) #t)
+    (let ([x (random (expt 10 1000))])
+      (unless (let ([p ($eispair x)])
+                (let ([s (car p)] [r (cdr p)])
+                  (and (<= (* s s) x)
+                       (> (* (+ s 1) (+ s 1)) x)
+                       (= (+ (* s s) r) x))))
+        (errorf #f "failed for ~s" x))))
+)
+
+
+(define x -11111111111111111111111111111111111111111111111)
+(define n -10)
+
+
+(mat integer-length
+   (error? (integer-length))
+   (error? (integer-length 1 1 1))
+   (error? (integer-length .1))
+   (= (integer-length 0) 0)
+   (= (integer-length 1) 1)
+   (= (integer-length 3) 2)
+   (= (integer-length 4) 3)
+   (= (integer-length 7) 3)
+   (= (integer-length -1) 0)
+   (= (integer-length -4) 2)
+   (= (integer-length -7) 3)
+   (= (integer-length -8) 3)
+   (= (integer-length (expt 2 1000)) 1001)
+   (= (integer-length (+ (expt 2 1000) 1)) 1001)
+   (= (integer-length (- (expt 2 1000) 1)) 1000)
+   (= (integer-length (- (expt 2 1000))) 1000)
+   (= (integer-length (- -1 (expt 2 1000))) 1001)
+   (= (integer-length (- 1 (expt 2 1000))) 1000)
+)
+
+(mat bitwise-length
+   (error? (bitwise-length))
+   (error? (bitwise-length 1 1 1))
+   (error? (bitwise-length .1))
+   (= (bitwise-length 0) 0)
+   (= (bitwise-length 1) 1)
+   (= (bitwise-length 3) 2)
+   (= (bitwise-length 4) 3)
+   (= (bitwise-length 7) 3)
+   (= (bitwise-length -1) 0)
+   (= (bitwise-length -4) 2)
+   (= (bitwise-length -7) 3)
+   (= (bitwise-length -8) 3)
+   (= (bitwise-length (expt 2 1000)) 1001)
+   (= (bitwise-length (+ (expt 2 1000) 1)) 1001)
+   (= (bitwise-length (- (expt 2 1000) 1)) 1000)
+   (= (bitwise-length (- (expt 2 1000))) 1000)
+   (= (bitwise-length (- -1 (expt 2 1000))) 1001)
+   (= (bitwise-length (- 1 (expt 2 1000))) 1000)
+   (let ()
+     (define r6rs-length
+       (lambda (x)
+         (do ([result 0 (+ result 1)]
+              [bits (if (negative? x) (bitwise-not x) x)
+                    (bitwise-arithmetic-shift-right bits 1)])
+             ((zero? bits) result))))
+     (let f ([n 10000])
+       (or (= n 0)
+           (let ([x (random (expt 2 1000))])
+             (and (= (bitwise-length x) (r6rs-length x))
+                  (= (bitwise-length (- x)) (r6rs-length (- x)))
+                  (f (- n 1)))))))
+)
+
+(mat bitwise-bit-count
+  (error? (bitwise-bit-count))
+  (error? (bitwise-bit-count 75 32))
+  (error? (bitwise-bit-count 3.0))
+  (error? (bitwise-bit-count 'a))
+  (eqv? (bitwise-bit-count 0) 0)
+  (eqv? (bitwise-bit-count #xabcd) 10)
+  (eqv? (bitwise-bit-count #xabcdf0123456789abcdef0123456789) 61)
+  (eqv? (bitwise-bit-count -1) -1)
+  (eqv? (bitwise-bit-count -10) -3)
+  (equal?
+    (map bitwise-bit-count '(0 1 2 3 4 5 6 7 8 9 10))
+    '(0 1 1 2 1 2 2 3 1 2 2))
+  (equal?
+    (map bitwise-bit-count '(-1 -2 -3 -4 -5 -6 -7 -8 -9 -10))
+    '(-1 -2 -2 -3 -2 -3 -3 -4 -2 -3))
+  (let ([n (expt (+ (greatest-fixnum) 1) 4)])
+    (let f ([i 2] [j 1])
+      (or (= i n)
+          (and (eqv? (bitwise-bit-count i) 1)
+               (eqv? (bitwise-bit-count (+ i 1)) 2)
+               (eqv? (bitwise-bit-count (- i 1)) j)
+               (f (bitwise-arithmetic-shift i 1) (+ j 1))))))
+  (let ([n (expt (+ (greatest-fixnum) 1) 4)])
+    (define slow-bit-count
+      (lambda (x)
+        (if (< x 0)
+            (bitwise-not (slow-bit-count (bitwise-not x)))
+            (let f ([x x] [c 0])
+              (if (= x 0)
+                  c
+                  (f (bitwise-arithmetic-shift-right x 1)
+                     (if (bitwise-bit-set? x 0) (+ c 1) c)))))))
+    (let f ([i 10000])
+      (let ([r (random n)])
+        (or (fx= i 0)
+            (and (= (bitwise-bit-count r) (slow-bit-count r))
+                 (= (bitwise-bit-count (- r)) (slow-bit-count (- r)))
+                 (f (fx- i 1)))))))
+)
+
+(mat bitwise-first-bit-set
+  (error? (bitwise-first-bit-set))
+  (error? (bitwise-first-bit-set 75 32))
+  (error? (bitwise-first-bit-set 3.0))
+  (error? (bitwise-first-bit-set 'a))
+  (eqv? (bitwise-first-bit-set 0) -1)
+  (eqv? (bitwise-first-bit-set 1) 0)
+  (eqv? (bitwise-first-bit-set -1) 0)
+  (eqv? (bitwise-first-bit-set -4) 2)
+  (eqv? (bitwise-first-bit-set #xabcdf0123400000000000000000) 70)
+  (eqv? (bitwise-first-bit-set #x-abcdf0123400000000000000000) 70)
+  (equal?
+    (map bitwise-first-bit-set '(0 1 2 3 4 5 6 7 8 9 10))
+    '(-1 0 1 0 2 0 1 0 3 0 1))
+  (equal?
+    (map bitwise-first-bit-set '(-1 -2 -3 -4 -5 -6 -7 -8 -9 -10))
+    '(0 1 0 2 0 1 0 3 0 1))
+  (let ([n (expt (+ (greatest-fixnum) 1) 4)])
+    (let f ([i 2] [j 1])
+      (or (= i n)
+          (and (eqv? (bitwise-first-bit-set i) j)
+               (eqv? (bitwise-first-bit-set (+ i 1)) 0)
+               (eqv? (bitwise-first-bit-set (- i 1)) 0)
+               (f (bitwise-arithmetic-shift i 1) (fx+ j 1))))))
+  (let ([n (+ (greatest-fixnum) 1)])
+    (define slow-first-bit-set
+      (lambda (x)
+        (if (= x 0)
+            0
+            (let f ([x x])
+              (if (odd? x) 0 (+ (f (bitwise-arithmetic-shift-right x 1)) 1))))))
+    (let f ([i 10000])
+      (let ([r (bitwise-arithmetic-shift-left (random n) (random 100))])
+        (unless (fx= i 0)
+          (unless (and (= (bitwise-first-bit-set r) (slow-first-bit-set r))
+                       (= (bitwise-first-bit-set (- r)) (slow-first-bit-set (- r))))
+            (errorf #f "failed for ~s" r))
+          (f (fx- i 1)))))
+    #t)
+)
+
+(define quotient-remainder
+   (parameterize ([subset-mode 'system])
+      (eval '$quotient-remainder)))
+
+(mat $quotient-remainder
+   (error? (quotient-remainder))
+   (error? (quotient-remainder 1))
+   (error? (quotient-remainder 1 1 1))
+   (error? (quotient-remainder 1 0))
+   (equal? (quotient-remainder 103 5) '(20 . 3))
+   (equal? (quotient-remainder 103 -5) '(-20 . 3))
+   (equal? (quotient-remainder -103 5) '(-20 . -3))
+   (equal? (quotient-remainder -103 -5) '( 20 . -3))
+   (let ([x 11111111111111111] [y 11111111111111])
+      (equal? (quotient-remainder x y) (cons (quotient x y) (remainder x y))))
+   (let ([x 11111111111111111] [y -11111111111111])
+      (equal? (quotient-remainder x y) (cons (quotient x y) (remainder x y))))
+   (let ([x -11111111111111111] [y 11111111111111])
+      (equal? (quotient-remainder x y) (cons (quotient x y) (remainder x y))))
+   (let ([x -11111111111111111] [y -11111111111111])
+      (equal? (quotient-remainder x y) (cons (quotient x y) (remainder x y))))
+   ;; following returns incorrect result in all versions prior to 5.9b
+   (equal? (quotient-remainder (most-negative-fixnum)
+                               (- (most-negative-fixnum)))
+           '(-1 . 0))
+)
+
+(mat lognot
+  (error? (lognot (void)))
+  (error? (lognot "hello"))
+  (error? (lognot 3/4))
+  (error? (lognot 7.7))
+  (error? (lognot 1+3i))
+  (error? (lognot 1.0-7.5i))
+  (error? (lognot 3.0))
+  (eqv? (lognot 0) -1)
+  (eqv? (lognot -1) 0)
+  (eqv? (lognot 2) -3)
+  (eqv? (lognot #xfffffffffffffffffffffffffffff)
+        #x-100000000000000000000000000000)
+  (eqv? (lognot #x-100000000000000000000000000000)
+        #xfffffffffffffffffffffffffffff)
+)
+
+(mat bitwise-not
+  (error? (bitwise-not (void)))
+  (error? (bitwise-not "hello"))
+  (error? (bitwise-not 3/4))
+  (error? (bitwise-not 7.7))
+  (error? (bitwise-not 1+3i))
+  (error? (bitwise-not 1.0-7.5i))
+  (error? (bitwise-not 3.0))
+  (eqv? (bitwise-not 0) -1)
+  (eqv? (bitwise-not -1) 0)
+  (eqv? (bitwise-not 2) -3)
+  (eqv? (bitwise-not #xfffffffffffffffffffffffffffff)
+        #x-100000000000000000000000000000)
+  (eqv? (bitwise-not #x-100000000000000000000000000000)
+        #xfffffffffffffffffffffffffffff)
+)
+
+(mat logand
+  (error? (logand (void) 0))
+  (error? (logand 0 (void)))
+  (error? (logand 'a 17))
+  (error? (logand 17 'a))
+  (error? (logand 25 "oops"))
+  (error? (logand "oops" 25))
+  (error? (logand 25 3.4))
+  (error? (logand 3.4 25))
+  (error? (logand 0 3/4))
+  (error? (logand 3/4 0))
+  (error? (logand 0 1+1i))
+  (error? (logand 1+1i 0))
+  (error? (logand 1 3.4-2.3i))
+  (error? (logand 3.4-2.3i 1))
+  (error? (logand 3.0 4.0))
+  (eqv? (logand 0 0) 0)
+  (eqv? (logand -1 0) 0)
+  (eqv? (logand #xfffffffffffffffffffffffff 0) 0)
+  (eqv? (logand 0 -1) 0)
+  (eqv? (logand 0 #xfffffffffffffffffffffffff) 0)
+  (eqv? (logand 20 -1) 20)
+  (eqv? (logand #xfffffffffffffffffffffffff -1) #xfffffffffffffffffffffffff)
+  (eqv? (logand #x1111111111111111111111111 -1) #x1111111111111111111111111)
+  (eqv? (logand (- (expt 2 300) 167) -1) (- (expt 2 300) 167))
+  (eqv? (logand (- 167 (expt 2 300)) -1) (- 167 (expt 2 300)))
+  (eqv? (logand (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (eqv? (logand (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (eqv? (logand #x1111111111111111111111111 #x2222222222222222222222222) 0) 
+  (eqv? (logand #x1212121212121212121212121 #x2222222222222222222222222)
+        #x202020202020202020202020)
+  (eqv? (logand #x-1212121212121212121212121
+                #x-2222222222222222222222222)
+        #x-3232323232323232323232322)
+  (eqv? (logand #x-123456789abcdeffedca987654321
+                #xfedca987654321123456789abcdef)
+        #xECC8A9876543210010146088A8CCF)
+  (eqv? (logand #x2B225D27F49C1FED301B89103
+                #x-F2D8DD782236F835A1A50858)
+        #x20025020749C106C200189100)
+  (eqv? (logand #x2B225D27F49C1FED301B89103
+                #x1F366567)
+        #x1300103)
+  (eqv? (logand #x2B225D27F49C1FED301B89103
+                #x-717D004)
+        #x2B225D27F49C1FED300A80100)
+  (eqv? (logand #x-F2D8DD782236F835A1A50858
+                #x1F366567)
+        #x1E126520)
+  (eqv? (logand #x-F2D8DD782236F835A1A50858
+                #x-717D004)
+        #x-F2D8DD782236F835A7B7D858)
+  (eqv? (logand #x1F366567
+                #x2B225D27F49C1FED301B89103)
+        #x1300103)
+  (eqv? (logand #x-717D004
+                #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED300A80100)
+  (eqv? (logand #x1F366567
+                #x-F2D8DD782236F835A1A50858)
+        #x1E126520)
+  (eqv? (logand #x-717D004
+                #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835A7B7D858)
+  (eqv? (logand) -1)
+  (eqv? (logand #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (logand #x1212121212121212121212121
+                #x2222222222222222222222222
+                #x0103010301030103010301030)
+        #x2000200020002000200020)
+  (eqv? (logand #b1110111
+                #b1101011
+                -1
+                #b1011110
+                #b1000111)
+        #b1000010)
+  (eqv? (logand #b1110111
+                #b1101011
+                0
+                #b1011110
+                #b1000111)
+        0)
+  (test-cp0-expansion eqv? '(logand 0 0) 0)
+  (test-cp0-expansion eqv? '(logand -1 0) 0)
+  (test-cp0-expansion eqv? '(logand #xfffffffffffffffffffffffff 0) 0)
+  (test-cp0-expansion eqv? '(logand 0 -1) 0)
+  (test-cp0-expansion eqv? '(logand 0 #xfffffffffffffffffffffffff) 0)
+  (test-cp0-expansion eqv? '(logand 20 -1) 20)
+  (test-cp0-expansion eqv? '(logand #xfffffffffffffffffffffffff -1) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(logand #x1111111111111111111111111 -1) #x1111111111111111111111111)
+  (test-cp0-expansion eqv? '(logand (- (expt 2 300) 167) -1) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(logand (- 167 (expt 2 300)) -1) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? '(logand (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(logand (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? '(logand #x1111111111111111111111111 #x2222222222222222222222222) 0) 
+  (test-cp0-expansion eqv? '(logand #x1212121212121212121212121 #x2222222222222222222222222)
+    #x202020202020202020202020)
+  (test-cp0-expansion eqv? 
+    '(logand #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x-3232323232323232323232322)
+  (test-cp0-expansion eqv? 
+    '(logand #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #xECC8A9876543210010146088A8CCF)
+  (test-cp0-expansion eqv? 
+    '(logand #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x20025020749C106C200189100)
+  (test-cp0-expansion eqv? 
+    '(logand #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x1300103)
+  (test-cp0-expansion eqv? 
+    '(logand #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x2B225D27F49C1FED300A80100)
+  (test-cp0-expansion eqv? 
+    '(logand #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x1E126520)
+  (test-cp0-expansion eqv? 
+    '(logand #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #x-F2D8DD782236F835A7B7D858)
+  (test-cp0-expansion eqv? 
+    '(logand #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x1300103)
+  (test-cp0-expansion eqv? 
+    '(logand #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED300A80100)
+  (test-cp0-expansion eqv? 
+    '(logand #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x1E126520)
+  (test-cp0-expansion eqv? 
+    '(logand #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835A7B7D858)
+  (test-cp0-expansion eqv? 
+    '(logand) -1)
+  (test-cp0-expansion eqv? 
+    '(logand #x1212121212121212121212121)
+    #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(logand #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x2000200020002000200020)
+  (test-cp0-expansion eqv? 
+    '(logand #b1110111
+       #b1101011
+       -1
+       #b1011110
+       #b1000111)
+    #b1000010)
+  (test-cp0-expansion eqv? 
+    '(logand #b1110111
+       #b1101011
+       0
+       #b1011110
+       #b1000111)
+    0)
+)
+
+(mat bitwise-and
+  (error? (bitwise-and (void) 0))
+  (error? (bitwise-and 0 (void)))
+  (error? (bitwise-and 'a 17))
+  (error? (bitwise-and 17 'a))
+  (error? (bitwise-and 25 "oops"))
+  (error? (bitwise-and "oops" 25))
+  (error? (bitwise-and 25 3.4))
+  (error? (bitwise-and 3.4 25))
+  (error? (bitwise-and 0 3/4))
+  (error? (bitwise-and 3/4 0))
+  (error? (bitwise-and 0 1+1i))
+  (error? (bitwise-and 1+1i 0))
+  (error? (bitwise-and 1 3.4-2.3i))
+  (error? (bitwise-and 3.4-2.3i 1))
+  (error? (bitwise-and 3.0 4.0))
+  (eqv? (bitwise-and 0 0) 0)
+  (eqv? (bitwise-and -1 0) 0)
+  (eqv? (bitwise-and #xfffffffffffffffffffffffff 0) 0)
+  (eqv? (bitwise-and 0 -1) 0)
+  (eqv? (bitwise-and 0 #xfffffffffffffffffffffffff) 0)
+  (eqv? (bitwise-and 20 -1) 20)
+  (eqv? (bitwise-and #xfffffffffffffffffffffffff -1) #xfffffffffffffffffffffffff)
+  (eqv? (bitwise-and #x1111111111111111111111111 -1) #x1111111111111111111111111)
+  (eqv? (bitwise-and (- (expt 2 300) 167) -1) (- (expt 2 300) 167))
+  (eqv? (bitwise-and (- 167 (expt 2 300)) -1) (- 167 (expt 2 300)))
+  (eqv? (bitwise-and (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (eqv? (bitwise-and (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (eqv? (bitwise-and #x1111111111111111111111111 #x2222222222222222222222222) 0) 
+  (eqv? (bitwise-and #x1212121212121212121212121 #x2222222222222222222222222)
+        #x202020202020202020202020)
+  (eqv? (bitwise-and #x-1212121212121212121212121
+                #x-2222222222222222222222222)
+        #x-3232323232323232323232322)
+  (eqv? (bitwise-and #x-123456789abcdeffedca987654321
+                #xfedca987654321123456789abcdef)
+        #xECC8A9876543210010146088A8CCF)
+  (eqv? (bitwise-and #x2B225D27F49C1FED301B89103
+                #x-F2D8DD782236F835A1A50858)
+        #x20025020749C106C200189100)
+  (eqv? (bitwise-and #x2B225D27F49C1FED301B89103
+                #x1F366567)
+        #x1300103)
+  (eqv? (bitwise-and #x2B225D27F49C1FED301B89103
+                #x-717D004)
+        #x2B225D27F49C1FED300A80100)
+  (eqv? (bitwise-and #x-F2D8DD782236F835A1A50858
+                #x1F366567)
+        #x1E126520)
+  (eqv? (bitwise-and #x-F2D8DD782236F835A1A50858
+                #x-717D004)
+        #x-F2D8DD782236F835A7B7D858)
+  (eqv? (bitwise-and #x1F366567
+                #x2B225D27F49C1FED301B89103)
+        #x1300103)
+  (eqv? (bitwise-and #x-717D004
+                #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED300A80100)
+  (eqv? (bitwise-and #x1F366567
+                #x-F2D8DD782236F835A1A50858)
+        #x1E126520)
+  (eqv? (bitwise-and #x-717D004
+                #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835A7B7D858)
+  (eqv? (bitwise-and) -1)
+  (eqv? (bitwise-and #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (bitwise-and #x1212121212121212121212121
+                #x2222222222222222222222222
+                #x0103010301030103010301030)
+        #x2000200020002000200020)
+  (eqv? (bitwise-and #b1110111
+                #b1101011
+                -1
+                #b1011110
+                #b1000111)
+        #b1000010)
+  (eqv? (bitwise-and #b1110111
+                #b1101011
+                0
+                #b1011110
+                #b1000111)
+        0)
+  (test-cp0-expansion eqv? '(bitwise-and 0 0) 0)
+  (test-cp0-expansion eqv? '(bitwise-and -1 0) 0)
+  (test-cp0-expansion eqv? '(bitwise-and #xfffffffffffffffffffffffff 0) 0)
+  (test-cp0-expansion eqv? '(bitwise-and 0 -1) 0)
+  (test-cp0-expansion eqv? '(bitwise-and 0 #xfffffffffffffffffffffffff) 0)
+  (test-cp0-expansion eqv? '(bitwise-and 20 -1) 20)
+  (test-cp0-expansion eqv? '(bitwise-and #xfffffffffffffffffffffffff -1) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(bitwise-and #x1111111111111111111111111 -1) #x1111111111111111111111111)
+  (test-cp0-expansion eqv? '(bitwise-and (- (expt 2 300) 167) -1) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(bitwise-and (- 167 (expt 2 300)) -1) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? '(bitwise-and (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(bitwise-and (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? '(bitwise-and #x1111111111111111111111111 #x2222222222222222222222222) 0) 
+  (test-cp0-expansion eqv? '(bitwise-and #x1212121212121212121212121 #x2222222222222222222222222)
+    #x202020202020202020202020)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x-3232323232323232323232322)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #xECC8A9876543210010146088A8CCF)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x20025020749C106C200189100)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x1300103)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x2B225D27F49C1FED300A80100)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x1E126520)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #x-F2D8DD782236F835A7B7D858)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x1300103)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED300A80100)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x1E126520)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835A7B7D858)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and) -1)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x1212121212121212121212121)
+    #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x2000200020002000200020)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #b1110111
+       #b1101011
+       -1
+       #b1011110
+       #b1000111)
+    #b1000010)
+  (test-cp0-expansion eqv? 
+    '(bitwise-and #b1110111
+       #b1101011
+       0
+       #b1011110
+       #b1000111)
+    0)
+)
+
+(mat logior ; same as logor
+  (error? (logior (void) 0))
+  (error? (logior 0 (void)))
+  (error? (logior 'a 17))
+  (error? (logior 17 'a))
+  (error? (logior 25 "oops"))
+  (error? (logior "oops" 25))
+  (error? (logior 25 3.4))
+  (error? (logior 3.4 25))
+  (error? (logior 0 3/4))
+  (error? (logior 3/4 0))
+  (error? (logior 0 1+1i))
+  (error? (logior 1+1i 0))
+  (error? (logior 1 3.4-2.3i))
+  (error? (logior 3.4-2.3i 1))
+  (error? (logior 3.0 4.0))
+  (eqv? (logior 0 0) 0)
+  (eqv? (logior -1 0) -1)
+  (eqv? (logior #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (eqv? (logior 0 -1) -1)
+  (eqv? (logior 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (eqv? (logior 20 -1) -1)
+  (eqv? (logior #xfffffffffffffffffffffffff -1) -1)
+  (eqv? (logior #x1111111111111111111111111 -1) -1)
+  (eqv? (logior (- (expt 2 300) 167) -1) -1)
+  (eqv? (logior (- 167 (expt 2 300)) -1) -1)
+  (eqv? (logior (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (eqv? (logior (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (eqv? (logior #x1111111111111111111111111 #x2222222222222222222222222)
+        #x3333333333333333333333333)
+  (eqv? (logior #x1212121212121212121212121 #x2222222222222222222222222)
+        #x3232323232323232323232323)
+  (eqv? (logior #x-1212121212121212121212121
+               #x-2222222222222222222222222)
+        #x-202020202020202020202021)
+  (eqv? (logior #x-3333333333333333333333333 #x-2222222222222222222222222)
+        #x-2222222222222222222222221)
+  (eqv? (logior #x-123456789abcdeffedca987654321
+               #x-fedca987654321123456789abcdef)
+        #x-12140000000000122442181214121)
+  (eqv? (logior #x-123456789abcdeffedca987654321
+               #x-fedca987654321123456789abcdef)
+        #x-12140000000000122442181214121)
+  (eqv? (logior #x-123456789abcdeffedca987654321
+               #xfedca987654321123456789abcdef)
+        #x-2056789ABCDEEDC988806440201)
+  (eqv? (logior #x2B225D27F49C1FED301B89103
+               #x-F2D8DD782236F835A1A50858)
+        #x-40D80D0022360024A0050855)
+  (eqv? (logior #x2B225D27F49C1FED301B89103
+               #x1F366567)
+        #x2B225D27F49C1FED31FBEF567)
+  (eqv? (logior #x2B225D27F49C1FED301B89103
+               #x-717D004)
+        #x-6074001)
+  (eqv? (logior #x-F2D8DD782236F835A1A50858
+               #x1F366567)
+        #x-F2D8DD782236F835A0810811)
+  (eqv? (logior #x-F2D8DD782236F835A1A50858
+               #x-717D004)
+        #x-1050004)
+  (eqv? (logior #x1F366567
+               #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED31FBEF567)
+  (eqv? (logior #x-717D004
+               #x2B225D27F49C1FED301B89103)
+        #x-6074001)
+  (eqv? (logior #x1F366567
+               #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835A0810811)
+  (eqv? (logior #x-717D004
+               #x-F2D8DD782236F835A1A50858)
+        #x-1050004)
+  (eqv? (logior) 0)
+  (eqv? (logior #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (logior #x1212121212121212121212121
+               #x2222222222222222222222222
+               #x0103010301030103010301030)
+        #x3333333333333333333333333)
+  (eqv? (logior #b1010111
+               #b1001011
+               -1
+               #b1011110
+               #b1000111)
+        -1)
+  (eqv? (logior #b1010111
+               #b1001011
+               0
+               #b1011110
+               #b1000111)
+        #b1011111)
+  (test-cp0-expansion eqv? '(logior 0 0) 0)
+  (test-cp0-expansion eqv? '(logior -1 0) -1)
+  (test-cp0-expansion eqv? '(logior #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(logior 0 -1) -1)
+  (test-cp0-expansion eqv? '(logior 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(logior 20 -1) -1)
+  (test-cp0-expansion eqv? '(logior #xfffffffffffffffffffffffff -1) -1)
+  (test-cp0-expansion eqv? '(logior #x1111111111111111111111111 -1) -1)
+  (test-cp0-expansion eqv? '(logior (- (expt 2 300) 167) -1) -1)
+  (test-cp0-expansion eqv? '(logior (- 167 (expt 2 300)) -1) -1)
+  (test-cp0-expansion eqv? '(logior (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(logior (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? 
+    '(logior #x1111111111111111111111111 #x2222222222222222222222222)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(logior #x1212121212121212121212121 #x2222222222222222222222222)
+    #x3232323232323232323232323)
+  (test-cp0-expansion eqv? 
+    '(logior #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x-202020202020202020202021)
+  (test-cp0-expansion eqv? 
+    '(logior #x-3333333333333333333333333 #x-2222222222222222222222222)
+    #x-2222222222222222222222221)
+  (test-cp0-expansion eqv? 
+    '(logior #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #x-12140000000000122442181214121)
+  (test-cp0-expansion eqv? 
+    '(logior #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #x-12140000000000122442181214121)
+  (test-cp0-expansion eqv? 
+    '(logior #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #x-2056789ABCDEEDC988806440201)
+  (test-cp0-expansion eqv? 
+    '(logior #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x-40D80D0022360024A0050855)
+  (test-cp0-expansion eqv? 
+    '(logior #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x2B225D27F49C1FED31FBEF567)
+  (test-cp0-expansion eqv? 
+    '(logior #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x-6074001)
+  (test-cp0-expansion eqv? 
+    '(logior #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x-F2D8DD782236F835A0810811)
+  (test-cp0-expansion eqv? 
+    '(logior #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #x-1050004)
+  (test-cp0-expansion eqv? 
+    '(logior #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED31FBEF567)
+  (test-cp0-expansion eqv? 
+    '(logior #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x-6074001)
+  (test-cp0-expansion eqv? 
+    '(logior #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835A0810811)
+  (test-cp0-expansion eqv? 
+    '(logior #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #x-1050004)
+  (test-cp0-expansion eqv? '(logior) 0)
+  (test-cp0-expansion eqv? '(logior #x1212121212121212121212121)
+    #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(logior #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(logior #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+        -1)
+  (test-cp0-expansion eqv? 
+    '(logior #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    #b1011111)
+)
+
+(mat logor
+  (error? (logor (void) 0))
+  (error? (logor 0 (void)))
+  (error? (logor 'a 17))
+  (error? (logor 17 'a))
+  (error? (logor 25 "oops"))
+  (error? (logor "oops" 25))
+  (error? (logor 25 3.4))
+  (error? (logor 3.4 25))
+  (error? (logor 0 3/4))
+  (error? (logor 3/4 0))
+  (error? (logor 0 1+1i))
+  (error? (logor 1+1i 0))
+  (error? (logor 1 3.4-2.3i))
+  (error? (logor 3.4-2.3i 1))
+  (error? (logor 3.0 4.0))
+  (eqv? (logor 0 0) 0)
+  (eqv? (logor -1 0) -1)
+  (eqv? (logor #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (eqv? (logor 0 -1) -1)
+  (eqv? (logor 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (eqv? (logor 20 -1) -1)
+  (eqv? (logor #xfffffffffffffffffffffffff -1) -1)
+  (eqv? (logor #x1111111111111111111111111 -1) -1)
+  (eqv? (logor (- (expt 2 300) 167) -1) -1)
+  (eqv? (logor (- 167 (expt 2 300)) -1) -1)
+  (eqv? (logor (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (eqv? (logor (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (eqv? (logor #x1111111111111111111111111 #x2222222222222222222222222)
+        #x3333333333333333333333333)
+  (eqv? (logor #x1212121212121212121212121 #x2222222222222222222222222)
+        #x3232323232323232323232323)
+  (eqv? (logor #x-1212121212121212121212121
+               #x-2222222222222222222222222)
+        #x-202020202020202020202021)
+  (eqv? (logor #x-3333333333333333333333333 #x-2222222222222222222222222)
+        #x-2222222222222222222222221)
+  (eqv? (logor #x-123456789abcdeffedca987654321
+               #x-fedca987654321123456789abcdef)
+        #x-12140000000000122442181214121)
+  (eqv? (logor #x-123456789abcdeffedca987654321
+               #x-fedca987654321123456789abcdef)
+        #x-12140000000000122442181214121)
+  (eqv? (logor #x-123456789abcdeffedca987654321
+               #xfedca987654321123456789abcdef)
+        #x-2056789ABCDEEDC988806440201)
+  (eqv? (logor #x2B225D27F49C1FED301B89103
+               #x-F2D8DD782236F835A1A50858)
+        #x-40D80D0022360024A0050855)
+  (eqv? (logor #x2B225D27F49C1FED301B89103
+               #x1F366567)
+        #x2B225D27F49C1FED31FBEF567)
+  (eqv? (logor #x2B225D27F49C1FED301B89103
+               #x-717D004)
+        #x-6074001)
+  (eqv? (logor #x-F2D8DD782236F835A1A50858
+               #x1F366567)
+        #x-F2D8DD782236F835A0810811)
+  (eqv? (logor #x-F2D8DD782236F835A1A50858
+               #x-717D004)
+        #x-1050004)
+  (eqv? (logor #x1F366567
+               #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED31FBEF567)
+  (eqv? (logor #x-717D004
+               #x2B225D27F49C1FED301B89103)
+        #x-6074001)
+  (eqv? (logor #x1F366567
+               #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835A0810811)
+  (eqv? (logor #x-717D004
+               #x-F2D8DD782236F835A1A50858)
+        #x-1050004)
+  (eqv? (logor) 0)
+  (eqv? (logor #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (logor #x1212121212121212121212121
+               #x2222222222222222222222222
+               #x0103010301030103010301030)
+        #x3333333333333333333333333)
+  (eqv? (logor #b1010111
+               #b1001011
+               -1
+               #b1011110
+               #b1000111)
+        -1)
+  (eqv? (logor #b1010111
+               #b1001011
+               0
+               #b1011110
+               #b1000111)
+        #b1011111)
+  (test-cp0-expansion eqv? '(logor 0 0) 0)
+  (test-cp0-expansion eqv? '(logor -1 0) -1)
+  (test-cp0-expansion eqv? '(logor #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(logor 0 -1) -1)
+  (test-cp0-expansion eqv? '(logor 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(logor 20 -1) -1)
+  (test-cp0-expansion eqv? '(logor #xfffffffffffffffffffffffff -1) -1)
+  (test-cp0-expansion eqv? '(logor #x1111111111111111111111111 -1) -1)
+  (test-cp0-expansion eqv? '(logor (- (expt 2 300) 167) -1) -1)
+  (test-cp0-expansion eqv? '(logor (- 167 (expt 2 300)) -1) -1)
+  (test-cp0-expansion eqv? '(logor (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(logor (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? 
+    '(logor #x1111111111111111111111111 #x2222222222222222222222222)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(logor #x1212121212121212121212121 #x2222222222222222222222222)
+    #x3232323232323232323232323)
+  (test-cp0-expansion eqv? 
+    '(logor #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x-202020202020202020202021)
+  (test-cp0-expansion eqv? 
+    '(logor #x-3333333333333333333333333 #x-2222222222222222222222222)
+    #x-2222222222222222222222221)
+  (test-cp0-expansion eqv? 
+    '(logor #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #x-12140000000000122442181214121)
+  (test-cp0-expansion eqv? 
+    '(logor #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #x-12140000000000122442181214121)
+  (test-cp0-expansion eqv? 
+    '(logor #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #x-2056789ABCDEEDC988806440201)
+  (test-cp0-expansion eqv? 
+    '(logor #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x-40D80D0022360024A0050855)
+  (test-cp0-expansion eqv? 
+    '(logor #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x2B225D27F49C1FED31FBEF567)
+  (test-cp0-expansion eqv? 
+    '(logor #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x-6074001)
+  (test-cp0-expansion eqv? 
+    '(logor #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x-F2D8DD782236F835A0810811)
+  (test-cp0-expansion eqv? 
+    '(logor #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #x-1050004)
+  (test-cp0-expansion eqv? 
+    '(logor #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED31FBEF567)
+  (test-cp0-expansion eqv? 
+    '(logor #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x-6074001)
+  (test-cp0-expansion eqv? 
+    '(logor #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835A0810811)
+  (test-cp0-expansion eqv? 
+    '(logor #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #x-1050004)
+  (test-cp0-expansion eqv? '(logor) 0)
+  (test-cp0-expansion eqv? '(logor #x1212121212121212121212121)
+    #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(logor #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(logor #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+        -1)
+  (test-cp0-expansion eqv? 
+    '(logor #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    #b1011111)
+)
+
+(mat bitwise-ior ; same as logor
+  (error? (bitwise-ior (void) 0))
+  (error? (bitwise-ior 0 (void)))
+  (error? (bitwise-ior 'a 17))
+  (error? (bitwise-ior 17 'a))
+  (error? (bitwise-ior 25 "oops"))
+  (error? (bitwise-ior "oops" 25))
+  (error? (bitwise-ior 25 3.4))
+  (error? (bitwise-ior 3.4 25))
+  (error? (bitwise-ior 0 3/4))
+  (error? (bitwise-ior 3/4 0))
+  (error? (bitwise-ior 0 1+1i))
+  (error? (bitwise-ior 1+1i 0))
+  (error? (bitwise-ior 1 3.4-2.3i))
+  (error? (bitwise-ior 3.4-2.3i 1))
+  (error? (bitwise-ior 3.0 4.0))
+  (eqv? (bitwise-ior 0 0) 0)
+  (eqv? (bitwise-ior -1 0) -1)
+  (eqv? (bitwise-ior #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (eqv? (bitwise-ior 0 -1) -1)
+  (eqv? (bitwise-ior 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (eqv? (bitwise-ior 20 -1) -1)
+  (eqv? (bitwise-ior #xfffffffffffffffffffffffff -1) -1)
+  (eqv? (bitwise-ior #x1111111111111111111111111 -1) -1)
+  (eqv? (bitwise-ior (- (expt 2 300) 167) -1) -1)
+  (eqv? (bitwise-ior (- 167 (expt 2 300)) -1) -1)
+  (eqv? (bitwise-ior (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (eqv? (bitwise-ior (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (eqv? (bitwise-ior #x1111111111111111111111111 #x2222222222222222222222222)
+        #x3333333333333333333333333)
+  (eqv? (bitwise-ior #x1212121212121212121212121 #x2222222222222222222222222)
+        #x3232323232323232323232323)
+  (eqv? (bitwise-ior #x-1212121212121212121212121
+               #x-2222222222222222222222222)
+        #x-202020202020202020202021)
+  (eqv? (bitwise-ior #x-3333333333333333333333333 #x-2222222222222222222222222)
+        #x-2222222222222222222222221)
+  (eqv? (bitwise-ior #x-123456789abcdeffedca987654321
+               #x-fedca987654321123456789abcdef)
+        #x-12140000000000122442181214121)
+  (eqv? (bitwise-ior #x-123456789abcdeffedca987654321
+               #x-fedca987654321123456789abcdef)
+        #x-12140000000000122442181214121)
+  (eqv? (bitwise-ior #x-123456789abcdeffedca987654321
+               #xfedca987654321123456789abcdef)
+        #x-2056789ABCDEEDC988806440201)
+  (eqv? (bitwise-ior #x2B225D27F49C1FED301B89103
+               #x-F2D8DD782236F835A1A50858)
+        #x-40D80D0022360024A0050855)
+  (eqv? (bitwise-ior #x2B225D27F49C1FED301B89103
+               #x1F366567)
+        #x2B225D27F49C1FED31FBEF567)
+  (eqv? (bitwise-ior #x2B225D27F49C1FED301B89103
+               #x-717D004)
+        #x-6074001)
+  (eqv? (bitwise-ior #x-F2D8DD782236F835A1A50858
+               #x1F366567)
+        #x-F2D8DD782236F835A0810811)
+  (eqv? (bitwise-ior #x-F2D8DD782236F835A1A50858
+               #x-717D004)
+        #x-1050004)
+  (eqv? (bitwise-ior #x1F366567
+               #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED31FBEF567)
+  (eqv? (bitwise-ior #x-717D004
+               #x2B225D27F49C1FED301B89103)
+        #x-6074001)
+  (eqv? (bitwise-ior #x1F366567
+               #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835A0810811)
+  (eqv? (bitwise-ior #x-717D004
+               #x-F2D8DD782236F835A1A50858)
+        #x-1050004)
+  (eqv? (bitwise-ior) 0)
+  (eqv? (bitwise-ior #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (bitwise-ior #x1212121212121212121212121
+               #x2222222222222222222222222
+               #x0103010301030103010301030)
+        #x3333333333333333333333333)
+  (eqv? (bitwise-ior #b1010111
+               #b1001011
+               -1
+               #b1011110
+               #b1000111)
+        -1)
+  (eqv? (bitwise-ior #b1010111
+               #b1001011
+               0
+               #b1011110
+               #b1000111)
+        #b1011111)
+  (test-cp0-expansion eqv? '(bitwise-ior 0 0) 0)
+  (test-cp0-expansion eqv? '(bitwise-ior -1 0) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(bitwise-ior 0 -1) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv? '(bitwise-ior 20 -1) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior #xfffffffffffffffffffffffff -1) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior #x1111111111111111111111111 -1) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior (- (expt 2 300) 167) -1) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior (- 167 (expt 2 300)) -1) -1)
+  (test-cp0-expansion eqv? '(bitwise-ior (- (expt 2 300) 167) (- (expt 2 300) 167)) (- (expt 2 300) 167))
+  (test-cp0-expansion eqv? '(bitwise-ior (- 167 (expt 2 300)) (- 167 (expt 2 300))) (- 167 (expt 2 300)))
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x1111111111111111111111111 #x2222222222222222222222222)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x1212121212121212121212121 #x2222222222222222222222222)
+    #x3232323232323232323232323)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x-202020202020202020202021)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-3333333333333333333333333 #x-2222222222222222222222222)
+    #x-2222222222222222222222221)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #x-12140000000000122442181214121)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #x-12140000000000122442181214121)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #x-2056789ABCDEEDC988806440201)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x-40D80D0022360024A0050855)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x2B225D27F49C1FED31FBEF567)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x-6074001)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x-F2D8DD782236F835A0810811)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #x-1050004)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED31FBEF567)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x-6074001)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835A0810811)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #x-1050004)
+  (test-cp0-expansion eqv? '(bitwise-ior) 0)
+  (test-cp0-expansion eqv? '(bitwise-ior #x1212121212121212121212121)
+    #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+        -1)
+  (test-cp0-expansion eqv? 
+    '(bitwise-ior #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    #b1011111)
+)
+
+(mat logxor
+  (error? (logxor (void) 0))
+  (error? (logxor 0 (void)))
+  (error? (logxor 'a 17))
+  (error? (logxor 17 'a))
+  (error? (logxor 25 "oops"))
+  (error? (logxor "oops" 25))
+  (error? (logxor 25 3.4))
+  (error? (logxor 3.4 25))
+  (error? (logxor 0 3/4))
+  (error? (logxor 3/4 0))
+  (error? (logxor 0 1+1i))
+  (error? (logxor 1+1i 0))
+  (error? (logxor 1 3.4-2.3i))
+  (error? (logxor 3.4-2.3i 1))
+  (error? (logxor 3.0 4.0))
+  (eqv? (logxor 0 0) 0)
+  (eqv? (logxor -1 0) -1)
+  (eqv? (logxor #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (eqv? (logxor 0 -1) -1)
+  (eqv? (logxor 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (eqv? (logxor 20 -1) -21)
+  (eqv? (logxor #xfffffffffffffffffffffffff -1)
+        #x-10000000000000000000000000)
+  (eqv? (logxor #x1111111111111111111111111 -1)
+        #x-1111111111111111111111112)
+  (eqv? (logxor (- (expt 2 100) 167) -1) #x-FFFFFFFFFFFFFFFFFFFFFFF5A)
+  (eqv? (logxor (- 167 (expt 2 100)) -1) #xFFFFFFFFFFFFFFFFFFFFFFF58)
+  (eqv? (logxor (- (expt 2 300) 167) (- (expt 2 300) 167)) 0)
+  (eqv? (logxor (- 167 (expt 2 300)) (- 167 (expt 2 300))) 0)
+  (eqv? (logxor #x1111111111111111111111111 #x2222222222222222222222222)
+        #x3333333333333333333333333)
+  (eqv? (logxor #x1212121212121212121212121 #x2222222222222222222222222)
+        #x3030303030303030303030303)
+  (eqv? (logxor #x-1212121212121212121212121
+                #x-2222222222222222222222222)
+        #x3030303030303030303030301)
+  (eqv? (logxor #x-3333333333333333333333333 #x-2222222222222222222222222)
+        #x1111111111111111111111113)
+  (eqv? (logxor #x-123456789abcdeffedca987654321
+                #x-fedca987654321123456789abcdef)
+        #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (eqv? (logxor #x-123456789abcdeffedca987654321
+                #x-fedca987654321123456789abcdef)
+        #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (eqv? (logxor #x-123456789abcdeffedca987654321
+                #xfedca987654321123456789abcdef)
+        #x-ECE8FFFFFFFFFFEDD99CE0ECE8ED0)
+  (eqv? (logxor #x2B225D27F49C1FED301B89103
+                #x-F2D8DD782236F835A1A50858)
+        #x-240FD0F076BF706E6A01D9955)
+  (eqv? (logxor #x2B225D27F49C1FED301B89103
+                #x1F366567)
+        #x2B225D27F49C1FED31E8EF464)
+  (eqv? (logxor #x2B225D27F49C1FED301B89103
+                #x-717D004)
+        #x-2B225D27F49C1FED306AF4101)
+  (eqv? (logxor #x-F2D8DD782236F835A1A50858
+                #x1F366567)
+        #x-F2D8DD782236F835BE936D31)
+  (eqv? (logxor #x-F2D8DD782236F835A1A50858
+                #x-717D004)
+        #xF2D8DD782236F835A6B2D854)
+  (eqv? (logxor #x1F366567
+                #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED31E8EF464)
+  (eqv? (logxor #x-717D004
+                #x2B225D27F49C1FED301B89103)
+        #x-2B225D27F49C1FED306AF4101)
+  (eqv? (logxor #x1F366567
+                #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835BE936D31)
+  (eqv? (logxor #x-717D004
+                #x-F2D8DD782236F835A1A50858)
+        #xF2D8DD782236F835A6B2D854)
+  (eqv? (logxor) 0)
+  (eqv? (logxor #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (logxor #x1212121212121212121212121
+                #x2222222222222222222222222
+                #x0103010301030103010301030)
+        #x3133313331333133313331333)
+  (eqv? (logxor #b1010111
+                #b1001011
+                -1
+                #b1011110
+                #b1000111)
+        -6)
+  (eqv? (logxor #b1010111
+                #b1001011
+                0
+                #b1011110
+                #b1000111)
+        5)
+  (test-cp0-expansion eqv?  '(logxor 0 0) 0)
+  (test-cp0-expansion eqv?  '(logxor -1 0) -1)
+  (test-cp0-expansion eqv?  '(logxor #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv?  '(logxor 0 -1) -1)
+  (test-cp0-expansion eqv?  '(logxor 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv?  '(logxor 20 -1) -21)
+  (test-cp0-expansion eqv? 
+    '(logxor #xfffffffffffffffffffffffff -1)
+    #x-10000000000000000000000000)
+  (test-cp0-expansion eqv? 
+    '(logxor #x1111111111111111111111111 -1)
+    #x-1111111111111111111111112)
+  (test-cp0-expansion eqv? '(logxor (- (expt 2 100) 167) -1) #x-FFFFFFFFFFFFFFFFFFFFFFF5A)
+  (test-cp0-expansion eqv? '(logxor (- 167 (expt 2 100)) -1) #xFFFFFFFFFFFFFFFFFFFFFFF58)
+  (test-cp0-expansion eqv? '(logxor (- (expt 2 300) 167) (- (expt 2 300) 167)) 0)
+  (test-cp0-expansion eqv? '(logxor (- 167 (expt 2 300)) (- 167 (expt 2 300))) 0)
+  (test-cp0-expansion eqv? 
+    '(logxor #x1111111111111111111111111 #x2222222222222222222222222)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(logxor #x1212121212121212121212121 #x2222222222222222222222222)
+    #x3030303030303030303030303)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x3030303030303030303030301)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-3333333333333333333333333 #x-2222222222222222222222222)
+    #x1111111111111111111111113)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #x-ECE8FFFFFFFFFFEDD99CE0ECE8ED0)
+  (test-cp0-expansion eqv? 
+    '(logxor #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x-240FD0F076BF706E6A01D9955)
+  (test-cp0-expansion eqv? 
+    '(logxor #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x2B225D27F49C1FED31E8EF464)
+  (test-cp0-expansion eqv? 
+    '(logxor #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x-2B225D27F49C1FED306AF4101)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x-F2D8DD782236F835BE936D31)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #xF2D8DD782236F835A6B2D854)
+  (test-cp0-expansion eqv? 
+    '(logxor #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED31E8EF464)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x-2B225D27F49C1FED306AF4101)
+  (test-cp0-expansion eqv? 
+    '(logxor #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835BE936D31)
+  (test-cp0-expansion eqv? 
+    '(logxor #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #xF2D8DD782236F835A6B2D854)
+  (test-cp0-expansion eqv?  '(logxor) 0)
+  (test-cp0-expansion eqv?  '(logxor #x1212121212121212121212121) #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(logxor #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x3133313331333133313331333)
+  (test-cp0-expansion eqv? 
+    '(logxor #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -6)
+  (test-cp0-expansion eqv? 
+    '(logxor #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    5)
+)
+
+(mat bitwise-xor
+  (error? (bitwise-xor (void) 0))
+  (error? (bitwise-xor 0 (void)))
+  (error? (bitwise-xor 'a 17))
+  (error? (bitwise-xor 17 'a))
+  (error? (bitwise-xor 25 "oops"))
+  (error? (bitwise-xor "oops" 25))
+  (error? (bitwise-xor 25 3.4))
+  (error? (bitwise-xor 3.4 25))
+  (error? (bitwise-xor 0 3/4))
+  (error? (bitwise-xor 3/4 0))
+  (error? (bitwise-xor 0 1+1i))
+  (error? (bitwise-xor 1+1i 0))
+  (error? (bitwise-xor 1 3.4-2.3i))
+  (error? (bitwise-xor 3.4-2.3i 1))
+  (error? (bitwise-xor 3.0 4.0))
+  (eqv? (bitwise-xor 0 0) 0)
+  (eqv? (bitwise-xor -1 0) -1)
+  (eqv? (bitwise-xor #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (eqv? (bitwise-xor 0 -1) -1)
+  (eqv? (bitwise-xor 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (eqv? (bitwise-xor 20 -1) -21)
+  (eqv? (bitwise-xor #xfffffffffffffffffffffffff -1)
+        #x-10000000000000000000000000)
+  (eqv? (bitwise-xor #x1111111111111111111111111 -1)
+        #x-1111111111111111111111112)
+  (eqv? (bitwise-xor (- (expt 2 100) 167) -1) #x-FFFFFFFFFFFFFFFFFFFFFFF5A)
+  (eqv? (bitwise-xor (- 167 (expt 2 100)) -1) #xFFFFFFFFFFFFFFFFFFFFFFF58)
+  (eqv? (bitwise-xor (- (expt 2 300) 167) (- (expt 2 300) 167)) 0)
+  (eqv? (bitwise-xor (- 167 (expt 2 300)) (- 167 (expt 2 300))) 0)
+  (eqv? (bitwise-xor #x1111111111111111111111111 #x2222222222222222222222222)
+        #x3333333333333333333333333)
+  (eqv? (bitwise-xor #x1212121212121212121212121 #x2222222222222222222222222)
+        #x3030303030303030303030303)
+  (eqv? (bitwise-xor #x-1212121212121212121212121
+                #x-2222222222222222222222222)
+        #x3030303030303030303030301)
+  (eqv? (bitwise-xor #x-3333333333333333333333333 #x-2222222222222222222222222)
+        #x1111111111111111111111113)
+  (eqv? (bitwise-xor #x-123456789abcdeffedca987654321
+                #x-fedca987654321123456789abcdef)
+        #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (eqv? (bitwise-xor #x-123456789abcdeffedca987654321
+                #x-fedca987654321123456789abcdef)
+        #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (eqv? (bitwise-xor #x-123456789abcdeffedca987654321
+                #xfedca987654321123456789abcdef)
+        #x-ECE8FFFFFFFFFFEDD99CE0ECE8ED0)
+  (eqv? (bitwise-xor #x2B225D27F49C1FED301B89103
+                #x-F2D8DD782236F835A1A50858)
+        #x-240FD0F076BF706E6A01D9955)
+  (eqv? (bitwise-xor #x2B225D27F49C1FED301B89103
+                #x1F366567)
+        #x2B225D27F49C1FED31E8EF464)
+  (eqv? (bitwise-xor #x2B225D27F49C1FED301B89103
+                #x-717D004)
+        #x-2B225D27F49C1FED306AF4101)
+  (eqv? (bitwise-xor #x-F2D8DD782236F835A1A50858
+                #x1F366567)
+        #x-F2D8DD782236F835BE936D31)
+  (eqv? (bitwise-xor #x-F2D8DD782236F835A1A50858
+                #x-717D004)
+        #xF2D8DD782236F835A6B2D854)
+  (eqv? (bitwise-xor #x1F366567
+                #x2B225D27F49C1FED301B89103)
+        #x2B225D27F49C1FED31E8EF464)
+  (eqv? (bitwise-xor #x-717D004
+                #x2B225D27F49C1FED301B89103)
+        #x-2B225D27F49C1FED306AF4101)
+  (eqv? (bitwise-xor #x1F366567
+                #x-F2D8DD782236F835A1A50858)
+        #x-F2D8DD782236F835BE936D31)
+  (eqv? (bitwise-xor #x-717D004
+                #x-F2D8DD782236F835A1A50858)
+        #xF2D8DD782236F835A6B2D854)
+  (eqv? (bitwise-xor) 0)
+  (eqv? (bitwise-xor #x1212121212121212121212121)
+        #x1212121212121212121212121)
+  (eqv? (bitwise-xor #x1212121212121212121212121
+                #x2222222222222222222222222
+                #x0103010301030103010301030)
+        #x3133313331333133313331333)
+  (eqv? (bitwise-xor #b1010111
+                #b1001011
+                -1
+                #b1011110
+                #b1000111)
+        -6)
+  (eqv? (bitwise-xor #b1010111
+                #b1001011
+                0
+                #b1011110
+                #b1000111)
+        5)
+  (test-cp0-expansion eqv?  '(bitwise-xor 0 0) 0)
+  (test-cp0-expansion eqv?  '(bitwise-xor -1 0) -1)
+  (test-cp0-expansion eqv?  '(bitwise-xor #xfffffffffffffffffffffffff 0) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv?  '(bitwise-xor 0 -1) -1)
+  (test-cp0-expansion eqv?  '(bitwise-xor 0 #xfffffffffffffffffffffffff) #xfffffffffffffffffffffffff)
+  (test-cp0-expansion eqv?  '(bitwise-xor 20 -1) -21)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #xfffffffffffffffffffffffff -1)
+    #x-10000000000000000000000000)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x1111111111111111111111111 -1)
+    #x-1111111111111111111111112)
+  (test-cp0-expansion eqv? '(bitwise-xor (- (expt 2 100) 167) -1) #x-FFFFFFFFFFFFFFFFFFFFFFF5A)
+  (test-cp0-expansion eqv? '(bitwise-xor (- 167 (expt 2 100)) -1) #xFFFFFFFFFFFFFFFFFFFFFFF58)
+  (test-cp0-expansion eqv? '(bitwise-xor (- (expt 2 300) 167) (- (expt 2 300) 167)) 0)
+  (test-cp0-expansion eqv? '(bitwise-xor (- 167 (expt 2 300)) (- 167 (expt 2 300))) 0)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x1111111111111111111111111 #x2222222222222222222222222)
+    #x3333333333333333333333333)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x1212121212121212121212121 #x2222222222222222222222222)
+    #x3030303030303030303030303)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-1212121212121212121212121
+       #x-2222222222222222222222222)
+    #x3030303030303030303030301)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-3333333333333333333333333 #x-2222222222222222222222222)
+    #x1111111111111111111111113)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-123456789abcdeffedca987654321
+       #x-fedca987654321123456789abcdef)
+    #xECE8FFFFFFFFFFEDD99CE0ECE8ECE)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-123456789abcdeffedca987654321
+       #xfedca987654321123456789abcdef)
+    #x-ECE8FFFFFFFFFFEDD99CE0ECE8ED0)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x2B225D27F49C1FED301B89103
+       #x-F2D8DD782236F835A1A50858)
+    #x-240FD0F076BF706E6A01D9955)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x2B225D27F49C1FED301B89103
+       #x1F366567)
+    #x2B225D27F49C1FED31E8EF464)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x2B225D27F49C1FED301B89103
+       #x-717D004)
+    #x-2B225D27F49C1FED306AF4101)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-F2D8DD782236F835A1A50858
+       #x1F366567)
+    #x-F2D8DD782236F835BE936D31)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-F2D8DD782236F835A1A50858
+       #x-717D004)
+    #xF2D8DD782236F835A6B2D854)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x1F366567
+       #x2B225D27F49C1FED301B89103)
+    #x2B225D27F49C1FED31E8EF464)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-717D004
+       #x2B225D27F49C1FED301B89103)
+    #x-2B225D27F49C1FED306AF4101)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x1F366567
+       #x-F2D8DD782236F835A1A50858)
+    #x-F2D8DD782236F835BE936D31)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x-717D004
+       #x-F2D8DD782236F835A1A50858)
+    #xF2D8DD782236F835A6B2D854)
+  (test-cp0-expansion eqv?  '(bitwise-xor) 0)
+  (test-cp0-expansion eqv?  '(bitwise-xor #x1212121212121212121212121) #x1212121212121212121212121)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #x1212121212121212121212121
+       #x2222222222222222222222222
+       #x0103010301030103010301030)
+    #x3133313331333133313331333)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -6)
+  (test-cp0-expansion eqv? 
+    '(bitwise-xor #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    5)
+)
+
+(mat logtest
+  (error? (logtest))
+  (error? (logtest 1))
+  (error? (logtest 1 2 3))
+  (error? (logtest 3.4 5))
+  (error? (logtest 5 "3"))
+  (eqv? (logtest (+ (most-positive-fixnum) 1) 0) #f)
+  (eqv? (logtest (+ (most-positive-fixnum) 6)
+                 (+ (most-positive-fixnum) 8))
+        #t)
+  (eqv? (logtest (- (most-negative-fixnum) 1) 0) #f)
+  (eqv? (logtest 1 (- (most-negative-fixnum) 1)) #t)
+  (eqv? (logtest 750 -1) #t)
+  (eqv? (logtest -1 -6) #t)
+  (eqv? (logtest 0 -1) #f)
+  (eqv? (logtest -1 0) #f)
+  (eqv? (logtest #b1000101001 #b0111010110) #f)
+  (eqv? (logtest #b1000101001 #b0111110110) #t)
+  (eqv? (logtest #b1010101001 #b0111010110) #t)
+  (eqv? (logtest #x100010100110001010011000101001
+                 #x011101011001110101100111010110) #f)
+  (eqv? (logtest #x101010100110001010011000101001
+                 #x011101011001110101100111010110) #t)
+  (eqv? (logtest #x100010100110001010011000101001
+                 #x011101011101110101100111010110) #t)
+  (eqv? (logtest (most-positive-fixnum) 3) #t)
+  (eqv? (logtest (most-negative-fixnum) 3) #f)
+  (eqv? (logtest (most-negative-fixnum) (most-negative-fixnum)) #t)
+  (eqv? (logtest (most-negative-fixnum) (most-positive-fixnum)) #f)
+  (eqv? (let ([n (ash (most-positive-fixnum) 1)])
+          (do ([i 1000 (fx- i 1)]
+               [a #t (and a (logtest (- (random n)) (- (random n))))])
+              ((fx= i 0) a)))
+        #t)
+  (eqv? (let ([n1 (ash (most-positive-fixnum) 400)]
+              [n2 (ash (most-positive-fixnum) 100)])
+          (do ([i 1000 (fx- i 1)]
+               [a #t (and a
+                       (logtest (- (random n1)) (- (random n1)))
+                       (logtest (- (random n1)) (- (random n2)))
+                       (logtest (- (random n2)) (- (random n1))))])
+              ((fx= i 0) a)))
+        #t)
+  (eqv? (logtest (ash 1 256) (ash 1 255)) #f)
+  (eqv? (logtest (ash 1 256) (ash 3 255)) #t)
+  (eqv? (logtest (ash 1 256) (- (ash 3 100))) #t)
+  (eqv? (logtest (- 1 (ash 1 256)) (ash 3 100)) #f)
+  (eqv? (logtest (- 1 (ash 1 256)) (+ (ash 3 100) 1)) #t)
+  (eqv? (logtest (- 1 (ash 1 256)) (ash 1 255)) #f)
+  (eqv? (logtest (- 1 (ash 1 256)) (ash 1 256)) #t)
+  (eqv? (logtest (- 1 (ash 1 256)) (ash 1 257)) #t)
+  (eqv? (logtest (- 1 (ash 1 255)) (ash 1 254)) #f)
+  (eqv? (logtest (- 1 (ash 1 255)) (ash 1 255)) #t)
+  (eqv? (logtest (- 1 (ash 1 255)) (ash 1 256)) #t)
+  (eqv? (logtest (- 1 (ash 1 254)) (ash 1 253)) #f)
+  (eqv? (logtest (- 1 (ash 1 254)) (ash 1 254)) #t)
+  (eqv? (logtest (- 1 (ash 1 254)) (ash 1 255)) #t)
+
+ ; make sure we've properly labeled logtest an arith-pred in primvars.ss
+  (begin
+    (define ($logtest-foo x y)
+      (if (logtest x y)
+          'yes
+          'no))
+    (equal?
+      (list ($logtest-foo 3 4) ($logtest-foo 3 3))
+      '(no yes)))
+)
+
+(mat bitwise-if
+  (error? (bitwise-if))
+  (error? (bitwise-if 0))
+  (error? (bitwise-if 0 0))
+  (error? (bitwise-if 0 0 0 0))
+  (error? (bitwise-if 'a 0 0))
+  (error? (bitwise-if 0 3.4 0))
+  (error? (bitwise-if 0 0 '(a)))
+  (eqv? (bitwise-if 0 0 0) 0)
+  (eqv? (bitwise-if 0 -1 0) 0)
+  (eqv? (bitwise-if 0 0 -1) -1)
+  (eqv? (bitwise-if #b10101010 0 -1) (bitwise-not #b10101010))
+  (eqv? (bitwise-if #b10101010 -1 0) #b10101010)
+  (eqv? (bitwise-if #b10101010110011001101011010110101101011010110101010101011100111111000010101000111001110001101010011
+                    #b11111110000000111111100000001111111000000011111110000000111111100000001111111000000011111110000000
+                    #b11001100110011110011001100111100110011001111001100110011110011001100111100110011001111001100110011)
+          #b11101110000000111111000100001101111000001011101110010000110111100100101101110000000011001100100000)
+  (let ([n (expt (+ (greatest-fixnum) 1) 2)])
+    (define r6rs-bitwise-if
+      (lambda (ei1 ei2 ei3)
+        (bitwise-ior (bitwise-and ei1 ei2)
+                     (bitwise-and (bitwise-not ei1) ei3))))
+    (let f ([i 10000])
+      (unless (fx= i 0)
+        (let ([x (random n)] [y (random n)] [z (random n)]
+              [kx (random (+ (most-positive-fixnum) 1))]
+              [ky (random (+ (most-positive-fixnum) 1))]
+              [kz (random (+ (most-positive-fixnum) 1))])
+          (unless (and (= (bitwise-if x y z) (r6rs-bitwise-if x y z))
+                       (= (bitwise-if (bitwise-not x) y z)
+                          (r6rs-bitwise-if (bitwise-not x) y z))
+                       (= (bitwise-if (bitwise-not x) y (bitwise-not z))
+                                      (r6rs-bitwise-if (bitwise-not x) y (bitwise-not z)))
+                       (= (bitwise-if x (bitwise-not y) z) (r6rs-bitwise-if x (bitwise-not y) z))
+                       (= (bitwise-if (bitwise-not x) (bitwise-not y) (bitwise-not z))
+                                      (r6rs-bitwise-if (bitwise-not x) (bitwise-not y) (bitwise-not z)))
+                       (= (bitwise-if x ky z) (r6rs-bitwise-if x ky z))
+                       (= (bitwise-if x ky kz) (r6rs-bitwise-if x ky kz))
+                       (= (bitwise-if kx y z) (r6rs-bitwise-if kx y z))
+                       (= (bitwise-if kx (bitwise-not y) z) (r6rs-bitwise-if kx (bitwise-not y) z))
+                       (= (bitwise-if (bitwise-not kx) (bitwise-not y) z) (r6rs-bitwise-if (bitwise-not kx) (bitwise-not y) z)))
+            (errorf #f "failed for ~s, ~s, ~s, ~s, ~s, ~s" x y z kx ky kz)))
+        (f (fx- i 1))))
+    #t)
+)
+
+(mat logbit?
+  (error? (logbit?))
+  (error? (logbit? 1))
+  (error? (logbit? 1 2 3))
+  (error? (logbit? 3.4 5))
+  (error? (logbit? 5 "3"))
+  (error? (logbit? -1 -1))
+  (let ()
+    (define (f x b)
+      (let f ([i 0])
+        (or (> i 100000)
+            (and (eq? (logbit? i x) b)
+                 (f (fx+ i 7))))))
+    (and (f 0 #f) (f -1 #t)))
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (logbit? i -1))])
+            ((fx> i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (logbit? i (most-positive-fixnum)))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (logbit? (integer-length (most-positive-fixnum)) (most-positive-fixnum)) #f)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #f (or a (logbit? i (+ (most-positive-fixnum) 1)))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #f)
+  (eqv? (logbit? (integer-length (most-positive-fixnum))
+                 (+ (most-positive-fixnum) 1))
+        #t)
+  (eqv? (do ([i (fx+ (integer-length (most-positive-fixnum)) 1) (fx+ i 1)]
+             [a #f (or a (logbit? i (+ (most-positive-fixnum) 1)))])
+            ((fx= i (* (integer-length (most-positive-fixnum)) 10)) a))
+        #f)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (logbit? i (- (most-negative-fixnum) 1)))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (logbit? (integer-length (most-positive-fixnum))
+                 (- (most-negative-fixnum) 1))
+        #f)
+  (eqv? (do ([i (fx+ (integer-length (most-positive-fixnum)) 1) (fx+ i 1)]
+             [a #t (and a (logbit? i (- (most-negative-fixnum) 1)))])
+            ((fx= i (* (integer-length (most-positive-fixnum)) 10)) a))
+        #t)
+  (eqv? (logbit? 0 #b0111010110) #f)
+  (eqv? (logbit? 4 #b0111010110) #t)
+  (eqv? (logbit? 8 #b0111010110) #t)
+  (eqv? (logbit? 9 #b0111010110) #f)
+
+  (eqv? (logbit? 0 #x42310521068980111010110) #f)
+  (eqv? (logbit? 4 #x42310521068980111010110) #t)
+  (eqv? (logbit? 85 #x42310521068980111010110) #t)
+  (eqv? (logbit? 86 #x42310521068980111010110) #f)
+  (eqv? (logbit? 90 #x42310521068980111010110) #t)
+  (eqv? (logbit? 91 #x42310521068980111010110) #f)
+  (eqv? (logbit? 1000 #x42310521068980111010110) #f)
+
+  (eqv? (logbit? 0 #x-55555555555555555555555555) #t)
+  (eqv? (logbit? 1 #x-55555555555555555555555555) #t)
+  (eqv? (logbit? 2 #x-55555555555555555555555555) #f)
+  (eqv? (logbit? 100 #x-55555555555555555555555555) #f)
+  (eqv? (logbit? 101 #x-55555555555555555555555555) #t)
+  (eqv? (logbit? 102 #x-55555555555555555555555555) #f)
+  (eqv? (logbit? 103 #x-55555555555555555555555555) #t)
+  (eqv? (logbit? 1000 #x-55555555555555555555555555) #t)
+
+  (eqv? (logbit? 31 (ash 1 32)) #f)
+  (eqv? (logbit? 32 (ash 1 32)) #t)
+  (eqv? (logbit? 33 (ash 1 32)) #f)
+  (eqv? (logbit? 30 (ash 1 31)) #f)
+  (eqv? (logbit? 31 (ash 1 31)) #t)
+  (eqv? (logbit? 32 (ash 1 31)) #f)
+  (eqv? (logbit? 63 (ash 1 64)) #f)
+  (eqv? (logbit? 64 (ash 1 64)) #t)
+  (eqv? (logbit? 65 (ash 1 64)) #f)
+  (eqv? (logbit? 62 (ash 1 63)) #f)
+  (eqv? (logbit? 63 (ash 1 63)) #t)
+  (eqv? (logbit? 64 (ash 1 63)) #f)
+
+  (eqv? (logbit? 255 (ash 1 256)) #f)
+  (eqv? (logbit? 256 (ash 1 256)) #t)
+  (eqv? (logbit? 257 (ash 1 256)) #f)
+  (eqv? (logbit? 254 (ash 1 255)) #f)
+  (eqv? (logbit? 255 (ash 1 255)) #t)
+  (eqv? (logbit? 256 (ash 1 255)) #f)
+
+  (equal?
+    (let ([x (- 1 (ash 1 256))])
+      (list 
+        (logbit? 0 x)
+        (do ([i 1 (fx+ i 1)] [a #f (or a (logbit? i x))])
+            ((fx= i 256) a))
+        (do ([i 256 (fx+ i 1)] [a #t (and a (logbit? i x))])
+            ((fx= i 1000) a))))
+    '(#t #f #t))
+  (equal?
+    (let ([x (- (ash 1 256))])
+      (list 
+        (do ([i 0 (fx+ i 1)] [a #f (or a (logbit? i x))])
+            ((fx= i 256) a))
+        (do ([i 256 (fx+ i 1)] [a #t (and a (logbit? i x))])
+            ((fx= i 1000) a))))
+    '(#f #t))
+
+  (eqv? (logbit? (integer-length (most-positive-fixnum)) #b0111010110) #f)
+  (eqv? (logbit? 0 -6) #f)
+  (eqv? (logbit? 1 -6) #t)
+  (eqv? (logbit? 2 -6) #f)
+  (eqv? (do ([i 3 (fx+ i 1)] [a #t (and a (logbit? i -6))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+ ; check to see if we can look as far to the left as we please ...
+  (eqv? (logbit? (+ (integer-length (most-positive-fixnum)) 1) -1) #t)
+  (eqv? (logbit? (expt (integer-length (most-positive-fixnum)) 2) (most-positive-fixnum)) #f)
+  (eqv? (logbit? (expt (integer-length (most-positive-fixnum)) 2) -1) #t)
+
+ ; make sure we've properly labeled logbit? an arith-pred in primvars.ss
+  (begin
+    (define ($logbit?-foo x y)
+      (if (logbit? x y)
+          'yes
+          'no))
+    (equal?
+      (list ($logbit?-foo 2 4) ($logbit?-foo 3 3))
+      '(yes no)))
+)
+
+(mat bitwise-bit-set? ; same as logbit?
+  (error? (bitwise-bit-set?))
+  (error? (bitwise-bit-set? 3))
+  (error? (bitwise-bit-set? 3 4 5))
+  (error? (bitwise-bit-set? 3.0 4))
+  (error? (bitwise-bit-set? "hi" 4))
+  (error? (bitwise-bit-set? 3 4/3))
+  (error? (bitwise-bit-set? 3 'a))
+  (error? (bitwise-bit-set? 3 -3))
+  (let ()
+    (define (f x b)
+      (let f ([i 0])
+        (or (> i 100000)
+            (and (eq? (bitwise-bit-set? x i) b)
+                 (f (fx+ i 7))))))
+    (and (f 0 #f) (f -1 #t)))
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (bitwise-bit-set? -1 i))])
+            ((fx> i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (bitwise-bit-set? (most-positive-fixnum) 1))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (bitwise-bit-set? (most-positive-fixnum) (integer-length (most-positive-fixnum))) #f)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #f (or a (bitwise-bit-set? (+ (most-positive-fixnum) 1) i))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #f)
+  (eqv? (bitwise-bit-set? (+ (most-positive-fixnum) 1)
+                 (integer-length (most-positive-fixnum)))
+        #t)
+  (eqv? (do ([i (fx+ (integer-length (most-positive-fixnum)) 1) (fx+ i 1)]
+             [a #f (or a (bitwise-bit-set? (+ (most-positive-fixnum) 1) i))])
+            ((fx= i (* (integer-length (most-positive-fixnum)) 10)) a))
+        #f)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (bitwise-bit-set? (- (most-negative-fixnum) 1) i))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (bitwise-bit-set? (- (most-negative-fixnum) 1)
+                 (integer-length (most-positive-fixnum)))
+        #f)
+  (eqv? (do ([i (fx+ (integer-length (most-positive-fixnum)) 1) (fx+ i 1)]
+             [a #t (and a (bitwise-bit-set? (- (most-negative-fixnum) 1)i ))])
+            ((fx= i (* (integer-length (most-positive-fixnum)) 10)) a))
+        #t)
+  (eqv? (bitwise-bit-set? #b0111010110 0) #f)
+  (eqv? (bitwise-bit-set? #b0111010110 4) #t)
+  (eqv? (bitwise-bit-set? #b0111010110 8) #t)
+  (eqv? (bitwise-bit-set? #b0111010110 9) #f)
+
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 0) #f)
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 4) #t)
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 85) #t)
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 86) #f)
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 90) #t)
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 91) #f)
+  (eqv? (bitwise-bit-set? #x42310521068980111010110 1000) #f)
+
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 0) #t)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 1) #t)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 2) #f)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 100) #f)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 101) #t)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 102) #f)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 103) #t)
+  (eqv? (bitwise-bit-set? #x-55555555555555555555555555 1000) #t)
+
+  (eqv? (bitwise-bit-set? (ash 1 32) 31) #f)
+  (eqv? (bitwise-bit-set? (ash 1 32) 32) #t)
+  (eqv? (bitwise-bit-set? (ash 1 32) 33) #f)
+  (eqv? (bitwise-bit-set? (ash 1 31) 30) #f)
+  (eqv? (bitwise-bit-set? (ash 1 31) 31) #t)
+  (eqv? (bitwise-bit-set? (ash 1 31) 32) #f)
+  (eqv? (bitwise-bit-set? (ash 1 64) 63) #f)
+  (eqv? (bitwise-bit-set? (ash 1 64) 64) #t)
+  (eqv? (bitwise-bit-set? (ash 1 64) 65) #f)
+  (eqv? (bitwise-bit-set? (ash 1 63) 62) #f)
+  (eqv? (bitwise-bit-set? (ash 1 63) 63) #t)
+  (eqv? (bitwise-bit-set? (ash 1 63) 64) #f)
+
+  (eqv? (bitwise-bit-set? (ash 1 256) 255) #f)
+  (eqv? (bitwise-bit-set? (ash 1 256) 256) #t)
+  (eqv? (bitwise-bit-set? (ash 1 256) 257) #f)
+  (eqv? (bitwise-bit-set? (ash 1 255) 254) #f)
+  (eqv? (bitwise-bit-set? (ash 1 255) 255) #t)
+  (eqv? (bitwise-bit-set? (ash 1 255) 256) #f)
+
+  (equal?
+    (let ([x (- 1 (ash 1 256))])
+      (list 
+        (bitwise-bit-set? x 0)
+        (do ([i 1 (fx+ i 1)] [a #f (or a (bitwise-bit-set? x i))])
+            ((fx= i 256) a))
+        (do ([i 256 (fx+ i 1)] [a #t (and a (bitwise-bit-set? x i))])
+            ((fx= i 1000) a))))
+    '(#t #f #t))
+  (equal?
+    (let ([x (- (ash 1 256))])
+      (list 
+        (do ([i 0 (fx+ i 1)] [a #f (or a (bitwise-bit-set? x i))])
+            ((fx= i 256) a))
+        (do ([i 256 (fx+ i 1)] [a #t (and a (bitwise-bit-set? x i))])
+            ((fx= i 1000) a))))
+    '(#f #t))
+
+  (eqv? (bitwise-bit-set? #b0111010110 (integer-length (most-positive-fixnum))) #f)
+  (eqv? (bitwise-bit-set? -6 0) #f)
+  (eqv? (bitwise-bit-set? -6 1) #t)
+  (eqv? (bitwise-bit-set? -6 2) #f)
+  (eqv? (do ([i 3 (fx+ i 1)] [a #t (and a (bitwise-bit-set? -6 i))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+ ; check to see if we can look as far to the left as we please ...
+  (eqv? (bitwise-bit-set? -1 (+ (integer-length (most-positive-fixnum)) 1)) #t)
+  (eqv? (bitwise-bit-set? (most-positive-fixnum) (expt (integer-length (most-positive-fixnum)) 2)) #f)
+  (eqv? (bitwise-bit-set? -1 (expt (integer-length (most-positive-fixnum)) 2)) #t)
+
+ ; make sure we've properly labeled bitwise-bit-set? an arith-pred in primvars.ss
+  (begin
+    (define ($bitwise-bit-set?-foo x y)
+      (if (bitwise-bit-set? y x)
+          'yes
+          'no))
+    (equal?
+      (list ($bitwise-bit-set?-foo 2 4) ($bitwise-bit-set?-foo 3 3))
+      '(yes no)))
+)
+
+(mat logbit0
+  (error? (logbit0))
+  (error? (logbit0 1))
+  (error? (logbit0 1 2 3))
+  (error? (logbit0 3.4 5))
+  (error? (logbit0 5 "3"))
+  (error? (logbit0 -1 -1))
+  (eqv? (logbit0 0 (+ (most-positive-fixnum) 2)) (+ (most-positive-fixnum) 1))
+  (eqv? (logbit0 0 (- (most-negative-fixnum) 1)) (- (most-negative-fixnum) 2))
+  (eqv? (logbit0 (integer-length (most-positive-fixnum)) -1)
+        (- -1 (expt 2 (integer-length (most-positive-fixnum)))))
+  (eqv? (logbit0 2 0) 0)
+  (eqv? (logbit0 2 -1) -5)
+  (eqv? (logbit0 3 #b10101010) #b10100010)
+  (eqv? (logbit0 4 #b10101010) #b10101010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (logbit0 i -1) (fx- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (logbit0 i n)
+                               (fxlogand (lognot (fxsll 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+
+  (eqv? (logbit0 31 (- (ash 1 32) 1)) (- (ash 1 31) 1))
+  (eqv? (logbit0 32 (- (ash 1 32) 1)) (- (ash 1 32) 1))
+  (eqv? (logbit0 33 (- (ash 1 32) 1)) (- (ash 1 32) 1))
+  (eqv? (logbit0 31 (ash 1 32)) (ash 1 32))
+  (eqv? (logbit0 32 (ash 1 32)) 0)
+  (eqv? (logbit0 31 (- (ash 1 33) 1)) (- (ash 1 33) (ash 1 31) 1))
+  (eqv? (logbit0 32 (- (ash 1 33) 1)) (- (ash 1 32) 1))
+  (eqv? (logbit0 33 (- (ash 1 33) 1)) (- (ash 1 33) 1))
+
+  (eqv? (logbit0 63 (- (ash 1 64) 1)) (- (ash 1 63) 1))
+  (eqv? (logbit0 64 (- (ash 1 64) 1)) (- (ash 1 64) 1))
+  (eqv? (logbit0 65 (- (ash 1 64) 1)) (- (ash 1 64) 1))
+  (eqv? (logbit0 63 (ash 1 64)) (ash 1 64))
+  (eqv? (logbit0 64 (ash 1 64)) 0)
+  (eqv? (logbit0 63 (- (ash 1 65) 1)) (- (ash 1 65) (ash 1 63) 1))
+  (eqv? (logbit0 64 (- (ash 1 65) 1)) (- (ash 1 64) 1))
+  (eqv? (logbit0 65 (- (ash 1 65) 1)) (- (ash 1 65) 1))
+
+  (eqv? (logbit0 255 (- (ash 1 256) 1)) (- (ash 1 255) 1))
+  (eqv? (logbit0 256 (- (ash 1 256) 1)) (- (ash 1 256) 1))
+  (eqv? (logbit0 257 (- (ash 1 256) 1)) (- (ash 1 256) 1))
+  (eqv? (logbit0 255 (ash 1 256)) (ash 1 256))
+  (eqv? (logbit0 256 (ash 1 256)) 0)
+  (eqv? (logbit0 255 (- (ash 1 257) 1)) (- (ash 1 257) (ash 1 255) 1))
+  (eqv? (logbit0 256 (- (ash 1 257) 1)) (- (ash 1 256) 1))
+  (eqv? (logbit0 257 (- (ash 1 257) 1)) (- (ash 1 257) 1))
+
+ ; two's comp rep'n of #x-32B225D27F49C1FED301B89103 is
+ ; ...FCD4DDA2D80B63E012CFE476EFD
+  (eqv? (logbit0 0 #x-32B225D27F49C1FED301B89103)
+                   #x-32B225D27F49C1FED301B89104)
+  (eqv? (logbit0 1 #x-32B225D27F49C1FED301B89103)
+                   #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit0 2 #x-32B225D27F49C1FED301B89103)
+                   #x-32B225D27F49C1FED301B89107)
+  (eqv? (logbit0 31 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED381B89103)
+  (eqv? (logbit0 32 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit0 63 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27FC9C1FED301B89103)
+  (eqv? (logbit0 64 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit0 99 #x-32B225D27F49C1FED301B89103)
+                    #x-3AB225D27F49C1FED301B89103)
+  (eqv? (logbit0 100 #x-32B225D27F49C1FED301B89103)
+                     #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit0 101 #x-32B225D27F49C1FED301B89103)
+                     #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit0 102 #x-32B225D27F49C1FED301B89103)
+                     #x-72B225D27F49C1FED301B89103)
+  (eqv? (logbit0 103 #x-32B225D27F49C1FED301B89103)
+                     #x-B2B225D27F49C1FED301B89103)
+  (eqv? (logbit0 104 #x-32B225D27F49C1FED301B89103)
+                     #x-132B225D27F49C1FED301B89103)
+  (eqv? (logbit0 1000 #x-32B225D27F49C1FED301B89103)
+        #x-10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000032B225D27F49C1FED301B89103)
+
+  (eqv? (logbit0 0 #x-CD4DDA2D80B63E012CFE476EFD)
+                   #x-CD4DDA2D80B63E012CFE476EFE)
+  (eqv? (logbit0 1 #x-CD4DDA2D80B63E012CFE476EFD)
+                   #x-CD4DDA2D80B63E012CFE476EFF)
+  (eqv? (logbit0 2 #x-CD4DDA2D80B63E012CFE476EFD)
+                   #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 31 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 32 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012DFE476EFD)
+  (eqv? (logbit0 63 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 64 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D81B63E012CFE476EFD)
+  (eqv? (logbit0 99 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 100 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-DD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 101 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-ED4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 102 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 103 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 104 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-1CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit0 1000 #x-CD4DDA2D80B63E012CFE476EFD)
+                      #x-100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000CD4DDA2D80B63E012CFE476EFD)
+
+  (andmap values
+    (let ([p? (lambda (i) (= (logbit0 i -1) (- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i 1000)
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (= (logbit0 i n) (logand (lognot (ash 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (ash (most-positive-fixnum) 5)
+                                    (ash (most-negative-fixnum) 5))
+                                 1))
+                      (ash (most-negative-fixnum) 5))])
+            (let f ([i 0])
+              (if (fx= i (* (integer-length (ash (most-negative-fixnum) 5)) 2))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+)
+
+(mat logbit1
+  (error? (logbit1))
+  (error? (logbit1 1))
+  (error? (logbit1 1 2 3))
+  (error? (logbit1 3.4 5))
+  (error? (logbit1 5 "3"))
+  (error? (logbit1 -1 -1))
+  (eqv? (logbit1 0 (+ (most-positive-fixnum) 1)) (+ (most-positive-fixnum) 2))
+  (eqv? (logbit1 0 (- (most-negative-fixnum) 2)) (- (most-negative-fixnum) 1))
+  (eqv? (logbit1 (integer-length (most-positive-fixnum)) 0)
+        (ash 1 (integer-length (most-positive-fixnum))))
+  (eqv? (logbit1 (integer-length (most-positive-fixnum)) 0)
+        (+ (most-positive-fixnum) 1))
+  (eqv? (logbit1 2 0) 4)
+  (eqv? (logbit1 2 -1) -1)
+  (eqv? (logbit1 (expt 2 20) -75) -75)
+  (eqv? (logbit1 1000 -75) -75)
+  (eqv? (logbit1 3 #b10101010) #b10101010)
+  (eqv? (logbit1 4 #b10101010) #b10111010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (logbit1 i 0) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (logbit1 i n) (fxlogor (fxsll 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+
+  (eqv? (logbit1 31 (ash 1 32)) (ash 3 31))
+  (eqv? (logbit1 32 (ash 1 32)) (ash 1 32))
+  (eqv? (logbit1 33 (ash 1 32)) (ash 3 32))
+  (eqv? (logbit1 30 (ash 1 31)) (ash 3 30))
+  (eqv? (logbit1 31 (ash 1 31)) (ash 1 31))
+  (eqv? (logbit1 32 (ash 1 31)) (ash 3 31))
+  (eqv? (logbit1 63 (ash 1 64)) (ash 3 63))
+  (eqv? (logbit1 64 (ash 1 64)) (ash 1 64))
+  (eqv? (logbit1 65 (ash 1 64)) (ash 3 64))
+  (eqv? (logbit1 62 (ash 1 63)) (ash 3 62))
+  (eqv? (logbit1 63 (ash 1 63)) (ash 1 63))
+  (eqv? (logbit1 64 (ash 1 63)) (ash 3 63))
+
+  (eqv? (logbit1 255 (ash 1 256)) (ash 3 255))
+  (eqv? (logbit1 256 (ash 1 256)) (ash 1 256))
+  (eqv? (logbit1 257 (ash 1 256)) (ash 3 256))
+  (eqv? (logbit1 254 (ash 1 255)) (ash 3 254))
+  (eqv? (logbit1 255 (ash 1 255)) (ash 1 255))
+  (eqv? (logbit1 256 (ash 1 255)) (ash 3 255))
+
+ ; two's comp rep'n of #x-32B225D27F49C1FED301B89103 is
+ ; ...FCD4DDA2D80B63E012CFE476EFD
+  (eqv? (logbit1 0 #x-32B225D27F49C1FED301B89103)
+                   #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 1 #x-32B225D27F49C1FED301B89103)
+                   #x-32B225D27F49C1FED301B89101)
+  (eqv? (logbit1 2 #x-32B225D27F49C1FED301B89103)
+                   #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 31 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 32 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED201B89103)
+  (eqv? (logbit1 63 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 64 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27E49C1FED301B89103)
+  (eqv? (logbit1 99 #x-32B225D27F49C1FED301B89103)
+                    #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 100 #x-32B225D27F49C1FED301B89103)
+                     #x-22B225D27F49C1FED301B89103)
+  (eqv? (logbit1 101 #x-32B225D27F49C1FED301B89103)
+                     #x-12B225D27F49C1FED301B89103)
+  (eqv? (logbit1 102 #x-32B225D27F49C1FED301B89103)
+                     #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 103 #x-32B225D27F49C1FED301B89103)
+                     #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 104 #x-32B225D27F49C1FED301B89103)
+                     #x-32B225D27F49C1FED301B89103)
+  (eqv? (logbit1 1000 #x-32B225D27F49C1FED301B89103)
+                      #x-32B225D27F49C1FED301B89103)
+
+  (eqv? (logbit1 0 #x-CD4DDA2D80B63E012CFE476EFD)
+                   #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 1 #x-CD4DDA2D80B63E012CFE476EFD)
+                   #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 2 #x-CD4DDA2D80B63E012CFE476EFD)
+                   #x-CD4DDA2D80B63E012CFE476EF9)
+  (eqv? (logbit1 31 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012C7E476EFD)
+  (eqv? (logbit1 32 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 63 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80363E012CFE476EFD)
+  (eqv? (logbit1 64 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 99 #x-CD4DDA2D80B63E012CFE476EFD)
+                    #x-C54DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 100 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 101 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 102 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-8D4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 103 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-4D4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 104 #x-CD4DDA2D80B63E012CFE476EFD)
+                     #x-CD4DDA2D80B63E012CFE476EFD)
+  (eqv? (logbit1 1000 #x-CD4DDA2D80B63E012CFE476EFD)
+                      #x-CD4DDA2D80B63E012CFE476EFD)
+  (andmap values
+    (let ([p? (lambda (i) (= (logbit1 i 0) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i 1000)
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (= (logbit1 i n) (logor (ash 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (ash (most-positive-fixnum) 5)
+                                    (ash (most-negative-fixnum) 5))
+                                 1))
+                      (ash (most-negative-fixnum) 5))])
+            (let f ([i 0])
+              (if (fx= i (* (integer-length (ash (most-negative-fixnum) 5)) 2))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+)
+
+(mat bitwise-copy-bit ; adapted from logbit0 and logbit1 above
+  (error? (bitwise-copy-bit))
+  (error? (bitwise-copy-bit 1))
+  (error? (bitwise-copy-bit 1 2))
+  (error? (bitwise-copy-bit 1 2 0 4))
+  (error? (bitwise-copy-bit 3.4 5 0))
+  (error? (bitwise-copy-bit 1 'a 0))
+  (error? (bitwise-copy-bit 1 -2 0))
+  (error? (bitwise-copy-bit 1 2 2))
+  (error? (bitwise-copy-bit 1 2 -1))
+  (error? (bitwise-copy-bit 1 2 'a))
+  (eqv?
+    (bitwise-copy-bit (+ (most-positive-fixnum) 2) 0 0)
+    (+ (most-positive-fixnum) 1))
+  (eqv?
+    (bitwise-copy-bit (- (most-negative-fixnum) 1) 0 0)
+    (- (most-negative-fixnum) 2))
+  (eqv?
+    (bitwise-copy-bit
+      -1
+      (integer-length (most-positive-fixnum))
+      0)
+    (- -1 (expt 2 (integer-length (most-positive-fixnum)))))
+  (eqv? (bitwise-copy-bit 0 2 0) 0)
+  (eqv? (bitwise-copy-bit -1 2 0) -5)
+  (eqv? (bitwise-copy-bit 170 3 0) 162)
+  (eqv? (bitwise-copy-bit 170 4 0) 170)
+  (andmap
+    values
+    (let ([p? (lambda (i)
+                (fx= (bitwise-copy-bit -1 i 0) (fx- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i)
+              (fx= (bitwise-copy-bit n i 0)
+                   (fxlogand (lognot (fxsll 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random
+                        (+ (- (most-positive-fixnum)
+                              (most-negative-fixnum))
+                           1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 32) 1) 31 0)
+    (- (ash 1 31) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 32) 1) 32 0)
+    (- (ash 1 32) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 32) 1) 33 0)
+    (- (ash 1 32) 1))
+  (eqv? (bitwise-copy-bit (ash 1 32) 31 0) (ash 1 32))
+  (eqv? (bitwise-copy-bit (ash 1 32) 32 0) 0)
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 33) 1) 31 0)
+    (- (ash 1 33) (ash 1 31) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 33) 1) 32 0)
+    (- (ash 1 32) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 33) 1) 33 0)
+    (- (ash 1 33) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 64) 1) 63 0)
+    (- (ash 1 63) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 64) 1) 64 0)
+    (- (ash 1 64) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 64) 1) 65 0)
+    (- (ash 1 64) 1))
+  (eqv? (bitwise-copy-bit (ash 1 64) 63 0) (ash 1 64))
+  (eqv? (bitwise-copy-bit (ash 1 64) 64 0) 0)
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 65) 1) 63 0)
+    (- (ash 1 65) (ash 1 63) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 65) 1) 64 0)
+    (- (ash 1 64) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 65) 1) 65 0)
+    (- (ash 1 65) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 256) 1) 255 0)
+    (- (ash 1 255) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 256) 1) 256 0)
+    (- (ash 1 256) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 256) 1) 257 0)
+    (- (ash 1 256) 1))
+  (eqv? (bitwise-copy-bit (ash 1 256) 255 0) (ash 1 256))
+  (eqv? (bitwise-copy-bit (ash 1 256) 256 0) 0)
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 257) 1) 255 0)
+    (- (ash 1 257) (ash 1 255) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 257) 1) 256 0)
+    (- (ash 1 256) 1))
+  (eqv?
+    (bitwise-copy-bit (- (ash 1 257) 1) 257 0)
+    (- (ash 1 257) 1))
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 0 0)
+    #x-32b225d27f49c1fed301b89104)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 1 0)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 2 0)
+    #x-32b225d27f49c1fed301b89107)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 31 0)
+    #x-32b225d27f49c1fed381b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 32 0)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 63 0)
+    #x-32b225d27fc9c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 64 0)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 99 0)
+    #x-3ab225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 100 0)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 101 0)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 102 0)
+    #x-72b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 103 0)
+    #x-b2b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 104 0)
+    #x-132b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 1000 0)
+    #x-10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000032b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 0 0)
+    #x-cd4dda2d80b63e012cfe476efe)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 1 0)
+    #x-cd4dda2d80b63e012cfe476eff)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 2 0)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 31 0)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 32 0)
+    #x-cd4dda2d80b63e012dfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 63 0)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 64 0)
+    #x-cd4dda2d81b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 99 0)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 100 0)
+    #x-dd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 101 0)
+    #x-ed4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 102 0)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 103 0)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 104 0)
+    #x-1cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 1000 0)
+    #x-100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000cd4dda2d80b63e012cfe476efd)
+  (andmap
+    values
+    (let ([p? (lambda (i)
+                (= (bitwise-copy-bit -1 i 0) (- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i 1000) '() (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i)
+              (= (bitwise-copy-bit n i 0)
+                 (logand (lognot (ash 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random
+                        (+ (- (ash (most-positive-fixnum) 5)
+                              (ash (most-negative-fixnum) 5))
+                           1))
+                      (ash (most-negative-fixnum) 5))])
+            (let f ([i 0])
+              (if (fx= i
+                       (* (integer-length (ash (most-negative-fixnum) 5))
+                          2))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv?
+    (bitwise-copy-bit (+ (most-positive-fixnum) 1) 0 1)
+    (+ (most-positive-fixnum) 2))
+  (eqv?
+    (bitwise-copy-bit (- (most-negative-fixnum) 2) 0 1)
+    (- (most-negative-fixnum) 1))
+  (eqv?
+    (bitwise-copy-bit
+      0
+      (integer-length (most-positive-fixnum))
+      1)
+    (ash 1 (integer-length (most-positive-fixnum))))
+  (eqv?
+    (bitwise-copy-bit
+      0
+      (integer-length (most-positive-fixnum))
+      1)
+    (+ (most-positive-fixnum) 1))
+  (eqv? (bitwise-copy-bit 0 2 1) 4)
+  (eqv? (bitwise-copy-bit -1 2 1) -1)
+  (eqv? (bitwise-copy-bit -75 (expt 2 20) 1) -75)
+  (eqv? (bitwise-copy-bit -75 1000 1) -75)
+  (eqv? (bitwise-copy-bit 170 3 1) 170)
+  (eqv? (bitwise-copy-bit 170 4 1) 186)
+  (andmap
+    values
+    (let ([p? (lambda (i)
+                (fx= (bitwise-copy-bit 0 i 1) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i)
+              (fx= (bitwise-copy-bit n i 1) (fxlogor (fxsll 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random
+                        (+ (- (most-positive-fixnum)
+                              (most-negative-fixnum))
+                           1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv? (bitwise-copy-bit (ash 1 32) 31 1) (ash 3 31))
+  (eqv? (bitwise-copy-bit (ash 1 32) 32 1) (ash 1 32))
+  (eqv? (bitwise-copy-bit (ash 1 32) 33 1) (ash 3 32))
+  (eqv? (bitwise-copy-bit (ash 1 31) 30 1) (ash 3 30))
+  (eqv? (bitwise-copy-bit (ash 1 31) 31 1) (ash 1 31))
+  (eqv? (bitwise-copy-bit (ash 1 31) 32 1) (ash 3 31))
+  (eqv? (bitwise-copy-bit (ash 1 64) 63 1) (ash 3 63))
+  (eqv? (bitwise-copy-bit (ash 1 64) 64 1) (ash 1 64))
+  (eqv? (bitwise-copy-bit (ash 1 64) 65 1) (ash 3 64))
+  (eqv? (bitwise-copy-bit (ash 1 63) 62 1) (ash 3 62))
+  (eqv? (bitwise-copy-bit (ash 1 63) 63 1) (ash 1 63))
+  (eqv? (bitwise-copy-bit (ash 1 63) 64 1) (ash 3 63))
+  (eqv? (bitwise-copy-bit (ash 1 256) 255 1) (ash 3 255))
+  (eqv? (bitwise-copy-bit (ash 1 256) 256 1) (ash 1 256))
+  (eqv? (bitwise-copy-bit (ash 1 256) 257 1) (ash 3 256))
+  (eqv? (bitwise-copy-bit (ash 1 255) 254 1) (ash 3 254))
+  (eqv? (bitwise-copy-bit (ash 1 255) 255 1) (ash 1 255))
+  (eqv? (bitwise-copy-bit (ash 1 255) 256 1) (ash 3 255))
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 0 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 1 1)
+    #x-32b225d27f49c1fed301b89101)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 2 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 31 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 32 1)
+    #x-32b225d27f49c1fed201b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 63 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 64 1)
+    #x-32b225d27e49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 99 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 100 1)
+    #x-22b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 101 1)
+    #x-12b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 102 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 103 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 104 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-32b225d27f49c1fed301b89103 1000 1)
+    #x-32b225d27f49c1fed301b89103)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 0 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 1 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 2 1)
+    #x-cd4dda2d80b63e012cfe476ef9)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 31 1)
+    #x-cd4dda2d80b63e012c7e476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 32 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 63 1)
+    #x-cd4dda2d80363e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 64 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 99 1)
+    #x-c54dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 100 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 101 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 102 1)
+    #x-8d4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 103 1)
+    #x-4d4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 104 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (eqv?
+    (bitwise-copy-bit #x-cd4dda2d80b63e012cfe476efd 1000 1)
+    #x-cd4dda2d80b63e012cfe476efd)
+  (andmap
+    values
+    (let ([p? (lambda (i)
+                (= (bitwise-copy-bit 0 i 1) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i 1000) '() (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i)
+              (= (bitwise-copy-bit n i 1) (logor (ash 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random
+                        (+ (- (ash (most-positive-fixnum) 5)
+                              (ash (most-negative-fixnum) 5))
+                           1))
+                      (ash (most-negative-fixnum) 5))])
+            (let f ([i 0])
+              (if (fx= i
+                       (* (integer-length (ash (most-negative-fixnum) 5))
+                          2))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+)
+
+
+(mat real->flonum
+   (error? (real->flonum))
+   (error? (real->flonum 3 4))
+   (error? (real->flonum 'a))
+   (error? (real->flonum 3+4i))
+   (= (real->flonum (most-positive-fixnum))
+      (* (most-positive-fixnum) 1.0))
+   (= (real->flonum (+ (most-positive-fixnum) 1))
+      (+ (most-positive-fixnum) 1.0))
+   (= (real->flonum #e1e10000) +inf.0)
+   (= (real->flonum #e-1e10000) -inf.0)
+   (= (real->flonum 0) 0.0)
+   (= (real->flonum 1) 1.0)
+   (= (real->flonum -1) -1.0)
+   (= (real->flonum 4.5) 4.5)
+   (= (real->flonum 3/4) .75)
+   (= (real->flonum -3/4) -.75)
+   (= (real->flonum -3/4) -.75)
+)
+
+(mat div-and-mod
+ ; div-and-mod
+  (error? (div-and-mod 3 0))
+  (error? (div-and-mod (+ (most-positive-fixnum) 1) 0))
+  (error? (div-and-mod 3/5 0))
+  (error? (div-and-mod 'a 17))
+  (error? (div-and-mod 17 '(a)))
+ ; div
+  (error? (div 3 0))
+  (error? (div (+ (most-positive-fixnum) 1) 0))
+  (error? (div 3/5 0))
+  (error? (div 'a 17))
+  (error? (div 17 '(a)))
+ ; mod
+  (error? (mod 3 0))
+  (error? (mod (+ (most-positive-fixnum) 1) 0))
+  (error? (mod 3/5 0))
+  (error? (mod 'a 17))
+  (error? (mod 17 '(a)))
+ ; div-and-mod
+  (begin
+    (define $d&m div-and-mod)
+    (define ($dmpair x y)
+      (if (and (eq? y 0) (exact? x))
+          #f
+          (call-with-values (lambda () ($d&m x y)) cons)))
+    (define ($dmpairs x y)
+      (list ($dmpair x y) ($dmpair (- x) y) ($dmpair x (- y)) ($dmpair (- x) (- y))
+            ($dmpair y x) ($dmpair (- y) x) ($dmpair y (- x)) ($dmpair (- y) (- x))))
+    (define ($dmequal? x y)
+      (cond
+        [(pair? x)
+         (and (pair? y)
+              ($dmequal? (car x) (car y))
+              ($dmequal? (cdr x) (cdr y)))]
+        [(number? x)
+         (and (number? y)
+              (if (inexact? x)
+                  (and (inexact? y) (== x y))
+                  (and (exact? y) (= x y))))]
+        [else (eq? x y)]))
+    #t)
+  ($dmequal?
+    ($dmpairs 0 1)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 24 8)
+    '((3 . 0) (-3 . 0) (-3 . 0) (3 . 0) (0 . 8) (-1 . 16) (0 . 8) (1 . 16)))
+  ($dmequal?
+    ($dmpairs 0 (expt (most-positive-fixnum) 3))
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0 1.0)
+    '((0.0 . 0.0) (0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0) (-inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0 3/4)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0.0 1)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 (* (most-positive-fixnum) 7))
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3/4)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal? ; fixnum, fixnum
+    ($dmpairs 3 1000)
+    '((0 . 3) (-1 . 997) (0 . 3) (1 . 997) (333 . 1) (-334 . 2) (-333 . 1) (334 . 2)))
+  ($dmequal? ; fixnum, fixnum overflow case
+    ($dmpair (most-negative-fixnum) -1)
+    (cons (- (most-negative-fixnum)) 0))
+  ($dmequal? ; fixnum, bignum
+    ($dmpairs 3 (expt (most-positive-fixnum) 3))
+    (case (fixnum-width)
+      [(30) '((0 . 3) (-1 . 154742504045981407517868028)
+              (0 . 3) (1 . 154742504045981407517868028)
+              (51580834681993802505956010 . 1) (-51580834681993802505956011 . 2)
+              (-51580834681993802505956010 . 1) (51580834681993802505956011 . 2))]
+      [(61) '((0 . 3)
+              (-1 .  1532495540865888854370663039795561568366082455163109372)
+              (0 . 3)
+              (1 .  1532495540865888854370663039795561568366082455163109372)
+              (510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (510831846955296284790221013265187189455360818387703125 .  0))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; fixnum, flonum
+    ($dmpairs 3 15.5)
+    '((0.0 . 3.0) (-1.0 . 12.5) (-0.0 . 3.0) (1.0 . 12.5)
+      (5.0 . 0.5) (-6.0 . 2.5) (-5.0 . 0.5) (6.0 . 2.5)))
+  ($dmequal? ; fixnum, ratnum
+    ($dmpairs 3 32/7)
+    '((0 . 3) (-1 . 11/7) (0 . 3) (1 . 11/7)
+      (1 . 11/7) (-2 . 10/7) (-1 . 11/7) (2 . 10/7)))
+  ($dmequal? ; bignum, flonum
+    ($dmpairs (+ (most-positive-fixnum) 16) 0.25)
+    (case (fixnum-width)
+      [(30) '((2147483708.0 . 0.0) (-2147483708.0 . 0.0)
+              (-2147483708.0 . 0.0) (2147483708.0 . 0.0)
+              (0.0 . 0.25) (-1.0 . 536870926.75)
+              (-0.0 . 0.25) (1.0 . 536870926.75))]
+      [(61) '((4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (4.611686018427388e18 . 0.0) (0.0 . 0.25)
+              (-1.0 . 1.152921504606847e18) (-0.0 . 0.25)
+              (1.0 . 1.152921504606847e18))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; bignum, ratnum
+    ($dmpairs (+ (most-positive-fixnum) 16) 3/11)
+    (case (fixnum-width)
+      [(30) '((1968526732 . 1/11) (-1968526733 . 2/11)
+              (-1968526732 . 1/11) (1968526733 . 2/11)
+              (0 . 3/11) (-1 . 5905580194/11) (0 . 3/11)
+              (1 . 5905580194/11))]
+      [(61) '((4227378850225105633 . 2/11)
+              (-4227378850225105634 . 1/11)
+              (-4227378850225105633 . 2/11)
+              (4227378850225105634 . 1/11) (0 . 3/11)
+              (-1 . 12682136550675316898/11) (0 . 3/11)
+              (1 . 12682136550675316898/11))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; flonum, flonum
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (-1.0 . 7.75) (-0.0 . 3.5) (1.0 . 7.75)
+      (3.0 . 0.75) (-4.0 . 2.75) (-3.0 . 0.75) (4.0 . 2.75)))
+  ($dmequal? ; flonum, ratnum
+    ($dmpairs 3.5 23/2)
+    '((0.0 . 3.5) (-1.0 . 8.0) (-0.0 . 3.5) (1.0 . 8.0)
+      (3.0 . 1.0) (-4.0 . 2.5) (-3.0 . 1.0) (4.0 . 2.5)))
+  ($dmequal? ; ratnum, ratnum
+    ($dmpairs 3/5 23/7)
+    '((0 . 3/5) (-1 . 94/35) (0 . 3/5) (1 . 94/35)
+      (5 . 2/7) (-6 . 11/35) (-5 . 2/7) (6 . 11/35)))
+ ; div with mod
+  (begin
+    (set! $d&m (lambda (x y) (values (div x y) (mod x y))))
+    #t)
+  ($dmequal?
+    ($dmpairs 0 1)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 24 8)
+    '((3 . 0) (-3 . 0) (-3 . 0) (3 . 0) (0 . 8) (-1 . 16) (0 . 8) (1 . 16)))
+  ($dmequal?
+    ($dmpairs 0 (expt (most-positive-fixnum) 3))
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0 1.0)
+    '((0.0 . 0.0) (0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0) (-inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0 3/4)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0.0 1)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 (* (most-positive-fixnum) 7))
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3/4)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal? ; fixnum, fixnum
+    ($dmpairs 3 1000)
+    '((0 . 3) (-1 . 997) (0 . 3) (1 . 997) (333 . 1) (-334 . 2) (-333 . 1) (334 . 2)))
+  ($dmequal? ; fixnum, fixnum overflow case
+    ($dmpair (most-negative-fixnum) -1)
+    (cons (- (most-negative-fixnum)) 0))
+  ($dmequal? ; fixnum, bignum
+    ($dmpairs 3 (expt (most-positive-fixnum) 3))
+    (case (fixnum-width)
+      [(30) '((0 . 3) (-1 . 154742504045981407517868028)
+              (0 . 3) (1 . 154742504045981407517868028)
+              (51580834681993802505956010 . 1)
+              (-51580834681993802505956011 . 2)
+              (-51580834681993802505956010 . 1)
+              (51580834681993802505956011 . 2))]
+      [(61) '((0 . 3)
+              (-1 .  1532495540865888854370663039795561568366082455163109372)
+              (0 . 3)
+              (1 .  1532495540865888854370663039795561568366082455163109372)
+              (510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (510831846955296284790221013265187189455360818387703125 .  0))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; fixnum, flonum
+    ($dmpairs 3 15.5)
+    '((0.0 . 3.0) (-1.0 . 12.5) (-0.0 . 3.0) (1.0 . 12.5)
+      (5.0 . 0.5) (-6.0 . 2.5) (-5.0 . 0.5) (6.0 . 2.5)))
+  ($dmequal? ; fixnum, ratnum
+    ($dmpairs 3 32/7)
+    '((0 . 3) (-1 . 11/7) (0 . 3) (1 . 11/7)
+      (1 . 11/7) (-2 . 10/7) (-1 . 11/7) (2 . 10/7)))
+  ($dmequal? ; bignum, flonum
+    ($dmpairs (+ (most-positive-fixnum) 16) 0.25)
+    (case (fixnum-width)
+      [(30) '((2147483708.0 . 0.0) (-2147483708.0 . 0.0)
+              (-2147483708.0 . 0.0) (2147483708.0 . 0.0)
+              (0.0 . 0.25) (-1.0 . 536870926.75)
+              (-0.0 . 0.25) (1.0 . 536870926.75))]
+      [(61) '((4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (4.611686018427388e18 . 0.0) (0.0 . 0.25)
+              (-1.0 . 1.152921504606847e18) (-0.0 . 0.25)
+              (1.0 . 1.152921504606847e18))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; bignum, ratnum
+    ($dmpairs (+ (most-positive-fixnum) 16) 3/11)
+    (case (fixnum-width)
+      [(30) '((1968526732 . 1/11) (-1968526733 . 2/11)
+              (-1968526732 . 1/11) (1968526733 . 2/11)
+              (0 . 3/11) (-1 . 5905580194/11) (0 . 3/11)
+              (1 . 5905580194/11))]
+      [(61) '((4227378850225105633 . 2/11)
+              (-4227378850225105634 . 1/11)
+              (-4227378850225105633 . 2/11)
+              (4227378850225105634 . 1/11) (0 . 3/11)
+              (-1 . 12682136550675316898/11) (0 . 3/11)
+              (1 . 12682136550675316898/11))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; flonum, flonum
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (-1.0 . 7.75) (-0.0 . 3.5) (1.0 . 7.75)
+      (3.0 . 0.75) (-4.0 . 2.75) (-3.0 . 0.75) (4.0 . 2.75)))
+  ($dmequal? ; flonum, ratnum
+    ($dmpairs 3.5 23/2)
+    '((0.0 . 3.5) (-1.0 . 8.0) (-0.0 . 3.5) (1.0 . 8.0)
+      (3.0 . 1.0) (-4.0 . 2.5) (-3.0 . 1.0) (4.0 . 2.5)))
+  ($dmequal? ; ratnum, ratnum
+    ($dmpairs 3/5 23/7)
+    '((0 . 3/5) (-1 . 94/35) (0 . 3/5) (1 . 94/35)
+      (5 . 2/7) (-6 . 11/35) (-5 . 2/7) (6 . 11/35)))
+)
+
+(mat div0-and-mod0
+ ; div0-and-mod0
+  (error? (div0-and-mod0 3 0))
+  (error? (div0-and-mod0 (+ (most-positive-fixnum) 1) 0))
+  (error? (div0-and-mod0 3/5 0))
+  (error? (div0-and-mod0 'a 17))
+  (error? (div0-and-mod0 17 '(a)))
+ ; div0
+  (error? (div0 3 0))
+  (error? (div0 (+ (most-positive-fixnum) 1) 0))
+  (error? (div0 3/5 0))
+  (error? (div0 'a 17))
+  (error? (div0 17 '(a)))
+ ; mod0
+  (error? (mod0 3 0))
+  (error? (mod0 (+ (most-positive-fixnum) 1) 0))
+  (error? (mod0 3/5 0))
+  (error? (mod0 'a 17))
+  (error? (mod0 17 '(a)))
+ ; div0-and-mod0
+  (begin
+    (define $d&m div0-and-mod0)
+    (define ($dmpair x y)
+      (if (and (eq? y 0) (exact? x))
+          #f
+          (call-with-values (lambda () ($d&m x y)) cons)))
+    (define ($dmpairs x y)
+      (list ($dmpair x y) ($dmpair (- x) y) ($dmpair x (- y)) ($dmpair (- x) (- y))
+            ($dmpair y x) ($dmpair (- y) x) ($dmpair y (- x)) ($dmpair (- y) (- x))))
+    #t)
+  ($dmequal?
+    ($dmpairs 0 1)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0 (expt (most-positive-fixnum) 3))
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0 1.0)
+    '((0.0 . 0.0) (0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0) (-inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0 3/4)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0.0 1)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 (* (most-positive-fixnum) 7))
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3/4)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal? ; fixnum, fixnum
+    ($dmpairs 3 1000)
+    '((0 . 3) (0 . -3) (0 . 3) (0 . -3) (333 . 1) (-333 . -1) (-333 . 1) (333 . -1)))
+  ($dmequal? ; fixnum, fixnum overflow case
+    ($dmpair (most-negative-fixnum) -1)
+    (cons (- (most-negative-fixnum)) 0))
+  ($dmequal? ; fixnum, bignum
+    ($dmpairs 3 (expt (most-positive-fixnum) 3))
+    (case (fixnum-width)
+      [(30) '((0 . 3) (0 . -3) (0 . 3) (0 . -3)
+              (51580834681993802505956010 . 1)
+              (-51580834681993802505956010 . -1)
+              (-51580834681993802505956010 . 1)
+              (51580834681993802505956010 . -1))]
+      [(61) '((0 . 3) (0 . -3) (0 . 3) (0 . -3)
+              (510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (510831846955296284790221013265187189455360818387703125 .  0))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; fixnum, flonum
+    ($dmpairs 3 15.5)
+    '((0.0 . 3.0) (0.0 . -3.0) (-0.0 . 3.0) (0.0 . -3.0)
+      (5.0 . 0.5) (-5.0 . -0.5) (-5.0 . 0.5) (5.0 . -0.5)))
+  ($dmequal? ; fixnum, ratnum
+    ($dmpairs 3 32/7)
+    '((1 . -11/7) (-1 . 11/7) (-1 . -11/7) (1 . 11/7)
+      (2 . -10/7) (-2 . 10/7) (-2 . -10/7) (2 . 10/7)))
+  ($dmequal? ; bignum, flonum
+    ($dmpairs (+ (most-positive-fixnum) 16) 0.25)
+    (case (fixnum-width)
+      [(30) '((2147483708.0 . 0.0) (-2147483708.0 . 0.0)
+              (-2147483708.0 . 0.0) (2147483708.0 . 0.0)
+              (0.0 . 0.25) (0.0 . -0.25) (-0.0 . 0.25)
+              (0.0 . -0.25))]
+      [(61) '((4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (4.611686018427388e18 . 0.0) (0.0 . 0.25)
+              (0.0 . 0.0) (-0.0 . 0.25) (0.0 . 0.0))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; bignum, ratnum
+    ($dmpairs (+ (most-positive-fixnum) 16) 3/11)
+    (case (fixnum-width)
+      [(30) '((1968526732 . 1/11) (-1968526732 . -1/11)
+              (-1968526732 . 1/11) (1968526732 . -1/11)
+              (0 . 3/11) (0 . -3/11) (0 . 3/11) (0 . -3/11))]
+      [(61) '((4227378850225105634 . -1/11)
+              (-4227378850225105634 . 1/11)
+              (-4227378850225105634 . -1/11)
+              (4227378850225105634 . 1/11) (0 . 3/11)
+              (0 . -3/11) (0 . 3/11) (0 . -3/11))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; flonum, flonum
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (0.0 . -3.5) (-0.0 . 3.5) (0.0 . -3.5)
+      (3.0 . 0.75) (-3.0 . -0.75) (-3.0 . 0.75) (3.0 . -0.75)))
+  ($dmequal? ; flonum, ratnum
+    ($dmpairs 3.5 23/2)
+    '((0.0 . 3.5) (0.0 . -3.5) (-0.0 . 3.5) (0.0 . -3.5)
+      (3.0 . 1.0) (-3.0 . -1.0) (-3.0 . 1.0) (3.0 . -1.0)))
+  ($dmequal? ; ratnum, ratnum
+    ($dmpairs 3/5 23/7)
+    '((0 . 3/5) (0 . -3/5) (0 . 3/5) (0 . -3/5)
+      (5 . 2/7) (-5 . -2/7) (-5 . 2/7) (5 . -2/7)))
+ ; div0 with mod0
+  (begin
+    (set! $d&m (lambda (x y) (values (div0 x y) (mod0 x y))))
+    #t)
+  ($dmequal?
+    ($dmpairs 0 1)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0 (expt (most-positive-fixnum) 3))
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0 1.0)
+    '((0.0 . 0.0) (0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0) (-inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0 3/4)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  ($dmequal?
+    ($dmpairs 0.0 1)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 (* (most-positive-fixnum) 7))
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 0.0 3/4)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal? ; fixnum, fixnum
+    ($dmpairs 3 1000)
+    '((0 . 3) (0 . -3) (0 . 3) (0 . -3) (333 . 1) (-333 . -1) (-333 . 1) (333 . -1)))
+  ($dmequal? ; fixnum, fixnum overflow case
+    ($dmpair (most-negative-fixnum) -1)
+    (cons (- (most-negative-fixnum)) 0))
+  ($dmequal? ; fixnum, bignum
+    ($dmpairs 3 (expt (most-positive-fixnum) 3))
+    (case (fixnum-width)
+      [(30) '((0 . 3) (0 . -3) (0 . 3) (0 . -3)
+              (51580834681993802505956010 . 1)
+              (-51580834681993802505956010 . -1)
+              (-51580834681993802505956010 . 1)
+              (51580834681993802505956010 . -1))]
+      [(61) '((0 . 3) (0 . -3) (0 . 3) (0 . -3)
+              (510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (-510831846955296284790221013265187189455360818387703125 .  0)
+              (510831846955296284790221013265187189455360818387703125 .  0))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; fixnum, flonum
+    ($dmpairs 3 15.5)
+    '((0.0 . 3.0) (0.0 . -3.0) (-0.0 . 3.0) (0.0 . -3.0)
+      (5.0 . 0.5) (-5.0 . -0.5) (-5.0 . 0.5) (5.0 . -0.5)))
+  ($dmequal? ; fixnum, ratnum
+    ($dmpairs 3 32/7)
+    '((1 . -11/7) (-1 . 11/7) (-1 . -11/7) (1 . 11/7)
+      (2 . -10/7) (-2 . 10/7) (-2 . -10/7) (2 . 10/7)))
+  ($dmequal? ; bignum, flonum
+    ($dmpairs (+ (most-positive-fixnum) 16) 0.25)
+    (case (fixnum-width)
+      [(30) '((2147483708.0 . 0.0) (-2147483708.0 . 0.0)
+              (-2147483708.0 . 0.0) (2147483708.0 . 0.0)
+              (0.0 . 0.25) (0.0 . -0.25) (-0.0 . 0.25)
+              (0.0 . -0.25))]
+      [(61) '((4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (-4.611686018427388e18 . 0.0)
+              (4.611686018427388e18 . 0.0) (0.0 . 0.25)
+              (0.0 . 0.0) (-0.0 . 0.25) (0.0 . 0.0))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; bignum, ratnum
+    ($dmpairs (+ (most-positive-fixnum) 16) 3/11)
+    (case (fixnum-width)
+      [(30) '((1968526732 . 1/11) (-1968526732 . -1/11)
+              (-1968526732 . 1/11) (1968526732 . -1/11)
+              (0 . 3/11) (0 . -3/11) (0 . 3/11) (0 . -3/11))]
+      [(61) '((4227378850225105634 . -1/11)
+              (-4227378850225105634 . 1/11)
+              (-4227378850225105634 . -1/11)
+              (4227378850225105634 . 1/11) (0 . 3/11)
+              (0 . -3/11) (0 . 3/11) (0 . -3/11))]
+      [else (errorf #f "mat does not handle fixnum width")]))
+  ($dmequal? ; flonum, flonum
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (0.0 . -3.5) (-0.0 . 3.5) (0.0 . -3.5)
+      (3.0 . 0.75) (-3.0 . -0.75) (-3.0 . 0.75) (3.0 . -0.75)))
+  ($dmequal? ; flonum, ratnum
+    ($dmpairs 3.5 23/2)
+    '((0.0 . 3.5) (0.0 . -3.5) (-0.0 . 3.5) (0.0 . -3.5)
+      (3.0 . 1.0) (-3.0 . -1.0) (-3.0 . 1.0) (3.0 . -1.0)))
+  ($dmequal? ; ratnum, ratnum
+    ($dmpairs 3/5 23/7)
+    '((0 . 3/5) (0 . -3/5) (0 . 3/5) (0 . -3/5)
+      (5 . 2/7) (-5 . -2/7) (-5 . 2/7) (5 . -2/7)))
+)
+
+(mat special-cases ; test special cases added Feb 2020
+  (begin
+    (define $n 40910371311673474504209841881478505181983799806634563)
+    (define $-n (- $n))
+    (define $q 40910371311673474504209841881478505181983799806634563/7312893582423593745243587)
+    (define $-q (- $q))
+    (define $x 1.499423325079378e100)
+    (define $-x (- $x))
+    (define $ez 3+4i)
+    (define $-ez (- $ez))
+    (define $iz 3.0-4.0i)
+    (define $-iz (- $iz))
+    #t)
+  (error? ; not a number
+    (div-and-mod 'bogus 1))
+  (error? ; not a number
+    (div-and-mod 'bogus -1))
+  (error? ; domain error
+    (div-and-mod $n 4+3i))
+  (error? ; domain error
+    (div-and-mod 4+3i $n))
+  (error? ; domain error
+    (div-and-mod 0 0))
+  (error? ; domain error
+    (div-and-mod $n 0))
+  (error? ; domain error
+    (div-and-mod $q 0))
+  (error? ; not a number
+    (div 'bogus 1))
+  (error? ; not a number
+    (div 'bogus -1))
+  (error? ; domain error
+    (div $n 4+3i))
+  (error? ; domain error
+    (div 4+3i $n))
+  (error? ; domain error
+    (div 0 0))
+  (error? ; domain error
+    (div $n 0))
+  (error? ; domain error
+    (div $q 0))
+  (error? ; not a number
+    (mod 'bogus 1))
+  (error? ; not a number
+    (mod 'bogus -1))
+  (error? ; domain error
+    (mod $n 4+3i))
+  (error? ; domain error
+    (mod 4+3i $n))
+  (error? ; domain error
+    (mod 0 0))
+  (error? ; domain error
+    (mod $n 0))
+  (error? ; domain error
+    (mod $q 0))
+  (error? ; not a number
+    (div0-and-mod0 'bogus 1))
+  (error? ; not a number
+    (div0-and-mod0 'bogus -1))
+  (error? ; domain error
+    (div0-and-mod0 $n 4+3i))
+  (error? ; domain error
+    (div0-and-mod0 4+3i $n))
+  (error? ; domain error
+    (div0-and-mod0 0 0))
+  (error? ; domain error
+    (div0-and-mod0 $n 0))
+  (error? ; domain error
+    (div0-and-mod0 $q 0))
+  (error? ; not a number
+    (div0 'bogus 1))
+  (error? ; not a number
+    (div0 'bogus -1))
+  (error? ; domain error
+    (div0 $n 4+3i))
+  (error? ; domain error
+    (div0 4+3i $n))
+  (error? ; domain error
+    (div0 0 0))
+  (error? ; domain error
+    (div0 $n 0))
+  (error? ; domain error
+    (div0 $q 0))
+  (error? ; not a number
+    (mod0 'bogus 1))
+  (error? ; not a number
+    (mod0 'bogus -1))
+  (error? ; domain error
+    (mod0 $n 4+3i))
+  (error? ; domain error
+    (mod0 4+3i $n))
+  (error? ; domain error
+    (mod0 0 0))
+  (error? ; domain error
+    (mod0 $n 0))
+  (error? ; domain error
+    (mod0 $q 0))
+  (error? ; not a number
+    (quotient 'bogus 1))
+  (error? ; not a number
+    (quotient 'bogus -1))
+  (error? ; domain error
+    (quotient $n 4+3i))
+  (error? ; domain error
+    (quotient 4.5 $n))
+  (error? ; domain error
+    (quotient 0 0))
+  (error? ; domain error
+    (quotient $n 0))
+  (error? ; domain error
+    (quotient 4.0 0))
+  (error? ; not a number
+    (remainder 'bogus 1))
+  (error? ; not a number
+    (remainder 'bogus -1))
+  (error? ; domain error
+    (remainder $n 4+3i))
+  (error? ; domain error
+    (remainder 4.5 $n))
+  (error? ; domain error
+    (remainder 0 0))
+  (error? ; domain error
+    (remainder $n 0))
+  (error? ; domain error
+    (remainder 4.0 0))
+  (error? ; not a number
+    (modulo 'bogus 1))
+  (error? ; not a number
+    (modulo 'bogus -1))
+  (error? ; domain error
+    (modulo $n 4+3i))
+  (error? ; domain error
+    (modulo 4.5 $n))
+  (error? ; domain error
+    (modulo 0 0))
+  (error? ; domain error
+    (modulo $n 0))
+  (error? ; domain error
+    (modulo 4.0 0))
+  (error? ; not a number
+    (/ 'bogus 1))
+  (error? ; not a number
+    (/ 'bogus -1))
+  (error? ; domain error
+    (/ 0 0))
+  (error? ; domain error
+    (/ $n 0))
+  (error? ; domain error
+    (/ $q 0))
+  (error? ; domain error
+    (/ $ez 0))
+  (error? ; not a number
+    (* 'bogus 0))
+  (error? ; not a number
+    (* 'bogus 1))
+  (error? ; not a number
+    (* 'bogus -1))
+  (error? ; not a number
+    (* 0 'bogus))
+  (error? ; not a number
+    (* 1 'bogus))
+  (error? ; not a number
+    (* -1 'bogus))
+  (error? ; not a number
+    (+ 'bogus 0))
+  (error? ; not a number
+    (+ 0 'bogus))
+  (error? ; not a number
+    (- 'bogus 0))
+  (error? ; not a number
+    (- 0 'bogus))
+  (equal? (call-with-values (lambda () (div-and-mod $n 1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (div-and-mod $n -1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div-and-mod $-n 1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div-and-mod $-n -1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div $n 1) (mod $n 1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div $n -1) (mod $n -1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div $-n 1) (mod $n 1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div $-n -1) (mod $n -1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $n 1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $n -1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $-n 1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $-n -1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $n 1) (mod0 $n 1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $n -1) (mod0 $n -1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $-n 1) (mod0 $n 1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $-n -1) (mod0 $n -1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $n 1) (remainder $n 1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $n -1) (remainder $n -1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $-n 1) (remainder $n 1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $-n -1) (remainder $n -1))) cons) `(,$n . 0))
+  (equal? (modulo $n 1) 0)
+  (equal? (modulo $n -1) 0)
+  (equal? (modulo $-n 1) 0)
+  (equal? (modulo $-n -1) 0)
+  (equal? (/ $n 1) $n)
+  (equal? (/ $n -1) $-n)
+  (equal? (/ $-n 1) $-n)
+  (equal? (/ $-n -1) $n)
+  (equal? (/ 0 $n) 0)
+  (equal? (/ 0 $-n) 0)
+  (equal? (/ $q 1) $q)
+  (equal? (/ $q -1) $-q)
+  (equal? (/ $-q 1) $-q)
+  (equal? (/ $-q -1) $q)
+  (equal? (/ $x 1) $x)
+  (equal? (/ $x -1) $-x)
+  (equal? (/ $-x 1) $-x)
+  (equal? (/ $-x -1) $x)
+  (equal? (/ $ez 1) $ez)
+  (equal? (/ $ez -1) $-ez)
+  (equal? (/ $-ez 1) $-ez)
+  (equal? (/ $-ez -1) $ez)
+  (equal? (/ $iz 1) $iz)
+  (equal? (/ $iz -1) $-iz)
+  (equal? (/ $-iz 1) $-iz)
+  (equal? (/ $-iz -1) $iz)
+  (equal? (* $n 1) $n)
+  (equal? (* $n -1) $-n)
+  (equal? (* $-n 1) $-n)
+  (equal? (* $-n -1) $n)
+  (equal? (* $n 0) 0)
+  (equal? (* $-n 0) 0)
+  (equal? (* $q 1) $q)
+  (equal? (* $q -1) $-q)
+  (equal? (* $-q 1) $-q)
+  (equal? (* $-q -1) $q)
+  (equal? (* $q 0) 0)
+  (equal? (* $-q 0) 0)
+  (equal? (* $x 1) $x)
+  (equal? (* $x -1) $-x)
+  (equal? (* $-x 1) $-x)
+  (equal? (* $-x -1) $x)
+  (equal? (* $x 0) 0)
+  (equal? (* $-x 0) 0)
+  (equal? (* $ez 1) $ez)
+  (equal? (* $ez -1) $-ez)
+  (equal? (* $-ez 1) $-ez)
+  (equal? (* $-ez -1) $ez)
+  (equal? (* $ez 0) 0)
+  (equal? (* $-ez 0) 0)
+  (equal? (* $iz 1) $iz)
+  (equal? (* $iz -1) $-iz)
+  (equal? (* $-iz 1) $-iz)
+  (equal? (* $-iz -1) $iz)
+  (equal? (* $iz 0) 0)
+  (equal? (* $-iz 0) 0)
+  (equal? (* 1 $n) $n)
+  (equal? (* -1 $n) $-n)
+  (equal? (* 1 $-n) $-n)
+  (equal? (* -1 $-n) $n)
+  (equal? (* 0 $n) 0)
+  (equal? (* 0 $-n) 0)
+  (equal? (* 1 $q) $q)
+  (equal? (* -1 $q) $-q)
+  (equal? (* 1 $-q) $-q)
+  (equal? (* -1 $-q) $q)
+  (equal? (* 0 $q) 0)
+  (equal? (* 0 $-q) 0)
+  (equal? (* 1 $x) $x)
+  (equal? (* -1 $x) $-x)
+  (equal? (* 1 $-x) $-x)
+  (equal? (* -1 $-x) $x)
+  (equal? (* 0 $x) 0)
+  (equal? (* 0 $-x) 0)
+  (equal? (* 1 $ez) $ez)
+  (equal? (* -1 $ez) $-ez)
+  (equal? (* 1 $-ez) $-ez)
+  (equal? (* -1 $-ez) $ez)
+  (equal? (* 0 $ez) 0)
+  (equal? (* 0 $-ez) 0)
+  (equal? (* 1 $iz) $iz)
+  (equal? (* -1 $iz) $-iz)
+  (equal? (* 1 $-iz) $-iz)
+  (equal? (* -1 $-iz) $iz)
+  (equal? (* 0 $iz) 0)
+  (equal? (* 0 $-iz) 0)
+  (equal? (+ $n 0) $n)
+  (equal? (+ $-n 0) $-n)
+  (equal? (+ 0 $n) $n)
+  (equal? (+ 0 $-n) $-n)
+  (equal? (+ $q 0) $q)
+  (equal? (+ $-q 0) $-q)
+  (equal? (+ 0 $q) $q)
+  (equal? (+ 0 $-q) $-q)
+  (equal? (+ $x 0) $x)
+  (equal? (+ $-x 0) $-x)
+  (equal? (+ 0 $x) $x)
+  (equal? (+ 0 $-x) $-x)
+  (equal? (+ $ez 0) $ez)
+  (equal? (+ $-ez 0) $-ez)
+  (equal? (+ 0 $ez) $ez)
+  (equal? (+ 0 $-ez) $-ez)
+  (equal? (+ $iz 0) $iz)
+  (equal? (+ $-iz 0) $-iz)
+  (equal? (+ 0 $iz) $iz)
+  (equal? (+ 0 $-iz) $-iz)
+  (equal? (- $n 0) $n)
+  (equal? (- $-n 0) $-n)
+  (equal? (- 0 $n) $-n)
+  (equal? (- 0 $-n) $n)
+  (equal? (- $q 0) $q)
+  (equal? (- $-q 0) $-q)
+  (equal? (- 0 $q) $-q)
+  (equal? (- 0 $-q) $q)
+  (equal? (- $x 0) $x)
+  (equal? (- $-x 0) $-x)
+  (equal? (- 0 $x) $-x)
+  (equal? (- 0 $-x) $x)
+  (equal? (- $ez 0) $ez)
+  (equal? (- $-ez 0) $-ez)
+  (equal? (- 0 $ez) $-ez)
+  (equal? (- 0 $-ez) $ez)
+  (equal? (- $iz 0) $iz)
+  (equal? (- $-iz 0) $-iz)
+  (equal? (- 0 $iz) $-iz)
+  (equal? (- 0 $-iz) $iz)
+  (equal? (- 0 (most-negative-fixnum)) (+ (most-positive-fixnum) 1))
+)
+
+(mat benchmarks
+  (let ()
+    ; revert to the original values for benchmarking
+    (define runs 1 #;10)
+    (define iter 1 #;100000)
+    (define min-ns 0 #;#e25e7)
+
+    (define time->ns
+      (lambda (t)
+        (+ (* (time-second t) 1000000000) (time-nanosecond t))))
+
+    (define mean
+      (lambda (ls)
+        (assert (not (null? ls)))
+        (/ (apply + ls) (length ls))))
+
+    (define stddev
+      (lambda (m ls)
+        (define (square x) (* x x))
+        (sqrt (mean (map (lambda (x) (square (- x m))) ls)))))
+
+    (define ($run-one expr th expected)
+      (define (do-big-iter)
+        (collect 0 0)
+        (let ([t0 (current-time 'time-monotonic)])
+          (do ([iter iter (#3%fx- iter 1)] [ans #f (th)])
+            ((#3%fx= iter 0)
+             (let ([t (time-difference t0 (current-time 'time-monotonic))])
+               (unless (equal? ans expected) (errorf #f "oops ~s != ~s for ~s" ans expected expr))
+               t)))))
+      (parameterize ([collect-request-handler void])
+        (collect (collect-maximum-generation))
+        ; warm up and calibrate number of ITERATIONS to at least meet min-ns
+        (let ([ITER (let loop ([ITER 1] [t (make-time 'time-duration 0 0)])
+                      (let ([t (time-difference t (do-big-iter))])
+                        (if (>= (time->ns t) min-ns)
+                            ITER
+                            (loop (fx+ ITER 1) t))))])
+          (do ([run runs (#3%fx- run 1)]
+               [t* '() (cons
+                         (let loop ([ITER ITER] [t (make-time 'time-duration 0 0)])
+                           (do ([ITER ITER (#3%fx- ITER 1)]
+                                [t (make-time 'time-duration 0 0) (time-difference t (do-big-iter))])
+                             ((#3%fx= ITER 0) t)))
+                         t*)])
+            ((#3%fx= run 0)
+             (let ([ns* (map time->ns (reverse t*))])
+               (let ([m (mean ns*)])
+                 (printf "~s\n" (vector expr (/ m ITER) (if (= m 0) 0 (/ (stddev m ns*) m)) ITER))
+                 (flush-output-port))))))))
+
+    (let ()
+      (define (run sra)
+        (define-syntax run-one
+          (lambda (x)
+            (define prettify
+              (lambda (x)
+                (let-values ([(neg? x) (if (< x 0) (values #t (- x)) (values #f x))])
+                  (let ([s (format "~{~a~^+~}"
+                             (let loop ([x x] [k 0] [ls '()])
+                               (let ([b (bitwise-first-bit-set x)])
+                                 (if (= b -1)
+                                     ls
+                                     (let ([k (+ k b)])
+                                       (loop (bitwise-arithmetic-shift-right x (fx+ b 1)) (fx+ k 1)
+                                         (cons (if (= k 0) "1" (format "2^~a" k)) ls)))))))])
+                    (if neg? (format "-(~a)" s) s)))))
+            (syntax-case x ()
+              [(_ sra x k expected)
+               (with-syntax ([n (eval (datum x))])
+                 (with-syntax ([expr (format "(sra ~a ~s)" (prettify (datum n)) (datum k))])
+                   #'($run-one expr (lambda () (sra n k)) expected)))])))
+        (printf "((iter . ~s) (min-ns . ~s))\n" iter min-ns)
+        (printf "(\n")
+        (run-one sra 1 1 0)
+        (run-one sra (ash 1 1024) 1024 1)
+        (run-one sra (ash 1 1024) 512 (ash 1 512))
+        (run-one sra (- (ash 1 1024)) 1024 -1)
+        (run-one sra (- (ash 1 1024)) 512 (- (ash 1 512)))
+        (run-one sra (+ (ash 1 1024) 1) 1024 1)
+        (run-one sra (+ (ash 1 1024) 1) 512 (ash 1 512))
+        (run-one sra (- (+ (ash 1 1024) 1)) 1024 -2)
+        (run-one sra (- (+ (ash 1 1024) 1)) 512 (- -1 (ash 1 512)))
+        (run-one sra (- (ash 1 1024)) 1024 -1)
+        (run-one sra (- (ash 1 1024)) 512 (- (ash 1 512)))
+        (run-one sra (ash 1 1024) 1025 0)
+        (run-one sra (- (ash 1 1024)) 1025 -1)
+        (run-one sra (ash 3 1023) 1024 1)
+        (run-one sra (- (ash 3 1023)) 1024 -2)
+        (run-one sra (ash 3 1023) 1025 0)
+        (run-one sra (- (ash 3 1023)) 1025 -1)
+        (run-one sra (ash 1 1000000) 1000000 1)
+        (run-one sra (- (ash 1 1000000)) 1000000 -1)
+        (run-one sra (ash 1 1000000) 1000001 0)
+        (run-one sra (- (ash 1 1000000)) 1000001 -1)
+        (run-one sra (ash 3 1000000) 1000001 1)
+        (run-one sra (- (ash 3 1000000)) 1000001 -2)
+        (run-one sra (ash 3 1000000) 1000002 0)
+        (run-one sra (- (ash 3 1000000)) 1000002 -1)
+        ; worst-case---only shifted-off one bit is in the middle
+        (run-one sra (- (+ (ash 1 1024) (ash 1 512))) 1024 -2)
+        ; shift by one bit
+        (run-one sra (ash 3 1000000) 1 (ash 3 999999))
+        (run-one sra (- (ash 3 1000000)) 1 (- (ash 3 999999)))
+        (printf ")\n"))
+
+      (run bitwise-arithmetic-shift-right)
+      (run (lambda (x k) (bitwise-arithmetic-shift x (- k))))
+      (run (lambda (x k) (ash x (- k)))))
+
+    (let ()
+      (define (run)
+        (define $x 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789)
+        (define $y (* (most-positive-fixnum) 2))
+        (define-syntax run-one
+          (syntax-rules ()
+            [(_ expr expected)
+             ($run-one 'expr (lambda () expr) expected)]
+            [(_ expr expected ...)
+             ($run-one 'expr (lambda () (call-with-values (lambda () expr) list)) (list expected ...))]))
+        (define $2x (* 2 $x))
+        (define $x+2 (+ $x 2))
+        (define $-x (- $x))
+        (define $x^4 (* $x $x $x $x))
+        (define $-x^4 (- $x^4))
+        (define $2y (* $y 2))
+        (define $y+2 (+ $y 2))
+        (printf "((iter . ~s) (min-ns . ~s) ($x . ~s) ($y . ~s))\n" iter min-ns $x $y)
+        (printf "(\n")
+        (run-one 0 0)
+        (run-one (* $x 0) 0)
+        (run-one (* $x^4 0) 0)
+        (run-one (* $x 1) $x)
+        (run-one (* $x^4 1) $x^4)
+        (run-one (* $x -1) $-x)
+        (run-one (* $x^4 -1) $-x^4)
+        (run-one (* 1 $x) $x)
+        (run-one (* 1 $x^4) $x^4)
+        (run-one (* -1 $x) $-x)
+        (run-one (* -1 $x^4) $-x^4)
+        (run-one (/ $x 1) $x)
+        (run-one (/ $x^4 1) $x^4)
+        (run-one (/ $x -1) $-x)
+        (run-one (/ $x^4 -1) $-x^4)
+        (run-one (+ $x 0) $x)
+        (run-one (+ $x^4 0) $x^4)
+        (run-one (- $x 0) $x)
+        (run-one (- $x^4 0) $x^4)
+        (run-one (+ 0 $x) $x)
+        (run-one (+ 0 $x^4) $x^4)
+        (run-one (- 0 $x) $-x)
+        (run-one (- 0 $x^4) $-x^4)
+        (run-one (quotient $x 1) $x)
+        (run-one (quotient $x^4 1) $x^4)
+        (run-one (quotient $x -1) $-x)
+        (run-one (remainder $x 1) 0)
+        (run-one (remainder $x^4 1) 0)
+        (run-one (remainder $x -1) 0)
+        (run-one (div-and-mod $x 1) $x 0)
+        (run-one (div-and-mod $x^4 1) $x^4 0)
+        (run-one (div-and-mod $x -1) $-x 0)
+        (run-one (div0-and-mod0 $x 1) $x 0)
+        (run-one (div0-and-mod0 $x^4 1) $x^4 0)
+        (run-one (div0-and-mod0 $x -1) $-x 0)
+        (run-one (div $x 1) $x)
+        (run-one (div $x^4 1) $x^4)
+        (run-one (div $x -1) $-x)
+        (run-one (div0 $x 1) $x)
+        (run-one (div0 $x^4 1) $x^4)
+        (run-one (div0 $x -1) $-x)
+        (run-one (mod $x 1) 0)
+        (run-one (mod $x^4 1) 0)
+        (run-one (mod $x -1) 0)
+        (run-one (mod0 $x 1) 0)
+        (run-one (mod0 $x^4 1) 0)
+        (run-one (mod0 $x -1) 0)
+        ; these should not improve and we hope not slow down measurably
+        (run-one (* $y 2) $2y)
+        (run-one (/ $2y 2) $y)
+        (run-one (+ $y 2) $y+2)
+        (run-one (- $y -2) $y+2)
+        (run-one (quotient $y 2) (ash $y -1))
+        (run-one (remainder $y 2) (logand $y 1))
+        (run-one (div-and-mod $2y 2) $y 0)
+        (run-one (div0-and-mod0 $2y 2) $y 0)
+        (run-one (div $2y 2) $y)
+        (run-one (div0 $2y 2) $y)
+        (run-one (mod $2y 2) 0)
+        (run-one (mod0 $2y 2) 0)
+        (printf ")\n"))
+
+      (run))
+
+    ; use with --program to compare results
+    #;(top-level-program
+      (import (chezscheme))
+
+      (unless (= (length (command-line-arguments)) 3)
+        (fprintf (current-error-port) "usage: ~a:   \n" (car (command-line)))
+        (exit 1))
+
+      (let ([reportfn (car (command-line-arguments))]
+            [beforefn (cadr (command-line-arguments))]
+            [afterfn (caddr (command-line-arguments))])
+        (let-values ([(before-info before) (with-input-from-file beforefn (lambda () (let ([info (read)]) (values info (read)))))]
+                     [(after-info after) (with-input-from-file afterfn (lambda () (let ([info (read)]) (values info (read)))))])
+          (with-output-to-file reportfn
+            (lambda ()
+              (unless (equal? before-info after-info) (errorf #f "before info ~s and after info ~s differ" before-info after-info))
+              (let ([iter (cond [(assq 'iter before-info) => cdr] [else (errorf #f "expected to find binding for iter in info\n")])])
+                (printf "Results ~a\n" (machine-type))
+                (printf "
    ~{~a~^
    ~}
    " (map (lambda (a) (format "~s = ~s" (car a) (cdr a))) before-info))
+                (printf "\n" iter iter)
+                (for-each
+                  (lambda (before after)
+                    (define EXPR 0)
+                    (define MEAN-NS 1)
+                    (define STDDEV 2)
+                    (define ITER 3)
+                    (for-each
+                      (lambda (i)
+                        (unless (equal? (vector-ref before i) (vector-ref after i))
+                          (errorf #f "comparing apples to oranges: ~s, ~s" before after)))
+                      (list EXPR))
+                    (printf "\n"
+                      (vector-ref before EXPR)
+                      (* (/ (- (vector-ref before MEAN-NS) (vector-ref after MEAN-NS)) (vector-ref before MEAN-NS)) 100)
+                      (vector-ref before STDDEV)
+                      (vector-ref after STDDEV)
+                      (/ (vector-ref before MEAN-NS) (expt 10 9))
+                      (/ (vector-ref after MEAN-NS) (expt 10 9))
+                      (vector-ref before ITER)
+                      (vector-ref after ITER)
+                      ))
+                  before
+                  after)
+                (printf "
    expressionspeedupbefore stddevafter stddevbefore time (x~s)after time (x~s)before iterationsafter iterations
    ~a~5,2f%~7,4f%~7,4f%~10,8f~10,8f~s~s
    \n")))
+            'replace))))
+    #t)
+)
diff --git a/mats/5_4.ms b/mats/5_4.ms
new file mode 100644
index 0000000..8f8ef2d
--- /dev/null
+++ b/mats/5_4.ms
@@ -0,0 +1,1576 @@
+;;; 5-4.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat char=?/char-ci=?
+    (error? (char=?))
+    (error? (char=? 'a))
+    (error? (char=? #\a 'a))
+    (error? (char=? #\a 'a #\b))
+    (error? (char=? 'a #\b #\a))
+    (error? (char=? #\a #\c 'a #\b))
+    (error? (char-ci=?))
+    (error? (char-ci=? 'a))
+    (error? (char-ci=? #\a 'a))
+    (error? (char-ci=? #\a 'a #\b))
+    (error? (char-ci=? 'a #\b #\a))
+    (error? (char-ci=? #\a #\c 'a #\b))
+    (char=? #\a #\a)
+    (char-ci=? #\a #\a)
+    (not (char=? #\a #\b))
+    (not (char-ci=? #\a #\b))
+    (not (char=? #\b #\a))
+    (not (char-ci=? #\b #\a))
+    (not (char=? #\a #\A))
+    (char-ci=? #\a #\A)
+    (char=? #\a)
+    (char=? #\a #\a #\a #\a)
+    (not (char=? #\a #\b #\c #\d))
+    (not (char=? #\z #\t #\m #\d))
+    (not (char=? #\a #\t #\m #\d))
+    (not (char=? #\a #\A #\a #\A))
+    (not (char=? #\a #\B #\C #\d))
+    (not (char=? #\Z #\t #\m #\D))
+    (char-ci=? #\a)
+    (char-ci=? #\a #\a #\a #\a)
+    (not (char-ci=? #\a #\b #\c #\d))
+    (not (char-ci=? #\z #\t #\m #\d))
+    (not (char-ci=? #\a #\t #\m #\d))
+    (char-ci=? #\a #\A #\a #\A)
+    (not (char-ci=? #\a #\B #\C #\d))
+    (not (char-ci=? #\Z #\t #\m #\D))
+    (guard (c [#t #t]) (char=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (char=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (char=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (char=? (error #f "oops"))))
+    (guard (c [#t #t]) (char-ci=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (char-ci=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (char-ci=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (char-ci=? (error #f "oops"))))
+ )
+
+(mat char?/char-ci>?
+    (error? (char>?))
+    (error? (char>? 'a))
+    (error? (char>? #\a 'a))
+    (error? (char>? #\a 'a #\b))
+    (error? (char>? 'a #\b #\a))
+    (error? (char>? #\a #\c 'a #\b))
+    (error? (char-ci>?))
+    (error? (char-ci>? 'a))
+    (error? (char-ci>? #\a 'a))
+    (error? (char-ci>? #\a 'a #\b))
+    (error? (char-ci>? 'a #\b #\a))
+    (error? (char-ci>? #\a #\c 'a #\b))
+    (not (char>? #\a #\a))
+    (not (char-ci>? #\a #\b))
+    (char>? #\b #\a)
+    (char-ci>? #\b #\a)
+    (char>? #\a #\A)
+    (not (char-ci>? #\a #\A))
+    (char>? #\a)
+    (not (char>? #\a #\a #\a #\a))
+    (not (char>? #\a #\b #\c #\d))
+    (char>? #\z #\t #\m #\d)
+    (not (char>? #\a #\t #\m #\d))
+    (not (char>? #\a #\A #\a #\A))
+    (not (char>? #\a #\B #\C #\d))
+    (not (char>? #\Z #\t #\m #\D))
+    (char-ci>? #\a)
+    (not (char-ci>? #\a #\a #\a #\a))
+    (not (char-ci>? #\a #\b #\c #\d))
+    (char-ci>? #\z #\t #\m #\d)
+    (not (char-ci>? #\a #\t #\m #\d))
+    (not (char-ci>? #\a #\A #\a #\A))
+    (not (char-ci>? #\a #\B #\C #\d))
+    (char-ci>? #\Z #\t #\m #\D)
+    (guard (c [#t #t]) (char>? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (char>? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (char>? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (char>? (error #f "oops"))))
+    (guard (c [#t #t]) (char-ci>? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (char-ci>? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (char-ci>? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (char-ci>? (error #f "oops"))))
+ )
+
+(mat char<=?/char-ci<=?
+    (error? (char<=?))
+    (error? (char<=? 'a))
+    (error? (char<=? #\a 'a))
+    (error? (char<=? #\a 'a #\b))
+    (error? (char<=? 'a #\b #\a))
+    (error? (char<=? #\a #\c 'a #\b))
+    (error? (char-ci<=?))
+    (error? (char-ci<=? 'a))
+    (error? (char-ci<=? #\a 'a))
+    (error? (char-ci<=? #\a 'a #\b))
+    (error? (char-ci<=? 'a #\b #\a))
+    (error? (char-ci<=? #\a #\c 'a #\b))
+    (char<=? #\a #\a)
+    (char-ci<=? #\a #\a)
+    (char<=? #\a #\b)
+    (char-ci<=? #\a #\b)
+    (not (char<=? #\b #\a))
+    (not (char-ci<=? #\b #\a))
+    (not (char<=? #\a #\A))
+    (char-ci<=? #\a #\A)
+    (char<=? #\a)
+    (char<=? #\a #\a #\a #\a)
+    (char<=? #\a #\b #\c #\d)
+    (not (char<=? #\z #\t #\m #\d))
+    (not (char<=? #\a #\t #\m #\d))
+    (not (char<=? #\a #\A #\a #\A))
+    (not (char<=? #\a #\B #\C #\d))
+    (not (char<=? #\Z #\t #\m #\D))
+    (char-ci<=? #\a)
+    (char-ci<=? #\a #\a #\a #\a)
+    (char-ci<=? #\a #\b #\c #\d)
+    (not (char-ci<=? #\z #\t #\m #\d))
+    (not (char-ci<=? #\a #\t #\m #\d))
+    (char-ci<=? #\a #\A #\a #\A)
+    (char-ci<=? #\a #\B #\C #\d)
+    (not (char-ci<=? #\Z #\t #\m #\D))
+    (guard (c [#t #t]) (char<=? #\4 #\3 (error #f "oops")))
+    (guard (c [#t #t]) (char<=? #\4 (error #f "oops") #\3))
+    (guard (c [#t #t]) (char<=? (error #f "oops") #\4 #\3))
+    (guard (c [#t #t]) (not (char<=? (error #f "oops"))))
+    (guard (c [#t #t]) (char-ci<=? #\4 #\3 (error #f "oops")))
+    (guard (c [#t #t]) (char-ci<=? #\4 (error #f "oops") #\3))
+    (guard (c [#t #t]) (char-ci<=? (error #f "oops") #\4 #\3))
+    (guard (c [#t #t]) (not (char-ci<=? (error #f "oops"))))
+ )
+
+(mat char>=?/char-ci>=?
+    (error? (char>=?))
+    (error? (char>=? 'a))
+    (error? (char>=? #\a 'a))
+    (error? (char>=? #\a 'a #\b))
+    (error? (char>=? 'a #\b #\a))
+    (error? (char>=? #\a #\c 'a #\b))
+    (error? (char-ci>=?))
+    (error? (char-ci>=? 'a))
+    (error? (char-ci>=? #\a 'a))
+    (error? (char-ci>=? #\a 'a #\b))
+    (error? (char-ci>=? 'a #\b #\a))
+    (error? (char-ci>=? #\a #\c 'a #\b))
+    (char>=? #\a #\a)
+    (char-ci>=? #\a #\a)
+    (not (char>=? #\a #\b))
+    (not (char-ci>=? #\a #\b))
+    (char>=? #\b #\a)
+    (char-ci>=? #\b #\a)
+    (not (char>=? #\A #\a))
+    (char-ci>=? #\A #\a)
+    (char>=? #\a)
+    (char>=? #\a #\a #\a #\a)
+    (not (char>=? #\a #\b #\c #\d))
+    (char>=? #\z #\t #\m #\d)
+    (not (char>=? #\a #\t #\m #\d))
+    (not (char>=? #\a #\A #\a #\A))
+    (not (char>=? #\a #\B #\C #\d))
+    (not (char>=? #\Z #\t #\m #\D))
+    (char-ci>=? #\a)
+    (char-ci>=? #\a #\a #\a #\a)
+    (not (char-ci>=? #\a #\b #\c #\d))
+    (char-ci>=? #\z #\t #\m #\d)
+    (not (char-ci>=? #\a #\t #\m #\d))
+    (char-ci>=? #\a #\A #\a #\A)
+    (not (char-ci>=? #\a #\B #\C #\d))
+    (char-ci>=? #\Z #\t #\m #\D)
+    (guard (c [#t #t]) (char>=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (char>=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (char>=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (char>=? (error #f "oops"))))
+    (guard (c [#t #t]) (char-ci>=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (char-ci>=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (char-ci>=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (char-ci>=? (error #f "oops"))))
+ )
+
+(mat r6rs:char=?/r6rs:char-ci=?
+    (error? (r6rs:char=?))
+    (error? (r6rs:char=? 'a))
+    (error? (r6rs:char=? #\a 'a))
+    (error? (r6rs:char=? #\a 'a #\b))
+    (error? (r6rs:char=? 'a #\b #\a))
+    (error? (r6rs:char=? #\a #\c 'a #\b))
+    (error? (r6rs:char-ci=?))
+    (error? (r6rs:char-ci=? 'a))
+    (error? (r6rs:char-ci=? #\a 'a))
+    (error? (r6rs:char-ci=? #\a 'a #\b))
+    (error? (r6rs:char-ci=? 'a #\b #\a))
+    (error? (r6rs:char-ci=? #\a #\c 'a #\b))
+    (r6rs:char=? #\a #\a)
+    (r6rs:char-ci=? #\a #\a)
+    (not (r6rs:char=? #\a #\b))
+    (not (r6rs:char-ci=? #\a #\b))
+    (not (r6rs:char=? #\b #\a))
+    (not (r6rs:char-ci=? #\b #\a))
+    (not (r6rs:char=? #\a #\A))
+    (r6rs:char-ci=? #\a #\A)
+    (r6rs:char=? #\a #\a #\a #\a)
+    (not (r6rs:char=? #\a #\b #\c #\d))
+    (not (r6rs:char=? #\z #\t #\m #\d))
+    (not (r6rs:char=? #\a #\t #\m #\d))
+    (not (r6rs:char=? #\a #\A #\a #\A))
+    (not (r6rs:char=? #\a #\B #\C #\d))
+    (not (r6rs:char=? #\Z #\t #\m #\D))
+    (r6rs:char-ci=? #\a #\a #\a #\a)
+    (not (r6rs:char-ci=? #\a #\b #\c #\d))
+    (not (r6rs:char-ci=? #\z #\t #\m #\d))
+    (not (r6rs:char-ci=? #\a #\t #\m #\d))
+    (r6rs:char-ci=? #\a #\A #\a #\A)
+    (not (r6rs:char-ci=? #\a #\B #\C #\d))
+    (not (r6rs:char-ci=? #\Z #\t #\m #\D))
+    (guard (c [#t #t]) (r6rs:char=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (r6rs:char=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (r6rs:char=? (error #f "oops"))))
+    (guard (c [#t #t]) (r6rs:char-ci=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char-ci=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (r6rs:char-ci=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (r6rs:char-ci=? (error #f "oops"))))
+ )
+
+(mat r6rs:char?/r6rs:char-ci>?
+    (error? (r6rs:char>?))
+    (error? (r6rs:char>? 'a))
+    (error? (r6rs:char>? #\a 'a))
+    (error? (r6rs:char>? #\a 'a #\b))
+    (error? (r6rs:char>? 'a #\b #\a))
+    (error? (r6rs:char>? #\a #\c 'a #\b))
+    (error? (r6rs:char-ci>?))
+    (error? (r6rs:char-ci>? 'a))
+    (error? (r6rs:char-ci>? #\a 'a))
+    (error? (r6rs:char-ci>? #\a 'a #\b))
+    (error? (r6rs:char-ci>? 'a #\b #\a))
+    (error? (r6rs:char-ci>? #\a #\c 'a #\b))
+    (not (r6rs:char>? #\a #\a))
+    (not (r6rs:char-ci>? #\a #\b))
+    (r6rs:char>? #\b #\a)
+    (r6rs:char-ci>? #\b #\a)
+    (r6rs:char>? #\a #\A)
+    (not (r6rs:char-ci>? #\a #\A))
+    (not (r6rs:char>? #\a #\a #\a #\a))
+    (not (r6rs:char>? #\a #\b #\c #\d))
+    (r6rs:char>? #\z #\t #\m #\d)
+    (not (r6rs:char>? #\a #\t #\m #\d))
+    (not (r6rs:char>? #\a #\A #\a #\A))
+    (not (r6rs:char>? #\a #\B #\C #\d))
+    (not (r6rs:char>? #\Z #\t #\m #\D))
+    (not (r6rs:char-ci>? #\a #\a #\a #\a))
+    (not (r6rs:char-ci>? #\a #\b #\c #\d))
+    (r6rs:char-ci>? #\z #\t #\m #\d)
+    (not (r6rs:char-ci>? #\a #\t #\m #\d))
+    (not (r6rs:char-ci>? #\a #\A #\a #\A))
+    (not (r6rs:char-ci>? #\a #\B #\C #\d))
+    (r6rs:char-ci>? #\Z #\t #\m #\D)
+    (guard (c [#t #t]) (r6rs:char>? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char>? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (r6rs:char>? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (r6rs:char>? (error #f "oops"))))
+    (guard (c [#t #t]) (r6rs:char-ci>? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char-ci>? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (r6rs:char-ci>? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (r6rs:char-ci>? (error #f "oops"))))
+ )
+
+(mat r6rs:char<=?/r6rs:char-ci<=?
+    (error? (r6rs:char<=?))
+    (error? (r6rs:char<=? 'a))
+    (error? (r6rs:char<=? #\a 'a))
+    (error? (r6rs:char<=? #\a 'a #\b))
+    (error? (r6rs:char<=? 'a #\b #\a))
+    (error? (r6rs:char<=? #\a #\c 'a #\b))
+    (error? (r6rs:char-ci<=?))
+    (error? (r6rs:char-ci<=? 'a))
+    (error? (r6rs:char-ci<=? #\a 'a))
+    (error? (r6rs:char-ci<=? #\a 'a #\b))
+    (error? (r6rs:char-ci<=? 'a #\b #\a))
+    (error? (r6rs:char-ci<=? #\a #\c 'a #\b))
+    (r6rs:char<=? #\a #\a)
+    (r6rs:char-ci<=? #\a #\a)
+    (r6rs:char<=? #\a #\b)
+    (r6rs:char-ci<=? #\a #\b)
+    (not (r6rs:char<=? #\b #\a))
+    (not (r6rs:char-ci<=? #\b #\a))
+    (not (r6rs:char<=? #\a #\A))
+    (r6rs:char-ci<=? #\a #\A)
+    (r6rs:char<=? #\a #\a #\a #\a)
+    (r6rs:char<=? #\a #\b #\c #\d)
+    (not (r6rs:char<=? #\z #\t #\m #\d))
+    (not (r6rs:char<=? #\a #\t #\m #\d))
+    (not (r6rs:char<=? #\a #\A #\a #\A))
+    (not (r6rs:char<=? #\a #\B #\C #\d))
+    (not (r6rs:char<=? #\Z #\t #\m #\D))
+    (r6rs:char-ci<=? #\a #\a #\a #\a)
+    (r6rs:char-ci<=? #\a #\b #\c #\d)
+    (not (r6rs:char-ci<=? #\z #\t #\m #\d))
+    (not (r6rs:char-ci<=? #\a #\t #\m #\d))
+    (r6rs:char-ci<=? #\a #\A #\a #\A)
+    (r6rs:char-ci<=? #\a #\B #\C #\d)
+    (not (r6rs:char-ci<=? #\Z #\t #\m #\D))
+    (guard (c [#t #t]) (r6rs:char<=? #\4 #\3 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char<=? #\4 (error #f "oops") #\3))
+    (guard (c [#t #t]) (r6rs:char<=? (error #f "oops") #\4 #\3))
+    (guard (c [#t #t]) (not (r6rs:char<=? (error #f "oops"))))
+    (guard (c [#t #t]) (r6rs:char-ci<=? #\4 #\3 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char-ci<=? #\4 (error #f "oops") #\3))
+    (guard (c [#t #t]) (r6rs:char-ci<=? (error #f "oops") #\4 #\3))
+    (guard (c [#t #t]) (not (r6rs:char-ci<=? (error #f "oops"))))
+ )
+
+(mat r6rs:char>=?/r6rs:char-ci>=?
+    (error? (r6rs:char>=?))
+    (error? (r6rs:char>=? 'a))
+    (error? (r6rs:char>=? #\a 'a))
+    (error? (r6rs:char>=? #\a 'a #\b))
+    (error? (r6rs:char>=? 'a #\b #\a))
+    (error? (r6rs:char>=? #\a #\c 'a #\b))
+    (error? (r6rs:char-ci>=?))
+    (error? (r6rs:char-ci>=? 'a))
+    (error? (r6rs:char-ci>=? #\a 'a))
+    (error? (r6rs:char-ci>=? #\a 'a #\b))
+    (error? (r6rs:char-ci>=? 'a #\b #\a))
+    (error? (r6rs:char-ci>=? #\a #\c 'a #\b))
+    (r6rs:char>=? #\a #\a)
+    (r6rs:char-ci>=? #\a #\a)
+    (not (r6rs:char>=? #\a #\b))
+    (not (r6rs:char-ci>=? #\a #\b))
+    (r6rs:char>=? #\b #\a)
+    (r6rs:char-ci>=? #\b #\a)
+    (not (r6rs:char>=? #\A #\a))
+    (r6rs:char-ci>=? #\A #\a)
+    (r6rs:char>=? #\a #\a #\a #\a)
+    (not (r6rs:char>=? #\a #\b #\c #\d))
+    (r6rs:char>=? #\z #\t #\m #\d)
+    (not (r6rs:char>=? #\a #\t #\m #\d))
+    (not (r6rs:char>=? #\a #\A #\a #\A))
+    (not (r6rs:char>=? #\a #\B #\C #\d))
+    (not (r6rs:char>=? #\Z #\t #\m #\D))
+    (r6rs:char-ci>=? #\a #\a #\a #\a)
+    (not (r6rs:char-ci>=? #\a #\b #\c #\d))
+    (r6rs:char-ci>=? #\z #\t #\m #\d)
+    (not (r6rs:char-ci>=? #\a #\t #\m #\d))
+    (r6rs:char-ci>=? #\a #\A #\a #\A)
+    (not (r6rs:char-ci>=? #\a #\B #\C #\d))
+    (r6rs:char-ci>=? #\Z #\t #\m #\D)
+    (guard (c [#t #t]) (r6rs:char>=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char>=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (r6rs:char>=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (r6rs:char>=? (error #f "oops"))))
+    (guard (c [#t #t]) (r6rs:char-ci>=? #\3 #\4 (error #f "oops")))
+    (guard (c [#t #t]) (r6rs:char-ci>=? #\3 (error #f "oops") #\4))
+    (guard (c [#t #t]) (r6rs:char-ci>=? (error #f "oops") #\3 #\4))
+    (guard (c [#t #t]) (not (r6rs:char-ci>=? (error #f "oops"))))
+ )
+
+(mat char-alphabetic?
+    (error? (char-alphabetic?))
+    (error? (char-alphabetic? #\a #\b))
+    (error? (char-alphabetic? 'a))
+    (char-alphabetic? #\z)
+    (not (char-alphabetic? #\3))
+    (char-alphabetic? #\A)
+    (not (char-alphabetic? #\space))
+ )
+
+(mat char-numeric?
+    (error? (char-numeric?))
+    (error? (char-numeric? #\a #\b))
+    (error? (char-numeric? 'a))
+    (not (char-numeric? #\k))
+    (char-numeric? #\0)
+    (char-numeric? #\4)
+    (char-numeric? #\9)
+    (not (char-numeric? #\newline))
+ )
+
+(mat char-lower-case?
+    (error? (char-lower-case?))
+    (error? (char-lower-case? #\a #\b))
+    (error? (char-lower-case? 'a))
+    (char-lower-case? #\z)
+    (not (char-lower-case? #\A))
+ )
+
+(mat char-upper-case?
+    (error? (char-upper-case?))
+    (error? (char-upper-case? #\a #\b))
+    (error? (char-upper-case? 'a))
+    (char-upper-case? #\A)
+    (not (char-upper-case? #\z))
+ )
+
+(mat char-title-case?
+    (error? (char-title-case?))
+    (error? (char-title-case? #\a #\b))
+    (error? (char-title-case? 'a))
+    (char-title-case? #\x01C5)
+    (not (char-title-case? #\z))
+ )
+
+(mat char-general-category
+    (error? (char-general-category))
+    (error? (char-general-category #\a #\b))
+    (error? (char-general-category 'a))
+    (eq? (char-general-category #\A) 'Lu)
+    (eq? (char-general-category #\z) 'Ll)
+ )
+
+(mat char-whitespace?
+    (error? (char-whitespace?))
+    (error? (char-whitespace? #\a #\b))
+    (error? (char-whitespace? 'a))
+    (char-whitespace? #\space)
+    (char-whitespace? #\return)
+    (not (char-whitespace? #\F))
+    (char-whitespace? #\newline)
+    (char-whitespace? #\tab)
+    (not (char-whitespace? #\%))
+    (char-whitespace? #\page)
+    (not (char-whitespace? #\3))
+    (char-whitespace? #\linefeed)
+ )
+
+(mat char-upcase
+    (error? (char-upcase))
+    (error? (char-upcase #\a #\b))
+    (error? (char-upcase 'a))
+    (eqv? (char-upcase #\a) #\A)
+    (eqv? (char-upcase #\Z) #\Z)
+ )
+
+(mat char-titlecase
+    (error? (char-titlecase))
+    (error? (char-titlecase #\a #\b))
+    (error? (char-titlecase 'a))
+    (eqv? (char-titlecase #\a) #\A)
+    (eqv? (char-titlecase #\Z) #\Z)
+ )
+
+(mat char-downcase
+    (error? (char-downcase))
+    (error? (char-downcase #\a #\b))
+    (error? (char-downcase 'a))
+    (eqv? (char-downcase #\a) #\a)
+    (eqv? (char-downcase #\Z) #\z)
+ )
+
+(mat char-foldcase
+    (error? (char-foldcase))
+    (error? (char-foldcase #\a #\b))
+    (error? (char-foldcase 'a))
+    (eqv? (char-foldcase #\a) #\a)
+    (eqv? (char-foldcase #\Z) #\z)
+ )
+
+(mat integer->char
+    (error? (integer->char))
+    (error? (integer->char 17 3))
+    (error? (integer->char 'a))
+    (error? (integer->char #f))
+    (error? (integer->char #\a))
+    (error? (integer->char -1))
+    (error? (integer->char (+ (most-positive-fixnum) 1)))
+    (error? (integer->char (- (most-negative-fixnum) 1)))
+    (error? (integer->char #xD800))
+    (error? (integer->char #xD900))
+    (error? (integer->char #xDA00))
+    (error? (integer->char #xDB00))
+    (error? (integer->char #xDC00))
+    (error? (integer->char #xDD00))
+    (error? (integer->char #xDE00))
+    (error? (integer->char #xDF00))
+    (error? (integer->char #xDFFF))
+    (error? (integer->char #x110000))
+    (error? (integer->char #x120000))
+    (error? (integer->char #x7fffffff))
+    (eqv? (integer->char #x20) #\space)
+    (eqv? (integer->char #x41) #\A)
+    (eqv? (integer->char #x61) #\a)
+    (eqv? (integer->char #x7f) #\rubout)
+    (eqv? (integer->char #xD7FF) #\xD7FF)
+    (eqv? (integer->char #xE000) #\xE000)
+    (eqv? (integer->char #x10FFFF) #\x10FFFF)
+ )
+
+(mat char->integer
+    (error? (char->integer))
+    (error? (char->integer #\a #\b))
+    (error? (char->integer 'a))
+    (error? (char->integer #x20))
+    (eqv? (char->integer #\1) #x31)
+    (eqv? (char->integer #\z) #x7a)
+    (eqv? (char->integer #\~) #x7e)
+    (eqv? (char->integer #\nul) #x00)
+    (eqv? (char->integer #\backspace) #x08)
+    (eqv? (char->integer #\return) #x0d)
+    (eqv? (char->integer #\page) #x0c)
+    (eqv? (char->integer #\linefeed) #x0a)
+    (eqv? (char->integer #\newline) #x0a)
+    (eqv? (char->integer #\rubout) #x7f)
+    (eqv? (char->integer #\space) #x20)
+    (eqv? (char->integer #\tab) #x09)
+    (begin
+      (do ([i 0 (fx+ i 1)])
+          ((fx>= i #xD800))
+        (unless (eqv? (char->integer (integer->char i)) i)
+          (errorf #f "failed for ~s" i)))
+      (do ([i #xE000 (fx+ i 1)])
+          ((fx>= i #x110000))
+        (unless (eqv? (char->integer (integer->char i)) i)
+          (errorf #f "failed for ~s" i)))
+      #t)
+ )
+
+(mat char-
+  (error? (char-))
+  (error? (char- #\a #\b #\c))
+  (error? (char- #\a 4))
+  (eqv? (char- #\b #\a) 1)
+  (eqv? (char- #\a #\b) -1)
+  ;; lambda - eta
+  (eqv? (char- #\x03BB #\x03B7) 4)
+  ;; eta - lambda
+  (eqv? (char- #\x03B7 #\x03BB) -4)
+)
+
+(mat string-for-each
+  (error? ; invalid number of arguments
+    (string-for-each))
+  (error? ; invalid number of arguments
+    (string-for-each '#()))
+  (error? ; invalid number of arguments
+    (string-for-each +))
+  (error? ; non procedure ""
+    (string-for-each "" ""))
+  (error? ; non procedure ""
+    (string-for-each "" "" ""))
+  (error? ; non procedure ""
+    (string-for-each "" "" "" '()))
+  (error? ; non procedure ""
+    (string-for-each "" "" "" "" ""))
+  (error? ; non string 3
+    (string-for-each + 3))
+  (error? ; non string (3)
+    (string-for-each + "" '(3)))
+  (error? ; non string (3)
+    (string-for-each + "" "" '(3)))
+  (error? ; non string (3)
+    (string-for-each + "" "" '(3) ""))
+  (error? ; non string 7
+    (string-for-each + 7 "" "" "" ""))
+  (error? ; lengths differ
+    (string-for-each + "" "x"))
+  (error? ; lengths differ
+    (string-for-each + "" "" "x"))
+  (error? ; lengths differ
+    (string-for-each + "" "" "x" ""))
+  (error? ; lengths differ
+    (string-for-each + "y" "" "x" ""))
+  (error? ; lengths differ
+    (string-for-each + "y" "" "" "" ""))
+  (equal? (string-for-each + "") (void))
+  (equal? (string-for-each + "" "") (void))
+  (equal? (string-for-each + "" "" "") (void))
+  (equal? (string-for-each + "" "" "" "" "") (void))
+  (equal?
+    (let ([ls '()])
+      (string-for-each (lambda (x) (set! ls (cons x ls))) "abcdef")
+      ls)
+    '(#\f #\e #\d #\c #\b #\a))
+  (equal?
+    (let ([ls '()])
+      (string-for-each
+        (lambda (x y) (set! ls (cons (cons x y) ls)))
+        "abcdef"
+        "327654")
+      ls)
+    '((#\f . #\4) (#\e . #\5) (#\d . #\6) (#\c . #\7) (#\b . #\2) (#\a . #\3)))
+  (equal?
+    (let ([ls '()])
+      (string-for-each
+        (lambda r (set! ls (cons r ls)))
+        "abcdef"
+        "327654"
+        "!@#$%^")
+      ls)
+    '((#\f #\4 #\^) (#\e #\5 #\%) (#\d #\6 #\$) (#\c #\7 #\#) (#\b #\2 #\@) (#\a #\3 #\!)))
+  (equal?
+    (let ([ls '()])
+      (string-for-each
+        (lambda r (set! ls (cons r ls)))
+        "abcdef"
+        "327654"
+        "!@#$%^"
+        "hello!"
+        "hello?"
+        "3.1415")
+      (map list->string ls))
+    '("f4^!?5" "e5%oo1" "d6$ll4" "c7#ll1" "b2@ee." "a3!hh3"))
+  (begin
+    (define ($string-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (string-for-each p "")
+        (string-for-each p "" x1)
+        (string-for-each p "" x1 x2)
+        (string-for-each p "" x1 x2 x3)
+        (string-for-each p "" x1 x2 x3 x4)
+        (string-for-each p "" x1 x2 x3 x4 x5)
+        (string-for-each p x1 "")
+        (string-for-each p x1 "" x2)
+        (string-for-each p x1 "" x2 x3)
+        (string-for-each p x1 "" x2 x3 x4)
+        (string-for-each p x1 "" x2 x3 x4 x5)
+        (string-for-each p x1 x2 "")
+        (string-for-each p x1 x2 "" x3)
+        (string-for-each p x1 x2 "" x3 x4)
+        (string-for-each p x1 x2 "" x3 x4 x5)
+        (string-for-each p x1 x2 x3 "")
+        (string-for-each p x1 x2 x3 "" x4)
+        (string-for-each p x1 x2 x3 "" x4 x5)
+        (string-for-each p x1 x2 x3 x4 "")
+        (string-for-each p x1 x2 x3 x4 "" x5)
+        (string-for-each p x1 x2 x3 x4 x5 "")))
+    (procedure? $string-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($string-for-each-f1 q "" "" "" "" "")
+      (reverse ls))
+    '())
+  (begin
+    (define ($string-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (string-for-each p "a")
+        (string-for-each p "a" x1)
+        (string-for-each p "a" x1 x2)
+        (string-for-each p "a" x1 x2 x3)
+        (string-for-each p "a" x1 x2 x3 x4)
+        (string-for-each p "a" x1 x2 x3 x4 x5)
+        (string-for-each p x1 "a")
+        (string-for-each p x1 "a" x2)
+        (string-for-each p x1 "a" x2 x3)
+        (string-for-each p x1 "a" x2 x3 x4)
+        (string-for-each p x1 "a" x2 x3 x4 x5)
+        (string-for-each p x1 x2 "a")
+        (string-for-each p x1 x2 "a" x3)
+        (string-for-each p x1 x2 "a" x3 x4)
+        (string-for-each p x1 x2 "a" x3 x4 x5)
+        (string-for-each p x1 x2 x3 "a")
+        (string-for-each p x1 x2 x3 "a" x4)
+        (string-for-each p x1 x2 x3 "a" x4 x5)
+        (string-for-each p x1 x2 x3 x4 "a")
+        (string-for-each p x1 x2 x3 x4 "a" x5)
+        (string-for-each p x1 x2 x3 x4 x5 "a")))
+    (procedure? $string-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($string-for-each-f1 q "1" "f" "k" "p" "u")
+      (map list->string (reverse ls)))
+    '("a" "1a" "f1a" "kf1a" "pkf1a" "upkf1a" "a1" "fa1"
+      "kfa1" "pkfa1" "upkfa1" "af1" "kaf1" "pkaf1" "upkaf1"
+      "akf1" "pakf1" "upakf1" "apkf1" "uapkf1" "aupkf1"))
+  (begin
+    (define ($string-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (string-for-each p "ab")
+        (string-for-each p "ab" x1)
+        (string-for-each p "ab" x1 x2)
+        (string-for-each p "ab" x1 x2 x3)
+        (string-for-each p "ab" x1 x2 x3 x4)
+        (string-for-each p "ab" x1 x2 x3 x4 x5)
+        (string-for-each p x1 "ab")
+        (string-for-each p x1 "ab" x2)
+        (string-for-each p x1 "ab" x2 x3)
+        (string-for-each p x1 "ab" x2 x3 x4)
+        (string-for-each p x1 "ab" x2 x3 x4 x5)
+        (string-for-each p x1 x2 "ab")
+        (string-for-each p x1 x2 "ab" x3)
+        (string-for-each p x1 x2 "ab" x3 x4)
+        (string-for-each p x1 x2 "ab" x3 x4 x5)
+        (string-for-each p x1 x2 x3 "ab")
+        (string-for-each p x1 x2 x3 "ab" x4)
+        (string-for-each p x1 x2 x3 "ab" x4 x5)
+        (string-for-each p x1 x2 x3 x4 "ab")
+        (string-for-each p x1 x2 x3 x4 "ab" x5)
+        (string-for-each p x1 x2 x3 x4 x5 "ab")))
+    (procedure? $string-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($string-for-each-f1 q "12" "fg" "kl" "pq" "uv")
+      (map list->string (reverse ls)))
+    '("a" "b" "1a" "2b" "f1a" "g2b" "kf1a" "lg2b" "pkf1a"
+      "qlg2b" "upkf1a" "vqlg2b" "a1" "b2" "fa1" "gb2" "kfa1"
+      "lgb2" "pkfa1" "qlgb2" "upkfa1" "vqlgb2" "af1" "bg2"
+      "kaf1" "lbg2" "pkaf1" "qlbg2" "upkaf1" "vqlbg2" "akf1"
+      "blg2" "pakf1" "qblg2" "upakf1" "vqblg2" "apkf1"
+      "bqlg2" "uapkf1" "vbqlg2" "aupkf1" "bvqlg2"))
+  (begin
+    (define ($string-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (string-for-each p "abc")
+        (string-for-each p "abc" x1)
+        (string-for-each p "abc" x1 x2)
+        (string-for-each p "abc" x1 x2 x3)
+        (string-for-each p "abc" x1 x2 x3 x4)
+        (string-for-each p "abc" x1 x2 x3 x4 x5)
+        (string-for-each p x1 "abc")
+        (string-for-each p x1 "abc" x2)
+        (string-for-each p x1 "abc" x2 x3)
+        (string-for-each p x1 "abc" x2 x3 x4)
+        (string-for-each p x1 "abc" x2 x3 x4 x5)
+        (string-for-each p x1 x2 "abc")
+        (string-for-each p x1 x2 "abc" x3)
+        (string-for-each p x1 x2 "abc" x3 x4)
+        (string-for-each p x1 x2 "abc" x3 x4 x5)
+        (string-for-each p x1 x2 x3 "abc")
+        (string-for-each p x1 x2 x3 "abc" x4)
+        (string-for-each p x1 x2 x3 "abc" x4 x5)
+        (string-for-each p x1 x2 x3 x4 "abc")
+        (string-for-each p x1 x2 x3 x4 "abc" x5)
+        (string-for-each p x1 x2 x3 x4 x5 "abc")))
+    (procedure? $string-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($string-for-each-f1 q "123" "fgh" "klm" "pqr" "uvw")
+      (map list->string (reverse ls)))
+    '("a" "b" "c" "1a" "2b" "3c" "f1a" "g2b" "h3c" "kf1a"
+      "lg2b" "mh3c" "pkf1a" "qlg2b" "rmh3c" "upkf1a" "vqlg2b"
+      "wrmh3c" "a1" "b2" "c3" "fa1" "gb2" "hc3" "kfa1" "lgb2"
+      "mhc3" "pkfa1" "qlgb2" "rmhc3" "upkfa1" "vqlgb2"
+      "wrmhc3" "af1" "bg2" "ch3" "kaf1" "lbg2" "mch3" "pkaf1"
+      "qlbg2" "rmch3" "upkaf1" "vqlbg2" "wrmch3" "akf1"
+      "blg2" "cmh3" "pakf1" "qblg2" "rcmh3" "upakf1" "vqblg2"
+      "wrcmh3" "apkf1" "bqlg2" "crmh3" "uapkf1" "vbqlg2"
+      "wcrmh3" "aupkf1" "bvqlg2" "cwrmh3"))
+  (begin
+    (define ($string-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (string-for-each p "abcd")
+        (string-for-each p "abcd" x1)
+        (string-for-each p "abcd" x1 x2)
+        (string-for-each p "abcd" x1 x2 x3)
+        (string-for-each p "abcd" x1 x2 x3 x4)
+        (string-for-each p "abcd" x1 x2 x3 x4 x5)
+        (string-for-each p x1 "abcd")
+        (string-for-each p x1 "abcd" x2)
+        (string-for-each p x1 "abcd" x2 x3)
+        (string-for-each p x1 "abcd" x2 x3 x4)
+        (string-for-each p x1 "abcd" x2 x3 x4 x5)
+        (string-for-each p x1 x2 "abcd")
+        (string-for-each p x1 x2 "abcd" x3)
+        (string-for-each p x1 x2 "abcd" x3 x4)
+        (string-for-each p x1 x2 "abcd" x3 x4 x5)
+        (string-for-each p x1 x2 x3 "abcd")
+        (string-for-each p x1 x2 x3 "abcd" x4)
+        (string-for-each p x1 x2 x3 "abcd" x4 x5)
+        (string-for-each p x1 x2 x3 x4 "abcd")
+        (string-for-each p x1 x2 x3 x4 "abcd" x5)
+        (string-for-each p x1 x2 x3 x4 x5 "abcd")))
+    (procedure? $string-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($string-for-each-f1 q "1234" "fghi" "klmn" "pqrs" "uvwx")
+      (map list->string (reverse ls)))
+    '("a" "b" "c" "d" "1a" "2b" "3c" "4d" "f1a" "g2b" "h3c"
+      "i4d" "kf1a" "lg2b" "mh3c" "ni4d" "pkf1a" "qlg2b"
+      "rmh3c" "sni4d" "upkf1a" "vqlg2b" "wrmh3c" "xsni4d"
+      "a1" "b2" "c3" "d4" "fa1" "gb2" "hc3" "id4" "kfa1"
+      "lgb2" "mhc3" "nid4" "pkfa1" "qlgb2" "rmhc3" "snid4"
+      "upkfa1" "vqlgb2" "wrmhc3" "xsnid4" "af1" "bg2" "ch3"
+      "di4" "kaf1" "lbg2" "mch3" "ndi4" "pkaf1" "qlbg2"
+      "rmch3" "sndi4" "upkaf1" "vqlbg2" "wrmch3" "xsndi4"
+      "akf1" "blg2" "cmh3" "dni4" "pakf1" "qblg2" "rcmh3"
+      "sdni4" "upakf1" "vqblg2" "wrcmh3" "xsdni4" "apkf1"
+      "bqlg2" "crmh3" "dsni4" "uapkf1" "vbqlg2" "wcrmh3"
+      "xdsni4" "aupkf1" "bvqlg2" "cwrmh3" "dxsni4"))
+  (begin
+    (define ($string-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (string-for-each p "abcde")
+        (string-for-each p "abcde" x1)
+        (string-for-each p "abcde" x1 x2)
+        (string-for-each p "abcde" x1 x2 x3)
+        (string-for-each p "abcde" x1 x2 x3 x4)
+        (string-for-each p "abcde" x1 x2 x3 x4 x5)
+        (string-for-each p x1 "abcde")
+        (string-for-each p x1 "abcde" x2)
+        (string-for-each p x1 "abcde" x2 x3)
+        (string-for-each p x1 "abcde" x2 x3 x4)
+        (string-for-each p x1 "abcde" x2 x3 x4 x5)
+        (string-for-each p x1 x2 "abcde")
+        (string-for-each p x1 x2 "abcde" x3)
+        (string-for-each p x1 x2 "abcde" x3 x4)
+        (string-for-each p x1 x2 "abcde" x3 x4 x5)
+        (string-for-each p x1 x2 x3 "abcde")
+        (string-for-each p x1 x2 x3 "abcde" x4)
+        (string-for-each p x1 x2 x3 "abcde" x4 x5)
+        (string-for-each p x1 x2 x3 x4 "abcde")
+        (string-for-each p x1 x2 x3 x4 "abcde" x5)
+        (string-for-each p x1 x2 x3 x4 x5 "abcde")))
+    (procedure? $string-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($string-for-each-f1 q "12345" "fghij" "klmno" "pqrst" "uvwxy")
+      (map list->string (reverse ls)))
+    '("a" "b" "c" "d" "e" "1a" "2b" "3c" "4d" "5e" "f1a"
+      "g2b" "h3c" "i4d" "j5e" "kf1a" "lg2b" "mh3c" "ni4d"
+      "oj5e" "pkf1a" "qlg2b" "rmh3c" "sni4d" "toj5e" "upkf1a"
+      "vqlg2b" "wrmh3c" "xsni4d" "ytoj5e" "a1" "b2" "c3" "d4"
+      "e5" "fa1" "gb2" "hc3" "id4" "je5" "kfa1" "lgb2" "mhc3"
+      "nid4" "oje5" "pkfa1" "qlgb2" "rmhc3" "snid4" "toje5"
+      "upkfa1" "vqlgb2" "wrmhc3" "xsnid4" "ytoje5" "af1"
+      "bg2" "ch3" "di4" "ej5" "kaf1" "lbg2" "mch3" "ndi4"
+      "oej5" "pkaf1" "qlbg2" "rmch3" "sndi4" "toej5" "upkaf1"
+      "vqlbg2" "wrmch3" "xsndi4" "ytoej5" "akf1" "blg2"
+      "cmh3" "dni4" "eoj5" "pakf1" "qblg2" "rcmh3" "sdni4"
+      "teoj5" "upakf1" "vqblg2" "wrcmh3" "xsdni4" "yteoj5"
+      "apkf1" "bqlg2" "crmh3" "dsni4" "etoj5" "uapkf1"
+      "vbqlg2" "wcrmh3" "xdsni4" "yetoj5" "aupkf1" "bvqlg2"
+      "cwrmh3" "dxsni4" "eytoj5"))
+ ; check for proper tail recursion
+   (equal?
+     (list
+       (let ([s (statistics)])
+         (let ([k 100000] [str "abc"])
+           (let ([n k] [m 0])
+             (define (f) (unless (fx= n 0) (string-for-each foo str)))
+             (define (foo x)
+               (set! m (+ m 1))
+               (when (char=? x (string-ref str (fx- (string-length str) 1)))
+                 (set! n (- n 1))
+                 (f)
+                 17)) ; blow tail recursion here
+             (f)
+             (list (> (sstats-bytes (sstats-difference (statistics) s))
+                      10000)
+                   (eqv? n 0)
+                   (eqv? m (* k (string-length str)))))))
+       (let ([s (statistics)])
+         (let ([k 100000] [str "abc"])
+           (let ([n k] [m 0])
+             (define (f) (unless (fx= n 0) (string-for-each foo str)))
+             (define (foo x)
+               (set! m (+ m 1))
+               (when (char=? x (string-ref str (fx- (string-length str) 1)))
+                 (set! n (- n 1))
+                 (f)))
+             (f)
+             (list (<= 0
+                      (sstats-bytes (sstats-difference (statistics) s))
+                      1000)
+                   (eqv? n 0)
+                   (eqv? m (* k (string-length str))))))))
+     '((#t #t #t) (#t #t #t)))
+ )
+
+(mat string-xcase-errors
+  (error? (string-upcase))
+  (error? (string-upcase "hello" "goodbye"))
+  (error? (string-upcase 'ouch))
+  (error? (string-downcase))
+  (error? (string-downcase "hello" "goodbye"))
+  (error? (string-downcase 'ouch))
+  (error? (string-titlecase))
+  (error? (string-titlecase "hello" "goodbye"))
+  (error? (string-titlecase 'ouch))
+  (error? (string-foldcase))
+  (error? (string-foldcase "hello" "goodbye"))
+  (error? (string-foldcase 'ouch))
+)
+
+(mat normalization-tests
+  (error? (string-normalize-nfd))
+  (error? (string-normalize-nfd "hello" "goodbye"))
+  (error? (string-normalize-nfd 'ouch))
+  (error? (string-normalize-nfkd))
+  (error? (string-normalize-nfkd "hello" "goodbye"))
+  (error? (string-normalize-nfkd 'ouch))
+  (error? (string-normalize-nfc))
+  (error? (string-normalize-nfc "hello" "goodbye"))
+  (error? (string-normalize-nfc 'ouch))
+  (error? (string-normalize-nfkc))
+  (error? (string-normalize-nfkc "hello" "goodbye"))
+  (error? (string-normalize-nfkc 'ouch))
+  (begin
+    (load (format "~a/../unicode/unicode-data.ss" *mats-dir*))
+    #t)
+  (let ()
+    (import (unicode-data))
+    (define (split str)
+      (remove ""
+        (let f ([i 0] [n (string-length str)])
+          (cond
+            [(= i n) (list (substring str 0 n))]
+            [(char=? (string-ref str i) #\space)
+             (cons (substring str 0 i) 
+                   (split (substring str (+ i 1) n)))]
+            [else (f (add1 i) n)]))))
+
+    (define (conv x)
+      (list->string
+        (map (lambda (x) (integer->char (string->number x 16)))
+             (split x))))
+
+    (let ([data (map (lambda (x) (map conv (list-head x 5)))
+                     (filter (lambda (x) (>= (length x) 5))
+                       (get-unicode-data
+                         (format "~a/../unicode/UNIDATA/NormalizationTest.txt" *mats-dir*))))])
+      (define NFD string-normalize-nfd)
+      (define NFKD string-normalize-nfkd)
+      (define NFC string-normalize-nfc)
+      (define NFKC string-normalize-nfkc)
+
+      (printf "found ~s tests\n" (length data))
+
+     ; test 1
+      (for-each
+        (lambda (x testno)
+          (apply
+            (lambda (c1 c2 c3 c4 c5)
+              (unless (and (string=? c2 (NFC c1) (NFC c2) (NFC c3))
+                           (string=? c4 (NFC c4) (NFC c5)))
+                (parameterize ([print-unicode #f])
+                  (printf "test 1[~s] failed for ~s\n" testno x)
+                  (printf "       c2 = ~s\n" c2)
+                  (printf "  NFC(c1) = ~s\n" (NFC c1))
+                  (printf "  NFC(c2) = ~s\n" (NFC c2))
+                  (printf "  NFC(c3) = ~s\n" (NFC c3))
+                  (printf "       c4 = ~s\n" c4)
+                  (printf "  NFC(c4) = ~s\n" (NFC c4))
+                  (printf "  NFC(c5) = ~s\n" (NFC c5))
+                  (errorf #f "test 1 failed: see make output"))))
+            x))
+        data (enumerate data))
+
+     ; test 2
+      (for-each
+        (lambda (x testno)
+          (apply
+            (lambda (c1 c2 c3 c4 c5)
+              (unless (and (string=? c3 (NFD c1) (NFD c2) (NFD c3))
+                           (string=? c5 (NFD c4) (NFD c5)))
+                (parameterize ([print-unicode #f])
+                  (printf "test 2[~s] failed for ~s\n" testno x)
+                  (printf "       c3 = ~s\n" c3)
+                  (printf "  NFD(c1) = ~s\n" (NFD c1))
+                  (printf "  NFD(c2) = ~s\n" (NFD c2))
+                  (printf "  NFD(c3) = ~s\n" (NFD c3))
+                  (printf "       c5 = ~s\n" c5)
+                  (printf "  NFD(c4) = ~s\n" (NFD c4))
+                  (printf "  NFD(c5) = ~s\n" (NFD c5))
+                  (errorf #f "test 2 failed: see make output"))))
+            x))
+        data (enumerate data))
+
+     ; test 3
+      (for-each
+        (lambda (x testno)
+          (apply
+            (lambda (c1 c2 c3 c4 c5)
+              (unless (string=? c4 (NFKC c1) (NFKC c2) (NFKC c3) (NFKC c4) (NFKC c5))
+                (parameterize ([print-unicode #f])
+                  (printf "test 3[~s] failed for ~s\n" testno x)
+                  (printf "       c4 = ~s\n" c4)
+                  (printf "  NFKC(c1) = ~s\n" (NFKC c1))
+                  (printf "  NFKC(c2) = ~s\n" (NFKC c2))
+                  (printf "  NFKC(c3) = ~s\n" (NFKC c3))
+                  (printf "  NFKC(c4) = ~s\n" (NFKC c4))
+                  (printf "  NFKC(c5) = ~s\n" (NFKC c5))
+                  (errorf #f "test 3 failed: see make output"))))
+            x))
+        data (enumerate data))
+
+     ; test 4
+      (for-each
+        (lambda (x testno)
+          (apply
+            (lambda (c1 c2 c3 c4 c5)
+              (unless (string=? c5 (NFKD c1) (NFKD c2) (NFKD c3) (NFKD c4) (NFKD c5))
+                (parameterize ([print-unicode #f])
+                  (printf "test 4[~s] failed for ~s\n" testno x)
+                  (printf "       c5 = ~s\n" c5)
+                  (printf "  NFKD(c1) = ~s\n" (NFKD c1))
+                  (printf "  NFKD(c2) = ~s\n" (NFKD c2))
+                  (printf "  NFKD(c3) = ~s\n" (NFKD c3))
+                  (printf "  NFKD(c4) = ~s\n" (NFKD c4))
+                  (printf "  NFKD(c5) = ~s\n" (NFKD c5))
+                  (errorf #f "test 4 failed: see make output"))))
+            x))
+        data (enumerate data)))
+    #t)
+ )
+
+(mat r6rs-unicode-tests ; from Flatt's R6RS test suite
+  (begin
+    (define test equal?)
+    (test test equal?))
+
+  (test (char-upcase #\i) #\I)
+  (test (char-downcase #\i) #\i)
+  (test (char-titlecase #\i) #\I)
+  (test (char-foldcase #\i) #\i)
+  
+  (test (char-upcase #\xDF) #\xDF)
+  (test (char-downcase #\xDF) #\xDF)
+  (test (char-titlecase #\xDF) #\xDF)
+  (test (char-foldcase #\xDF) #\xDF)
+  
+  (test (char-upcase #\x3A3) #\x3A3)
+  (test (char-downcase #\x3A3) #\x3C3)
+  (test (char-titlecase #\x3A3) #\x3A3)
+  (test (char-foldcase #\x3A3) #\x3C3)
+
+  (test (char-upcase #\x3C2) #\x3A3)
+  (test (char-downcase #\x3C2) #\x3C2)
+  (test (char-titlecase #\x3C2) #\x3A3)
+  (test (char-foldcase #\x3C2) #\x3C3)
+
+  (test (char-ci? #\z #\Z) #f)
+  (test (char-ci>? #\Z #\z) #f)
+  (test (char-ci>? #\a #\Z) #f)
+  (test (char-ci>? #\Z #\a) #t)
+  (test (char-ci>=? #\Z #\z) #t)
+  (test (char-ci>=? #\z #\Z) #t)
+  (test (char-ci>=? #\z #\Z) #t)
+  (test (char-ci>=? #\a #\z) #f)
+
+  (test (char-alphabetic? #\a) #t)
+  (test (char-alphabetic? #\1) #f)
+  (test (char-numeric? #\1) #t)
+  (test (char-numeric? #\a) #f)
+  (test (char-whitespace? #\space) #t)
+  (test (char-whitespace? #\x00A0) #t)
+  (test (char-whitespace? #\a) #f)
+  (test (char-upper-case? #\a) #f)
+  (test (char-upper-case? #\A) #t)
+  (test (char-upper-case? #\x3A3) #t)
+  (test (char-lower-case? #\a) #t)
+  (test (char-lower-case? #\A) #f)
+  (test (char-lower-case? #\x3C3) #t)
+  (test (char-lower-case? #\x00AA) #t)
+  (test (char-title-case? #\a) #f)
+  (test (char-title-case? #\A) #f)
+  (test (char-title-case? #\I) #f)
+  (test (char-title-case? #\x01C5) #t)
+
+  (test (char-general-category #\a) 'Ll)
+  (test (char-general-category #\space) 'Zs)
+  (test (char-general-category #\x10FFFF) 'Cn)
+
+  (test (string-upcase "Hi") "HI")
+  (test (string-upcase "HI") "HI")
+  (test (string-downcase "Hi") "hi")
+  (test (string-downcase "hi") "hi")
+  (test (string-foldcase "Hi") "hi")
+  (test (string-foldcase "HI") "hi")
+  (test (string-foldcase "hi") "hi")
+
+  (test (string-upcase "Stra\xDF;e") "STRASSE")
+  (test (string-downcase "Stra\xDF;e") "stra\xDF;e")
+  (test (string-foldcase "Stra\xDF;e") "strasse")
+  (test (string-downcase "STRASSE")  "strasse")
+  
+  (test (string-downcase "\x3A3;") "\x3C3;")
+
+  (test (string-upcase "\x39E;\x391;\x39F;\x3A3;") "\x39E;\x391;\x39F;\x3A3;")
+  (test (string-downcase "\x39E;\x391;\x39F;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C2;")
+  (test (string-downcase "\x39E;\x391;\x39F;\x3A3;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C3;\x3C2;")
+  (test (string-downcase "\x39E;\x391;\x39F;\x3A3; \x3A3;") "\x3BE;\x3B1;\x3BF;\x3C2; \x3C3;")
+  (test (string-foldcase "\x39E;\x391;\x39F;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C3;")
+  (test (string-upcase "\x3BE;\x3B1;\x3BF;\x3C3;") "\x39E;\x391;\x39F;\x3A3;") 
+  (test (string-upcase "\x3BE;\x3B1;\x3BF;\x3C2;") "\x39E;\x391;\x39F;\x3A3;") 
+
+  (test (string-titlecase "kNock KNoCK") "Knock Knock")
+  (test (string-titlecase "who's there?") "Who's There?")
+  (test (string-titlecase "r6rs") "R6rs") ; this example appears to be wrong in R6RS (Sept 2007 version)
+  (test (string-titlecase "R6RS") "R6rs") ; this one, too
+
+  (test (string-downcase "A\x3A3;'x") "a\x3C3;'x") ; ' is a MidLetter
+
+  (test (string-ci? "a" "Z") #f)
+  (test (string-ci>? "A" "z") #f)
+  (test (string-ci>? "Z" "a") #t)
+  (test (string-ci>? "z" "A") #t)
+  (test (string-ci>? "z" "Z") #f)
+  (test (string-ci>? "Z" "z") #f)
+  (test (string-ci=? "z" "Z") #t)
+  (test (string-ci=? "z" "a") #f)
+  (test (string-ci=? "Stra\xDF;e" "Strasse") #t)
+  (test (string-ci=? "Stra\xDF;e" "STRASSE") #t)
+  (test (string-ci=? "\x39E;\x391;\x39F;\x3A3;" "\x3BE;\x3B1;\x3BF;\x3C2;") #t)
+  (test (string-ci=? "\x39E;\x391;\x39F;\x3A3;" "\x3BE;\x3B1;\x3BF;\x3C3;") #t)
+  (test (string-ci<=? "a" "Z") #t)
+  (test (string-ci<=? "A" "z") #t)
+  (test (string-ci<=? "Z" "a") #f)
+  (test (string-ci<=? "z" "A") #f)
+  (test (string-ci<=? "z" "Z") #t)
+  (test (string-ci<=? "Z" "z") #t)
+  (test (string-ci>=? "a" "Z") #f)
+  (test (string-ci>=? "A" "z") #f)
+  (test (string-ci>=? "Z" "a") #t)
+  (test (string-ci>=? "z" "A") #t)
+  (test (string-ci>=? "z" "Z") #t)
+  (test (string-ci>=? "Z" "z") #t)
+
+  (test (string-normalize-nfd "\xE9;") "\x65;\x301;")
+  (test (string-normalize-nfc "\xE9;") "\xE9;")
+  (test (string-normalize-nfd "\x65;\x301;") "\x65;\x301;")
+  (test (string-normalize-nfc "\x65;\x301;") "\xE9;")
+
+  (test (string-normalize-nfkd "\xE9;") "\x65;\x301;")
+  (test (string-normalize-nfkc "\xE9;") "\xE9;")
+  (test (string-normalize-nfkd "\x65;\x301;") "\x65;\x301;")
+  (test (string-normalize-nfkc "\x65;\x301;") "\xE9;")
+ )
+
+(mat unicode-tests.sch ; adapted from Clinger's unicode-tests.sch
+  ; Copyright 2006 William D Clinger.
+  ;
+  ; Permission to copy this software, in whole or in part, to use this
+  ; software for any lawful purpose, and to redistribute this software
+  ; is granted subject to the restriction that all copies made of this
+  ; software must include this copyright and permission notice in full.
+  ;
+  ; I also request that you send me a copy of any improvements that you
+  ; make to this software so that they may be incorporated within it to
+  ; the benefit of the Scheme community.
+
+  (begin
+    (define es-zed (integer->char #x00df))
+    (define final-sigma (integer->char #x03c2))
+    (define lower-sigma (integer->char #x03c3))
+    (define upper-sigma (integer->char #x03a3))
+    (define upper-chi (integer->char #x03a7))
+    (define upper-alpha (integer->char #x0391))
+    (define upper-omicron (integer->char #x039f))
+    (define lower-chi (integer->char #x03c7))
+    (define lower-alpha (integer->char #x03b1))
+    (define lower-omicron (integer->char #x03bf))
+    (define strasse (string #\S #\t #\r #\a es-zed #\e))
+    (define upper-chaos (string upper-chi upper-alpha upper-omicron upper-sigma))
+    (define final-chaos (string lower-chi lower-alpha lower-omicron final-sigma))
+    (define lower-chaos (string lower-chi lower-alpha lower-omicron lower-sigma))
+   ; Given a unary predicate on characters, returns a sorted
+   ; list of all characters that satisfy the predicate.
+    (define (filter-all-chars p?)
+      (do ((i 0 (+ i 1))
+           (chars '()
+                  (if (and (not (<= #xd800 i #xdfff))
+                           (p? (integer->char i)))
+                      (cons (integer->char i) chars)
+                      chars)))
+          ((= i #x110000)
+           (reverse chars))))
+   ; Given a list of characters, prints its length and returns 0.
+    (define (report chars n)
+      (display "  ")
+      (display (length chars))
+      (display " characters")
+      (if (not (= n (length chars)))
+          (begin (display " but expected ")
+                 (write n)
+                 (display " in Unicode 14.0")))
+      (newline)
+      0)
+    (define-syntax test
+      (syntax-rules (=> error)
+        [(test name exp => result)
+         (equal? exp result)]))
+   ; According to SRFI 77, this is a complete list of all code points
+   ; above 127 in Unicode 4.1 whose Unicode general category is
+   ; Ps, Pe, Pi, Pf, Zs, Zp, Zl, Cc, or Cf.
+   ;
+   ; In Unicode 5.0, the general category of
+   ; #\x23B4 (TOP SQUARE BRACKET)
+   ; and
+   ; #\x23B5 (BOTTOM SQUARE BRACKET)
+   ; was changed from Ps and Pe to So.
+   ; rkd: Unicode 5.1 adds
+   ; #x2064 #x27EC #x27ED #x27EE #x27EF #x2E20 #x2E21 #x2E22
+   ; #x2E23 #x2E24 #x2E25 #x2E26 #x2E27 #x2E28 #x2E29
+   ; rkd: Unicode 7.0 adds:
+   ; #x604 #x605 #x61C #x2066 #x2067 #x2068 #x2069 #x2308 #x2309
+   ; #x230A #x230B #x2E42 #x110BD #x1BCA0 #x1BCA1 #x1BCA2 #x1BCA3
+   ; rkd: Unicode 7.0 removes:
+   ; #x17B4 #x17B5
+   ; Unicode 14.0 adds:
+   ; #x890 #x891 #x8E2 #x2E55 #x2E56 #x2E57 #x2E58 #x2E59 #x2E5A
+   ; #x2E5B #x2E5C #x110CD #x13430 #x13431 #x13432 #x13433 #x13434
+   ; #x13435 #x13436 #x13437 #x13438
+    (define excluded-code-points-above-127
+      '(
+    
+     #x80 #x81 #x82 #x83 #x84 #x85 #x86 #x87 #x88 #x89
+     #x8A #x8B #x8C #x8D #x8E #x8F #x90 #x91 #x92 #x93
+     #x94 #x95 #x96 #x97 #x98 #x99 #x9A #x9B #x9C #x9D
+     #x9E #x9F #xA0 #xAB #xAD #xBB #x600 #x601 #x602 #x603
+     #x604 #x605 #x61C                                       ; Unicode 7.0
+     #x6DD #x70F
+     #x890 #x891 #x8E2                                       ; Unicode 14.0
+     #xF3A #xF3B #xF3C #xF3D #x1680 #x169B #x169C
+     #;#x17B4 #;#x17B5                                       ; Unicode 7.0
+     #x180E #x2000 #x2001 #x2002 #x2003
+     #x2004 #x2005 #x2006 #x2007 #x2008 #x2009 #x200A #x200B
+     #x200C #x200D #x200E #x200F #x2018 #x2019 #x201A #x201B
+     #x201C #x201D #x201E #x201F #x2028 #x2029 #x202A #x202B
+     #x202C #x202D #x202E #x202F #x2039 #x203A #x2045 #x2046
+     #x205F #x2060 #x2061 #x2062 #x2063
+     #x2064                                                  ; Unicode 5.1
+     #x2066 #x2067 #x2068 #x2069                             ; Unicode 7.0
+     #x206A #x206B #x206C
+     #x206D #x206E #x206F #x207D #x207E #x208D #x208E
+     #x2308 #x2309 #x230A #x230B                             ; Unicode 7.0
+     #x2329 #x232A 
+    ;       #x23B4 #x23B5 ; see note above for Unicode 5.0
+                          #x2768 #x2769 #x276A #x276B #x276C
+     #x276D #x276E #x276F #x2770 #x2771 #x2772 #x2773 #x2774
+     #x2775 #x27C5 #x27C6 #x27E6 #x27E7 #x27E8 #x27E9 #x27EA
+     #x27EB 
+     #x27EC #x27ED #x27EE #x27EF                             ; Unicode 5.1
+     #x2983 #x2984 #x2985 #x2986 #x2987 #x2988 #x2989
+     #x298A #x298B #x298C #x298D #x298E #x298F #x2990 #x2991
+     #x2992 #x2993 #x2994 #x2995 #x2996 #x2997 #x2998 #x29D8
+     #x29D9 #x29DA #x29DB #x29FC #x29FD #x2E02 #x2E03 #x2E04
+     #x2E05 #x2E09 #x2E0A #x2E0C #x2E0D #x2E1C #x2E1D
+     #x2E20 #x2E21 #x2E22 #x2E23 #x2E24 #x2E25 #x2E26 #x2E27 ; Unicode 5.1
+     #x2E28 #x2E29                                           ; Unicode 5.1
+     #x2E42                                                  ; Unicode 7.0
+     #x2E55 #x2E56 #x2E57 #x2E58 #x2E59 #x2E5A #x2E5B #x2E5C ; Unicode 14.0
+     #x3000
+     #x3008 #x3009 #x300A #x300B #x300C #x300D #x300E #x300F
+     #x3010 #x3011 #x3014 #x3015 #x3016 #x3017 #x3018 #x3019
+     #x301A #x301B #x301D #x301E #x301F #xFD3E #xFD3F #xFE17
+     #xFE18 #xFE35 #xFE36 #xFE37 #xFE38 #xFE39 #xFE3A #xFE3B
+     #xFE3C #xFE3D #xFE3E #xFE3F #xFE40 #xFE41 #xFE42 #xFE43
+     #xFE44 #xFE47 #xFE48 #xFE59 #xFE5A #xFE5B #xFE5C #xFE5D
+     #xFE5E #xFEFF #xFF08 #xFF09 #xFF3B #xFF3D #xFF5B #xFF5D
+     #xFF5F #xFF60 #xFF62 #xFF63 #xFFF9 #xFFFA #xFFFB
+     #x110BD                                                 ; Unicode 7.0
+     #x110CD #x13430 #x13431 #x13432 #x13433 #x13434 #x13435 ; Unicode 14.0
+     #x13436 #x13437 #x13438                                 ; Unicode 14.0
+     #x1BCA0 #x1BCA1 #x1BCA2 #x1BCA3                         ; Unicode 7.0
+     #x1D173
+     #x1D174 #x1D175 #x1D176 #x1D177 #x1D178 #x1D179 #x1D17A
+     #xE0001 #xE0020 #xE0021 #xE0022 #xE0023 #xE0024 #xE0025
+     #xE0026 #xE0027 #xE0028 #xE0029 #xE002A #xE002B #xE002C
+     #xE002D #xE002E #xE002F #xE0030 #xE0031 #xE0032 #xE0033
+     #xE0034 #xE0035 #xE0036 #xE0037 #xE0038 #xE0039 #xE003A
+     #xE003B #xE003C #xE003D #xE003E #xE003F #xE0040 #xE0041
+     #xE0042 #xE0043 #xE0044 #xE0045 #xE0046 #xE0047 #xE0048
+     #xE0049 #xE004A #xE004B #xE004C #xE004D #xE004E #xE004F
+     #xE0050 #xE0051 #xE0052 #xE0053 #xE0054 #xE0055 #xE0056
+     #xE0057 #xE0058 #xE0059 #xE005A #xE005B #xE005C #xE005D
+     #xE005E #xE005F #xE0060 #xE0061 #xE0062 #xE0063 #xE0064
+     #xE0065 #xE0066 #xE0067 #xE0068 #xE0069 #xE006A #xE006B
+     #xE006C #xE006D #xE006E #xE006F #xE0070 #xE0071 #xE0072
+     #xE0073 #xE0074 #xE0075 #xE0076 #xE0077 #xE0078 #xE0079
+     #xE007A #xE007B #xE007C #xE007D #xE007E #xE007F))
+   #t)
+
+  (test type1 (integer->char 32) => #\space)
+  (test type2 (char->integer (integer->char 5000)) => 5000)
+  ;(test type3 (integer->char #xd800) => error)
+
+  (test comp1 (char #t)
+  (test comp2 (char #f)
+  (test comp3 (char-ci #f)
+  (test comp4 (char-ci=? #\z #\Z) => #t)
+  (test comp5 (char-ci=? final-sigma lower-sigma) => #t)
+
+  (test case1 (char-upcase #\i) => #\I)
+  (test case2 (char-downcase #\i) => #\i)
+  (test case3 (char-titlecase #\i) => #\I)
+  (test case4 (char-foldcase #\i) => #\i)
+
+  (test case5 (char-upcase es-zed) => es-zed)
+  (test case6 (char-downcase es-zed) => es-zed)
+  (test case7 (char-titlecase es-zed) => es-zed)
+  (test case8 (char-foldcase es-zed) => es-zed)
+
+  (test case9 (char-upcase upper-sigma) => upper-sigma)
+  (test case10 (char-downcase upper-sigma) => lower-sigma)
+  (test case11 (char-titlecase upper-sigma) => upper-sigma)
+  (test case12 (char-foldcase upper-sigma) => lower-sigma)
+
+  (test case13 (char-upcase final-sigma) => upper-sigma)
+  (test case14 (char-downcase final-sigma) => final-sigma)
+  (test case15 (char-titlecase final-sigma) => upper-sigma)
+  (test case16 (char-foldcase final-sigma) => lower-sigma)
+
+  (test cat1 (char-general-category #\a) => 'Ll)
+  (test cat2 (char-general-category #\space) => 'Zs)
+  (test cat3 (char-general-category (integer->char #x10FFFF)) => 'Cn)
+
+  (test alpha1 (char-alphabetic? #\a) => #t)
+  (test numer1 (char-numeric? #\1) => #t)
+  (test white1 (char-whitespace? #\space) => #t)
+  (test white2 (char-whitespace? (integer->char #x00A0)) => #t)
+  (test upper1 (char-upper-case? upper-sigma) => #t)
+  (test lower1 (char-lower-case? lower-sigma) => #t)
+  (test lower2 (char-lower-case? (integer->char #x00AA)) => #t)
+  (test title1 (char-title-case? #\I) => #f)
+  (test title2 (char-title-case? (integer->char #x01C5)) => #t)
+
+  ; 01/30/15 rkd: modified to print the exceptions
+  (test excluded
+        (let f ((i 128) (excluded excluded-code-points-above-127) (okay? #t))
+          (if (= i #x110000)
+              okay?
+              (if (and (not (null? excluded)) (> i (car excluded)))
+                  (begin
+                    (printf "missed excluded char \\x~x\n" (car excluded))
+                    (f i (cdr excluded) #f))
+                  (let ([excluded? (and (not (<= #xd800 i #xdfff))
+                                        (memq (char-general-category (integer->char i))
+                                          '(Ps Pe Pi Pf Zs Zp Zl Cc Cf)))])
+                    (if excluded?
+                        (if (and (not (null? excluded)) (eqv? i (car excluded)))
+                            (f (+ i 1) (cdr excluded) okay?)
+                            (begin
+                              (printf "excluding non-excluded char \\x~x\n" i)
+                              (f (+ i 1) excluded #f)))
+                        (f (+ i 1) excluded okay?))))))
+        => #t)
+
+  (test upcase
+        (filter-all-chars (lambda (c) (char-upcase c) #f))
+        => '())
+
+  (test downcase
+        (filter-all-chars (lambda (c) (char-downcase c) #f))
+        => '())
+
+  (test titlecase
+        (filter-all-chars (lambda (c) (char-titlecase c) #f))
+        => '())
+
+  (test foldcase
+        (filter-all-chars (lambda (c) (char-foldcase c) #f))
+        => '())
+
+  (test general-category
+        (report (filter-all-chars (lambda (c)
+                                    (char-general-category c)))
+                1112064)
+        => 0)
+
+  (test alphabetic?
+        (report (filter-all-chars char-alphabetic?) 133396)
+        => 0)
+
+  (test numeric?
+        (report (filter-all-chars char-numeric?) 1799)
+        => 0)
+
+  (test whitespace?
+        (report (filter-all-chars char-whitespace?) 25)
+        => 0)
+
+  (test upper-case?
+        (report (filter-all-chars char-upper-case?) 1951)
+        => 0)
+
+  (test lower-case?
+        (report (filter-all-chars char-lower-case?) 2471)
+        => 0)
+
+  (test title-case?
+        (report (filter-all-chars char-title-case?) 31)
+        => 0)
+
+  (test scomp1 (string #t)
+  (test scomp2 (string #t)
+  (test scomp3 (string #f)
+  (test scomp4 (string=? strasse "Strasse") => #f)
+
+  (test sup1 (string-upcase "Hi") => "HI")
+  (test sdown1 (string-downcase "Hi") => "hi")
+  (test sfold1 (string-foldcase "Hi") => "hi")
+
+  (test sup2  (string-upcase strasse) => "STRASSE")
+  (test sdown2 (string-downcase strasse)
+               => (string-append "s" (substring strasse 1 6)))
+  (test sfold2 (string-foldcase strasse) => "strasse")
+  (test sdown3 (string-downcase "STRASSE")  => "strasse")
+
+  (test chaos1 (string-upcase upper-chaos) => upper-chaos)
+  (test chaos2 (string-downcase (string upper-sigma))
+               => (string lower-sigma))
+  (test chaos3 (string-downcase upper-chaos) => final-chaos)
+  (test chaos4 (string-downcase (string-append upper-chaos
+                                               (string upper-sigma)))
+               => (string-append (substring lower-chaos 0 3)
+                                 (string lower-sigma final-sigma)))
+  (test chaos5 (string-downcase (string-append upper-chaos
+                                               (string #\space
+                                                       upper-sigma)))
+               => (string-append final-chaos
+                                 (string #\space lower-sigma)))
+  (test chaos6 (string-foldcase (string-append upper-chaos
+                                               (string upper-sigma)))
+               => (string-append lower-chaos
+                                 (string lower-sigma)))
+  (test chaos7 (string-upcase final-chaos) => upper-chaos)
+  (test chaos8 (string-upcase lower-chaos) => upper-chaos)
+
+  (test stitle1 (string-titlecase "kNock KNoCK") => "Knock Knock")
+  (test stitle2 (string-titlecase "who's there?") => "Who's There?")
+  (test stitle3 (string-titlecase "r6rs") => "R6rs")
+  (test stitle4 (string-titlecase "R6RS") => "R6rs")
+
+  (test norm1 (string-normalize-nfd (string #\xE9))
+              => (string #\x65 #\x301))
+  (test norm2 (string-normalize-nfc (string #\xE9))
+              => (string #\xE9))
+  (test norm3 (string-normalize-nfd (string #\x65 #\x301))
+              => (string #\x65 #\x301))
+  (test norm4 (string-normalize-nfc (string #\x65 #\x301))
+              => (string #\xE9))
+
+  (test sci1 (string-ci #f)
+  (test sci2 (string-ci=? "z" "Z") => #t)
+  (test sci3 (string-ci=? strasse "Strasse") => #t)
+  (test sci4 (string-ci=? strasse "STRASSE") => #t)
+  (test sci5 (string-ci=? upper-chaos lower-chaos) => #t)
+
+ ; eliminate macro binding for test so it doesn't screw up later mats
+  (begin (define test) #t)
+)
+
+(mat string-titlecase
+  (equal? (string-titlecase "ciao12") "Ciao12")
+  (equal? (string-titlecase "ciao123") "Ciao123")
+  (equal? (string-titlecase "ciao123 futzmo") "Ciao123 Futzmo")
+  (equal? (string-titlecase "ciao123 futzmo.  goobar") "Ciao123 Futzmo.  Goobar")
+  (equal? (string-titlecase "ciao123 futzmo.  goob33ar") "Ciao123 Futzmo.  Goob33ar")
+  (equal? (string-titlecase "ciao123 futzmo.  33ar") "Ciao123 Futzmo.  33Ar")
+)
diff --git a/mats/5_5.ms b/mats/5_5.ms
new file mode 100644
index 0000000..40b4e3b
--- /dev/null
+++ b/mats/5_5.ms
@@ -0,0 +1,781 @@
+;;; 5-5.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat string=?/string-ci=?
+    (error? (string=?))
+    (error? (string=? 'a))
+    (error? (string=? "hi" 'a))
+    (error? (string=? "hi" 'a "ho"))
+    (error? (string=? 'a "hi" "ho"))
+    (error? (string=? "hi" "ho" 'a "he"))
+    (error? (string-ci=?))
+    (error? (string-ci=? 'a))
+    (error? (string-ci=? "hi" 'a))
+    (error? (string-ci=? "hi" 'a "ho"))
+    (error? (string-ci=? 'a "hi" "ho"))
+    (error? (string-ci=? "hi" "ho" 'a "he"))
+    (string=? "abc" "abc")
+    (string-ci=? "abc" "abc")
+    (not (string=? "Abc" "abc"))
+    (string-ci=? "Abc" "abc")
+    (not (string=? "abc" "abc "))
+    (not (string-ci=? "abc" "abc "))
+    (not (string=? "abc " "abc"))
+    (not (string-ci=? "abc " "abc"))
+    (string=? "a")
+    (string=? "a" "a" "a")
+    (not (string=? "a" "b" "c"))
+    (not (string=? "c" "b" "a"))
+    (not (string=? "b" "c" "a"))
+    (not (string=? "A" "a" "A"))
+    (not (string=? "a" "B" "c"))
+    (not (string=? "C" "b" "A"))
+    (string-ci=? "a")
+    (string-ci=? "a" "a" "a")
+    (not (string-ci=? "a" "b" "c"))
+    (not (string-ci=? "c" "b" "a"))
+    (not (string-ci=? "b" "c" "a"))
+    (string-ci=? "A" "a" "A")
+    (not (string-ci=? "a" "B" "c"))
+    (not (string-ci=? "C" "b" "A"))
+ )
+
+(mat string?/string-ci>?
+    (error? (string>?))
+    (error? (string>? 'a))
+    (error? (string>? "hi" 'a))
+    (error? (string>? "hi" 'a "ho"))
+    (error? (string>? 'a "hi" "ho"))
+    (error? (string>? "hi" "ho" 'a "he"))
+    (error? (string-ci>?))
+    (error? (string-ci>? 'a))
+    (error? (string-ci>? "hi" 'a))
+    (error? (string-ci>? "hi" 'a "ho"))
+    (error? (string-ci>? 'a "hi" "ho"))
+    (error? (string-ci>? "hi" "ho" 'a "he"))
+    (not (string>? "abc" "abc"))
+    (not (string-ci>? "abc" "abc"))
+    (string>? "abc" "Abc")
+    (not (string-ci>? "aBc" "AbC"))
+    (not (string>? "abc" "abc "))
+    (not (string-ci>? "aBc" "AbC "))
+    (string>? "abc " "abc")
+    (string-ci>? "aBc " "AbC")
+    (string>? "a")
+    (not (string>? "a" "a" "a"))
+    (not (string>? "a" "b" "c"))
+    (string>? "c" "b" "a")
+    (not (string>? "b" "c" "a"))
+    (not (string>? "A" "a" "A"))
+    (not (string>? "a" "B" "c"))
+    (not (string>? "C" "b" "A"))
+    (string-ci>? "a")
+    (not (string-ci>? "a" "a" "a"))
+    (not (string-ci>? "a" "b" "c"))
+    (string-ci>? "c" "b" "a")
+    (not (string-ci>? "b" "c" "a"))
+    (not (string-ci>? "A" "a" "A"))
+    (not (string-ci>? "a" "B" "c"))
+    (string-ci>? "C" "b" "A")
+ )
+
+(mat string<=?/string-ci<=?
+    (error? (string<=?))
+    (error? (string<=? 'a))
+    (error? (string<=? "hi" 'a))
+    (error? (string<=? "hi" 'a "ho"))
+    (error? (string<=? 'a "hi" "ho"))
+    (error? (string<=? "hi" "ho" 'a "he"))
+    (error? (string-ci<=?))
+    (error? (string-ci<=? 'a))
+    (error? (string-ci<=? "hi" 'a))
+    (error? (string-ci<=? "hi" 'a "ho"))
+    (error? (string-ci<=? 'a "hi" "ho"))
+    (error? (string-ci<=? "hi" "ho" 'a "he"))
+    (string<=? "abc" "abc")
+    (string-ci<=? "abc" "abc")
+    (not (string<=? "abc" "Abc"))
+    (string-ci<=? "aBc" "AbC")
+    (string<=? "abc" "abc ")
+    (string-ci<=? "aBc" "AbC ")
+    (not (string<=? "abc " "abc"))
+    (not (string-ci<=? "aBc " "AbC"))
+    (string<=? "a")
+    (string<=? "a" "a" "a")
+    (string<=? "a" "b" "c")
+    (not (string<=? "c" "b" "a"))
+    (not (string<=? "b" "c" "a"))
+    (not (string<=? "A" "a" "A"))
+    (not (string<=? "a" "B" "c"))
+    (not (string<=? "C" "b" "A"))
+    (string-ci<=? "a")
+    (string-ci<=? "a" "a" "a")
+    (string-ci<=? "a" "b" "c")
+    (not (string-ci<=? "c" "b" "a"))
+    (not (string-ci<=? "b" "c" "a"))
+    (string-ci<=? "A" "a" "A")
+    (string-ci<=? "a" "B" "c")
+    (not (string-ci<=? "C" "b" "A"))
+ )
+
+(mat string>=?/string-ci>=?
+    (error? (string>=?))
+    (error? (string>=? 'a))
+    (error? (string>=? "hi" 'a))
+    (error? (string>=? "hi" 'a "ho"))
+    (error? (string>=? 'a "hi" "ho"))
+    (error? (string>=? "hi" "ho" 'a "he"))
+    (error? (string-ci>=?))
+    (error? (string-ci>=? 'a))
+    (error? (string-ci>=? "hi" 'a))
+    (error? (string-ci>=? "hi" 'a "ho"))
+    (error? (string-ci>=? 'a "hi" "ho"))
+    (error? (string-ci>=? "hi" "ho" 'a "he"))
+    (string>=? "abc" "abc")
+    (string-ci>=? "abc" "abc")
+    (not (string>=? "Abc" "abc"))
+    (string-ci>=? "aBc" "AbC")
+    (not (string>=? "abc" "abc "))
+    (not (string-ci>=? "aBc" "AbC "))
+    (string>=? "abc " "abc")
+    (string-ci>=? "aBc " "AbC")
+    (string>=? "a")
+    (string>=? "a" "a" "a")
+    (not (string>=? "a" "b" "c"))
+    (string>=? "c" "b" "a")
+    (not (string>=? "b" "c" "a"))
+    (not (string>=? "A" "a" "A"))
+    (not (string>=? "a" "B" "c"))
+    (not (string>=? "C" "b" "A"))
+    (string-ci>=? "a")
+    (string-ci>=? "a" "a" "a")
+    (not (string-ci>=? "a" "b" "c"))
+    (string-ci>=? "c" "b" "a")
+    (not (string-ci>=? "b" "c" "a"))
+    (string-ci>=? "A" "a" "A")
+    (not (string-ci>=? "a" "B" "c"))
+    (string-ci>=? "C" "b" "A")
+ )
+
+(mat r6rs:string=?/r6rs:string-ci=?
+    (error? (r6rs:string=?))
+    (error? (r6rs:string=? 'a))
+    (error? (r6rs:string=? "hi" 'a))
+    (error? (r6rs:string=? "hi" 'a "ho"))
+    (error? (r6rs:string=? 'a "hi" "ho"))
+    (error? (r6rs:string=? "hi" "ho" 'a "he"))
+    (error? (r6rs:string-ci=?))
+    (error? (r6rs:string-ci=? 'a))
+    (error? (r6rs:string-ci=? "hi" 'a))
+    (error? (r6rs:string-ci=? "hi" 'a "ho"))
+    (error? (r6rs:string-ci=? 'a "hi" "ho"))
+    (error? (r6rs:string-ci=? "hi" "ho" 'a "he"))
+    (r6rs:string=? "abc" "abc")
+    (r6rs:string-ci=? "abc" "abc")
+    (not (r6rs:string=? "Abc" "abc"))
+    (r6rs:string-ci=? "Abc" "abc")
+    (not (r6rs:string=? "abc" "abc "))
+    (not (r6rs:string-ci=? "abc" "abc "))
+    (not (r6rs:string=? "abc " "abc"))
+    (not (r6rs:string-ci=? "abc " "abc"))
+    (r6rs:string=? "a" "a" "a")
+    (not (r6rs:string=? "a" "b" "c"))
+    (not (r6rs:string=? "c" "b" "a"))
+    (not (r6rs:string=? "b" "c" "a"))
+    (not (r6rs:string=? "A" "a" "A"))
+    (not (r6rs:string=? "a" "B" "c"))
+    (not (r6rs:string=? "C" "b" "A"))
+    (r6rs:string-ci=? "a" "a" "a")
+    (not (r6rs:string-ci=? "a" "b" "c"))
+    (not (r6rs:string-ci=? "c" "b" "a"))
+    (not (r6rs:string-ci=? "b" "c" "a"))
+    (r6rs:string-ci=? "A" "a" "A")
+    (not (r6rs:string-ci=? "a" "B" "c"))
+    (not (r6rs:string-ci=? "C" "b" "A"))
+ )
+
+(mat r6rs:string?/r6rs:string-ci>?
+    (error? (r6rs:string>?))
+    (error? (r6rs:string>? 'a))
+    (error? (r6rs:string>? "hi" 'a))
+    (error? (r6rs:string>? "hi" 'a "ho"))
+    (error? (r6rs:string>? 'a "hi" "ho"))
+    (error? (r6rs:string>? "hi" "ho" 'a "he"))
+    (error? (r6rs:string-ci>?))
+    (error? (r6rs:string-ci>? 'a))
+    (error? (r6rs:string-ci>? "hi" 'a))
+    (error? (r6rs:string-ci>? "hi" 'a "ho"))
+    (error? (r6rs:string-ci>? 'a "hi" "ho"))
+    (error? (r6rs:string-ci>? "hi" "ho" 'a "he"))
+    (not (r6rs:string>? "abc" "abc"))
+    (not (r6rs:string-ci>? "abc" "abc"))
+    (r6rs:string>? "abc" "Abc")
+    (not (r6rs:string-ci>? "aBc" "AbC"))
+    (not (r6rs:string>? "abc" "abc "))
+    (not (r6rs:string-ci>? "aBc" "AbC "))
+    (r6rs:string>? "abc " "abc")
+    (r6rs:string-ci>? "aBc " "AbC")
+    (not (r6rs:string>? "a" "a" "a"))
+    (not (r6rs:string>? "a" "b" "c"))
+    (r6rs:string>? "c" "b" "a")
+    (not (r6rs:string>? "b" "c" "a"))
+    (not (r6rs:string>? "A" "a" "A"))
+    (not (r6rs:string>? "a" "B" "c"))
+    (not (r6rs:string>? "C" "b" "A"))
+    (not (r6rs:string-ci>? "a" "a" "a"))
+    (not (r6rs:string-ci>? "a" "b" "c"))
+    (r6rs:string-ci>? "c" "b" "a")
+    (not (r6rs:string-ci>? "b" "c" "a"))
+    (not (r6rs:string-ci>? "A" "a" "A"))
+    (not (r6rs:string-ci>? "a" "B" "c"))
+    (r6rs:string-ci>? "C" "b" "A")
+ )
+
+(mat r6rs:string<=?/r6rs:string-ci<=?
+    (error? (r6rs:string<=?))
+    (error? (r6rs:string<=? 'a))
+    (error? (r6rs:string<=? "hi" 'a))
+    (error? (r6rs:string<=? "hi" 'a "ho"))
+    (error? (r6rs:string<=? 'a "hi" "ho"))
+    (error? (r6rs:string<=? "hi" "ho" 'a "he"))
+    (error? (r6rs:string-ci<=?))
+    (error? (r6rs:string-ci<=? 'a))
+    (error? (r6rs:string-ci<=? "hi" 'a))
+    (error? (r6rs:string-ci<=? "hi" 'a "ho"))
+    (error? (r6rs:string-ci<=? 'a "hi" "ho"))
+    (error? (r6rs:string-ci<=? "hi" "ho" 'a "he"))
+    (r6rs:string<=? "abc" "abc")
+    (r6rs:string-ci<=? "abc" "abc")
+    (not (r6rs:string<=? "abc" "Abc"))
+    (r6rs:string-ci<=? "aBc" "AbC")
+    (r6rs:string<=? "abc" "abc ")
+    (r6rs:string-ci<=? "aBc" "AbC ")
+    (not (r6rs:string<=? "abc " "abc"))
+    (not (r6rs:string-ci<=? "aBc " "AbC"))
+    (r6rs:string<=? "a" "a" "a")
+    (r6rs:string<=? "a" "b" "c")
+    (not (r6rs:string<=? "c" "b" "a"))
+    (not (r6rs:string<=? "b" "c" "a"))
+    (not (r6rs:string<=? "A" "a" "A"))
+    (not (r6rs:string<=? "a" "B" "c"))
+    (not (r6rs:string<=? "C" "b" "A"))
+    (r6rs:string-ci<=? "a" "a" "a")
+    (r6rs:string-ci<=? "a" "b" "c")
+    (not (r6rs:string-ci<=? "c" "b" "a"))
+    (not (r6rs:string-ci<=? "b" "c" "a"))
+    (r6rs:string-ci<=? "A" "a" "A")
+    (r6rs:string-ci<=? "a" "B" "c")
+    (not (r6rs:string-ci<=? "C" "b" "A"))
+ )
+
+(mat r6rs:string>=?/r6rs:string-ci>=?
+    (error? (r6rs:string>=?))
+    (error? (r6rs:string>=? 'a))
+    (error? (r6rs:string>=? "hi" 'a))
+    (error? (r6rs:string>=? "hi" 'a "ho"))
+    (error? (r6rs:string>=? 'a "hi" "ho"))
+    (error? (r6rs:string>=? "hi" "ho" 'a "he"))
+    (error? (r6rs:string-ci>=?))
+    (error? (r6rs:string-ci>=? 'a))
+    (error? (r6rs:string-ci>=? "hi" 'a))
+    (error? (r6rs:string-ci>=? "hi" 'a "ho"))
+    (error? (r6rs:string-ci>=? 'a "hi" "ho"))
+    (error? (r6rs:string-ci>=? "hi" "ho" 'a "he"))
+    (r6rs:string>=? "abc" "abc")
+    (r6rs:string-ci>=? "abc" "abc")
+    (not (r6rs:string>=? "Abc" "abc"))
+    (r6rs:string-ci>=? "aBc" "AbC")
+    (not (r6rs:string>=? "abc" "abc "))
+    (not (r6rs:string-ci>=? "aBc" "AbC "))
+    (r6rs:string>=? "abc " "abc")
+    (r6rs:string-ci>=? "aBc " "AbC")
+    (r6rs:string>=? "a" "a" "a")
+    (not (r6rs:string>=? "a" "b" "c"))
+    (r6rs:string>=? "c" "b" "a")
+    (not (r6rs:string>=? "b" "c" "a"))
+    (not (r6rs:string>=? "A" "a" "A"))
+    (not (r6rs:string>=? "a" "B" "c"))
+    (not (r6rs:string>=? "C" "b" "A"))
+    (r6rs:string-ci>=? "a" "a" "a")
+    (not (r6rs:string-ci>=? "a" "b" "c"))
+    (r6rs:string-ci>=? "c" "b" "a")
+    (not (r6rs:string-ci>=? "b" "c" "a"))
+    (r6rs:string-ci>=? "A" "a" "A")
+    (not (r6rs:string-ci>=? "a" "B" "c"))
+    (r6rs:string-ci>=? "C" "b" "A")
+ )
+
+(mat string
+    (error? (string 'a))
+    (error? (string #\a 'a))
+    (error? (string #\a #\b 'a))
+    (equal? (string #\a #\b #\c) "abc")
+    (equal? (string #\a (string-ref "b" 0) #\c) "abc")
+    (equal? (let ([x #\a]) (string x (string-ref "b" 0) #\c)) "abc")
+    (eq? (string) "")
+ )
+
+(mat make-string
+    (error? (make-string))
+    (error? (make-string 2 #\a #\b))
+    (error? (make-string 3 'a))
+    (error? (make-string 'a 3))
+    (eqv? (make-string 0) "")
+    (eqv? (make-string (- 4 4)) (string))
+    (eqv? (string-length (make-string 3)) 3)
+    (eqv? (string-length (make-string (+ 3 4))) 7)
+    (eqv? (string-length (make-string 1000)) 1000)
+    (string=? (make-string 10 #\a) "aaaaaaaaaa")
+    (string=? (make-string (- 4 1) #\a) "aaa")
+    (string=? (make-string (- 4 1) (string-ref "b" 0)) "bbb")
+    (andmap char? (string->list (make-string 20)))
+ )
+
+(mat string-length
+    (error? (string-length))
+    (error? (string-length "hi" "there"))
+    (error? (string-length 'a))
+    (eqv? (string-length "abc") 3)
+    (eqv? (string-length "") 0)
+ )
+
+(mat $string-ref-check?
+  (let ([s (make-string 3)] [imm-s (string->immutable-string (make-string 3))] [not-s (make-vector 3)])
+    (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
+      (and
+        (not (#%$string-ref-check? not-s i0))
+        (not (#%$string-ref-check? s ifalse))
+        (not (#%$string-ref-check? s i-1))
+        (not (#%$string-ref-check? imm-s i-1))
+        (#%$string-ref-check? s 0)
+        (#%$string-ref-check? s 1)
+        (#%$string-ref-check? s 2)
+        (#%$string-ref-check? imm-s 0)
+        (#%$string-ref-check? imm-s 1)
+        (#%$string-ref-check? imm-s 2)
+        (#%$string-ref-check? s i0)
+        (#%$string-ref-check? s i1)
+        (#%$string-ref-check? s i2)
+        (#%$string-ref-check? imm-s i0)
+        (#%$string-ref-check? imm-s i1)
+        (#%$string-ref-check? imm-s i2)
+        (not (#%$string-ref-check? s 3))
+        (not (#%$string-ref-check? s i3))
+        (not (#%$string-ref-check? s ibig))
+        (not (#%$string-ref-check? imm-s 3))
+        (not (#%$string-ref-check? imm-s i3))
+        (not (#%$string-ref-check? imm-s ibig)))))
+ )
+
+(mat string-ref
+    (error? (string-ref))
+    (error? (string-ref "hi"))
+    (error? (string-ref "hi" 3 4))
+    (error? (string-ref 'a 3))
+    (error? (string-ref "hi" 'a))
+    (error? (string-ref "hi" -1))
+    (error? (string-ref "hi" 2))
+    (eqv? (string-ref "abc" 0) #\a)
+    (eqv? (string-ref "abc" 1) #\b)
+    (eqv? (string-ref "abc" 2) #\c)
+ )
+
+(mat string-set!
+    (error? (string-set!))
+    (error? (string-set! "hi"))
+    (error? (string-set! "hi" 1))
+    (error? (string-set! "hi" 3 #\a #\b))
+    (error? (string-set! 'a 3 #\a))
+    (error? (string-set! "hi" 'a #\a))
+    (error? (string-set! "hi" 3 'a))
+    (error? (string-set! "hi" -1 #\a))
+    (error? (string-set! "hi" 2 #\a))
+    (let ((s (string #\a #\b #\c)))
+        (and
+            (begin (string-set! s 0 #\x) (equal? s "xbc"))
+            (begin (string-set! s 1 #\y) (equal? s "xyc"))
+            (begin (string-set! s 2 #\z) (equal? s "xyz"))))
+ )
+
+(mat string-copy
+ ; incorrect argument count
+  (error? (string-copy))
+  (error? (string-copy "hi" "there"))
+
+ ; not a string
+  (error? (string-copy 'a))
+  (error? (if (string-copy '(a b c)) #f #t))
+
+  (equal? (string-copy "") "")
+  (equal? (string-copy "abc") "abc")
+  (let* ((x1 (string #\1 #\2 #\3)) (x2 (string-copy x1)))
+    (and (equal? x2 x1) (not (eq? x2 x1))))
+)
+
+(mat string-copy!
+  (begin
+    (define $s1 (string #\1 #\2 #\3 #\4))
+    (define $s2 (string #\a #\b #\c #\d #\e #\f #\g #\h #\i))
+    (and (string? $s1)
+         (string? $s2)
+         (eqv? (string-length $s1) 4)
+         (eqv? (string-length $s2) 9)))
+
+ ; wrong number of arguments
+  (error? (string-copy!))
+  (error? (string-copy! $s2))
+  (error? (string-copy! $s2 3))
+  (error? (string-copy! $s2 3 $s1))
+  (error? (string-copy! $s2 3 $s1 1))
+  (error? (if (string-copy! $s2 3 $s1 1 2 3) #f #t))
+
+ ; not string
+  (error? (string-copy! 0 0 $s2 0 0))
+  (error? (if (string-copy! $s1 0 (bytevector 1 2 3) 0 0) #f #t))
+
+ ; bad index
+  (error? (string-copy! $s1 -1 $s2 0 0))
+  (error? (string-copy! $s1 0 $s2 -1 0))
+  (error? (string-copy! $s1 'a $s2 0 0))
+  (error? (string-copy! $s1 0 $s2 0.0 0))
+  (error? (string-copy! $s1 (+ (most-positive-fixnum) 1) $s2 0 0))
+  (error? (if (string-copy! $s1 0 $s2 (+ (most-positive-fixnum) 1) 0) #f #t))
+
+ ; bad count
+  (error? (string-copy! $s1 0 $s2 0 -1))
+  (error? (string-copy! $s1 0 $s2 0 (+ (most-positive-fixnum) 1)))
+  (error? (if (string-copy! $s1 0 $s2 0 'a) #f #t))
+
+ ; beyond end
+  (error? (string-copy! $s1 0 $s2 0 5))
+  (error? (string-copy! $s2 0 $s1 0 5))
+  (error? (string-copy! $s1 1 $s2 0 4))
+  (error? (string-copy! $s2 0 $s1 1 4))
+  (error? (string-copy! $s1 2 $s2 0 3))
+  (error? (string-copy! $s2 0 $s1 2 3))
+  (error? (string-copy! $s1 3 $s2 0 2))
+  (error? (string-copy! $s2 0 $s1 3 2))
+  (error? (string-copy! $s1 4 $s2 0 1))
+  (error? (string-copy! $s2 0 $s1 4 1))
+  (error? (string-copy! $s2 0 $s1 0 500))
+  (error? (if (string-copy! $s2 500 $s1 0 0) #f #t))
+
+ ; make sure no damage done
+  (and (string? $s1)
+       (string? $s2)
+       (equal? $s1 "1234")
+       (equal? $s2 "abcdefghi"))
+
+  (begin
+    (string-copy! $s2 3 $s1 1 2)
+    (and (equal? $s1 "1de4")
+         (equal? $s2 "abcdefghi")))
+  (begin
+    (string-copy! $s2 6 $s1 2 2)
+    (and (equal? $s1 "1dgh")
+         (equal? $s2 "abcdefghi")))
+  (begin
+    (string-copy! $s2 0 $s1 4 0)
+    (and (equal? $s1 "1dgh")
+         (equal? $s2 "abcdefghi")))
+  (begin
+    (string-copy! $s2 3 $s1 4 0)
+    (and (equal? $s1 "1dgh")
+         (equal? $s2 "abcdefghi")))
+  (begin
+    (string-copy! $s2 3 $s2 4 0)
+    (and (equal? $s1 "1dgh")
+         (equal? $s2 "abcdefghi")))
+  (begin
+    (string-copy! $s2 2 $s1 1 3)
+    (and (equal? $s1 "1cde")
+         (equal? $s2 "abcdefghi")))
+  (begin
+    (string-copy! $s1 0 $s2 3 4)
+    (and (equal? $s1 "1cde")
+         (equal? $s2 "abc1cdehi")))
+  (begin
+    (string-copy! $s2 0 $s2 3 5)
+    (and (equal? $s1 "1cde")
+         (equal? $s2 "abcabc1ci")))
+  (begin
+    (string-copy! $s2 4 $s2 2 5)
+    (and (equal? $s1 "1cde")
+         (equal? $s2 "abbc1cici")))
+  (begin
+    (string-copy! $s2 1 $s2 1 7)
+    (and (equal? $s1 "1cde")
+         (equal? $s2 "abbc1cici")))
+)
+
+(mat string-truncate!
+  (begin
+    (define $s (string #\a #\b #\c #\d #\e #\f #\g #\h #\i))
+    (and (string? $s)
+         (fx= (string-length $s) 9)
+         (string=? $s "abcdefghi")))
+
+ ; wrong number of arguments
+  (error? (string-truncate!))
+  (error? (string-truncate! $s))
+  (error? (string-truncate! $s 3 15))
+
+ ; not string
+  (error? (string-truncate! 0 0))
+  (error? (if (string-truncate! (bytevector 1 2 3) 2) #f #t))
+
+ ; bad length
+  (error? (string-truncate! $s -1))
+  (error? (string-truncate! $s 10))
+  (error? (string-truncate! $s 1000))
+  (error? (string-truncate! $s (+ (most-positive-fixnum) 1)))
+  (error? (string-truncate! $s 'a))
+
+  (begin
+    (string-truncate! $s 9)
+    (and (string? $s)
+         (fx= (string-length $s) 9)
+         (string=? $s "abcdefghi")))
+
+  (begin
+    (string-truncate! $s 8)
+    (and (string? $s)
+         (fx= (string-length $s) 8)
+         (string=? $s "abcdefgh")))
+
+  (begin
+    (string-truncate! $s 6)
+    (and (string? $s)
+         (fx= (string-length $s) 6)
+         (string=? $s "abcdef")))
+
+  (begin
+    (string-truncate! $s 3)
+    (and (string? $s)
+         (fx= (string-length $s) 3)
+         (string=? $s "abc")))
+
+  (begin
+    (define $s2 (string-truncate! $s 0))
+    (and (eqv? $s2 "")
+         (string? $s)
+         (fx= (string-length $s) 3)
+         (string=? $s "abc")))
+)
+
+(mat string-append
+    (error? (string-append 'a))
+    (error? (string-append "hi" 'b))
+    (error? (string-append "hi" 'b "there"))
+    (error? (string-copy 'a))
+    (eqv? (string-append) "")
+    (let ([x (make-string 10 #\space)])
+       (and (equal? x "          ")
+            (not (eq? x (string-append x)))))
+    (equal? (string-append "abc") "abc")
+    (equal? (string-append "abc" "xyz") "abcxyz")
+    (equal? (string-append "hi " "there " "mom") "hi there mom")
+    (equal? (string-append "" "there") "there")
+    (equal? (string-append "hi " "") "hi ")
+    (eqv? (string-append "" "") "")
+ )
+
+(mat substring
+    (error? (substring))
+    (error? (substring "hi"))
+    (error? (substring "hi" 0))
+    (error? (substring "hi" 0 2 3))
+    (error? (substring "hi" 0 3))
+    (error? (substring "hi" -1 2))
+    (error? (substring "hi" 'a 2))
+    (error? (substring 'a 0 1))
+    (error? (substring "hi" 0 'a))
+    (error? (substring "hi" 1 0))
+    (equal? (substring "hi there" 0 1) "h")
+    (equal? (substring "hi there" 3 6) "the")
+    (equal? (substring "hi there" 5 5) "")
+    (equal? (substring "hi there" 0 8) "hi there")
+    (eqv? (substring "" 0 0) "")
+ )
+
+(mat string-fill!
+    (error? (string-fill!))
+    (error? (string-fill! "hi"))
+    (error? (string-fill! "hi" #\a #\b))
+    (error? (string-fill! "hi" 'a))
+    (error? (string-fill! 'a #\a))
+    (let ([s (string #\a #\b #\c)])
+       (and (equal? s "abc")
+            (begin (string-fill! s #\*) (equal? s "***"))))
+    ; test for bug filling beyond the end of the string
+    (eqv? (let* ((s1 (make-string 3 #\a))
+                 (s2 (make-string 3 #\b)))
+            (string-fill! s1 #\*)
+            (string-ref s2 0))
+          #\b)
+ )
+
+(mat substring-fill!
+    (error? (substring-fill!))
+    (error? (substring-fill! "hi"))
+    (error? (substring-fill! "hi" 0))
+    (error? (substring-fill! "hi" 0 2))
+    (error? (substring-fill! "hi" 0 3 #\a))
+    (error? (substring-fill! "hi" -1 3 #\a))
+    (error? (substring-fill! 'a 0 1 #\a))
+    (error? (substring-fill! "hi" 0 'a #\a))
+    (error? (substring-fill! "hi" 1 0 #\a))
+    (let ([s (string-copy "hitme!")])
+      (substring-fill! s 0 5 #\a)
+      (equal? s "aaaaa!"))
+    (let ([s ""])
+      (substring-fill! s 0 0 #\a)
+      (eqv? s ""))
+    (let ([s (string-copy "ABCDE")])
+       (and (begin
+               (substring-fill! s 0 0 #\$)
+               (equal? s "ABCDE"))
+            (begin
+               (substring-fill! s 2 5 #\$)
+               (equal? s "AB$$$"))
+            (begin
+               (substring-fill! s 0 3 #\&)
+               (equal? s "&&&$$"))))
+ )
+
+(mat list->string
+    (error? (list->string))
+    (error? (list->string '(#\a #\b) '(#\c #\d)))
+    (error? (list->string 'a))
+    (error? (list->string '(a b)))
+    (error? (list->string '(#\a #\b . #\c)))
+    (error? (list->string (let ([ls (list #\a #\b #\c)]) (set-cdr! (cddr ls) (cdr ls)) ls)))
+    (equal? (list->string '(#\a #\b #\c)) "abc")
+    (equal? (list->string '()) "")
+ )
+
+(mat string->list
+    (error? (string->list))
+    (error? (string->list "ab" "cd"))
+    (error? (string->list 'a))
+    (equal? (string->list "abc") '(#\a #\b #\c))
+    (equal? (string->list "") '())
+ )
+
+(mat string->immutable-string
+    (begin
+      (define immutable-abc-string
+        (string->immutable-string (string #\a #\b #\c)))
+      #t)
+
+    (immutable-string? immutable-abc-string)
+    (not (mutable-string? immutable-abc-string))
+    
+    (equal? "abc" immutable-abc-string)
+    (eq? immutable-abc-string
+         (string->immutable-string immutable-abc-string))
+    
+    (not (immutable-string? (make-string 5)))
+    (mutable-string? (make-string 5))
+    
+    (immutable-string? (string->immutable-string (string)))
+    (not (mutable-string? (string->immutable-string (string))))
+    (not (immutable-string? (string)))
+    (mutable-string? (string))
+    
+    (not (immutable-string? (string-copy immutable-abc-string)))
+
+    (error? (string-set! immutable-abc-string 0 #\a))
+    (error? (string-fill! immutable-abc-string #\a))
+    (error? (substring-fill! immutable-abc-string 0 1 #\a))
+    (error? (string-copy! "xyz" 0 immutable-abc-string 0 3))
+    (error? (string-truncate! immutable-abc-string 1))
+)
diff --git a/mats/5_6.ms b/mats/5_6.ms
new file mode 100644
index 0000000..6b46205
--- /dev/null
+++ b/mats/5_6.ms
@@ -0,0 +1,1302 @@
+;;; 5_6.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat vector
+    (equal? (vector 1 2 3 4) '#(1 2 3 4))
+    (eq? (vector) '#())
+ )
+
+(mat make-vector
+    (eqv? (vector-length (make-vector 10)) 10)
+    (eqv? (vector-length (make-vector 100)) 100)
+    (eqv? (vector-length (make-vector (+ 100 17))) 117)
+    (equal? (make-vector 0) '#())
+    (equal? (make-vector 3 'a) '#(a a a))
+    (equal? (make-vector 10 '#t) (vector #t #t #t #t #t #t #t #t #t #t))
+    (equal? (make-vector (- 4 2) (+ 1 1)) (vector 2 2))
+    (eqv? (make-vector (- 4 4) (+ 1 1)) (vector))
+    (error? (make-vector 'a 23))
+ )
+
+(mat vector-length
+    (eqv? (vector-length '#(a b c)) 3)
+    (eqv? (vector-length '#100(a b c)) 100)
+    (eqv? (vector-length '#()) 0)
+    (error? (vector-length '(a b c)))
+ )
+
+(mat $vector-ref-check?
+  (let ([v (make-vector 3)] [imm-v (vector->immutable-vector (make-vector 3))] [not-v (make-fxvector 3)])
+    (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
+      (and
+        (not (#%$vector-ref-check? not-v i0))
+        (not (#%$vector-ref-check? v ifalse))
+        (not (#%$vector-ref-check? imm-v ifalse))
+        (not (#%$vector-ref-check? v i-1))
+        (not (#%$vector-ref-check? imm-v i-1))
+        (#%$vector-ref-check? v 0)
+        (#%$vector-ref-check? v 1)
+        (#%$vector-ref-check? v 2) 
+        (#%$vector-ref-check? imm-v 0)
+        (#%$vector-ref-check? imm-v 1)
+        (#%$vector-ref-check? imm-v 2)
+        (#%$vector-ref-check? v i0)
+        (#%$vector-ref-check? v i1)
+        (#%$vector-ref-check? v i2) 
+        (#%$vector-ref-check? imm-v i0)
+        (#%$vector-ref-check? imm-v i1)
+        (#%$vector-ref-check? imm-v i2)
+        (not (#%$vector-ref-check? v 3))
+        (not (#%$vector-ref-check? v i3))
+        (not (#%$vector-ref-check? v ibig))
+        (not (#%$vector-ref-check? imm-v 3))
+        (not (#%$vector-ref-check? imm-v i3))
+        (not (#%$vector-ref-check? imm-v ibig)))))
+ )
+
+
+(mat vector-ref
+    (eqv? (vector-ref '#(a b c) 0) 'a)
+    (eqv? (vector-ref '#(a b c) 1) 'b)
+    (eqv? (vector-ref '#(a b c) 2) 'c)
+    (error? (vector-ref '#(a b c) 3))
+    (error? (vector-ref '#(a b c) -1))
+    (error? (vector-ref '#(a b c) 'a))
+    (error? (vector-ref '(a b c) 2))
+ )
+
+(mat vector-set!
+    (let ((v (vector 'a 'b 'c)))
+        (and
+            (begin (vector-set! v 0 'x) (equal? v '#(x b c)))
+            (begin (vector-set! v 1 'y) (equal? v '#(x y c)))
+            (begin (vector-set! v 2 'z) (equal? v '#(x y z)))))
+    (error? (vector-set! (vector 'a 'b 'c) 3 'd))
+    (error? (vector-set! (vector 'a 'b 'c) -1 'd))
+    (error? (vector-set! (vector 'a 'b 'c) 'a 'd))
+    (error? (vector-set! (list 'a 'b 'c) 2 'd))
+ )
+
+(mat vector-set-fixnum!
+    (let ((v (vector 'a 'b 'c)))
+        (and
+            (begin (vector-set-fixnum! v 0 5) (equal? v '#(5 b c)))
+            (begin (vector-set-fixnum! v 1 6) (equal? v '#(5 6 c)))
+            (begin (vector-set-fixnum! v 2 7) (equal? v '#(5 6 7)))))
+    (let ((v (vector 'a 'b 'c)) (n -1))
+        (and
+            (begin (set! n (+ n 1)) (vector-set-fixnum! v n (+ (* n n) 1)) (equal? v '#(1 b c)))
+            (begin (set! n (+ n 1)) (vector-set-fixnum! v n (+ (* n n) 1)) (equal? v '#(1 2 c)))
+            (begin (set! n (+ n 1)) (vector-set-fixnum! v n (+ (* n n) 1)) (equal? v '#(1 2 5)))))
+    (error? (vector-set-fixnum! (vector 'a 'b 'c) 3 0))
+    (error? (vector-set-fixnum! (vector 'a 'b 'c) -1 3))
+    (error? (vector-set-fixnum! (vector 'a 'b 'c) 'a 4))
+    (error? (vector-set-fixnum! (list 'a 'b 'c) 2 5))
+    (error? (vector-set-fixnum! (vector 'a 'b 'c) 2 'd))
+    (error? (vector-set-fixnum! (vector 'a 'b 'c) 2 #\d))
+    (error? (let ([v (vector 'a 'b 'c)] [n -1] [x '(a b c)])
+              (set! n (+ n 2))
+              (vector-set-fixnum! v n x)))
+ )
+
+(mat vector-copy
+    (equal? (vector-copy '#()) '#())
+    (equal? (vector-copy '#(a b c)) '#(a b c))
+    (let* ((x1 (vector 1 2 3)) (x2 (vector-copy x1)))
+        (and (equal? x2 x1) (not (eq? x2 x1))))
+    (andmap
+      (lambda (n)
+        (let ([v (vector-map random (make-vector n 1000))])
+          (equal? (vector-copy v) v)))
+      (map random (make-list 500 2500)))
+    (error? (vector-copy '(a b c)))
+ )
+
+(mat vector-fill!
+    (let ([v (vector-copy '#5(a b c d e))])
+       (and (equal? v '#5(a b c d e))
+            (begin
+               (vector-fill! v 9)
+               (equal? v '#5(9)))))
+    (let ([v (vector-copy '#5(a b c d e))])
+       (and (equal? v '#5(a b c d e))
+            (begin
+               (vector-fill! v (cons 'a 'b))
+               (equal? v '#5((a . b))))))
+    (error? (let ([v (fxvector)]) (vector-fill! v 3)))
+    (let ([v (make-vector 1000)])
+      (collect 0 1)
+      (let ([x (cons 'a 'b)])
+        (vector-fill! v x)
+        (collect 0 0)
+        (andmap (lambda (y) (eq? y x)) (vector->list v))))
+ )
+
+(mat list->vector
+    (equal? (list->vector '(a b c)) '#(a b c))
+    (equal? (list->vector '()) '#())
+    (error? (list->vector '#(a b c)))
+    (error? (list->vector '(#\a #\b . #\c)))
+    (error? (list->vector (let ([ls (list #\a #\b #\c)]) (set-cdr! (cddr ls) (cdr ls)) ls)))
+ )
+
+(mat vector->list
+    (equal? (vector->list '#(a b c)) '(a b c))
+    (equal? (vector->list '#()) '())
+    (error? (vector->list '(a b c)))
+ )
+
+(mat fxvector
+    (equal? (fxvector 1 2 3 4) '#vfx(1 2 3 4))
+    (eq? (fxvector) '#vfx())
+    (fxvector? (fxvector (most-positive-fixnum)))
+    (fxvector? (fxvector (most-negative-fixnum)))
+    (error? (fxvector (+ (most-positive-fixnum) 1)))
+    (error? (fxvector (- (most-negative-fixnum) 1)))
+    (error? (fxvector 1 2 'a 4))
+ )
+
+(mat make-fxvector
+    (eqv? (fxvector-length (make-fxvector 10)) 10)
+    (eqv? (fxvector-length (make-fxvector 100)) 100)
+    (eqv? (fxvector-length (make-fxvector (+ 100 17))) 117)
+    (eq? (make-fxvector 0) '#vfx())
+    (let ([x (make-fxvector 10)])
+      (and (= (fxvector-length x) 10)
+           (andmap fixnum? (fxvector->list x))))
+    (error? (make-fxvector 3 'a))
+    (error? (make-fxvector 10 (+ (most-positive-fixnum) 1)))
+    (error? (make-fxvector 10 (- (most-negative-fixnum) 1)))
+    (equal? (make-fxvector 10 7) (fxvector 7 7 7 7 7 7 7 7 7 7))
+    (equal? (make-fxvector (- 4 2) (+ 1 1)) (fxvector 2 2))
+    (eqv? (make-fxvector (- 4 4) (+ 1 1)) (fxvector))
+ )
+
+(mat fxvector-syntax
+  (eq? '#vfx() '#vfx())
+  (eq? '#0vfx() #vfx())
+  (equal? 
+    '(#vfx(1 2 3) #3vfx(1 2 3) #6vfx(1 2 3))
+    (list (fxvector 1 2 3) (fxvector 1 2 3) (fxvector 1 2 3 3 3 3)))
+  (let ([x #10vfx()])
+    (and (= (fxvector-length x) 10)
+         (andmap fixnum? (fxvector->list x))))
+ ; the following is invalid because the reader doesn't allow graph marks
+ ; and references within an fxvector
+ ; (equal? '(#0=#vfx(#1=33 #2# #1# #2=44 #3#) #2# #3=55)
+ ;         '(#vfx(33 44 33 44 55) 44 55))
+)
+
+(mat fxvector-length
+    (eqv? (fxvector-length '#vfx(3 4 5)) 3)
+    (eqv? (fxvector-length '#100vfx(5 4 3)) 100)
+    (eqv? (fxvector-length '#vfx()) 0)
+    (error? (fxvector-length '(a b c)))
+ )
+
+(mat $fxvector-ref-check?
+  (let ([fv (make-fxvector 3)] [imm-fv (fxvector->immutable-fxvector (make-fxvector 3))] [not-fv (make-vector 3)])
+    (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
+      (and
+        (not (#%$fxvector-ref-check? not-fv i0))
+        (not (#%$fxvector-ref-check? fv ifalse))
+        (not (#%$fxvector-ref-check? fv i-1))
+        (not (#%$fxvector-ref-check? imm-fv i-1))
+        (#%$fxvector-ref-check? fv 0)
+        (#%$fxvector-ref-check? fv 1)
+        (#%$fxvector-ref-check? fv 2)
+        (#%$fxvector-ref-check? imm-fv 0)
+        (#%$fxvector-ref-check? imm-fv 1)
+        (#%$fxvector-ref-check? imm-fv 2)
+        (#%$fxvector-ref-check? fv i0)
+        (#%$fxvector-ref-check? fv i1)
+        (#%$fxvector-ref-check? fv i2)
+        (#%$fxvector-ref-check? imm-fv i0)
+        (#%$fxvector-ref-check? imm-fv i1)
+        (#%$fxvector-ref-check? imm-fv i2)
+        (not (#%$fxvector-ref-check? fv 3))
+        (not (#%$fxvector-ref-check? fv i3))
+        (not (#%$fxvector-ref-check? fv ibig))
+        (not (#%$fxvector-ref-check? imm-fv 3))
+        (not (#%$fxvector-ref-check? imm-fv i3))
+        (not (#%$fxvector-ref-check? imm-fv ibig)))))
+ )
+
+(mat fxvector-ref
+    (eqv? (fxvector-ref '#vfx(3 4 5) 0) '3)
+    (eqv? (fxvector-ref '#vfx(3 4 5) 1) '4)
+    (eqv? (fxvector-ref '#vfx(3 4 5) 2) '5)
+    (eqv? (fxvector-ref (fxvector (most-positive-fixnum)) 0) (most-positive-fixnum))
+    (eqv? (fxvector-ref (fxvector (most-negative-fixnum)) 0) (most-negative-fixnum))
+    (error? (fxvector-ref '#vfx(3 4 5) 3))
+    (error? (fxvector-ref '#vfx(3 4 5) -1))
+    (error? (fxvector-ref '#vfx(3 4 5) 'a))
+    (error? (fxvector-ref '#(3 4 5) 2))
+    (error? (fxvector-ref '(3 4 5) 2))
+ )
+
+(mat fxvector-set!
+    (let ((v (fxvector '3 '4 '5)))
+        (and
+            (begin (fxvector-set! v 0 '33) (equal? v '#vfx(33 4 5)))
+            (begin (fxvector-set! v 1 '44) (equal? v '#vfx(33 44 5)))
+            (begin (fxvector-set! v 2 '55) (equal? v '#vfx(33 44 55)))))
+    (error? (fxvector-set! (fxvector '3 '4 '5) 3 'd))
+    (error? (fxvector-set! (fxvector '3 '4 '5) -1 'd))
+    (error? (fxvector-set! (fxvector '3 '4 '5) 'a 'd))
+    (error? (fxvector-set! (fxvector '3 '4 '5) 2 'd))
+    (error? (fxvector-set! (list '3 '4 '5) 2 'd))
+    (error? (fxvector-set! (fxvector 3 4 5) 1 (- (most-negative-fixnum) 1)))
+    (error? (fxvector-set! (fxvector 3 4 5) 0 (+ (most-positive-fixnum) 1)))
+    (begin
+      (define test-fxvector-set!
+        (lambda (v i x)
+          (fxvector-set! v i x)))
+      #t)
+    (equal?
+      (let ([v (fxvector 3 4 5)])
+        (test-fxvector-set! v 0 -3)
+        (test-fxvector-set! v 1 -4)
+        (test-fxvector-set! v 2 17)
+        v)
+      #vfx(-3 -4 17))
+    (error? (test-fxvector-set! (list 3 4 5) 0 9))
+    (error? (test-fxvector-set! (vector 3 4) 0 9))
+    (error? (test-fxvector-set! (fxvector 3 4 5) 3 9))
+    (error? (test-fxvector-set! (fxvector 3 4 5) -3 9))
+    (error? (test-fxvector-set! (fxvector 3 4 5) (+ (most-positive-fixnum) 1) 9))
+    (error? (test-fxvector-set! (fxvector 3 4 5) (- (most-negative-fixnum) 1) 9))
+    (error? (test-fxvector-set! (fxvector 3 4 5) 'a 9))
+    (error? (test-fxvector-set! (fxvector 3 4 5) 2 (+ (most-positive-fixnum) 1)))
+    (error? (test-fxvector-set! (fxvector 3 4 5) 2 (- (most-negative-fixnum) 1)))
+    (error? (test-fxvector-set! (fxvector 3 4 5) 2 'a))
+ )
+
+(mat fxvector-copy
+    (equal? (fxvector-copy '#vfx()) '#vfx())
+    (equal? (fxvector-copy '#vfx(3 4 5)) '#vfx(3 4 5))
+    (let* ((x1 (fxvector 1 2 3)) (x2 (fxvector-copy x1)))
+        (and (equal? x2 x1) (not (eq? x2 x1))))
+    (andmap
+      (lambda (n)
+        (let ([v (list->fxvector (map random (make-list n 1000)))])
+          (equal? (fxvector-copy v) v)))
+      (map random (make-list 500 2500)))
+    (error? (fxvector-copy '(a b c)))
+ )
+
+(mat fxvector-fill!
+    (let ([v (fxvector-copy '#5vfx(1 2 3 4 5))])
+       (and (equal? v '#5vfx(1 2 3 4 5))
+            (begin
+               (fxvector-fill! v 9)
+               (equal? v '#5vfx(9)))))
+    (let ([v (fxvector-copy '#5vfx(1 2 3 4 5))])
+       (and (equal? v '#5vfx(1 2 3 4 5))
+            (begin
+               (fxvector-fill! v -17)
+               (equal? v '#5vfx(-17)))))
+    (error? (let ([v (fxvector 1)]) (fxvector-fill! v 'a)))
+    (error? (let ([v (vector 1)]) (fxvector-fill! v 3)))
+ )
+
+(mat list->fxvector
+    (equal? (list->fxvector '(1 2 3)) '#vfx(1 2 3))
+    (equal? (list->fxvector '()) '#vfx())
+    (error? (list->fxvector '#(a b c)))
+    (error? (list->fxvector '(1 2 . 3)))
+    (error? (list->fxvector (let ([ls (list 1 2 3)]) (set-cdr! (cddr ls) (cdr ls)) ls)))
+ )
+
+(mat fxvector->list
+    (equal? (fxvector->list '#vfx(1 2 3)) '(1 2 3))
+    (equal? (fxvector->list '#vfx()) '())
+    (error? (fxvector->list '(a b c)))
+ )
+
+(mat vector-map
+  (error? ; invalid number of arguments
+    (vector-map))
+  (error? ; invalid number of arguments
+    (vector-map '#()))
+  (error? ; invalid number of arguments
+    (vector-map +))
+  (error? ; non procedure '#()
+    (vector-map '#() '#()))
+  (error? ; non procedure '#()
+    (vector-map '#() '#() '#()))
+  (error? ; non procedure '#()
+    (vector-map '#() '#() '#() '()))
+  (error? ; non procedure '#()
+    (vector-map '#() '#() '#() '#() '#()))
+  (error? ; non vector 3
+    (vector-map + 3))
+  (error? ; non vector (3)
+    (vector-map + '#() '(3)))
+  (error? ; non vector (3)
+    (vector-map + '#() '#() '(3)))
+  (error? ; non vector (3)
+    (vector-map + '#() '#() '(3) '#()))
+  (error? ; non vector 7
+    (vector-map + 7 '#() '#() '#() '#()))
+  (error? ; lengths differ
+    (vector-map + '#() '#(x)))
+  (error? ; lengths differ
+    (vector-map + '#() '#() '#(x)))
+  (error? ; lengths differ
+    (vector-map + '#() '#() '#(x) '#()))
+  (error? ; lengths differ
+    (vector-map + '#(y) '#() '#(x) '#()))
+  (error? ; lengths differ
+    (vector-map + '#(y) '#() '#() '#() '#()))
+
+  (equal? (vector-map + '#()) '#())
+  (equal? (vector-map + '#(1)) '#(1))
+  (equal? (vector-map + '#(1 2)) '#(1 2))
+  (equal? (vector-map + '#(1 2 3)) '#(1 2 3))
+  (equal? (vector-map + '#(1 2 3 4)) '#(1 2 3 4))
+  (equal? (vector-map + (make-vector 100 7)) '#100(7))
+
+  (equal? (vector-map list '#() '#()) '#())
+  (equal? (vector-map list '#(1) '#(5)) '#((1 5)))
+  (equal? (vector-map list '#(1 2) '#(5 7)) '#((1 5) (2 7)))
+  (equal? (vector-map list '#(1 2 3) '#(a b c)) '#((1 a) (2 b) (3 c)))
+  (equal? (vector-map list '#(1 2 3 4) '#(a b c d)) '#((1 a) (2 b) (3 c) (4 d)))
+
+  (equal? (vector-map list '#() '#() '#()) '#())
+  (equal? (vector-map list '#(1) '#(5) '#(a)) '#((1 5 a)))
+  (equal? (vector-map list '#(1 2) '#(5 7) '#(a b)) '#((1 5 a) (2 7 b)))
+  (equal?
+    (vector-map list '#(1 2 3) '#(5 7 9) '#(a b c))
+    '#((1 5 a) (2 7 b) (3 9 c)))
+  (equal?
+    (vector-map list '#(1 2 3 4) '#(5 7 9 11) '#(a b c d))
+    '#((1 5 a) (2 7 b) (3 9 c) (4 11 d)))
+
+  (equal? (vector-map list '#() '#() '#() '#()) '#())
+  (equal? (vector-map list '#(#\a) '#(1) '#(5) '#(a)) '#((#\a 1 5 a)))
+  (equal?
+    (vector-map list '#(#\a #\b) '#(1 2) '#(5 7) '#(a b))
+    '#((#\a 1 5 a) (#\b 2 7 b)))
+  (equal?
+    (vector-map list '#(#\a #\b #\c) '#(1 2 3) '#(5 7 9) '#(a b c))
+    '#((#\a 1 5 a) (#\b 2 7 b) (#\c 3 9 c)))
+  (equal?
+    (vector-map list '#(#\a #\b #\c #\d) '#(1 2 3 4) '#(5 7 9 11) '#(a b c d))
+    '#((#\a 1 5 a) (#\b 2 7 b) (#\c 3 9 c) (#\d 4 11 d)))
+  (let ([orig-v #f] [orig-elts #f] [next #f])
+    (let ([n 100])
+      (let ([v (vector-map
+                 (lambda (x) (cons (call/cc values) x))
+                 (list->vector (iota n)))])
+        (if orig-v
+            (unless (andmap eq? (vector->list orig-v) orig-elts)
+              (errorf #f "original vector-map elts mutated"))
+            (begin
+              (set! orig-v v)
+              (set! orig-elts (vector->list v))
+              (set! next 0)))
+        (let ([m next])
+          (unless (= m n)
+            (set! next (fx+ next 1)) 
+            (let ([p (vector-ref orig-v m)])
+              (unless (eqv? (cdr p) m)
+                (errorf #f "unexpected cdr value (~s instead of ~s)" (cdr p) m))
+              ((car p) n)))))
+      (eqv? next n)))
+   (begin
+     (define ($vector-map-f1 p x1 x2 x3 x4 x5)
+       (vector
+         (vector-map p '#())
+         (vector-map p '#() x1)
+         (vector-map p '#() x1 x2)
+         (vector-map p '#() x1 x2 x3)
+         (vector-map p '#() x1 x2 x3 x4)
+         (vector-map p '#() x1 x2 x3 x4 x5)
+         (vector-map p x1 '#())
+         (vector-map p x1 '#() x2)
+         (vector-map p x1 '#() x2 x3)
+         (vector-map p x1 '#() x2 x3 x4)
+         (vector-map p x1 '#() x2 x3 x4 x5)
+         (vector-map p x1 x2 '#())
+         (vector-map p x1 x2 '#() x3)
+         (vector-map p x1 x2 '#() x3 x4)
+         (vector-map p x1 x2 '#() x3 x4 x5)
+         (vector-map p x1 x2 x3 '#())
+         (vector-map p x1 x2 x3 '#() x4)
+         (vector-map p x1 x2 x3 '#() x4 x5)
+         (vector-map p x1 x2 x3 x4 '#())
+         (vector-map p x1 x2 x3 x4 '#() x5)
+         (vector-map p x1 x2 x3 x4 x5 '#())))
+     (procedure? $vector-map-f1))
+   (equal?
+     ($vector-map-f1 vector '#() '#() '#() '#() '#())
+     '#(#() #() #() #() #() #() #() #() #() #() #() #() #() #() #() #() #() #()
+       #() #() #()))
+   (begin
+     (define ($vector-map-f1 p x1 x2 x3 x4 x5)
+       (vector
+         (vector-map p '#(a))
+         (vector-map p '#(a) x1)
+         (vector-map p '#(a) x1 x2)
+         (vector-map p '#(a) x1 x2 x3)
+         (vector-map p '#(a) x1 x2 x3 x4)
+         (vector-map p '#(a) x1 x2 x3 x4 x5)
+         (vector-map p x1 '#(a))
+         (vector-map p x1 '#(a) x2)
+         (vector-map p x1 '#(a) x2 x3)
+         (vector-map p x1 '#(a) x2 x3 x4)
+         (vector-map p x1 '#(a) x2 x3 x4 x5)
+         (vector-map p x1 x2 '#(a))
+         (vector-map p x1 x2 '#(a) x3)
+         (vector-map p x1 x2 '#(a) x3 x4)
+         (vector-map p x1 x2 '#(a) x3 x4 x5)
+         (vector-map p x1 x2 x3 '#(a))
+         (vector-map p x1 x2 x3 '#(a) x4)
+         (vector-map p x1 x2 x3 '#(a) x4 x5)
+         (vector-map p x1 x2 x3 x4 '#(a))
+         (vector-map p x1 x2 x3 x4 '#(a) x5)
+         (vector-map p x1 x2 x3 x4 x5 '#(a))))
+     (procedure? $vector-map-f1))
+   (equal?
+     ($vector-map-f1 vector '#(1) '#(4) '#(d) '#(g) '#(7))
+     '#(#(#(a))
+       #(#(a 1))
+       #(#(a 1 4))
+       #(#(a 1 4 d))
+       #(#(a 1 4 d g))
+       #(#(a 1 4 d g 7))
+       #(#(1 a))
+       #(#(1 a 4))
+       #(#(1 a 4 d))
+       #(#(1 a 4 d g))
+       #(#(1 a 4 d g 7))
+       #(#(1 4 a))
+       #(#(1 4 a d))
+       #(#(1 4 a d g))
+       #(#(1 4 a d g 7))
+       #(#(1 4 d a))
+       #(#(1 4 d a g))
+       #(#(1 4 d a g 7))
+       #(#(1 4 d g a))
+       #(#(1 4 d g a 7))
+       #(#(1 4 d g 7 a))))
+   (begin
+     (define ($vector-map-f1 p x1 x2 x3 x4 x5)
+       (vector
+         (vector-map p '#(a b))
+         (vector-map p '#(a b) x1)
+         (vector-map p '#(a b) x1 x2)
+         (vector-map p '#(a b) x1 x2 x3)
+         (vector-map p '#(a b) x1 x2 x3 x4)
+         (vector-map p '#(a b) x1 x2 x3 x4 x5)
+         (vector-map p x1 '#(a b))
+         (vector-map p x1 '#(a b) x2)
+         (vector-map p x1 '#(a b) x2 x3)
+         (vector-map p x1 '#(a b) x2 x3 x4)
+         (vector-map p x1 '#(a b) x2 x3 x4 x5)
+         (vector-map p x1 x2 '#(a b))
+         (vector-map p x1 x2 '#(a b) x3)
+         (vector-map p x1 x2 '#(a b) x3 x4)
+         (vector-map p x1 x2 '#(a b) x3 x4 x5)
+         (vector-map p x1 x2 x3 '#(a b))
+         (vector-map p x1 x2 x3 '#(a b) x4)
+         (vector-map p x1 x2 x3 '#(a b) x4 x5)
+         (vector-map p x1 x2 x3 x4 '#(a b))
+         (vector-map p x1 x2 x3 x4 '#(a b) x5)
+         (vector-map p x1 x2 x3 x4 x5 '#(a b))))
+     (procedure? $vector-map-f1))
+   (equal?
+     ($vector-map-f1 vector '#(1 2) '#(4 5) '#(d e) '#(g h) '#(7 j))
+     '#(#(#(a) #(b))
+       #(#(a 1) #(b 2))
+       #(#(a 1 4) #(b 2 5))
+       #(#(a 1 4 d) #(b 2 5 e))
+       #(#(a 1 4 d g) #(b 2 5 e h))
+       #(#(a 1 4 d g 7) #(b 2 5 e h j))
+       #(#(1 a) #(2 b))
+       #(#(1 a 4) #(2 b 5))
+       #(#(1 a 4 d) #(2 b 5 e))
+       #(#(1 a 4 d g) #(2 b 5 e h))
+       #(#(1 a 4 d g 7) #(2 b 5 e h j))
+       #(#(1 4 a) #(2 5 b))
+       #(#(1 4 a d) #(2 5 b e))
+       #(#(1 4 a d g) #(2 5 b e h))
+       #(#(1 4 a d g 7) #(2 5 b e h j))
+       #(#(1 4 d a) #(2 5 e b))
+       #(#(1 4 d a g) #(2 5 e b h))
+       #(#(1 4 d a g 7) #(2 5 e b h j))
+       #(#(1 4 d g a) #(2 5 e h b))
+       #(#(1 4 d g a 7) #(2 5 e h b j))
+       #(#(1 4 d g 7 a) #(2 5 e h j b))))
+   (begin
+     (define ($vector-map-f1 p x1 x2 x3 x4 x5)
+       (vector
+         (vector-map p '#(a b c))
+         (vector-map p '#(a b c) x1)
+         (vector-map p '#(a b c) x1 x2)
+         (vector-map p '#(a b c) x1 x2 x3)
+         (vector-map p '#(a b c) x1 x2 x3 x4)
+         (vector-map p '#(a b c) x1 x2 x3 x4 x5)
+         (vector-map p x1 '#(a b c))
+         (vector-map p x1 '#(a b c) x2)
+         (vector-map p x1 '#(a b c) x2 x3)
+         (vector-map p x1 '#(a b c) x2 x3 x4)
+         (vector-map p x1 '#(a b c) x2 x3 x4 x5)
+         (vector-map p x1 x2 '#(a b c))
+         (vector-map p x1 x2 '#(a b c) x3)
+         (vector-map p x1 x2 '#(a b c) x3 x4)
+         (vector-map p x1 x2 '#(a b c) x3 x4 x5)
+         (vector-map p x1 x2 x3 '#(a b c))
+         (vector-map p x1 x2 x3 '#(a b c) x4)
+         (vector-map p x1 x2 x3 '#(a b c) x4 x5)
+         (vector-map p x1 x2 x3 x4 '#(a b c))
+         (vector-map p x1 x2 x3 x4 '#(a b c) x5)
+         (vector-map p x1 x2 x3 x4 x5 '#(a b c))))
+     (procedure? $vector-map-f1))
+   (equal?
+     ($vector-map-f1 vector '#(1 2 3) '#(4 5 6) '#(d e f) '#(g h i) '#(7 j 9))
+     '#(#(#(a) #(b) #(c))
+       #(#(a 1) #(b 2) #(c 3))
+       #(#(a 1 4) #(b 2 5) #(c 3 6))
+       #(#(a 1 4 d) #(b 2 5 e) #(c 3 6 f))
+       #(#(a 1 4 d g) #(b 2 5 e h) #(c 3 6 f i))
+       #(#(a 1 4 d g 7) #(b 2 5 e h j) #(c 3 6 f i 9))
+       #(#(1 a) #(2 b) #(3 c))
+       #(#(1 a 4) #(2 b 5) #(3 c 6))
+       #(#(1 a 4 d) #(2 b 5 e) #(3 c 6 f))
+       #(#(1 a 4 d g) #(2 b 5 e h) #(3 c 6 f i))
+       #(#(1 a 4 d g 7) #(2 b 5 e h j) #(3 c 6 f i 9))
+       #(#(1 4 a) #(2 5 b) #(3 6 c))
+       #(#(1 4 a d) #(2 5 b e) #(3 6 c f))
+       #(#(1 4 a d g) #(2 5 b e h) #(3 6 c f i))
+       #(#(1 4 a d g 7) #(2 5 b e h j) #(3 6 c f i 9))
+       #(#(1 4 d a) #(2 5 e b) #(3 6 f c))
+       #(#(1 4 d a g) #(2 5 e b h) #(3 6 f c i))
+       #(#(1 4 d a g 7) #(2 5 e b h j) #(3 6 f c i 9))
+       #(#(1 4 d g a) #(2 5 e h b) #(3 6 f i c))
+       #(#(1 4 d g a 7) #(2 5 e h b j) #(3 6 f i c 9))
+       #(#(1 4 d g 7 a) #(2 5 e h j b) #(3 6 f i 9 c))))
+   (begin
+     (define ($vector-map-f1 p x1 x2 x3 x4 x5)
+       (vector
+         (vector-map p '#(a b c d))
+         (vector-map p '#(a b c d) x1)
+         (vector-map p '#(a b c d) x1 x2)
+         (vector-map p '#(a b c d) x1 x2 x3)
+         (vector-map p '#(a b c d) x1 x2 x3 x4)
+         (vector-map p '#(a b c d) x1 x2 x3 x4 x5)
+         (vector-map p x1 '#(a b c d))
+         (vector-map p x1 '#(a b c d) x2)
+         (vector-map p x1 '#(a b c d) x2 x3)
+         (vector-map p x1 '#(a b c d) x2 x3 x4)
+         (vector-map p x1 '#(a b c d) x2 x3 x4 x5)
+         (vector-map p x1 x2 '#(a b c d))
+         (vector-map p x1 x2 '#(a b c d) x3)
+         (vector-map p x1 x2 '#(a b c d) x3 x4)
+         (vector-map p x1 x2 '#(a b c d) x3 x4 x5)
+         (vector-map p x1 x2 x3 '#(a b c d))
+         (vector-map p x1 x2 x3 '#(a b c d) x4)
+         (vector-map p x1 x2 x3 '#(a b c d) x4 x5)
+         (vector-map p x1 x2 x3 x4 '#(a b c d))
+         (vector-map p x1 x2 x3 x4 '#(a b c d) x5)
+         (vector-map p x1 x2 x3 x4 x5 '#(a b c d))))
+     (procedure? $vector-map-f1))
+   (equal?
+     ($vector-map-f1 vector '#(1 2 3 4) '#(f g h i) '#(k l m n) '#(p q r s) '#(u v w x))
+     '#(#(#(a) #(b) #(c) #(d)) #(#(a 1) #(b 2) #(c 3) #(d 4))
+       #(#(a 1 f) #(b 2 g) #(c 3 h) #(d 4 i))
+       #(#(a 1 f k) #(b 2 g l) #(c 3 h m) #(d 4 i n))
+       #(#(a 1 f k p) #(b 2 g l q) #(c 3 h m r) #(d 4 i n s))
+       #(#(a 1 f k p u) #(b 2 g l q v) #(c 3 h m r w) #(d 4 i n s x))
+       #(#(1 a) #(2 b) #(3 c) #(4 d))
+       #(#(1 a f) #(2 b g) #(3 c h) #(4 d i))
+       #(#(1 a f k) #(2 b g l) #(3 c h m) #(4 d i n))
+       #(#(1 a f k p) #(2 b g l q) #(3 c h m r) #(4 d i n s))
+       #(#(1 a f k p u) #(2 b g l q v) #(3 c h m r w) #(4 d i n s x))
+       #(#(1 f a) #(2 g b) #(3 h c) #(4 i d))
+       #(#(1 f a k) #(2 g b l) #(3 h c m) #(4 i d n))
+       #(#(1 f a k p) #(2 g b l q) #(3 h c m r) #(4 i d n s))
+       #(#(1 f a k p u) #(2 g b l q v) #(3 h c m r w) #(4 i d n s x))
+       #(#(1 f k a) #(2 g l b) #(3 h m c) #(4 i n d))
+       #(#(1 f k a p) #(2 g l b q) #(3 h m c r) #(4 i n d s))
+       #(#(1 f k a p u) #(2 g l b q v) #(3 h m c r w) #(4 i n d s x))
+       #(#(1 f k p a) #(2 g l q b) #(3 h m r c) #(4 i n s d))
+       #(#(1 f k p a u) #(2 g l q b v) #(3 h m r c w) #(4 i n s d x))
+       #(#(1 f k p u a) #(2 g l q v b) #(3 h m r w c) #(4 i n s x d))))
+   (begin
+     (define ($vector-map-f1 p x1 x2 x3 x4 x5)
+       (vector
+         (vector-map p '#(a b c d e))
+         (vector-map p '#(a b c d e) x1)
+         (vector-map p '#(a b c d e) x1 x2)
+         (vector-map p '#(a b c d e) x1 x2 x3)
+         (vector-map p '#(a b c d e) x1 x2 x3 x4)
+         (vector-map p '#(a b c d e) x1 x2 x3 x4 x5)
+         (vector-map p x1 '#(a b c d e))
+         (vector-map p x1 '#(a b c d e) x2)
+         (vector-map p x1 '#(a b c d e) x2 x3)
+         (vector-map p x1 '#(a b c d e) x2 x3 x4)
+         (vector-map p x1 '#(a b c d e) x2 x3 x4 x5)
+         (vector-map p x1 x2 '#(a b c d e))
+         (vector-map p x1 x2 '#(a b c d e) x3)
+         (vector-map p x1 x2 '#(a b c d e) x3 x4)
+         (vector-map p x1 x2 '#(a b c d e) x3 x4 x5)
+         (vector-map p x1 x2 x3 '#(a b c d e))
+         (vector-map p x1 x2 x3 '#(a b c d e) x4)
+         (vector-map p x1 x2 x3 '#(a b c d e) x4 x5)
+         (vector-map p x1 x2 x3 x4 '#(a b c d e))
+         (vector-map p x1 x2 x3 x4 '#(a b c d e) x5)
+         (vector-map p x1 x2 x3 x4 x5 '#(a b c d e))))
+     (procedure? $vector-map-f1))
+   (equal?
+     ($vector-map-f1 vector '#(1 2 3 4 5) '#(f g h i j) '#(k l m n o) '#(p q r s t) '#(u v w x y))
+     '#(#(#(a) #(b) #(c) #(d) #(e)) #(#(a 1) #(b 2) #(c 3) #(d 4) #(e 5))
+       #(#(a 1 f) #(b 2 g) #(c 3 h) #(d 4 i) #(e 5 j))
+       #(#(a 1 f k) #(b 2 g l) #(c 3 h m) #(d 4 i n) #(e 5 j o))
+       #(#(a 1 f k p) #(b 2 g l q) #(c 3 h m r) #(d 4 i n s) #(e 5 j o t))
+       #(#(a 1 f k p u) #(b 2 g l q v) #(c 3 h m r w) #(d 4 i n s x) #(e 5 j o t y))
+       #(#(1 a) #(2 b) #(3 c) #(4 d) #(5 e))
+       #(#(1 a f) #(2 b g) #(3 c h) #(4 d i) #(5 e j))
+       #(#(1 a f k) #(2 b g l) #(3 c h m) #(4 d i n) #(5 e j o))
+       #(#(1 a f k p) #(2 b g l q) #(3 c h m r) #(4 d i n s) #(5 e j o t))
+       #(#(1 a f k p u) #(2 b g l q v) #(3 c h m r w) #(4 d i n s x) #(5 e j o t y))
+       #(#(1 f a) #(2 g b) #(3 h c) #(4 i d) #(5 j e))
+       #(#(1 f a k) #(2 g b l) #(3 h c m) #(4 i d n) #(5 j e o))
+       #(#(1 f a k p) #(2 g b l q) #(3 h c m r) #(4 i d n s) #(5 j e o t))
+       #(#(1 f a k p u) #(2 g b l q v) #(3 h c m r w) #(4 i d n s x) #(5 j e o t y))
+       #(#(1 f k a) #(2 g l b) #(3 h m c) #(4 i n d) #(5 j o e))
+       #(#(1 f k a p) #(2 g l b q) #(3 h m c r) #(4 i n d s) #(5 j o e t))
+       #(#(1 f k a p u) #(2 g l b q v) #(3 h m c r w) #(4 i n d s x) #(5 j o e t y))
+       #(#(1 f k p a) #(2 g l q b) #(3 h m r c) #(4 i n s d) #(5 j o t e))
+       #(#(1 f k p a u) #(2 g l q b v) #(3 h m r c w) #(4 i n s d x) #(5 j o t e y))
+       #(#(1 f k p u a) #(2 g l q v b) #(3 h m r w c) #(4 i n s x d) #(5 j o t y e))))
+ )
+
+(mat vector-for-each
+  (error? ; invalid number of arguments
+    (vector-for-each))
+  (error? ; invalid number of arguments
+    (vector-for-each '#()))
+  (error? ; invalid number of arguments
+    (vector-for-each +))
+  (error? ; non procedure '#()
+    (vector-for-each '#() '#()))
+  (error? ; non procedure '#()
+    (vector-for-each '#() '#() '#()))
+  (error? ; non procedure '#()
+    (vector-for-each '#() '#() '#() '()))
+  (error? ; non procedure '#()
+    (vector-for-each '#() '#() '#() '#() '#()))
+  (error? ; non vector 3
+    (vector-for-each + 3))
+  (error? ; non vector (3)
+    (vector-for-each + '#() '(3)))
+  (error? ; non vector (3)
+    (vector-for-each + '#() '#() '(3)))
+  (error? ; non vector (3)
+    (vector-for-each + '#() '#() '(3) '#()))
+  (error? ; non vector 7
+    (vector-for-each + 7 '#() '#() '#() '#()))
+  (error? ; lengths differ
+    (vector-for-each + '#() '#(x)))
+  (error? ; lengths differ
+    (vector-for-each + '#() '#() '#(x)))
+  (error? ; lengths differ
+    (vector-for-each + '#() '#() '#(x) '#()))
+  (error? ; lengths differ
+    (vector-for-each + '#(y) '#() '#(x) '#()))
+  (error? ; lengths differ
+    (vector-for-each + '#(y) '#() '#() '#() '#()))
+  (equal? (vector-for-each + '#()) (void))
+  (equal? (vector-for-each + '#() '#()) (void))
+  (equal? (vector-for-each + '#() '#() '#()) (void))
+  (equal? (vector-for-each + '#() '#() '#() '#() '#()) (void))
+  (equal?
+    (let ([ls '()])
+      (vector-for-each (lambda (x) (set! ls (cons x ls))) '#(a b c d e f))
+      ls)
+    '(f e d c b a))
+  (equal?
+    (let ([ls '()])
+      (vector-for-each
+        (lambda (x y) (set! ls (cons (cons x y) ls)))
+        '#(a b c d e f)
+        '#(3 2 7 6 5 4))
+      ls)
+    '((f . 4) (e . 5) (d . 6) (c . 7) (b . 2) (a . 3)))
+  (equal?
+    (let ([ls '()])
+      (vector-for-each
+        (lambda r (set! ls (cons r ls)))
+        '#(a b c d e f)
+        '#(3 2 7 6 5 4)
+        '#(-1 -2 -3 -4 -5 -6))
+      ls)
+    '((f 4 -6) (e 5 -5) (d 6 -4) (c 7 -3) (b 2 -2) (a 3 -1)))
+  (equal?
+    (let ([ls '()])
+      (vector-for-each
+        (lambda r (set! ls (cons r ls)))
+        '#(a b c d e f)
+        '#(3 2 7 6 5 4)
+        '#(-1 -2 -3 -4 -5 -6)
+        '#(m n o p q r)
+        '#(z y x w v u))
+      ls)
+    '((f 4 -6 r u) (e 5 -5 q v) (d 6 -4 p w) (c 7 -3 o x)
+       (b 2 -2 n y) (a 3 -1 m z)))
+  (begin
+    (define ($vector-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (vector-for-each p '#())
+        (vector-for-each p '#() x1)
+        (vector-for-each p '#() x1 x2)
+        (vector-for-each p '#() x1 x2 x3)
+        (vector-for-each p '#() x1 x2 x3 x4)
+        (vector-for-each p '#() x1 x2 x3 x4 x5)
+        (vector-for-each p x1 '#())
+        (vector-for-each p x1 '#() x2)
+        (vector-for-each p x1 '#() x2 x3)
+        (vector-for-each p x1 '#() x2 x3 x4)
+        (vector-for-each p x1 '#() x2 x3 x4 x5)
+        (vector-for-each p x1 x2 '#())
+        (vector-for-each p x1 x2 '#() x3)
+        (vector-for-each p x1 x2 '#() x3 x4)
+        (vector-for-each p x1 x2 '#() x3 x4 x5)
+        (vector-for-each p x1 x2 x3 '#())
+        (vector-for-each p x1 x2 x3 '#() x4)
+        (vector-for-each p x1 x2 x3 '#() x4 x5)
+        (vector-for-each p x1 x2 x3 x4 '#())
+        (vector-for-each p x1 x2 x3 x4 '#() x5)
+        (vector-for-each p x1 x2 x3 x4 x5 '#())))
+    (procedure? $vector-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($vector-for-each-f1 q '#() '#() '#() '#() '#())
+      (reverse ls))
+    '())
+  (begin
+    (define ($vector-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (vector-for-each p '#(a))
+        (vector-for-each p '#(a) x1)
+        (vector-for-each p '#(a) x1 x2)
+        (vector-for-each p '#(a) x1 x2 x3)
+        (vector-for-each p '#(a) x1 x2 x3 x4)
+        (vector-for-each p '#(a) x1 x2 x3 x4 x5)
+        (vector-for-each p x1 '#(a))
+        (vector-for-each p x1 '#(a) x2)
+        (vector-for-each p x1 '#(a) x2 x3)
+        (vector-for-each p x1 '#(a) x2 x3 x4)
+        (vector-for-each p x1 '#(a) x2 x3 x4 x5)
+        (vector-for-each p x1 x2 '#(a))
+        (vector-for-each p x1 x2 '#(a) x3)
+        (vector-for-each p x1 x2 '#(a) x3 x4)
+        (vector-for-each p x1 x2 '#(a) x3 x4 x5)
+        (vector-for-each p x1 x2 x3 '#(a))
+        (vector-for-each p x1 x2 x3 '#(a) x4)
+        (vector-for-each p x1 x2 x3 '#(a) x4 x5)
+        (vector-for-each p x1 x2 x3 x4 '#(a))
+        (vector-for-each p x1 x2 x3 x4 '#(a) x5)
+        (vector-for-each p x1 x2 x3 x4 x5 '#(a))))
+    (procedure? $vector-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($vector-for-each-f1 q '#(1) '#(f) '#(k) '#(p) '#(u))
+      (reverse ls))
+    '((a) (1 a) (f 1 a) (k f 1 a) (p k f 1 a) (u p k f 1 a)
+      (a 1) (f a 1) (k f a 1) (p k f a 1) (u p k f a 1)
+      (a f 1) (k a f 1) (p k a f 1) (u p k a f 1) (a k f 1)
+      (p a k f 1) (u p a k f 1) (a p k f 1) (u a p k f 1)
+      (a u p k f 1)))
+  (begin
+    (define ($vector-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (vector-for-each p '#(a b))
+        (vector-for-each p '#(a b) x1)
+        (vector-for-each p '#(a b) x1 x2)
+        (vector-for-each p '#(a b) x1 x2 x3)
+        (vector-for-each p '#(a b) x1 x2 x3 x4)
+        (vector-for-each p '#(a b) x1 x2 x3 x4 x5)
+        (vector-for-each p x1 '#(a b))
+        (vector-for-each p x1 '#(a b) x2)
+        (vector-for-each p x1 '#(a b) x2 x3)
+        (vector-for-each p x1 '#(a b) x2 x3 x4)
+        (vector-for-each p x1 '#(a b) x2 x3 x4 x5)
+        (vector-for-each p x1 x2 '#(a b))
+        (vector-for-each p x1 x2 '#(a b) x3)
+        (vector-for-each p x1 x2 '#(a b) x3 x4)
+        (vector-for-each p x1 x2 '#(a b) x3 x4 x5)
+        (vector-for-each p x1 x2 x3 '#(a b))
+        (vector-for-each p x1 x2 x3 '#(a b) x4)
+        (vector-for-each p x1 x2 x3 '#(a b) x4 x5)
+        (vector-for-each p x1 x2 x3 x4 '#(a b))
+        (vector-for-each p x1 x2 x3 x4 '#(a b) x5)
+        (vector-for-each p x1 x2 x3 x4 x5 '#(a b))))
+    (procedure? $vector-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($vector-for-each-f1 q '#(1 2) '#(f g) '#(k l) '#(p q) '#(u v))
+      (reverse ls))
+    '((a) (b) (1 a) (2 b) (f 1 a) (g 2 b) (k f 1 a)
+      (l g 2 b) (p k f 1 a) (q l g 2 b) (u p k f 1 a)
+      (v q l g 2 b) (a 1) (b 2) (f a 1) (g b 2) (k f a 1)
+      (l g b 2) (p k f a 1) (q l g b 2) (u p k f a 1)
+      (v q l g b 2) (a f 1) (b g 2) (k a f 1) (l b g 2)
+      (p k a f 1) (q l b g 2) (u p k a f 1) (v q l b g 2)
+      (a k f 1) (b l g 2) (p a k f 1) (q b l g 2)
+      (u p a k f 1) (v q b l g 2) (a p k f 1) (b q l g 2)
+      (u a p k f 1) (v b q l g 2) (a u p k f 1)
+      (b v q l g 2)))
+  (begin
+    (define ($vector-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (vector-for-each p '#(a b c))
+        (vector-for-each p '#(a b c) x1)
+        (vector-for-each p '#(a b c) x1 x2)
+        (vector-for-each p '#(a b c) x1 x2 x3)
+        (vector-for-each p '#(a b c) x1 x2 x3 x4)
+        (vector-for-each p '#(a b c) x1 x2 x3 x4 x5)
+        (vector-for-each p x1 '#(a b c))
+        (vector-for-each p x1 '#(a b c) x2)
+        (vector-for-each p x1 '#(a b c) x2 x3)
+        (vector-for-each p x1 '#(a b c) x2 x3 x4)
+        (vector-for-each p x1 '#(a b c) x2 x3 x4 x5)
+        (vector-for-each p x1 x2 '#(a b c))
+        (vector-for-each p x1 x2 '#(a b c) x3)
+        (vector-for-each p x1 x2 '#(a b c) x3 x4)
+        (vector-for-each p x1 x2 '#(a b c) x3 x4 x5)
+        (vector-for-each p x1 x2 x3 '#(a b c))
+        (vector-for-each p x1 x2 x3 '#(a b c) x4)
+        (vector-for-each p x1 x2 x3 '#(a b c) x4 x5)
+        (vector-for-each p x1 x2 x3 x4 '#(a b c))
+        (vector-for-each p x1 x2 x3 x4 '#(a b c) x5)
+        (vector-for-each p x1 x2 x3 x4 x5 '#(a b c))))
+    (procedure? $vector-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($vector-for-each-f1 q '#(1 2 3) '#(f g h) '#(k l m) '#(p q r) '#(u v w))
+      (reverse ls))
+    '((a) (b) (c) (1 a) (2 b) (3 c) (f 1 a) (g 2 b) (h 3 c)
+      (k f 1 a) (l g 2 b) (m h 3 c) (p k f 1 a) (q l g 2 b)
+      (r m h 3 c) (u p k f 1 a) (v q l g 2 b) (w r m h 3 c)
+      (a 1) (b 2) (c 3) (f a 1) (g b 2) (h c 3) (k f a 1)
+      (l g b 2) (m h c 3) (p k f a 1) (q l g b 2) (r m h c 3)
+      (u p k f a 1) (v q l g b 2) (w r m h c 3) (a f 1)
+      (b g 2) (c h 3) (k a f 1) (l b g 2) (m c h 3)
+      (p k a f 1) (q l b g 2) (r m c h 3) (u p k a f 1)
+      (v q l b g 2) (w r m c h 3) (a k f 1) (b l g 2)
+      (c m h 3) (p a k f 1) (q b l g 2) (r c m h 3)
+      (u p a k f 1) (v q b l g 2) (w r c m h 3) (a p k f 1)
+      (b q l g 2) (c r m h 3) (u a p k f 1) (v b q l g 2)
+      (w c r m h 3) (a u p k f 1) (b v q l g 2)
+      (c w r m h 3)))
+  (begin
+    (define ($vector-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (vector-for-each p '#(a b c d))
+        (vector-for-each p '#(a b c d) x1)
+        (vector-for-each p '#(a b c d) x1 x2)
+        (vector-for-each p '#(a b c d) x1 x2 x3)
+        (vector-for-each p '#(a b c d) x1 x2 x3 x4)
+        (vector-for-each p '#(a b c d) x1 x2 x3 x4 x5)
+        (vector-for-each p x1 '#(a b c d))
+        (vector-for-each p x1 '#(a b c d) x2)
+        (vector-for-each p x1 '#(a b c d) x2 x3)
+        (vector-for-each p x1 '#(a b c d) x2 x3 x4)
+        (vector-for-each p x1 '#(a b c d) x2 x3 x4 x5)
+        (vector-for-each p x1 x2 '#(a b c d))
+        (vector-for-each p x1 x2 '#(a b c d) x3)
+        (vector-for-each p x1 x2 '#(a b c d) x3 x4)
+        (vector-for-each p x1 x2 '#(a b c d) x3 x4 x5)
+        (vector-for-each p x1 x2 x3 '#(a b c d))
+        (vector-for-each p x1 x2 x3 '#(a b c d) x4)
+        (vector-for-each p x1 x2 x3 '#(a b c d) x4 x5)
+        (vector-for-each p x1 x2 x3 x4 '#(a b c d))
+        (vector-for-each p x1 x2 x3 x4 '#(a b c d) x5)
+        (vector-for-each p x1 x2 x3 x4 x5 '#(a b c d))))
+    (procedure? $vector-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($vector-for-each-f1 q '#(1 2 3 4) '#(f g h i) '#(k l m n) '#(p q r s) '#(u v w x))
+      (reverse ls))
+    '((a) (b) (c) (d) (1 a) (2 b) (3 c) (4 d) (f 1 a)
+      (g 2 b) (h 3 c) (i 4 d) (k f 1 a) (l g 2 b) (m h 3 c)
+      (n i 4 d) (p k f 1 a) (q l g 2 b) (r m h 3 c)
+      (s n i 4 d) (u p k f 1 a) (v q l g 2 b) (w r m h 3 c)
+      (x s n i 4 d) (a 1) (b 2) (c 3) (d 4) (f a 1) (g b 2)
+      (h c 3) (i d 4) (k f a 1) (l g b 2) (m h c 3) (n i d 4)
+      (p k f a 1) (q l g b 2) (r m h c 3) (s n i d 4)
+      (u p k f a 1) (v q l g b 2) (w r m h c 3) (x s n i d 4)
+      (a f 1) (b g 2) (c h 3) (d i 4) (k a f 1) (l b g 2)
+      (m c h 3) (n d i 4) (p k a f 1) (q l b g 2) (r m c h 3)
+      (s n d i 4) (u p k a f 1) (v q l b g 2) (w r m c h 3)
+      (x s n d i 4) (a k f 1) (b l g 2) (c m h 3) (d n i 4)
+      (p a k f 1) (q b l g 2) (r c m h 3) (s d n i 4)
+      (u p a k f 1) (v q b l g 2) (w r c m h 3) (x s d n i 4)
+      (a p k f 1) (b q l g 2) (c r m h 3) (d s n i 4)
+      (u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
+      (a u p k f 1) (b v q l g 2) (c w r m h 3)
+      (d x s n i 4)))
+  (begin
+    (define ($vector-for-each-f1 p x1 x2 x3 x4 x5)
+      (begin
+        (vector-for-each p '#(a b c d e))
+        (vector-for-each p '#(a b c d e) x1)
+        (vector-for-each p '#(a b c d e) x1 x2)
+        (vector-for-each p '#(a b c d e) x1 x2 x3)
+        (vector-for-each p '#(a b c d e) x1 x2 x3 x4)
+        (vector-for-each p '#(a b c d e) x1 x2 x3 x4 x5)
+        (vector-for-each p x1 '#(a b c d e))
+        (vector-for-each p x1 '#(a b c d e) x2)
+        (vector-for-each p x1 '#(a b c d e) x2 x3)
+        (vector-for-each p x1 '#(a b c d e) x2 x3 x4)
+        (vector-for-each p x1 '#(a b c d e) x2 x3 x4 x5)
+        (vector-for-each p x1 x2 '#(a b c d e))
+        (vector-for-each p x1 x2 '#(a b c d e) x3)
+        (vector-for-each p x1 x2 '#(a b c d e) x3 x4)
+        (vector-for-each p x1 x2 '#(a b c d e) x3 x4 x5)
+        (vector-for-each p x1 x2 x3 '#(a b c d e))
+        (vector-for-each p x1 x2 x3 '#(a b c d e) x4)
+        (vector-for-each p x1 x2 x3 '#(a b c d e) x4 x5)
+        (vector-for-each p x1 x2 x3 x4 '#(a b c d e))
+        (vector-for-each p x1 x2 x3 x4 '#(a b c d e) x5)
+        (vector-for-each p x1 x2 x3 x4 x5 '#(a b c d e))))
+    (procedure? $vector-for-each-f1))
+  (equal?
+    (let ([ls '()])
+      (define q (lambda args (set! ls (cons (reverse args) ls))))
+      ($vector-for-each-f1 q '#(1 2 3 4 5) '#(f g h i j) '#(k l m n o) '#(p q r s t) '#(u v w x y))
+      (reverse ls))
+    '((a) (b) (c) (d) (e) (1 a) (2 b) (3 c) (4 d) (5 e)
+      (f 1 a) (g 2 b) (h 3 c) (i 4 d) (j 5 e) (k f 1 a)
+      (l g 2 b) (m h 3 c) (n i 4 d) (o j 5 e) (p k f 1 a)
+      (q l g 2 b) (r m h 3 c) (s n i 4 d) (t o j 5 e)
+      (u p k f 1 a) (v q l g 2 b) (w r m h 3 c) (x s n i 4 d)
+      (y t o j 5 e) (a 1) (b 2) (c 3) (d 4) (e 5) (f a 1)
+      (g b 2) (h c 3) (i d 4) (j e 5) (k f a 1) (l g b 2)
+      (m h c 3) (n i d 4) (o j e 5) (p k f a 1) (q l g b 2)
+      (r m h c 3) (s n i d 4) (t o j e 5) (u p k f a 1)
+      (v q l g b 2) (w r m h c 3) (x s n i d 4) (y t o j e 5)
+      (a f 1) (b g 2) (c h 3) (d i 4) (e j 5) (k a f 1)
+      (l b g 2) (m c h 3) (n d i 4) (o e j 5) (p k a f 1)
+      (q l b g 2) (r m c h 3) (s n d i 4) (t o e j 5)
+      (u p k a f 1) (v q l b g 2) (w r m c h 3) (x s n d i 4)
+      (y t o e j 5) (a k f 1) (b l g 2) (c m h 3) (d n i 4)
+      (e o j 5) (p a k f 1) (q b l g 2) (r c m h 3)
+      (s d n i 4) (t e o j 5) (u p a k f 1) (v q b l g 2)
+      (w r c m h 3) (x s d n i 4) (y t e o j 5) (a p k f 1)
+      (b q l g 2) (c r m h 3) (d s n i 4) (e t o j 5)
+      (u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
+      (y e t o j 5) (a u p k f 1) (b v q l g 2) (c w r m h 3)
+      (d x s n i 4) (e y t o j 5)))
+ ; check for proper tail recursion
+   (equal?
+     (list
+       (let ([s (statistics)])
+         (let ([k 100000] [v '#(a b c)])
+           (let ([n k] [m 0])
+             (define (f) (unless (fx= n 0) (vector-for-each foo v)))
+             (define (foo x)
+               (set! m (+ m 1))
+               (when (eq? x (vector-ref v (fx- (vector-length v) 1)))
+                 (set! n (- n 1))
+                 (f)
+                 17)) ; blow tail recursion here
+             (f)
+             (list (> (sstats-bytes (sstats-difference (statistics) s))
+                      10000)
+                   (eqv? n 0)
+                   (eqv? m (* k (vector-length v)))))))
+       (let ([s (statistics)])
+         (let ([k 100000] [v '#(a b c)])
+           (let ([n k] [m 0])
+             (define (f) (unless (fx= n 0) (vector-for-each foo v)))
+             (define (foo x)
+               (set! m (+ m 1))
+               (when (eq? x (vector-ref v (fx- (vector-length v) 1)))
+                 (set! n (- n 1))
+                 (f)))
+             (f)
+             (list (<= 0
+                      (sstats-bytes (sstats-difference (statistics) s))
+                      1000)
+                   (eqv? n 0)
+                   (eqv? m (* k (vector-length v))))))))
+     '((#t #t #t) (#t #t #t)))
+ )
+
+(define $merge-sort
+  (lambda (lt? ls)
+    (define merge
+      (lambda (ls1 ls2)
+        (if (null? ls1)
+            ls2
+            (if (null? ls2)
+                ls1
+                (if (lt? (car ls1) (car ls2))
+                    (cons (car ls1) (merge (cdr ls1) ls2))
+                    (cons (car ls2) (merge ls1 (cdr ls2))))))))
+    (define sort
+      (lambda (ls n)
+        (if (fx<= n 1)
+            ls
+            (let ([mid (quotient n 2)])
+              (merge
+                (sort (list-head ls mid) mid)
+                (sort (list-tail ls mid) (fx- n mid)))))))
+    (sort ls (length ls))))
+
+(mat vector-sort
+  (error? ; invalid number of arguments
+    (vector-sort))
+  (error? ; invalid number of arguments
+    (vector-sort >))
+  (error? ; invalid number of arguments
+    (vector-sort '#(a b c)))
+  (error? ; invalid number of arguments
+    (vector-sort > '#(1 2 3) #t))
+  (error? ; 3 is not a proper list
+    (vector-sort > 3))
+  (error? ; (1 2 3) is not a vector
+    (vector-sort > '(1 2 3)))
+  (error? ; #(a b c) is not a procedure
+    (vector-sort '#(a b c) '#(a b c)))
+  (error? ; b is not a real number
+    (vector-sort > '#(1 b 3)))
+  (equal? (vector-sort > '#()) '#())
+  (let ([v (vector 3 2 1)])
+    (and
+      (equal? (vector-sort > v) '#(3 2 1))
+      (equal? v '#(3 2 1))))
+  (let ([v (vector 1 2 3)])
+    (and
+      (equal? (vector-sort > v) '#(3 2 1))
+      (equal? v '#(1 2 3))))
+  (let ([v (vector 2 3 1)])
+    (and
+      (equal? (vector-sort > v) '#(3 2 1))
+      (equal? v '#(2 3 1))))
+  (let ([v (vector -2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5)])
+    (and
+      (equal?
+        (vector-sort < v)
+        '#(-43 -11 -7 -5 -2 0 3.0 3 5 8 8.0 9 9))
+      (equal? v '#(-2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5))))
+  (let ([v (vector 2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9)])
+    (and
+      (equal?
+        (vector-sort (lambda (x y) (< (abs x) (abs y))) v)
+        '#(1 -1 2 2 -3 3 4 5 -5 8 8 -8 9 -9 10))
+      (equal? v '#(2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9))))
+  (let ([v (vector 1 3 2 4)])
+    (and
+      (equal? (vector-sort < v) '#(1 2 3 4))
+      (equal? v '#(1 3 2 4))))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (do ([n 1000 (fx- n 5)])
+            ((fx= n 0))
+          (write-char #\.)
+          (flush-output-port)
+          (do ([k 25 (fx- k 1)])
+              ((fx= k 0))
+            (let ([ls (map (lambda (x) (random k)) (make-list n))])
+              (unless (let ([v (list->vector ls)])
+                        (and
+                          (equal?
+                            (vector-sort < v)
+                            (list->vector ($merge-sort < ls)))
+                          (equal? v (list->vector ls))))
+                (fprintf (console-output-port) "\n~s\n" ls)
+                (errorf #f "failed")))))))
+    (make-string 200 #\.))
+)
+
+(mat vector-sort!
+  (error? ; invalid number of arguments
+    (vector-sort!))
+  (error? ; invalid number of arguments
+    (vector-sort! >))
+  (error? ; invalid number of arguments
+    (vector-sort! '#(a b c)))
+  (error? ; invalid number of arguments
+    (vector-sort! > '#(1 2 3) #t))
+  (error? ; 3 is not a proper list
+    (vector-sort! > 3))
+  (error? ; (1 2 3) is not a vector
+    (vector-sort! > '(1 2 3)))
+  (error? ; #(a b c) is not a procedure
+    (vector-sort! '#(a b c) '#(a b c)))
+  (error? ; b is not a real number
+    (vector-sort! > '#(1 b 3)))
+  (equal? (vector-sort! > '#()) (void))
+  (let ([v (vector 3 2 1)])
+    (and
+      (equal? (vector-sort! > v) (void))
+      (equal? v '#(3 2 1))))
+  (let ([v (vector 1 2 3)])
+    (and
+      (equal? (vector-sort! > v) (void))
+      (equal? v '#(3 2 1))))
+  (let ([v (vector 2 3 1)])
+    (and
+      (equal? (vector-sort! > v) (void))
+      (equal? v '#(3 2 1))))
+  (let ([v (vector -2 3.0 9 8 3 -11 0 9 -5 -7 -43 8.0 5)])
+    (and
+      (equal?
+        (vector-sort! < v)
+        (void))
+      (equal? v '#(-43 -11 -7 -5 -2 0 3.0 3 5 8 8.0 9 9))))
+  (let ([v (vector 2 5 8 -3 9 10 -5 8 -8 4 2 3 1 -1 -9)])
+    (and
+      (equal?
+        (vector-sort! (lambda (x y) (< (abs x) (abs y))) v)
+        (void))
+      (equal? v '#(1 -1 2 2 -3 3 4 5 -5 8 8 -8 9 -9 10))))
+  (let ([v (vector 1 3 2 4)])
+    (and
+      (equal? (vector-sort! < v) (void))
+      (equal? v '#(1 2 3 4))))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (do ([n 1000 (fx- n 5)])
+            ((fx= n 0))
+          (write-char #\.)
+          (flush-output-port)
+          (do ([k 25 (fx- k 1)])
+              ((fx= k 0))
+            (let ([ls (map (lambda (x) (random k)) (make-list n))])
+              (unless (let ([v (list->vector ls)])
+                        (and
+                          (equal? (vector-sort! < v) (void))
+                          (equal? v (list->vector ($merge-sort < ls)))))
+                (fprintf (console-output-port) "\n~s\n" ls)
+                (errorf #f "failed")))))))
+    (make-string 200 #\.))
+)
+
+(mat vector->immutable-vector
+    (begin
+      (define immutable-123-vector
+        (vector->immutable-vector (vector 1 2 3)))
+      #t)
+    
+    (immutable-vector? immutable-123-vector)
+    (not (mutable-vector? immutable-123-vector))
+    
+    (equal? '#(1 2 3) immutable-123-vector)
+    (eq? immutable-123-vector
+         (vector->immutable-vector immutable-123-vector))
+    
+    (mutable-vector? (make-vector 5))
+    (not (immutable-vector? (make-vector 5)))
+    
+    (immutable-vector? (vector->immutable-vector (vector)))
+    (not (mutable-vector? (vector->immutable-vector (vector))))
+    (not (immutable-vector? (vector)))
+    (mutable-vector? (vector))
+    
+    (not (immutable-vector? (vector-copy immutable-123-vector)))
+
+    (error? (vector-set! immutable-123-vector 0 1))
+    (error? (vector-set-fixnum! immutable-123-vector 0 1))
+    (error? (vector-fill! immutable-123-vector 0))
+    (error? (vector-sort! < immutable-123-vector))
+)
+
+
+
+(mat fxvector->immutable-fxvector
+    (begin
+      (define immutable-123-fxvector
+        (fxvector->immutable-fxvector (fxvector 1 2 3)))
+      #t)
+    
+    (immutable-fxvector? immutable-123-fxvector)
+    (not (mutable-fxvector? immutable-123-fxvector))
+    
+    (equal? '#vfx(1 2 3) immutable-123-fxvector)
+    (eq? immutable-123-fxvector
+         (fxvector->immutable-fxvector immutable-123-fxvector))
+    
+    (mutable-fxvector? (make-fxvector 5))
+    (not (immutable-fxvector? (make-fxvector 5)))
+    
+    (immutable-fxvector? (fxvector->immutable-fxvector (fxvector)))
+    (not (mutable-fxvector? (fxvector->immutable-fxvector (fxvector))))
+    (not (immutable-fxvector? (fxvector)))
+    (mutable-fxvector? (fxvector))
+    
+    (not (immutable-fxvector? (fxvector-copy immutable-123-fxvector)))
+
+    (error? (fxvector-set! immutable-123-fxvector 0 1))
+    (error? (fxvector-fill! immutable-123-fxvector 0))
+)
+
+(mat vector-cas!
+  (begin
+    (define vec1 (vector 1 2 3))
+    (define vec2 (vector 'apple 'banana 'coconut))
+    (eq? 1 (vector-ref vec1 0)))
+  (not (vector-cas! vec1 0 0 1))
+  (eq? 1 (vector-ref vec1 0))
+  (vector-cas! vec1 0 1 4)
+  (eq? 4 (vector-ref vec1 0))
+  (not (vector-cas! vec1 0 1 5))
+
+  (not (vector-cas! vec1 1 0 1))
+  (eq? 2 (vector-ref vec1 1))
+  (vector-cas! vec1 1 2 5)
+  (eq? 5 (vector-ref vec1 1))
+
+  (not (vector-cas! vec2 0 'banana 'donut))
+  (vector-cas! vec2 0 'apple 'donut)
+  (not (vector-cas! vec2 0 'apple 'eclair))
+  (eq? 'donut (vector-ref vec2 0))
+
+  (not (vector-cas! vec2 1 'apple 'fig))
+  (vector-cas! vec2 1 'banana 'fig)
+  (not (vector-cas! vec2 1 'banana 'grape))
+  (eq? 'fig (vector-ref vec2 1))
+
+  (error? (vector-cas! vec1)) ; arity
+  (error? (vector-cas! vec1 1)) ; arity
+  (error? (vector-cas! vec1 1 2)) ; arity
+  (error? (vector-cas! 1 vec1 2 3)) ; not a vector
+  (error? (vector-cas! (vector->immutable-vector vec1) 1 2 3)) ; not a mutable vector
+  (error? (vector-cas! vec1 vec1 2 3)) ; not a fixnum
+  (error? (vector-cas! vec1 (expt 2 100) 2 3)) ; not a fixnum
+  (error? (vector-cas! vec1 -1 2 3)) ; out of range
+  (error? (vector-cas! vec1 5 2 3)) ; out of range
+
+  ;; make sure `vector-cas!` works with GC generations:
+  (begin
+    (collect 0)
+    (let ([g1 (gensym)])
+      (and (vector-cas! vec2 2 'coconut g1)
+           (begin
+             (collect 0)
+             (eq? g1 (vector-ref vec2 2))))))
+)
diff --git a/mats/5_7.ms b/mats/5_7.ms
new file mode 100644
index 0000000..fd74e87
--- /dev/null
+++ b/mats/5_7.ms
@@ -0,0 +1,107 @@
+;;; 5-7.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat string->symbol
+    (eq? (string->symbol "foo") 'foo)
+    (eq? (string->symbol "a") (string->symbol "a"))
+    (error? (string->symbol 3))
+    (error? (string->symbol 'a))
+ )
+
+(mat gensym
+    (not (eq? (gensym "hi") 'hi))
+    (not (eq? (gensym "hi")
+         (gensym "hi")))
+    (equal? (symbol->string (gensym "hi")) "hi")
+    (error? (gensym '#(a b c)))
+ )
+
+(mat gensym
+  (error? (gensym 'hitme!))
+  (error? (gensym 17))
+  (error? (gensym #f))
+  (error? (gensym 'hitme "a"))
+  (error? (gensym 17 "a"))
+  (error? (gensym #f "a"))
+  (error? (gensym "a" 'hitme))
+  (error? (gensym "a" 17))
+  (error? (gensym "a" #f))
+  (symbol? (gensym))
+  (gensym? (gensym))
+  (not (eq? (gensym) (gensym)))
+  (not (equal? (symbol->string (gensym)) (symbol->string (gensym))))
+  (parameterize ([gensym-count 1000] [gensym-prefix "xxx"])
+    (equal? (symbol->string (gensym)) "xxx1000"))
+  (error? (gensym-count -1))
+  (error? (gensym-count 'a))
+  (error? (gensym-count "3.4"))
+  (equal? (parameterize ([gensym-count 73]) (format "~a" (gensym)))
+    "g73")
+  (equal?
+    (let* ([g1 (with-input-from-string "#{pn1 un1}" read)] [g2 (gensym "pn1" "un1")])
+      (list (gensym? g1) (gensym? g2) (eq? g1 g2)))
+    '(#t #t #t))
+  (equal?
+    (let* ([g1 (gensym "pn2" "un2")] [g2 (with-input-from-string "#{pn2 un2}" read)])
+      (list (gensym? g1) (gensym? g2) (eq? g1 g2)))
+    '(#t #t #t))
+ )
+
+(mat gensym?
+    (gensym? (gensym "foo"))
+    (not (gensym? 'foo))
+    (not (gensym? (string->symbol "foo")))
+    (not (gensym? '(a b)))
+ )
+
+(mat symbol->string
+    (equal? (symbol->string 'foo) "foo")
+    (equal? (symbol->string (string->symbol "hi")) "hi")
+    (equal? (symbol->string (gensym "hi there")) "hi there")
+    (error? (symbol->string 3))
+ )
+
+(mat gensym->unique-string
+  (error? ; not a gensym
+    (gensym->unique-string "spam"))
+  (error? ; not a gensym
+    (gensym->unique-string 3))
+  (error? ; not a gensym
+    (gensym->unique-string 'spam))
+  (string? (gensym->unique-string (gensym)))
+  (equal?
+    (gensym->unique-string '#{g0 e6sfz8u1obe67hsew4stu0-0})
+    "e6sfz8u1obe67hsew4stu0-0")
+)  
+
+(mat putprop-getprop
+    (begin (putprop 'xyz 'key 'value) (eq? (getprop 'xyz 'key) 'value))
+    (begin (putprop 'xyz 'key 'new-value) (eq? (getprop 'xyz 'key) 'new-value))
+    (begin (putprop 'xyz 'key #f) (not (getprop 'xyz 'key)))
+    (begin (putprop 'xyz 'key #t)
+           (remprop 'xyz 'key)
+           (not (getprop 'xyz 'key)))
+    (let ([g (gensym)] [flag (box 0)])
+       (and (eq? (getprop g 'a flag) flag)
+            (begin (putprop g 'a 'b)
+                   (and (eq? (getprop g 'a) 'b)
+                        (equal? (property-list g) '(a b))))))
+    (begin (putprop 'x 'a 'b)
+           (putprop 'x 'b 'c)
+           (eq? (getprop 'x (getprop 'x (getprop 'x '? 'a) 0) 1) 'c))
+    (error? (getprop 3 'key))
+    (error? (putprop "hi" 'key 'value))
+    (error? (property-list '(a b c)))
+ )
diff --git a/mats/5_8.ms b/mats/5_8.ms
new file mode 100644
index 0000000..a1c251b
--- /dev/null
+++ b/mats/5_8.ms
@@ -0,0 +1,66 @@
+;;; 5-7.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat box
+    (box? (box 3))
+    (equal? (box 'a) '#&a)
+    (equal? (box '(a b c)) '#&(a b c))
+    (not (eq? (box '()) (box '())))
+ )
+
+(mat unbox
+    (equal? (unbox '#&3) 3)
+    (equal? (unbox (box 3)) 3)
+ )
+
+(mat set-box!
+    (let ((x (box 3)))
+        (set-box! x 4)
+        (and (equal? x '#&4) (equal? (unbox x) 4)))
+ )
+
+(mat box-cas!
+  (begin
+    (define bx1 (box 1))
+    (define bx2 (box 'apple))
+    (eq? 1 (unbox bx1)))
+  (not (box-cas! bx1 0 1))
+  (eq? 1 (unbox bx1))
+  (box-cas! bx1 1 2)
+  (eq? 2 (unbox bx1))
+
+  (not (box-cas! bx2 #f 'banana))
+  (box-cas! bx2 'apple 'banana)
+  (not (box-cas! bx2 'apple 'banana))
+  (eq? 'banana (unbox bx2))
+
+  (not (box-cas! (box (bitwise-arithmetic-shift-left 1 40))
+                 (bitwise-arithmetic-shift-left 2 40)
+                 'wrong))
+
+  (error? (box-cas! bx1)) ; arity
+  (error? (box-cas! bx1 1)) ; arity
+  (error? (box-cas! 1 bx1 2)) ; not a box
+  (error? (box-cas! (box-immutable 1) 1 2)) ; not a mutable box
+
+  ;; make sure `box-cas!` works with GC generations:
+  (begin
+    (collect 0)
+    (let ([g1 (gensym)])
+      (and (box-cas! bx2 'banana g1)
+           (begin
+             (collect 0)
+             (eq? g1 (unbox bx2))))))
+  )
diff --git a/mats/6.ms b/mats/6.ms
new file mode 100644
index 0000000..4c36783
--- /dev/null
+++ b/mats/6.ms
@@ -0,0 +1,3559 @@
+;;; 6.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; sections 6-1 and 6-2:
+
+(define prettytest.ss (format "~a/prettytest.ss" *mats-dir*))
+
+(mat current-input-port
+   (port? (current-input-port))
+   (input-port? (current-input-port))
+   (eq? (current-input-port) (console-input-port))
+ )
+
+(mat current-output-port
+   (port? (current-output-port))
+   (output-port? (current-output-port))
+   (eq? (current-output-port) (console-output-port))
+ )
+
+(mat port-operations
+   (error? (open-input-file "nonexistent file"))
+   (error? (open-input-file "nonexistent file" 'compressed))
+   (error? (open-output-file "/nonexistent/directory/nonexistent/file"))
+   (error? (open-output-file "/nonexistent/directory/nonexistent/file" 'replace))
+   (error? (open-input-output-file "/nonexistent/directory/nonexistent/file"))
+   (error? (open-input-output-file "/nonexistent/directory/nonexistent/file" 'truncate))
+   ; the following several clauses test various open-output-file options
+   (let ([p (open-output-file "testfile.ss" 'truncate)])
+      (and (port? p) (output-port? p) (begin (close-output-port p) #t)))
+   (error? (open-output-file "testfile.ss"))
+   (error? (open-output-file "testfile.ss" 'error))
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (and (port? p) (output-port? p) (begin (close-output-port p) #t)))
+   (let ([p (open-output-file "testfile.ss" 'truncate)])
+      (and (port? p) (output-port? p) (begin (close-output-port p) #t)))
+   (let ([p (open-output-file "testfile.ss" 'truncate)])
+      (display "\"hello" p)
+      (close-output-port p)
+      (let ([p (open-output-file "testfile.ss" 'append)])
+         (display " there\"" p)
+         (close-output-port p)
+         (let ([p (open-input-file "testfile.ss")])
+            (and (equal? (read p) "hello there")
+                 (eof-object? (read p))
+                 (begin (close-input-port p) #t)))))
+   ; the following tests open-output-file, close-output-port, write,
+   ; display, and newline---and builds testfile.ss for the next test
+   (let ([p (let loop () (if (file-exists? "testfile.ss")
+                             (begin (delete-file "testfile.ss" #f) (loop))
+                             (open-output-file "testfile.ss")))])
+      (for-each (lambda (x) (write x p) (display " " p))
+                '(a b c d e))
+      (newline p)
+      (close-output-port p)
+      #t)
+   ; the following tests open-input-file, close-input-port, read,
+   ; and eof-object?
+   (equal? (let ([p (open-input-file "testfile.ss")])
+              (let f ([x (read p)])
+                 (if (eof-object? x)
+                     (begin (close-input-port p) '())
+                     (cons x (f (read p))))))
+           '(a b c d e))
+   ; the following tests with-output-to-file, close-port,
+   ; and write-char---and builds testfile.ss for the next test
+   (equal? (call-with-values
+             (lambda ()
+               (with-output-to-file "testfile.ss" 
+                 (lambda ()
+                   (for-each (lambda (c) (write-char c))
+                             (string->list "a b c d e"))
+                  (values 1 2 3))
+                 'replace))
+             list)
+           '(1 2 3))
+   ; the following tests with-input-from-file, close-port,
+   ; read-char, unread-char, and eof-object?
+   (equal? (with-input-from-file "testfile.ss"
+              (lambda ()
+                 (list->string
+                    (let f ()
+                       (let ([c (read-char)])
+                          (if (eof-object? c)
+                              '()
+                              (begin (unread-char c)
+                                     (let ([c (read-char)])
+                                        (cons c (f))))))))))
+           "a b c d e")
+   ; the following tests call-with-output-file, close-port,
+   ; and write-char---and builds testfile.ss for the next test
+   (equal? (call-with-values
+             (lambda ()
+               (call-with-output-file "testfile.ss" 
+                 (lambda (p)
+                   (for-each (lambda (c) (write-char c p))
+                             (string->list "a b c d e"))
+                   (close-port p)
+                  (values 1 2 3))
+                 'replace))
+             list)
+           '(1 2 3))
+   ; the following tests call-with-input-file, close-port,
+   ; read-char, unread-char, and eof-object?
+   (equal? (call-with-input-file "testfile.ss"
+              (lambda (p)
+                 (list->string
+                    (let f ()
+                       (let ([c (read-char p)])
+                          (if (eof-object? c)
+                              (begin (close-port p) '())
+                              (begin (unread-char c p)
+                                     (let ([c (read-char p)])
+                                        (cons c (f))))))))))
+           "a b c d e")
+   ; the following tests call-with-input-file, close-port,
+   ; read-char, unread-char, and eof-object?
+   (equal? (call-with-values
+             (lambda ()
+               (call-with-input-file "testfile.ss"
+                 (lambda (p)
+                    (apply values
+                      (let f ()
+                        (let ([c (read-char p)])
+                          (if (eof-object? c)
+                              (begin (close-port p) '())
+                              (begin (unread-char c p)
+                                     (let ([c (read-char p)])
+                                        (cons c (f)))))))))))
+             (lambda ls (list->string ls)))
+           "a b c d e")
+   ; the following tests call-with-input-file, close-input-port,
+   ; read-char, peek-char, and eof-object?
+   (equal? (call-with-input-file "testfile.ss"
+              (lambda (p)
+                 (list->string
+                    (let f ()
+                       (let ([c (peek-char p)])
+                          (if (eof-object? c)
+                              (begin (close-input-port p) '())
+                              (let ([c (read-char p)])
+                                 (cons c (f)))))))))
+           "a b c d e")
+   ; test various errors related to input ports
+   (begin (set! ip (open-input-file "testfile.ss"))
+          (and (port? ip) (input-port? ip)))
+   (error? (unread-char #\a ip))
+   (eqv? (read-char ip) #\a)
+   (begin (unread-char #\a ip) (eqv? (read-char ip) #\a))
+   (begin (clear-input-port ip) #t)
+   (error? (unread-char #\a ip))
+   (error? (write-char #\a ip))
+   (error? (write 'a ip))
+   (error? (display 'a ip))
+   (error? (newline ip))
+   (error? (fprintf ip "hi"))
+   (error? (flush-output-port ip))
+   (error? (clear-output-port ip))
+   (begin (close-input-port ip) #t)
+   (error? (read-char ip))
+   (error? (read ip))
+   (error? (char-ready? ip))
+   ; test various errors related to output ports
+   (begin (set! op (open-output-file "testfile.ss" 'replace))
+          (and (port? op) (output-port? op)))
+   (error? (char-ready? op))
+   (error? (peek-char op))
+   (error? (read-char op))
+   (error? (unread-char #\a op))
+   (error? (read op))
+   (error? (clear-input-port op))
+   (begin (close-output-port op) #t)
+   (error? (write-char #\a op))
+   (error? (write 'a op))
+   (error? (display 'a op))
+   (error? (newline op))
+   (error? (fprintf op "hi"))
+   (error? (flush-output-port op))
+   (error? (clear-output-port op))
+   (error? (current-output-port 'a))
+   (error? (current-input-port 'a))
+   (begin (current-output-port (console-output-port)) #t)
+   (begin (current-input-port (console-input-port)) #t)
+
+   ; the following tests open-input-string, open-output-string, read-char,
+   ; eof-object?, unread-char, write-char, and get-output-string
+   (let ([s "hi there, mom!"])
+      (let ([ip (open-input-string s)] [op (open-output-string)])
+         (do ([c (read-char ip) (read-char ip)])
+             ((eof-object? c)
+              (equal? (get-output-string op) s))
+             (unread-char c ip)
+             (write-char (read-char ip) op))))
+
+   (error? (with-input-from-string))
+   (error? (with-input-from-string "a"))
+   (error? (with-input-from-string 'a (lambda () 3)))
+   (error? (with-input-from-string "a" 'foo))
+   (error? (with-input-from-string (lambda () 3) "a"))
+   (error? (with-input-from-string '(this too?) values))
+   (error? (with-input-from-string "a" (lambda () 3) 'compressed))
+   (error? (with-output-to-string))
+   (error? (with-output-to-string "a"))
+   (error? (with-output-to-string 'a (lambda () 3)))
+   (error? (with-output-to-string '(this too?)))
+   (error? (eof-object #!eof))
+   (eq? (with-input-from-string "" read) #!eof)
+   (eq? (with-input-from-string "" read) (eof-object))
+   (eq? (eof-object) #!eof)
+   (error? (with-input-from-string "'" read))
+   ; the following tests with-input-from-string, with-output-to-string,
+   ; read-char, eof-object?, unread-char, and write-char
+   (let ([s "hi there, mom!"])
+     (equal?
+       (with-input-from-string s
+         (lambda ()
+           (with-output-to-string
+             (lambda ()
+               (do ([c (read-char) (read-char)])
+                   ((eof-object? c))
+                 (unread-char c)
+                 (write-char (read-char)))))))
+       s))
+
+   ; the following makes sure that call-with-{in,out}put-file close the
+   ; port (from Dave Boyer)---at least on systems which restrict the
+   ; number of open ports to less than 20
+   (let loop ((i 20))
+      (or (zero? i)
+          (begin (call-with-output-file "testfile.ss"
+                    (lambda (p) (write i p))
+                    'replace)
+                 (and (eq? (call-with-input-file "testfile.ss"
+                              (lambda (p) (read p)))
+                           i)
+                      (loop (- i 1))))))
+
+   ; test source information in error messages from read
+   (error?
+     (begin
+       (with-output-to-file "testfile.ss"
+         (lambda () (display "(cons 1 2 . 3 4)"))
+         'replace)
+       (let ([ip (open-input-file "testfile.ss")])
+         (dynamic-wind
+           void
+           (lambda () (read ip))
+           (lambda () (close-input-port ip))))))
+
+   ; test source information in error messages from read
+   (error?
+     (begin
+       (with-output-to-file "testfile.ss"
+         (lambda () (display "(cons 1 2 ] 3 4)"))
+         'replace)
+       (let ([ip (open-input-file "testfile.ss")])
+         (dynamic-wind
+           void
+           (lambda () (read ip))
+           (lambda () (close-input-port ip))))))
+ )
+
+(mat port-operations1
+  (error? (open-input-output-file))
+  (error? (open-input-output-file 'furball))
+  (error? (open-input-output-file "/probably/not/a/good/path"))
+  (error? (open-input-output-file "testfile.ss" 'compressed))
+  (error? (open-input-output-file "testfile.ss" 'uncompressed))
+  (begin
+    (define $ppp (open-input-output-file "testfile.ss"))
+    (and (input-port? $ppp) (output-port? $ppp) (port? $ppp)))
+  (error? (truncate-file $ppp -3))
+  (error? (truncate-file $ppp 'all-the-way))
+  (eof-object?
+    (begin
+      (truncate-file $ppp)
+      (display "hello" $ppp)
+      (flush-output-port $ppp)
+      (read $ppp)))
+  (eq? (begin (file-position $ppp 0) (read $ppp)) 'hello)
+  (eqv? (begin
+          (display "goodbye\n" $ppp)
+          (truncate-file $ppp 9)
+          (file-position $ppp))
+        9)
+  (eof-object? (read $ppp))
+  (eqv? (begin (file-position $ppp 0) (file-position $ppp)) 0)
+  (eq? (read $ppp) 'hellogood)
+  (eqv? (begin
+          (display "byebye\n" $ppp)
+          (truncate-file $ppp 0)
+          (file-position $ppp))
+        0)
+  (eof-object? (read $ppp))
+  (eof-object?
+    (begin
+      (close-port $ppp)
+      (let ([ip (open-input-file "testfile.ss")])
+        (let ([c (read-char ip)])
+          (close-input-port ip)
+          c))))
+  (error?
+    (let ([ip (open-input-file "testfile.ss")])
+      (dynamic-wind
+        void
+        (lambda () (truncate-file ip))
+        (lambda () (close-input-port ip)))))
+  (error? (truncate-file 'animal-crackers))
+  (error? (truncate-file))
+  (error? (truncate-file $ppp))
+  (let ([op (open-output-string)])
+    (and (= (file-position op) 0)
+         (= (file-length op) 0)
+         (begin (fresh-line op) #t)
+         (= (file-length op) 0)
+         (= (file-position op) 0)
+         (do ([i 4000 (fx- i 1)])
+             ((fx= i 0) #t)
+           (display "hello" op))
+         (= (file-length op) 20000)
+         (= (file-position op) 20000)
+         (begin (file-position op 5000) #t)
+         (= (file-position op) 5000)
+         (= (file-length op) 20000)
+         (begin (truncate-file op) #t)
+         (= (file-length op) 0)
+         (= (file-position op) 0)
+         (begin (truncate-file op 17) #t)
+         (= (file-length op) 17)
+         (= (file-position op) 17)
+         (begin (display "okay" op) #t)
+         (= (file-length op) 21)
+         (= (file-position op) 21)
+         (equal? (substring (get-output-string op) 17 21) "okay")
+         (= (file-length op) 0)
+         (= (file-position op) 0)
+         (begin (fresh-line op) #t)
+         (= (file-length op) 0)
+         (= (file-position op) 0)
+         (begin
+           (write-char #\a op)
+           (fresh-line op)
+           #t)
+         (= (file-position op) 2)
+         (begin (fresh-line op) #t)
+         (= (file-position op) 2)
+         (equal? (get-output-string op) "a\n")))
+  (let ([ip (open-input-string "beam me up, scotty!")]
+        [s (make-string 10)])
+    (and (= (file-position ip) 0)
+         (= (file-length ip) 19)
+         (not (eof-object? (peek-char ip)))
+         (equal? (read ip) 'beam)
+         (= (file-position ip) 4)
+         (not (eof-object? (peek-char ip)))
+         (equal? (block-read ip s 10) 10)
+         (equal? s " me up, sc")
+         (= (file-position ip) 14)
+         (equal? (block-read ip s 10) 5)
+         (equal? s "otty!p, sc")
+         (= (file-position ip) 19)
+         (eof-object? (peek-char ip))
+         (eof-object? (read-char ip))
+         (eof-object? (block-read ip s 10))
+         (eof-object? (block-read ip s 0))
+         (begin
+           (file-position ip 10)
+           (= (file-position ip) 10))
+         (equal? (block-read ip s 10) 9)
+         (equal? s ", scotty!c")))
+  (error? ; unhandled message
+    (get-output-string (open-input-string "oops")))
+  (error? ; unhandled message
+    (let ([op (open-output-file "testfile.ss" 'replace)])
+      (dynamic-wind
+        void
+        (lambda () (get-output-string op))
+        (lambda () (close-output-port op)))))
+ )
+
+(mat compression
+  (let ()
+    (define cp
+      (lambda (mode src dst)
+        (define buf-size 4096)
+        (let ([buf (make-string buf-size)])
+          (call-with-output-file dst
+            (lambda (op)
+              (call-with-input-file src
+                (lambda (ip)
+                  (let lp ()
+                    (let ([n (block-read ip buf buf-size)])
+                      (unless (eof-object? n) (block-write op buf n) (lp)))))))
+            mode))))
+    (define cmp
+      (lambda (mode1 src1 mode2 src2)
+        (define buf-size 4096)
+        (let ([buf1 (make-string buf-size)]
+              [buf2 (make-string buf-size)])
+          (call-with-input-file src1
+            (lambda (ip1)
+              (call-with-input-file src2
+                (lambda (ip2)
+                  (let lp ()
+                    (let ([n1 (block-read ip1 buf1 buf-size)]
+                          [n2 (block-read ip2 buf2 buf-size)])
+                      (if (eof-object? n1)
+                          (eof-object? n2)
+                          (and (eqv? n1 n2)
+                               (string=? (substring buf1 0 n1)
+                                         (substring buf2 0 n2))
+                               (lp))))))
+                mode2))
+            mode1))))
+    (and
+      (cmp '() prettytest.ss '() prettytest.ss)
+      (cmp '(compressed) prettytest.ss '() prettytest.ss)
+      (cmp '() prettytest.ss '(compressed) prettytest.ss)
+      (cmp '(compressed) prettytest.ss '(compressed) prettytest.ss)
+      (begin
+        (cp '(replace compressed) prettytest.ss "testfile.ss")
+        #t)
+      (cmp '(compressed) "testfile.ss" '() prettytest.ss)
+      (not (= (call-with-input-file "testfile.ss" file-length) (call-with-input-file prettytest.ss file-length)))
+     ; the following test could cause an error with anything but latin-1 codec
+      #;(not (cmp '() "testfile.ss" '() prettytest.ss))
+      (begin
+        (cp '(compressed append) prettytest.ss "testfile.ss")
+        #t)
+      (not (cmp '(compressed) "testfile.ss" '() prettytest.ss))
+    ))
+  (error? (open-output-file "testfile.ss" '(replace append)))
+  (error? (open-output-file "testfile.ss" '(append truncate)))
+ ; test workaround for bogus gzclose error return for empty input files
+  (and
+    (eqv? (with-output-to-file "testfile.ss" void 'replace) (void))
+    (eof-object? (with-input-from-file "testfile.ss" read 'compressed)))
+ )
+
+(mat read-comment
+  (equal? '; this is the first comment
+           (a ; second comment
+           #;(third ; comment in comment
+           comment #;(comment #1=e in
+           . #;(comment in comment in comment)
+           comment)) b ; fourth comment
+           c #| fifth comment #| more
+           nesting here |# |# d
+           ; sixth and final comment
+           #1#)
+          '(a b c d e))
+  (equal? (read (open-input-string "; this is the first comment
+                                    (a ; second comment
+                                    #;(third ; comment in comment
+                                    comment #;(comment #1=e in
+                                    . #;(comment in comment in comment)
+                                    comment)) b ; fourth comment
+                                    c #| fifth comment #| more
+                                    nesting here |# |# d
+                                    ; sixth and final comment
+                                    #1#)"))
+        '(a b c d e))
+  (equal? (read (open-input-string "(#|##|# |#|#1
+                                    #||#2
+                                    #|||#3
+                                    #|#||#|#4
+                                    #|| hello ||#5
+                                    #| ; rats |#)"))
+        '(1 2 3 4 5))
+ )
+
+(mat read-graph
+  (begin
+    (define read-test-graph
+      (case-lambda
+        [(s) (read-test-graph s s)]
+        [(s1 s2)
+         (string=?
+           (parameterize ((print-graph #t))
+             (format "~s" (read (open-input-string s1))))
+           s2)]))
+    #t)
+  (error?  ; verify that the error message is NOT "invalid memory reference"
+    (let ((ip (open-input-string "(cons 0 #0#)")))
+      ((#%$make-read ip #t #f) #t)))
+  (let ()
+    (define-record foo ((immutable x) (immutable y)))
+    (record-reader 'foo (record-rtd (make-foo 3 4)))
+    (and
+      (read-test-graph "#0=#[foo (#0#) 0]")
+      (read-test-graph "#0=(#[foo #0# 0])")
+      (read-test-graph "#[foo #0=(a b c) #0#]")))
+  (error? (read-test-graph "#0=#[foo #0# #0#]"))
+  (read-test-graph "#(123 #[foo #0=(a b c) #0#])")
+  (read-test-graph "#(#0=#[foo #1=(a b c) #1#] 0 #0#)")
+  (read-test-graph "#(#1# 0 #1=#[foo #0=(a b c) #0#])"
+                   "#(#0=#[foo #1=(a b c) #1#] 0 #0#)")
+  (read-test-graph "#(123 #0=(#0#))")
+  (read-test-graph "#(123 #0=(#0#))")
+  (let ()
+    (define-record r1 ((mutable a) (immutable b)))
+    (define-record r2 ((immutable a)))
+    (let* ((x2 (make-r2 (make-r1 '* '(a b c)))) (x1 (r2-a x2)))
+      (set-r1-a! x1 x2)
+      (record-reader 'r1 (record-rtd (make-r1 3 4)))
+      (record-reader 'r2 (record-rtd (make-r2 3)))
+      (read-test-graph
+        (parameterize ((print-graph #t))
+          (format "~s" (list (r1-b x1) x1))))))
+  (read-test-graph "(#0=(a b c) #1=#[r1 #[r2 #1#] #0#])")
+ )
+
+(mat block-io
+   ; test block-write and build testfile.ss for the following test
+   (let ([p (open-output-file "testfile.ss" 'truncate)])
+      (block-write p "hi there")
+      (display " mom" p)
+      (block-write p ", how are you?xxxx" (string-length ", how are you?"))
+      (newline p)
+      (let ([s (make-string 100 #\X)])
+         (string-set! s 99 #\newline)
+         (let ([s (apply string-append (make-list 10 s))])
+            (let ([s (apply string-append (make-list 10 s))])
+               (block-write p s)
+               (block-write p s 5000))))
+      (close-output-port p)
+      #t)
+   ; test block-read
+   (let ([random-read-up
+          (lambda (p n)
+             (let f ([n n] [ls '()])
+                (if (fx= n 0)
+                    (apply string-append (reverse ls))
+                    (if (fxodd? n)
+                        (f (- n 1) (cons (string (read-char p)) ls))
+                        (let ([s (make-string (random (fx+ n 1)))])
+                           (let ([i (if (fx= (random 2) 0)
+                                        (block-read p s)
+                                        (block-read p s (string-length s)))])
+                              (f (- n i) (cons (substring s 0 i) ls))))))))])
+      (let ([s (make-string 100 #\X)])
+         (string-set! s 99 #\newline)
+         (let ([s (apply string-append (make-list 10 s))])
+            (let ([s (apply string-append (make-list 10 s))])
+               (let ([s (string-append "hi there mom, how are you?"
+                                       (string #\newline)
+                                       s
+                                       (substring s 0 5000))])
+                  (let ([p (open-input-file "testfile.ss")])
+                     (let ([t (random-read-up p (string-length s))])
+                        (and (eof-object? (read-char p))
+                             (string=? t s)
+                             (eqv? (close-input-port p) (void))))))))))
+   ; test for bug: block-read complained when handler returned eof
+   (eof-object?
+     (let ((p (make-input-port (lambda args #!eof) "")))
+      (block-read p (make-string 100))))
+)
+
+(mat file-length-and-file-position
+   (procedure? file-length)
+   (procedure? file-position)
+   (let ([s "hi there"])
+      (let ([n (string-length s)]
+            [p (open-output-file "testfile.ss" 'replace)])
+         (and (eqv? (file-length p) 0)
+              (begin (display s p)
+                     (= (file-position p) (file-length p) n))
+              (begin (display #\space p)
+                     (= (file-position p) (file-length p) (+ n 1)))
+              (eqv? (file-position p 1) (void))
+              (write-char #\o p)
+              (eqv? (file-position p 2000) (void))
+              (begin (display s p)
+                     (= (file-length p) (file-position p) (+ 2000 n)))
+              (eqv? (close-output-port p) (void)))))
+;;; no error is reported, which isn't serious
+;   (error? (file-position (open-input-file "testfile.ss") 10000))
+   (error?
+     (let ((p (open-input-file "testfile.ss")))
+       (dynamic-wind
+         void
+         (lambda () (file-position p -1))
+         (lambda () (close-input-port p)))))
+   (guard (c [(i/o-invalid-position-error? c)])
+     (let ([p (open-input-file "testfile.ss")])
+       (dynamic-wind
+         void
+         (lambda ()
+           (file-position p (if (fixnum? (expt 2 32)) (- (expt 2 63) 1) (- (expt 2 31) 1)))
+           #t)
+         (lambda () (close-input-port p)))))
+   (error?
+     (let ([p (open-input-file "testfile.ss")])
+       (dynamic-wind
+         void
+         (lambda () (file-position p (expt 2 64)))
+         (lambda () (close-input-port p)))))
+   (error? (file-position 1))
+   (error? (file-length 1))
+   (let ([s "hi there"])
+      (let ([n (string-length s)] [p (open-input-file "testfile.ss")])
+         (and (eqv? (file-length p) (+ 2000 n))
+              (eq? (read p) 'ho)
+              (eq? (read p) 'there)
+              (eqv? (file-position p) n)
+              (eqv? (file-position p 2000) (void))
+              (eq? (read p) 'hi)
+              (eq? (read p) 'there)
+              (= (file-position p) (file-length p) (+ 2000 n))
+              (eqv? (close-input-port p) (void)))))
+ )
+
+(mat string-port-file-position
+  (let ([ip (open-input-string "hit me")])
+    (and (eq? (read ip) 'hit)
+         (eq? (file-position ip) 3)
+         (begin
+           (file-position ip 1)
+           (eq? (read ip) 'it))
+         (begin
+           (file-position ip 6)
+           (eof-object? (read ip)))
+         (begin
+           (file-position ip 0)
+           (eq? (read ip) 'hit))))
+  (error? (file-position (open-input-string "hi") 3))
+  (error? (file-position (open-input-string "hi") -1))
+  (let ()
+    (define f
+      (lambda (n)
+        (let ([op (open-output-string)])
+          (and (begin
+                 (write 'ab op)
+                 (eq? (file-position op) 2))
+               (begin
+                 (file-position op 4)
+                 (write 'ef op)
+                 (eq? (file-position op) 6))
+               (begin
+                 (file-position op 2)
+                 (write 'cd op)
+                 (eq? (file-position op) 4))
+               (begin
+                 (set-port-length! op n)
+                 (get-output-string op))))))
+    (and (equal? (f 6) "abcdef")
+         (equal? (f 4) "abcd")
+         (equal? (f 2) "ab")
+         (equal? (f 0) "")
+         (equal? (f 5) "abcde")
+         (let ((s (f 2000)))
+           (and s (= (string-length s) 2000)))))
+  (error? (file-position (open-output-string) -1))
+ )
+
+(mat fresh-line
+  (procedure? fresh-line)
+  (error? (fresh-line 3))
+  (error? (fresh-line (open-input-string "hello")))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (fresh-line)
+        (fresh-line)
+        (display "hello")
+        (fresh-line)
+        (fresh-line)))
+    "hello\n")
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (fresh-line)
+        (fresh-line)
+        (display "hello")
+        (fresh-line)
+        (fresh-line))
+      'replace)
+    #t)
+  (call-with-input-file "testfile.ss"
+    (lambda (p)
+      (let ([s (make-string 100)])
+        (and
+          (= (block-read p s (string-length s)) 6)
+          (string=? (substring s 0 6) "hello\n")
+          (eof-object? (read-char p))))))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (write-char #\a)
+        (fresh-line)
+        (flush-output-port)
+        (set-port-bol! (current-output-port) #f)
+        (fresh-line)
+        (write-char #\b)
+        (flush-output-port)
+        (set-port-bol! (current-output-port) #t)
+        (fresh-line)
+        (fresh-line)
+        (write-char #\c)
+        (fresh-line)
+        (fresh-line))
+      'replace)
+    #t)
+  (call-with-input-file "testfile.ss"
+    (lambda (p)
+      (let ([s (make-string 100)])
+        (and
+          (= (block-read p s (string-length s)) 6)
+          (string=? (substring s 0 6) "a\n\nbc\n")
+          (eof-object? (read-char p))))))
+ )
+
+(mat char-ready?
+   (procedure? char-ready?)
+   (let ([x (open-input-string "a")])
+      (and (char-ready? x)
+           (eqv? (read-char x) #\a)
+           (char-ready? x)
+           (eof-object? (read-char x))))
+   (parameterize ([current-input-port (open-input-string "a")])
+      (and (char-ready?)
+           (eqv? (read-char) #\a)
+           (char-ready?)
+           (eof-object? (read-char))))
+ )
+
+(mat clear-input-port ; test interactively
+   (procedure? clear-input-port)
+ )
+
+;;; pretty-equal? is like equal? except that it considers gensyms
+;;; with equal print names to be equal and any two nans to be equal.
+(define pretty-equal?
+   (rec equal?
+      (lambda (x y) ; mostly snarfed from 5_1.ss
+         (or (cond
+                [(eq? x y) #t]
+                [(pair? x)
+                 (and (pair? y)
+                      (equal? (car x) (car y))
+                      (equal? (cdr x) (cdr y)))]
+                [(symbol? x)
+                 (and (gensym? x)
+                      (gensym? y)
+                      (string=? (symbol->string x) (symbol->string y)))]
+                [(or (null? x) (null? y)) #f]
+                [(or (char? x) (char? y)) #f]
+                [(flonum? x)
+                 (and (flonum? y)
+                      (or (let ([nan? (lambda (x) (not (fl= x x)))])
+                            (and (nan? x) (nan? y)))
+                          (fl= x y)))]
+                [(number? x)
+                 (and (number? y)
+                      (if (exact? x)
+                          (and (exact? y) (= x y))
+                          (and (equal? (real-part x) (real-part y))
+                               (equal? (imag-part x) (imag-part y)))))]
+                [(string? x) (and (string? y) (string=? x y))]
+                [(box? x) (and (box? y) (equal? (unbox x) (unbox y)))]
+                [(vector? x)
+                 (and (vector? y)
+                      (= (vector-length x) (vector-length y))
+                      (let f ([i (- (vector-length x) 1)])
+                         (or (< i 0)
+                             (and (equal? (vector-ref x i) (vector-ref y i))
+                                  (f (1- i))))))]
+                [(fxvector? x)
+                 (and (fxvector? y)
+                      (= (fxvector-length x) (fxvector-length y))
+                      (let f ([i (- (fxvector-length x) 1)])
+                         (or (< i 0)
+                             (and (fx= (fxvector-ref x i) (fxvector-ref y i))
+                                  (f (1- i))))))]
+                [(bytevector? x)
+                 (and (bytevector? y)
+                      (bytevector=? x y))]
+                [else #f])
+             (parameterize ([print-length 6] [print-level 3])
+                (display "----------------------\n")
+                (pretty-print x)
+                (pretty-print '=/=)
+                (pretty-print y)
+                (display "----------------------\n")
+                #f)))))
+
+(mat pretty-print
+   (let ([pretty-copy
+          (lambda (ifn ofn)
+             (let ([ip (open-input-file ifn)]
+                   [op (open-output-file ofn 'replace)])
+                (dynamic-wind
+                   (lambda () #f)
+                   (rec loop
+                      (lambda ()
+                         (let ([x (read ip)])
+                            (or (eof-object? x)
+                                (parameterize ([print-unicode #f])
+                                  (pretty-print x op)
+                                  (newline op)
+                                  (loop))))))
+                   (lambda ()
+                      (close-input-port ip)
+                      (close-output-port op)))))])
+      (pretty-copy prettytest.ss "testfile.ss"))
+   (let ([p1 (open-input-file prettytest.ss)]
+         [p2 (open-input-file "testfile.ss")])
+      (dynamic-wind
+         (lambda () #f)
+         (rec loop
+            (lambda ()
+               (let ([x1 (read p1)] [x2 (read p2)])
+                  (unless (pretty-equal? x1 x2)
+                     (errorf 'pretty-equal "~s is not equal to ~s" x1 x2))
+                  (or (eof-object? x1) (loop)))))
+         (lambda ()
+            (close-input-port p1)
+            (close-input-port p2))))
+   (error? (pretty-format))
+   (error? (pretty-format 'foo 'x 'x))
+   (error? (pretty-format 3 'x))
+   (error? (pretty-format 'foo '(bad 0 ... ... 0 format)))
+   (list? (pretty-format 'let))
+   (let ([x (pretty-format 'let)])
+     (pretty-format 'let x)
+     (equal? x (pretty-format 'let)))
+   (string=?
+     (parameterize ([pretty-standard-indent 2] [pretty-one-line-limit 1])
+       (pretty-format 'frob '(frob (x 1 ...) 3 (x #f ...) 4 (x y 3 ...) ...))
+       (with-output-to-string
+         (lambda ()
+           (pretty-print '(frob (alpha b c d)
+                                (peter o n m)
+                                (zero 1 2 3)
+                                (nine 8 7 6))))))
+     "(frob (alpha\n        b\n        c\n        d)\n    (peter\n       o\n       n\n       m)\n     (zero 1\n         2\n         3)\n     (nine 8\n         7\n         6))\n")
+   (eqv? (begin (pretty-format 'frob #f) (pretty-format 'frob)) #f)
+   (equal?
+     (with-output-to-string
+       (lambda ()
+         (pretty-print ''#'#`#,#,@,,@`(a b c))))
+     "'#'#`#,#,@,,@`(a b c)\n")
+ )
+
+(mat write
+   (let ([unpretty-copy
+          (lambda (ifn ofn)
+             (let ([ip (open-input-file ifn)]
+                   [op (open-output-file ofn 'replace)])
+                (dynamic-wind
+                   (lambda () #f)
+                   (rec loop
+                      (lambda ()
+                         (let ([x (read ip)])
+                            (or (eof-object? x)
+                                (parameterize ([print-unicode #f])
+                                  (write x op)
+                                  (newline op)
+                                  (loop))))))
+                   (lambda ()
+                      (close-input-port ip)
+                      (close-output-port op)))))])
+      (unpretty-copy prettytest.ss "testfile.ss"))
+   (let ([p1 (open-input-file prettytest.ss)]
+         [p2 (open-input-file "testfile.ss")])
+      (dynamic-wind
+         (lambda () #f)
+         (rec loop
+            (lambda ()
+               (let ([x1 (read p1)] [x2 (read p2)])
+                  (unless (pretty-equal? x1 x2)
+                     (errorf 'pretty-equal "~s is not equal to ~s" x1 x2))
+                  (or (eof-object? x1) (loop)))))
+         (lambda ()
+            (close-input-port p1)
+            (close-input-port p2))))
+ )
+
+(mat fasl
+  (error?
+    (separate-eval '(let ([op (open-file-output-port "testfile.ss" (file-options compressed replace))])
+                      (fasl-write 3 op))))
+  (error?
+    (separate-eval '(let ([ip (open-file-input-port "testfile.ss" (file-options compressed))])
+                      (fasl-read ip))))
+  (equal?
+    (separate-eval '(with-exception-handler
+                      (lambda (c) (unless (warning? c) (raise-continuable c)))
+                      (lambda ()
+                        (let ([op (open-file-output-port "testfile.ss" (file-options compressed replace))])
+                          (fasl-write 3 op)))))
+    "")
+  (equal?
+    (separate-eval `(with-exception-handler
+                      (lambda (c) (unless (warning? c) (raise-continuable c)))
+                      (lambda ()
+                        (let ([ip (open-file-input-port "testfile.ss" (file-options compressed))])
+                          (fasl-read ip)))))
+    "3\n")
+  (pretty-equal?
+    (begin
+      (call-with-port
+        (open-file-output-port "testfile.ss" (file-options replace))
+        (lambda (p) (fasl-write +nan.0 p)))
+      (call-with-port (open-file-input-port "testfile.ss") fasl-read))
+    (/ 0.0 0.0))
+  (let ([ls (with-input-from-file prettytest.ss
+              (rec f
+                (lambda ()
+                  (let ([x (read)])
+                    (if (eof-object? x) '() (cons x (f)))))))])
+    (define-record frob (x1 (uptr x2) (fixnum x3) (float x4) (double x5) (wchar_t x6) (integer-64 x7) (char x8) (unsigned-64 x9)))
+    (let ([x (make-frob '#(#&3+4i 3.456+723i 3/4) 7500000 (most-negative-fixnum) +nan.0 3.1415 #\x3d0
+               (- (expt 2 63) 5) #\$ (- (expt 2 64) 5))])
+      (define put-stuff
+        (lambda (p)
+          (fasl-write (cons x x) p)
+          (fasl-write (list +nan.0 +inf.0 -inf.0 -0.0) p)
+          (for-each (lambda (x) (fasl-write x p)) ls)))
+      (define (get-stuff fasl-read)
+        (lambda (p)
+          (let ([y (fasl-read p)])
+            (and (equal? ($record->vector (car y)) ($record->vector x))
+                 (eq? (cdr y) (car y))
+                 (pretty-equal? (fasl-read p) (list +nan.0 +inf.0 -inf.0 -0.0))
+                 (let loop ([ls ls])
+                   (let ([x1 (fasl-read p)] [x2 (if (null? ls) #!eof (car ls))])
+                     (unless (pretty-equal? x1 x2)
+                       (errorf #f "~s is not equal to ~s" x1 x2))
+                     (or (eof-object? x1) (loop (cdr ls)))))))))
+      (call-with-port
+        (open-file-output-port "testfile.ss" (file-options replace))
+        put-stuff)
+      (and
+        (call-with-port
+          (open-file-input-port "testfile.ss")
+          (get-stuff fasl-read))
+        (call-with-port
+          (open-file-input-port "testfile.ss" (file-options #;compressed))
+          (get-stuff fasl-read))
+        (call-with-port
+          (open-file-input-port "testfile.ss" (file-options #;compressed))
+          (get-stuff (lambda (p)
+                       (when (eof-object? (lookahead-u8 p)) (printf "done\n"))
+                       (fasl-read p))))
+        (begin
+          (call-with-port
+            (open-file-output-port "testfile.ss" (file-options compressed replace))
+            put-stuff)
+          (call-with-port
+            (open-file-input-port "testfile.ss" (file-options compressed))
+            (get-stuff fasl-read)))
+        (call-with-port
+          (open-bytevector-input-port
+            (call-with-bytevector-output-port put-stuff))
+          (get-stuff fasl-read)))))
+  (eqv? (fasl-file prettytest.ss "testfile.ss") (void))
+  (let ([ls (with-input-from-file prettytest.ss
+              (rec f
+                (lambda ()
+                  (let ([x (read)])
+                    (if (eof-object? x) '() (cons x (f)))))))])
+    (call-with-port
+      (open-file-input-port "testfile.ss")
+      (lambda (p)
+        (let loop ([ls ls])
+          (let ([x1 (fasl-read p)] [x2 (if (null? ls) #!eof (car ls))])
+            (unless (pretty-equal? x1 x2)
+              (errorf #f "~s is not equal to ~s" x1 x2))
+            (or (eof-object? x1) (loop (cdr ls))))))))
+  (equal?
+    (with-interrupts-disabled
+      (let ([ls (cons (weak-cons 'a 'b) (weak-cons 'c (cons 'd (weak-cons 'e #f))))])
+        (call-with-port
+          (open-file-output-port "testfile.ss" (file-options replace))
+          (lambda (p) (fasl-write ls p))))
+      (let ([ls (call-with-port (open-file-input-port "testfile.ss") fasl-read)])
+        (list
+          (equal? ls '((a . b) c d e . #f))
+          (weak-pair? ls)
+          (weak-pair? (car ls))
+          (weak-pair? (cdr ls))
+          (weak-pair? (cddr ls))
+          (weak-pair? (cdddr ls)))))
+    '(#t #f #t #t #f #t))
+)
+
+(mat clear-output-port ; test interactively
+   (procedure? clear-output-port)
+ )
+
+(mat flush-output-port ; test interactively
+   (procedure? flush-output-port)
+ )
+
+;;; section 6-3:
+
+(mat format
+   (equal? (format "abcde") "abcde")
+   (equal? (format "~s ~a ~c ~~ ~%" "hi" "there" #\X)
+           (string-append "\"hi\" there X ~ " (string #\newline)))
+   (equal? (format "~s" car) "#")
+   (equal? (format "~s" (lambda () #f)) "#")
+ )
+
+(mat printf
+   (let ([p (open-output-string)])
+      (parameterize ([current-output-port p])
+         (printf "~s:~s" 3 4))
+      (equal? (get-output-string p) "3:4"))
+ )
+
+(mat fprintf
+   (let ([p (open-output-string)])
+      (fprintf p "~s.~s:~s" 'abc 345 "xyz")
+      (equal? (get-output-string p) "abc.345:\"xyz\""))
+ )
+
+(mat cp1in-verify-format-warnings
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(lambda () (import scheme) (format "~a~~~s" 5)))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(lambda () (import scheme) (format "~a~a~a~s" 1 2 3 4 5 6)))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(mat/cf (lambda () (import scheme) (format "~a~~~s" 5))))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(mat/cf (lambda () (import scheme) (format "~a~a~a~s" 1 2 3 4 5 6))))))
+
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(lambda () (import scheme) (printf "abc~s")))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(lambda () (import scheme) (printf "~%~abc~adef~ag~s~~~%" 1 2 3 4 5)))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(mat/cf (lambda () (import scheme) (printf "abc~s"))))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(mat/cf (lambda () (import scheme) (printf "~%~abc~adef~ag~s~~~%" 1 2 3 4 5))))))
+
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(lambda (p) (import scheme) (fprintf p "abc~s")))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(lambda (p) (import scheme) (fprintf p "~%~abc~adef~ag~s~~~%" 1 2 3 4 5)))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(mat/cf (lambda (p) (import scheme) (fprintf p "abc~s"))))))
+   (warning? (parameterize ([#%$suppress-primitive-inlining #f])
+               (eval '(mat/cf (lambda (p) (import scheme) (fprintf p "~%~abc~adef~ag~s~~~%" 1 2 3 4 5))))))
+)
+
+(mat print-parameters
+   (equal? (parameterize ([print-level 3])
+              (format "~s" (let ([x (list 'a)]) (set-car! x x) x)))
+           "((((...))))")
+   (equal? (parameterize ([print-length 3])
+              (format "~s" (let ([x (list 'a)]) (set-cdr! x x) x)))
+           "(a a a ...)")
+   (equal? (parameterize ([print-graph #t])
+              (format "~s" (let ([x (list 'a)]) (set-car! x x) x)))
+           "#0=(#0#)")
+   (equal? (parameterize ([print-graph #t])
+              (format "~s" (let ([x (list 'a)]) (set-cdr! x x) x)))
+           "#0=(a . #0#)")
+   (equal? (parameterize ([print-graph #t])
+              (format "~s" (let ([x (list 'a)] [y (list 'b)])
+                              (list x y y x))))
+           "(#0=(a) #1=(b) #1# #0#)")
+   (equal? (parameterize ([print-graph #t])
+              (format "~s" (let ([x (list 'a)] [y (list 'b)])
+                              (vector x y y x))))
+           "#(#0=(a) #1=(b) #1# #0#)")
+   (equal? (parameterize ([print-graph #t])
+              (format "~s" '(#2# #2=#{a b})))
+           "(#0=#{a b} #0#)")
+   (error? (guard (c [(and (warning? c) (format-condition? c))
+                      (apply errorf (condition-who c) (condition-message c) (condition-irritants c))])
+             (format "~s"
+               (let ([x (list '*)])
+                 (set-car! x x)
+                 (set-cdr! x x)
+                 x))))
+   (equal? (parameterize ([print-vector-length #f])
+              (format "~s ~s" '#5(1 2 3) '#8vfx(5 7 9 8 8 9 -1)))
+           "#(1 2 3 3 3) #vfx(5 7 9 8 8 9 -1 -1)")
+   (equal? (parameterize ([print-vector-length #t])
+              (format "~s ~s" '#(1 2 3 3 3) '#vfx(5 7 9 8 8 9 -1 -1)))
+           "#5(1 2 3) #8vfx(5 7 9 8 8 9 -1)")
+   (equal? (parameterize ([print-vector-length #f])
+              (format "~a ~a" '#5(1 2 3) '#8vfx(5 7 9 8 8 9 -1)))
+           "#(1 2 3 3 3) #vfx(5 7 9 8 8 9 -1 -1)")
+   (equal? (parameterize ([print-vector-length #t])
+              (format "~a ~a" '#(1 2 3 3 3) '#vfx(5 7 9 8 8 9 -1 -1)))
+           "#(1 2 3 3 3) #vfx(5 7 9 8 8 9 -1 -1)")
+   (equal? (parameterize ([print-vector-length #f])
+             (with-output-to-string
+               (lambda ()
+                 (pretty-print '#5(1 2 3))
+                 (pretty-print '#8vfx(5 7 9 8 8 9 -1)))))
+           "#(1 2 3 3 3)\n#vfx(5 7 9 8 8 9 -1 -1)\n")
+   (equal? (parameterize ([print-vector-length #t])
+             (with-output-to-string
+               (lambda ()
+                 (pretty-print '#(1 2 3 3 3))
+                 (pretty-print '#vfx(5 7 9 8 8 9 -1 -1)))))
+           "#5(1 2 3)\n#8vfx(5 7 9 8 8 9 -1)\n")
+   (equal? (parameterize ([print-extended-identifiers #f])
+             (with-output-to-string
+               (lambda ()
+                 (for-each pretty-print '(1+ +++ .. |12| xyz aBc |-155| |.5e7| |.5e|)))))
+           "\\x31;+\n\\x2B;++\n\\x2E;.\n\\x31;2\nxyz\naBc\n\\x2D;155\n\\x2E;5e7\n\\x2E;5e\n")
+   (equal? (parameterize ([print-extended-identifiers #t])
+             (with-output-to-string
+               (lambda ()
+                 (for-each pretty-print '(1+ +++ .. |12| xyz aBc |-155| |.5e7| |.5e|)))))
+           "1+\n+++\n..\n\\x31;2\nxyz\naBc\n\\x2D;155\n\\x2E;5e7\n.5e\n")
+   (equal? (parameterize ([print-gensym #f])
+              (format "~s" '(#3# #3=#{g0 fool})))
+           "(g0 g0)")
+   (equal? (parameterize ([print-graph #t] [print-gensym #f])
+              (format "~s" '(#4# #4=#{g0 fool})))
+           "(#0=g0 #0#)")
+   (equal? (parameterize ([print-gensym 'pretty])
+              (format "~s" '(#5# #5=#{g0 fool})))
+           "(#:g0 #:g0)")
+   (equal? (parameterize ([print-graph #t] [print-gensym 'pretty])
+              (format "~s" '(#6# #6=#{g0 fool})))
+           "(#0=#:g0 #0#)")
+   (equal? (parameterize ([print-gensym 'pretty])
+              (format "~s" '(#7# #7=#:g0)))
+           "(#:g0 #:g0)")
+   (let ([g (gensym "x")])
+     (parameterize ([print-gensym 'pretty/suffix])
+       (equal? (format "~s" g) (format "~s" g))))
+   (do ([i 100 (fx- i 1)])
+       ((fx= i 0) #t)
+     (let ([g (gensym "x")])
+       (unless (< (string-length (parameterize ([print-gensym 'pretty/suffix])
+                                   (format "~s" g)))
+                  (string-length (parameterize ([print-gensym #t])
+                                   (format "~s" g))))
+         (error #f "failed"))))
+   (let ([g (gensym "x")])
+     (let ([x (with-input-from-string
+                (parameterize ([print-gensym 'pretty/suffix])
+                  (format "~s" g))
+                read)])
+       (and (symbol? x) (not (gensym? x)))))
+   (equal? (parameterize ([print-gensym 'pretty/suffix])
+             (format "~s" '#{g0 cfdhkxfnlo6opm0x-c}))
+           "g0.cfdhkxfnlo6opm0x-c")
+   (equal? (parameterize ([print-graph #t] [print-gensym 'pretty])
+              (format "~s" '(#8# #8=#:g0)))
+           "(#0=#:g0 #0#)")
+   (equal? (parameterize ([print-brackets #t])
+              (let ([p (open-output-string)])
+                 (pretty-print '(let ((x 3)) x) p)
+                 (get-output-string p)))
+           (format "~a~%" "(let ([x 3]) x)"))
+   (equal? (parameterize ([print-brackets #f])
+              (let ([p (open-output-string)])
+                 (pretty-print '(let ((x 3)) x) p)
+                 (get-output-string p)))
+           (format "~a~%" "(let ((x 3)) x)"))
+   (equal? (parameterize ([case-sensitive #t])
+              (format "~s" (string->symbol "AbcDEfg")))
+           "AbcDEfg")
+   (equal? (format "~s" (read (open-input-string "abCdEfG")))
+           "abCdEfG")
+   (equal? (parameterize ([case-sensitive #f])
+              (format "~s" (read (open-input-string "abCdEfG"))))
+           "abcdefg")
+   (equal? (parameterize ([print-radix 36])
+              (format "~s" 35))
+           "#36rZ")
+   (equal? (parameterize ([print-radix 36])
+              (format "~a" 35))
+           "Z")
+)
+
+(mat general-port
+   (<= (port-input-index (console-input-port))
+       (port-input-size (console-input-port))
+       (string-length (port-input-buffer (console-input-port))))
+   (<= (port-input-count (console-input-port))
+       (string-length (port-input-buffer (console-input-port))))
+   (<= (port-output-index (console-output-port))
+       (port-output-size (console-output-port))
+       (string-length (port-output-buffer (console-output-port))))
+   (<= (port-output-count (console-output-port))
+       (string-length (port-output-buffer (console-output-port))))
+   (equal?
+     (let ([sip (open-string-input-port "hello")])
+       (let ([n1 (port-input-count sip)])
+         (read-char sip)
+         (list n1 (port-input-count sip))))
+     '(5 4))
+   (equal?
+     (let ([op (make-output-port (lambda args (error #f "oops")) (make-string 10))])
+       (let ([n1 (port-output-count op)])
+         (display "hey!" op)
+         (list n1 (port-output-count op))))
+     '(10 6))
+   (let ()
+      (define make-two-way-port
+         ; no local buffering
+         ; close-port passed through
+         (lambda (ip op)
+            (define handler
+               (lambda (msg . args)
+                  (record-case (cons msg args)
+                     [block-read (p s n) (block-read ip s n)]
+                     [block-write (p s n) (block-write op s n)]
+                     [char-ready? (p) (char-ready? ip)]
+                     [clear-input-port (p) (clear-input-port ip)]
+                     [clear-output-port (p) (clear-output-port op)]
+                     [close-port (p)
+                      (close-port ip)
+                      (close-port op)
+                      (mark-port-closed! p)]
+;                     [file-length (p) #f]
+                     [file-position (p . pos)
+                      (if (null? pos)
+                          (most-negative-fixnum)
+                          (errorf 'two-way-port "cannot reposition"))]
+                     [flush-output-port (p) (flush-output-port op)]
+                     [peek-char (p) (peek-char ip)]
+                     [port-name (p) "two-way port"]
+                     [read-char (p) (read-char ip)]
+                     [unread-char (c p) (unread-char c ip)]
+                     [write-char (c p) (write-char c op)]
+                     [else (errorf 'two-way-port "operation ~s not handled"
+                                  msg)])))
+            (make-input/output-port handler "" "")))
+      (let ([sip (open-input-string "far out")]
+            [sop (open-output-string)])
+         (let ([p1 (make-two-way-port sip sop)])
+            (and (port? p1)
+                 (begin (write (read p1) p1)
+                        (string=? (get-output-string sop) "far"))
+                 (char-ready? p1)
+                 (char=? (read-char p1) #\space)
+                 (char=? (read-char p1) #\o)
+                 (begin (unread-char #\o p1)
+                        (char=? (read-char p1) #\o))
+                ; can't count on clear-output-port doing anything for
+                ; string output ports, so next two checks are bogus
+                 #;(begin (write-char #\a p1)
+                        (clear-output-port p1)
+                        (string=? (get-output-string sop) ""))
+                 (begin
+                   (file-position sip (file-length sip))
+                   (char-ready? p1))
+                 (eof-object? (peek-char p1))
+                ; make sure these don't error out
+                 (eq? (clear-input-port p1) (void))
+                 (eq? (clear-output-port p1) (void))
+                 (begin (close-port p1) (port-closed? p1))
+                 (port-closed? sip)
+                 (port-closed? sop)))))
+   (let ()
+      (define make-broadcast-port
+         ; local buffering
+         ; closed-port not passed through
+         ; critical sections used where necessary to protect against interrupts
+         ; uses block-write to dump buffers to subordinate ports
+         ; check cltl2 to see what it says about local buffering,
+         ;    and about passing through flush, clear, and close
+         ; size set so that buffer always has room for character to be written,
+         ;   allowing buffer to be flushed as soon as it becomes full
+         (lambda ports
+            (define handler
+               (lambda (msg . args)
+                  (record-case (cons msg args)
+;                     [block-read (p s n) #f]
+                     [block-write (p s n)
+                      (unless (null? ports)
+                         (with-interrupts-disabled
+                            (flush-output-port p)
+                            (for-each (lambda (p) (block-write p s n))
+                                      ports)))]
+;                     [char-ready? (p) (char-ready? ip)]
+;                     [clear-input-port (p) (clear-input-port ip)]
+                     [clear-output-port (p) (set-port-output-index! p 0)]
+                     [close-port (p)
+                      (set-port-output-size! p 0)
+                      (mark-port-closed! p)]
+;                     [file-length (p) #f]
+                     [file-position (p . pos)
+                      (if (null? pos)
+                          (most-negative-fixnum)
+                          (errorf 'broadcast-port "cannot reposition"))]
+                     [flush-output-port (p)
+                      (with-interrupts-disabled
+                         (unless (null? ports)
+                            (let ([b (port-output-buffer p)]
+                                  [i (port-output-index p)])
+                               (for-each (lambda (p) (block-write p b i))
+                                         ports)))
+                         (set-port-output-index! p 0))]
+;                     [peek-char (p) (peek-char ip)]
+                     [port-name (p) "broadcast port"]
+;                     [read-char (p) (read-char ip)]
+;                     [unread-char (c p) (unread-char c ip)]
+                     [write-char (c p)
+                      (with-interrupts-disabled
+                         (unless (null? ports)
+                            (let ([b (port-output-buffer p)]
+                                  [i (port-output-index p)])
+                           ; could check here to be sure that we really need
+                           ; to flush
+                               (string-set! b i c)
+                               (for-each (lambda (p)
+                                            (block-write p b (fx+ i 1)))
+                                         ports)))
+                         (set-port-output-index! p 0))]
+                     [else (errorf 'broadcast-port "operation ~s not handled"
+                                  msg)])))
+            (let ([len 1024])
+               (let ([p (make-output-port handler (make-string len))])
+                  (set-port-output-size! p (fx- len 1))
+                  p))))
+      (let ([p (make-broadcast-port)])
+         (and (port? p)
+              (let ([x (make-string 1000 #\a)])
+                 (let loop ([i 1000])
+                    (if (fx= i 0)
+                        (fx<= (port-output-index p)
+                              (port-output-size p)
+                              (string-length (port-output-buffer p)))
+                        (begin (display x p)
+                               (loop (fx- i 1))))))
+              (begin (close-port p) (port-closed? p))))
+      (let ([sop (open-output-string)])
+         (let ([p (make-broadcast-port sop sop)])
+            (and (port? p)
+                 (let ([x "abcde"])
+                    (display x p)
+                    (and (string=? (get-output-string sop) "")
+                         (begin (flush-output-port p)
+                                (string=? (get-output-string sop)
+                                          (string-append x x)))))
+                 (begin (close-output-port p) (port-closed? p))))))
+
+   (let ()
+      (define make-transcript-port
+         ; local buffering; run into problems with unread-char and
+         ;     clear-output-port otherwise
+         ; close-port passed through to tp only
+         (lambda (ip op tp)
+            (define handler
+               (lambda (msg . args)
+                  (record-case (cons msg args)
+                     [block-read (p str cnt)
+                      (with-interrupts-disabled
+                         (let ([b (port-input-buffer p)]
+                               [i (port-input-index p)]
+                               [s (port-input-size p)])
+                            (if (< i s)
+                                (let ([cnt (fxmin cnt (fx- s i))])
+                                   (do ([i i (fx+ i 1)]
+                                        [j 0 (fx+ j 1)])
+                                       ((fx= j cnt)
+                                        (set-port-input-index! p i)
+                                        cnt)
+                                       (string-set! str j (string-ref b i))))
+                                (let ([cnt (block-read ip str cnt)])
+                                   (unless (eof-object? cnt)
+                                      (block-write tp str cnt))
+                                   cnt))))]
+                     [char-ready? (p)
+                      (or (< (port-input-index p) (port-input-size p))
+                          (char-ready? ip))]
+                     [clear-input-port (p)
+                      ; set size to zero rather than index to size
+                      ; in order to invalidate unread-char
+                      (set-port-input-size! p 0)]
+                     [clear-output-port (p) (set-port-output-index! p 0)]
+                     [close-port (p)
+                      (flush-output-port p)
+                      (close-port tp)
+                      (set-port-output-size! p 0)
+                      (set-port-input-size! p 0)
+                      (mark-port-closed! p)]
+;                     [file-length (p) #f]
+                     [file-position (p . pos)
+                      (if (null? pos)
+                          (most-negative-fixnum)
+                          (errorf 'transcript-port "cannot reposition"))]
+                     [flush-output-port (p)
+                      (with-interrupts-disabled
+                         (let ([b (port-output-buffer p)]
+                               [i (port-output-index p)])
+                            (block-write op b i)
+                            (block-write tp b i)
+                            (set-port-output-index! p 0)
+                            (flush-output-port op)
+                            (flush-output-port tp)))]
+                     [peek-char (p)
+                      (with-interrupts-disabled
+                         (let ([b (port-input-buffer p)]
+                               [i (port-input-index p)]
+                               [s (port-input-size p)])
+                            (if (fx< i s)
+                                (string-ref b i)
+                                (begin (flush-output-port p)
+                                       (let ([s (block-read ip b)])
+                                          (if (eof-object? s)
+                                              s
+                                              (begin (block-write tp b s)
+                                                     (set-port-input-size! p s)
+                                                     (string-ref b 0))))))))]
+                     [port-name (p) "transcript"]
+                     [read-char (p)
+                      (with-interrupts-disabled
+                         (let ([c (peek-char p)])
+                            (unless (eof-object? c)
+                               (set-port-input-index! p
+                                  (fx+ (port-input-index p) 1)))
+                            c))]
+                     [unread-char (c p)
+                      (with-interrupts-disabled
+                         (let ([b (port-input-buffer p)]
+                               [i (port-input-index p)]
+                               [s (port-input-size p)])
+                            (when (fx= i 0)
+                               (errorf 'unread-char
+                                      "tried to unread too far on ~s"
+                                      p))
+                            (set-port-input-index! p (fx- i 1))
+                            ; following could be skipped; supposed to be
+                            ; same character
+                            (string-set! b (fx- i 1) c)))]
+                     [write-char (c p)
+                      (with-interrupts-disabled
+                         (let ([b (port-output-buffer p)]
+                               [i (port-output-index p)]
+                               [s (port-output-size p)])
+                            (string-set! b i c)
+                           ; could check here to be sure that we really need
+                           ; to flush
+                            (block-write op b (fx+ i 1))
+                            (block-write tp b (fx+ i 1))
+                            (set-port-output-index! p 0)))]
+                     [block-write (p str cnt)
+                      (with-interrupts-disabled
+                        (let ([b (port-output-buffer p)]
+                              [i (port-output-index p)])
+                         ; flush buffered data
+                          (when (fx> i 0)
+                            (block-write op b i)
+                            (block-write tp b i))
+                         ; write new data
+                          (block-write op str cnt)
+                          (block-write tp str cnt)
+                          (set-port-output-index! p 0)))]
+                     [else (errorf 'transcript-port "operation ~s not handled"
+                                  msg)])))
+            (let ([ib (make-string 100)] [ob (make-string 100)])
+               (let ([p (make-input/output-port handler ib ob)])
+                 (if (char-ready? ip)
+                    ; kludge so that old input doesn't show up after later
+                    ; output (e.g., input newline after output prompt)
+                     (let ((n (block-read ip ib (string-length ib))))
+                       (if (eof-object? n)
+                           (set-port-input-size! p 0)
+                           (set-port-input-size! p n)))
+                     (set-port-input-size! p 0))
+                  (set-port-output-size! p (fx- (string-length ob) 1))
+                  p))))
+;      (define-record tp-frame (cip cop tp))
+;      (define tp-stack '())
+;      (define transcript-on
+;        (lambda (fn)
+;          (with-interrupts-disabled
+;            (let ((cip (console-input-port))
+;                  (cop (console-output-port)))
+;              (let ((tp (make-transcript-port cip cop
+;                          (open-output-file fn 'replace))))
+;                (set! tp-stack (cons (make-tp-frame cip cop tp) tp-stack))
+;               (console-output-port tp)
+;               (console-input-port tp)
+;               (when (eq? (current-input-port) cip)
+;                  (current-input-port tp))
+;               (when (eq? (current-output-port) cop)
+;                  (current-output-port tp)))))))
+;      (define transcript-off
+;        (lambda ()
+;          (with-interrupts-disabled
+;            (when (null? tp-stack) (errorf 'transcript-off "no transcript running"))
+;            (let ((frame (car tp-stack)))
+;              (let ((cip (tp-frame-cip frame))
+;                    (cop (tp-frame-cop frame))
+;                    (tp (tp-frame-tp frame)))
+;                (console-input-port cip)
+;                (console-output-port cop)
+;                (when (eq? (current-input-port) tp) (current-input-port cip))
+;                (when (eq? (current-output-port) tp) (current-output-port cop))
+;                (set! tp-stack (cdr tp-stack))
+;                (close-port tp))))))
+      (let ([ip (open-input-string (format "2"))]
+            [op (open-output-string)]
+            [tp (open-output-string)])
+         (let ([p (make-transcript-port ip op tp)])
+            (and (begin (display "1" p) (eq? (read p) 2))
+                 (begin (display "3" p)
+                        (flush-output-port p)
+                        (and (string=? (get-output-string op) "13")
+                            ; 2 doesn't show up since we scan past available
+                            ; input (see "kludge" above)
+                             (string=? (get-output-string tp) "13")))
+                 (begin (close-port p)
+                        (and (port-closed? p) (port-closed? tp)))))))
+ )
+
+(mat port-handler
+   (begin (set! ph (port-handler (current-output-port)))
+          (procedure? ph))
+   (string? (ph 'port-name (current-output-port)))
+   (error? (ph))
+   (error? (ph 'foo))
+   (error? (ph 'foo (current-output-port)))
+   (error? (ph 'read-char))
+   (error? (ph 'write-char))
+   (error? (ph 'write-char 3))
+   (error? (ph 'write-char (current-input-port)))
+   (error? (ph 'write-char 'a (current-output-port)))
+   (error? (ph 'write-char #\a 'a))
+   (error? (ph 'write-char #\a (open-input-string "hello")))
+   (error? (ph 'write-char #\a (current-output-port) 'a))
+   (boolean? (ph 'char-ready? (current-input-port)))
+ )
+
+(mat char-name
+  (eqv? (char-name 'space) #\space)
+  (eqv? (char-name #\space) 'space)
+  (eqv? (char-name 'tab) #\tab)
+  (eqv? (char-name #\tab) 'tab)
+  (eqv? (char-name 'return) #\return)
+  (eqv? (char-name #\return) 'return)
+  (eqv? (char-name 'page) #\page)
+  (eqv? (char-name #\page) 'page)
+  (eqv? (char-name 'linefeed) #\linefeed)
+  (eqv? (char-name #\linefeed) 'newline)
+  (eqv? (char-name 'newline) #\newline)
+  (eqv? (char-name #\newline) 'newline)
+  (eqv? (char-name #\backspace) 'backspace)
+  (eqv? (char-name 'backspace) #\backspace)
+  (eqv? (char-name #\rubout) 'delete)
+  (eqv? (char-name 'rubout) #\rubout)
+  (eqv? (char-name #\nul) 'nul)
+  (eqv? (char-name 'nul) #\nul)
+  (eqv? (char-name 'foo) #f)
+  (eqv? (char-name 'delete) #\delete)
+  (eqv? (char-name #\delete) 'delete)
+  (eqv? (char-name 'vtab) #\vtab)
+  (eqv? (char-name #\vtab) 'vtab)
+  (eqv? (char-name 'alarm) #\alarm)
+  (eqv? (char-name #\alarm) 'alarm)
+  (eqv? (char-name 'esc) #\esc)
+  (eqv? (char-name #\esc) 'esc)
+  (error? (read (open-input-string "#\\foo")))
+  (and (eqv? (char-name 'foo #\003) (void))
+       (eqv? (char-name 'foo) #\003)
+       (eqv? (char-name #\003) 'foo)
+       (eqv? (read (open-input-string "#\\foo")) #\003))
+  (equal?
+    (begin
+      (char-name 'foo #f)
+      (list (char-name 'foo) (char-name #\003)))
+    '(#f #f))
+  (error? (read (open-input-string "#\\new\\line")))
+  (error? (read (open-input-string "#\\new\\x6c;ine")))
+ )
+
+(mat string-escapes
+  (eqv? (string-ref "ab\b" 2) #\backspace)
+  (eqv? (string-ref "\n" 0) #\newline)
+  (eqv? (string-ref "a\fb" 1) #\page)
+  (eqv? (string-ref "ab\r" 2) #\return)
+  (eqv? (string-ref "\t" 0) #\tab)
+  (eqv? (string-ref "\a\v" 0) #\bel)
+  (eqv? (string-ref "\a\v" 1) #\vt)
+  (eqv? (string-ref "\000" 0) #\nul)
+  (eqv? (string-ref "\x00;" 0) #\nul)
+  (eqv? (string-ref "a\x20;b" 1) #\space)
+  (eqv? (string-ref "\\\"\'" 0) #\\)
+  (eqv? (string-ref "\\\"\'" 1) #\")
+  (eqv? (string-ref "\\\"\'" 2) #\')
+  (= (char->integer (string-ref "a\012" 1)) #o12 10)
+  (= (char->integer (string-ref "a\015" 1)) #o15 13)
+  (= (char->integer (string-ref "a\177" 1)) #o177 127)
+  (= (char->integer (string-ref "a\377" 1)) #o377 255)
+  (error? (read (open-input-string "\"ab\\\"")))
+  (error? (read (open-input-string "\"ab\\0\"")))
+  (error? (read (open-input-string "\"ab\\01\"")))
+  (error? (read (open-input-string "\"ab\\*\"")))
+  (error? (read (open-input-string "\"ab\\x\"")))
+  (error? (read (open-input-string "\"ab\\x*\"")))
+  (error? (read (open-input-string "\"ab\\xg\"")))
+  (equal? (format "~s" "\bab\nc\f\rd\t\v\a") "\"\\bab\\nc\\f\\rd\\t\\v\\a\"")
+ )
+
+(mat read-token
+  (let ([ip (open-input-string "(cons 33 #;hello \"rot\")")])
+    (and (let-values ([vals (read-token ip)])
+           (equal? vals '(lparen #f 0 1)))
+         (let-values ([vals (read-token ip)])
+           (equal? vals '(atomic cons 1 5)))
+         (let-values ([vals (read-token ip)])
+           (equal? vals '(atomic 33 6 8)))
+         (let-values ([vals (read-token ip)])
+           (equal? vals '(quote datum-comment 9 11)))
+         (let-values ([vals (read-token ip)])
+           (equal? vals '(atomic hello 11 16)))
+         (let-values ([vals (read-token ip)])
+           (equal? vals '(atomic "rot" 17 22)))
+         (let-values ([vals (read-token ip)])
+           (equal? vals '(rparen #f 22 23)))))
+  (let ()
+    (define with-input-from-string
+      (lambda (s p)
+        (parameterize ([current-input-port (open-input-string s)])
+          (p))))
+    (with-input-from-string "\n#17#\n"
+      (lambda ()
+        (let-values ([vals (read-token)])
+          (equal? vals '(insert 17 1 5))))))
+  (let ()
+    (with-output-to-file "testfile.ss"
+      (lambda () (display "\n#eat\n"))
+      'replace)
+    #t)
+  (error?
+    (let* ([ip (open-file-input-port "testfile.ss")]
+           [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
+           [ip (transcoded-port ip (native-transcoder))])
+      (dynamic-wind
+        void
+        (lambda () (read-token ip sfd 0))
+        (lambda () (close-input-port ip)))))
+  (let ()
+    (with-output-to-file "testfile.ss"
+      (lambda () (display "\neat\n"))
+      'replace)
+    #t)
+  (equal?
+    (let-values ([vals (let* ([ip (open-file-input-port "testfile.ss")]
+                              [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
+                              [ip (transcoded-port ip (native-transcoder))])
+                         (dynamic-wind
+                           void
+                           (lambda () (read-token ip sfd 0))
+                           (lambda () (close-input-port ip))))])
+      vals)
+    '(atomic eat 1 4))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#t" read-token)) list)
+    '(atomic #t 0 2))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#true" read-token)) list)
+    '(atomic #t 0 5))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#True" read-token)) list)
+    '(atomic #t 0 5))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#TRUE" read-token)) list)
+    '(atomic #t 0 5))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#f" read-token)) list)
+    '(atomic #f 0 2))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#false" read-token)) list)
+    '(atomic #f 0 6))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#False" read-token)) list)
+    '(atomic #f 0 6))
+  (equal?
+    (call-with-values (lambda () (with-input-from-string "#FALSE" read-token)) list)
+    '(atomic #f 0 6))
+ )
+
+(define read-test
+  (lambda (s)
+    (with-output-to-file "testfile.ss"
+      (lambda () (display s))
+      'replace)
+    (load "testfile.ss" values)
+    #t))
+(define load-test
+  (lambda (s)
+    (with-output-to-file "testfile.ss"
+      (lambda () (display s))
+      'replace)
+    (load "testfile.ss")
+    #t))
+(define compile-test
+  (lambda (s)
+    (with-output-to-file "testfile.ss"
+      (lambda () (display s))
+      'replace)
+    (compile-file "testfile.ss")
+    (load "testfile.so")
+    #t))
+
+(define-syntax xmat
+  (syntax-rules ()
+    [(_ string ...)
+     (begin
+       (mat read-test (error? (read-test string)) ...)
+       (mat load-test (error? (load-test string)) ...)
+       (mat compile-test (error? (compile-test string)) ...))]))
+
+(begin (define-record f800 (a b)) (record-reader "zinjanthropus" (type-descriptor f800)))
+(begin (define-record $acyclic ((immutable notme))) (record-reader '$acyclic (type-descriptor $acyclic)))
+
+(xmat
+  "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@\x2;\x4;\x0;\x0;\x0;5.9b\x0;\x4;\x0;\x0;\x0;\x2;\x1;\x0;\x0;\x0;a\x2;\x1;\x0;\x0;\x0;b\x2;\x1;\x0;\x0;\x0;c\x2;\x1;\x0;\x0;\x0;d\f&\x0;\x0;\x0;\n"
+  )
+
+(xmat
+  "; Test error \"bracketed list terminated by close parenthesis\"\n\n(define nil '[))\n\n"
+  "; Test error \"bracketed list terminated by close parenthesis\"\n\n(cond [(foobar) 'baz) [else 'ok])\n\n"
+  "; Test error \"bracketed list terminated by close parenthesis\"\n\n(define pair '[a . b))\n\n"
+  "; Test error \"duplicate mark #~s= seen\"\n\n(#327=(a b c #327=d) #327#)\n\n"
+  "; Test error \"expected close brace terminating gensym syntax\"\n\n(define #{foo |bar|\n  (lambda (zap doodle)\n    zap))\n\n"
+  "; Test error \"expected close brace terminating gensym syntax\"\n\n(define foo\n  (lambda (#{foo |bar| none)\n    'quack))\n\n"
+  "; Test error \"expected one item after dot (.)\"\n\n(define foo\n  (lambda (a b . )\n    'zapp))\n\n"
+  "; Test error \"expected one item after dot (.)\"\n\n(define foo\n  (lambda [a b . ]\n    'zapp))\n\n"
+  "; Test error \"invalid character #\\\\~a~a~a\"\n\n(memv #\\401 (string->list \"abcd\"))\n\n"
+  "; Test error \"invalid character #\\\\~a~a\"\n\n(make-list 25 (make-string 100 #\\37d))\n"
+  "; Test error \"invalid character name\"\n\n(memv #\\bugsbunny (string->list \"looneytunes\"))\n"
+  "; Test error \"invalid character name\"\n\n(memv #\\new (string->list \"deal\"))\n"
+  "; Test error \"invalid character name\"\n\n(memv #\\Space (string->list \"no deal\"))\n"
+  "; Test error \"invalid character name\"\n\n(memv #\\SPACE (string->list \"no deal\"))\n"
+  "; Test error \"invalid number syntax\"\n\n(list #e23q3 'a 'b 'c)\n\n"
+  "; Test error \"invalid number syntax\"\n\n(list #e3_4i 'a 'b 'c)\n\n"
+  "; Test error \"invalid number syntax\"\n\n(list #e3+)"
+  "; Test error \"invalid number syntax\"\n\n(sqrt #36r1+1i)\n\n"
+  "; Test error \"invalid number syntax\"\n\n(sqrt #36r1+i)\n\n"
+  "; Test error \"invalid number syntax\"\n\n(sqrt #36r1+1i)\n\n"
+  "; Test error \"invalid number syntax\"\n\n(sqrt #36r1+i)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt 1/0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt 1/0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt 1#/0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt 1##/0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e1/0#)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e1/0###)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e1/0###)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e1/0###)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e1/0###)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e+inf.0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e-inf.0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e+nan.0)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e0/0e20)\n\n"
+  "; Test error \"cannot represent\"\n\n(sqrt #e1@1)\n\n"
+  "; Test error \"invalid number syntax\"\n\n(sqrt #e+nan.5)\n\n"
+  "; Test error \"invalid sharp-sign prefix #~c\"\n\n(if #T #N #T)\n"
+  "; Test error \"invalid sharp-sign prefix ~a~a\"\n\n(if (optimize-til-it-hurts?) (#7%super-fast+ 1 2) (+ 1 2))\n"
+  "; Test error \"invalid sharp-sign prefix ~a~a\"\n\n(when #2_3_4 'huh?)\n"
+  "; Test error \"invalid string character \\\\~c~c~c\"\n\n  (define s \"james stock \\707!\")\n"
+  "; Test error \"invalid string character \\\\~c~c\"\n\n\"=tofu\\07gnorefsefawd2slivne\"\n\n"
+  "; Test error \"invalid string character \\\\~c\"\n\n\"I need \\3d glasses\"\n"
+  "; Test error \"invalid string character\"\n\n(pretty-print \"this is \\xa fine mess\")\n"
+  "; Test error \"invalid string character\"\n\n(pretty-print \"this is \\x\")\n"
+  "; Test error \"invalid string character\"\n\n(pretty-print \"this is \\xGreat news!\")\n"
+  "; Test error \"invalid string character \\\\~c\"\n\n\"status \\quo\"\n"
+  "; Test error \"invalid syntax #!~s\"\n\n(when #!whuppo! 1 2 3)\n\n"
+  "; Test error \"invalid syntax #!~s\"\n\n(when #!eo 1 2 3)\n\n"
+  "; Test error \"invalid syntax #v~s\"\n\n(list #vxx())\n"
+  "; Test error \"invalid syntax #~v,'0dv~s\"\n\n(list #073vxx())\n"
+  "; Test error \"invalid syntax #v~s\"\n\n(list #vf())\n"
+  "; Test error \"invalid syntax #~v,'0dv~s\"\n\n(list #073vf())\n"
+  "; Test error \"invalid syntax #v~s\"\n\n(list #vfx[])\n"
+  "; Test error \"invalid syntax #~v,'0dv~s\"\n\n(list #073vfx[])\n"
+  "; Test error \"invalid vector length\"\n\n(vector-length #999999999999999999999999999999(a b c))\n\n"
+  "; Test error \"invalid fxvector length\"\n\n(fxvector-length #999999999999999999999999999999vfx(1 2 3))\n\n"
+  "; Test error \"invalid bytevector length\"\n\n(bytevector-length #999999999999999999999999999999vu8(1 2 3))\n\n"
+  "; Test error \"mark #~s= missing\"\n\n'(what about this?) ; separate top-level S-expression, so ok.\n\n(begin\n  (reverse '(a b . #77#))\n  (cons 1 2))"
+  "; Test error \"more than one item found after dot (.)\"\n\n(define foo\n  (lambda (able baker . charlie delta epsilon)\n    'wow))\n\n"
+  "; Test error \"more than one item found after dot (.)\"\n\n(define foo\n  (lambda [able baker . charlie delta epsilon]\n    'wow))\n\n"
+  "; Test error \"non-symbol found after #[\"\n\n(pretty-print '#[(a \"b c\" #\\d) 1 2 3])\n"
+  "; Test error \"outdated object file format\"\n\n\"What is\"   #3q\n'(1 2 3)\n\n"
+  "; Test error \"parenthesized list terminated by close bracket\"\n\n(define nil '(])\n\n"
+  "; Test error \"parenthesized list terminated by close bracket\"\n\n(cond [(foobar) 'baz] (else 'ok])\n\n"
+  "; Test error \"parenthesized list terminated by close bracket\"\n\n(define pair '(a . b])\n\n"
+  "; Test error \"too many vector elements supplied\"\n\n(pretty-print '#3(one two three four five six seven))\n"
+  "; Test error \"non-fixnum found in fxvector\"\n\n(pretty-print '#vfx(1 2.0 3 4))\n"
+  "; Test error \"non-fixnum found in fxvector\"\n\n(pretty-print '#3vfx(1 2.0 3 4))\n"
+  "; Test error \"too many fxvector elements supplied\"\n\n(pretty-print '#3vfx(1 2 3 4))\n"
+  "; Test error \"invalid value 2.0 found in bytevector\"\n\n(pretty-print '#vu8(1 2.0 3 4))\n"
+  "; Test error \"invalid value -1 found in bytevector\"\n\n(pretty-print '#3vu8(1 -1 3 4))\n"
+  "; Test error \"invalid value #f found in bytevector\"\n\n#vu8(1 2 #f\n"
+  "; Test error \"invalid value #t found in bytevector\"\n\n#vu8(1 2 #t\n"
+  "; Test error \"invalid value \"foo\" found in bytevector\"\n\n#vu8(1 2 \"foo\")\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 (\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #(\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #7(\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #4=\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #5#\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 [\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #[\n"
+  "; Test error \"invalid value { found in bytevector\"\n\n#vu8(1 2 {\n"
+  "; Test error \"invalid value } found in bytevector\"\n\n#vu8(1 2 }\n"
+  "; Test error \"invalid value 3.4 found in bytevector\"\n\n#vu8(1 2 3.4\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 '\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 `\n"
+  "; Test error \"invalid value - found in bytevector\"\n\n#vu8(1 2 -\n"
+  "; Test error \"invalid value + found in bytevector\"\n\n#vu8(1 2 +\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 .\n"
+  "; Test error \"invalid value .. found in bytevector\"\n\n#vu8(1 2 ..)\n"
+  "; Test error \"invalid value ... found in bytevector\"\n\n#vu8(1 2 ...)\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 ,)\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #,@)\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #@)\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #vfx(3\n"
+  "; Test error \"non-octet found in bytevector\"\n\n#vu8(1 2 #vu8(3\n"
+  "; Test error \"too many bytevector elements supplied\"\n\n(pretty-print '#3vu8(1 2 3 4))\n"
+  "; Test error \"too few fields supplied for record ~s\"\n\n(define x '#[zinjanthropus 3])"
+  "; Test error \"too many fields supplied for record ~s\"\n\n(define x '#[zinjanthropus 3 4 5])"
+  "; Test error \"unexpected close bracket\"\n\n1 2 3 ]\n"
+  "; Test error \"unexpected close parenthesis\"\n\n(define x 3))\n"
+  "; Test error \"unexpected dot\"\n\n(lambda (x . . y) x)\n\n"
+  "; Test error \"unexpected dot\"\n\n(lambda ( . y) y)\n\n"
+  "; Test error \"unexpected dot\"\n\n(define x '(a . b . c))\n"
+  "; Test error \"unexpected dot\"\n\n(define x '[a . b . c])\n"
+  "; Test error \"unexpected end-of-file reading block comment\"\n(pretty-print\n #| foo\n   #| bar |#\n    baz \"pickle  ; not eof on string since we're in block comment"
+  "; Test error \"unexpected end-of-file reading block comment\"\n(pretty-print\n #| foo\n   #"
+  "; Test error \"unexpected end-of-file reading block comment\"\n(pretty-print\n #| foo\n   |"
+  "; Test error \"unexpected end-of-file reading box\"\n\n   #& ; box is empty!\n"
+  "; Test error \"unexpected end-of-file reading bracketed list\" (before first element)\n\n(lambda (x y z)\n  (cond\n    [\n\n   "
+  "; Test error \"unexpected end-of-file reading bracketed list\"\n\n(lambda (x y z)\n  (cond\n    [(< x 1) y\n    [else z]\n\n\n"
+  "; Test error \"unexpected end-of-file reading bracketed list\" (after dot)\n\n(car '[a b . c\n\n"
+  "; Test error \"unexpected end-of-file reading bracketed list\" (after element after dot)\n\n(car '[a b . c\n\n"
+  "; Test error \"unexpected end-of-file reading character\"\n#\\"
+  "; Test error \"unexpected end-of-file reading character\"\n#\\new"
+  "; Test error \"unexpected end-of-file reading character\"\n#\\02"
+  "; Test error \"unexpected end-of-file reading boolean\"\n\n#tr"
+  "; Test error \"unexpected end-of-file reading boolean\"\n\n#tru"
+  "; Test error \"unexpected end-of-file reading boolean\"\n\n#fa"
+  "; Test error \"unexpected end-of-file reading boolean\"\n\n#fal"
+  "; Test error \"unexpected end-of-file reading boolean\"\n\n#fals"
+  "; Test error \"unexpected end-of-file reading expression comment\"\n\n(define oops '#; ; that's all I've got!\n"
+  "; Test error \"unexpected end-of-file reading gensym\"\n(pretty-print '#{"
+  "; Test error \"unexpected end-of-file reading gensym\"\n(pretty-print '#{foo"
+  "; Test error \"unexpected end-of-file reading gensym\"\n(pretty-print '#{foo |bar|"
+  "; Test error \"unexpected end-of-file reading graph mark\"\n(define x '#1=\n"
+  "; Test error \"unexpected end-of-file reading hash-bang syntax\"\n\n(list #!eo"
+  "; Test error \"unexpected end-of-file reading #v syntax\"\n\"would this be cool?\" #v"
+  "; Test error \"unexpected end-of-file reading #~v,'0dv syntax\"\n\"would this be cool?\" #01v"
+  "; Test error \"unexpected end-of-file reading #v syntax\"\n\"would this be cool?\" #vf"
+  "; Test error \"unexpected end-of-file reading #~v,'0dv syntax\"\n\"would this be cool?\" #01vf"
+  "; Test error \"unexpected end-of-file reading #v syntax\"\n\"would this be cool?\" #vfx"
+  "; Test error \"unexpected end-of-file reading #~v,'0dv syntax\"\n\"would this be cool?\" #01vfx"
+  "; Test error \"unexpected end-of-file reading list\" (before first element) \n\n  (\n\n   "
+  "; Test error \"unexpected end-of-file reading list\"\n\n(lambda (x y z\n  (cond\n    [(< x 1) y]\n    [else z]))\n\n"
+  "; Test error \"unexpected end-of-file reading list\" (after dot)\n\n(car '(a b . \n\n"
+  "; Test error \"unexpected end-of-file reading list\" (after element after dot)\n\n(car '(a b . c\n\n"
+  "; Test error \"unexpected end-of-file reading # prefix\"\n\"would this be cool?\" #"
+  "; Test error \"unexpected end-of-file reading # prefix\"\n\"would this be cool?\" #35"
+  "; Test error \"unexpected end-of-file reading number\"\n\n(list #e3+"
+  "; Test error \"unexpected end-of-file reading quote\"\n(define fido '   \n\n\n"
+  "; Test error \"unexpected end-of-file reading quasiquote\"\n(define e `   \n"
+  "; Test error \"unexpected end-of-file reading unquote\"\n(define e `(+ ,(* 2 3) ,   \n\n"
+  "; Test error \"unexpected end-of-file reading unquote-splicing\"\n(define r (list 1 2 3))\n(set! r `(0 ,@   \n\n"
+  "; Test error \"unexpected end-of-file reading quasisyntax\"\n(define e #`   \n"
+  "; Test error \"unexpected end-of-file reading unsyntax\"\n(define e #`(+ #,(* 2 3) #,   \n\n"
+  "; Test error \"unexpected end-of-file reading unsyntax-splicing\"\n(define r (list 1 2 3))\n(set! r #`(0 #,@   \n\n"
+  "; Test error \"unexpected end-of-file reading record\"\n\n(define oops '#[   \n\n"
+  "; Test error \"unexpected end-of-file reading record\"\n\n(define oops '#[$acyclic   \n\n"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(printf \"This is \\\"not\\\" what I meant)\n\n"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(define s \"hello \\"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(define s \"hello \\0"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(define s \"hello \\03"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(define s \"hello \\x"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(define s \"hello \\x2"
+  "; Test error \"unexpected end-of-file reading string\"\n\n(list \"abc\\x3c3"
+  "; Test error \"invalid code point value 2097152 in string hex escape\"\n\n(list \"abc\\x200000;\")"
+  "; Test error \"invalid character q in string hex escape\"\n\n(list \"abc\\xq;\")"
+  "; Test error \"invalid character \" in string hex escape\"\n\n(list \"abc\\x\")"
+  "; Test error \"unexpected end-of-file reading symbol\"\n\n(list 'abc\\"
+  "; Test error \"unexpected end-of-file reading symbol\"\n\n(cons '|froma\\|gerie\\ %dq|jl&"
+  "; Test error \"unexpected end-of-file reading symbol\"\n(pretty-print\n #| foo\n   #| bar |#\n |#\n|# #| oops |#"
+  "; Test error \"unexpected end-of-file reading symbol\"\n\n(list 'abc\\x"
+  "; Test error \"unexpected end-of-file reading symbol\"\n\n(list 'abc\\x3c3"
+  "; Test error \"invalid code point value 2097152 in symbol hex escape\"\n\n(list 'abc\\x200000;)"
+  "; Test error \"invalid character q in symbol hex escape\"\n\n(list 'abc\\xq;)"
+  "; Test error \"unexpected end-of-file reading vector\"\n\n  (define v '#(a b \n"
+  "; Test error \"unexpected end-of-file reading vector\"\n\n  (define v '#35(a b \n"
+  "; Test error \"unexpected end-of-file reading fxvector\"\n\n  (define v '#vfx(0 1 \n"
+  "; Test error \"unexpected end-of-file reading fxvector\"\n\n  (define v '#35vfx(0 1 \n"
+  "; Test error \"unexpected end-of-file reading bytevector\"\n\n  (define v '#vu8(0 1 \n"
+  "; Test error \"unexpected end-of-file reading bytevector\"\n\n  (define v '#35vu8(0 1 \n"
+  "; Test error \"unrecognized record name ~s\"\n#[zsunekunvliwndwalv 1 2 3 4]"
+  "; Test error \"unresolvable cycle\"\n\n(define oops '#1=#[$acyclic #1#])\n"
+  "; Test error \"open brace syntax not allowed in #!r6rs mode\"\n\n#!r6rs '{\n"
+  "; Test error \"close brace syntax not allowed in #!r6rs mode\"\n\n#!r6rs '}\n"
+  "; Test error \"#[...] record syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#[abc]\n"
+  "; Test error \"#{...} gensym syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#{abc def}\n"
+  "; Test error \"#& box syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#&box\n"
+  "; Test error \"#% primitive syntax not allowed in #!r6rs mode\"\n\n#!r6rs #%car\n"
+  "; Test error \"#: gensym syntax not allowed in #!r6rs mode\"\n\n#!r6rs #:g0\n"
+  "; Test error \"#(...) vector syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#3(a b c)\n"
+  "; Test error \"#r number syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#3r1201\n"
+  "; Test error \"## insert syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#3#\n"
+  "; Test error \"#= mark syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#3=\n"
+  "; Test error \"#% primitive syntax not allowed in #!r6rs mode\"\n\n#!r6rs #3%car\n"
+  "; Test error \"octal character syntax not allowed in #!r6rs mode\"\n\n#!r6rs #\\010\n"
+  "; Test error \"invalid delimiter 1 for character\"\n\n#\\0001\n"
+  "; Test error \"delimiter { is not allowed in #!r6rs mode\"\n\n#!r6rs #\\0{\n"
+  "; Test error \"invalid delimiter 2 for boolean\"\n\n#t2\n"
+  "; Test error \"invalid delimiter 2 for boolean\"\n\n#true2\n"
+  "; Test error \"invalid delimiter 3 for boolean\"\n\n#f3\n"
+  "; Test error \"invalid delimiter 3 for boolean\"\n\n#false3\n"
+  "; Test error \"invalid boolean\"\n\n#travis"
+  "; Test error \"invalid boolean\"\n\n#FALSIFY"
+  ;; NOTE: there's no "delimiter not allowed in #!r6rs mode" test for r7rs-style booleans because they are not r6rs!
+  "; Test error \"#!eof syntax not allowed in #!r6rs mode\"\n\n#!r6rs #!eof\n"
+  "; Test error \"#!bwp syntax not allowed in #!r6rs mode\"\n\n#!r6rs #!bwp\n"
+  "; Test error \"#vfx(...) fxvector syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#vfx(1 2 3)\n"
+  "; Test error \"#vfx(...) fxvector syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#3vfx(1 2 3)\n"
+  "; Test error \"#vu8(...) fxvector syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#3vu8(1 2 3)\n"
+  "; Test error \"octal string-character syntax not allowed in #!r6rs mode\"\n\n#!r6rs \"a\\010b\"\n"
+  "; Test error \"back-slash symbol escape syntax not allowed in #!r6rs mode\"\n\n#!r6rs ab\\ cd\n"
+  "; Test error \"|...| symbol escape syntax not allowed in #!r6rs mode\"\n\n#!r6rs |ab  cd|\n"
+  "; Test error \"@abc symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs @abc\n"
+  "; Test error \"123a symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs 123a\n"
+  "; Test error \"123# number syntax not allowed in #!r6rs mode\"\n\n#!r6rs 123#\n"
+  "; Test error \"#x1/2e2 number syntax not allowed in #!r6rs mode\"\n\n#!r6rs 1/2e2\n"
+  "; Test error \"#x.3 number syntax not allowed in #!r6rs mode\"\n\n#!r6rs #x.3\n"
+  "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #true\n"
+  "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #True\n"
+  "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #TRUE\n"
+  "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #false\n"
+  "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #False\n"
+  "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #FALSE\n"
+ ; following tests adapted from the read0 benchmark distributed by Will
+ ; Clinger, which as of 08/08/2009 appears to be in the public domain,
+ ; with no license, copyright notice, author name, or date.
+  "; Test error \"\x488; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x488;\n"
+  "; Test error \"@ symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs @\n"
+  "; Test error \"@b symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs @b\n"
+  "; Test error \"@ symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs @\n"
+  "; Test error \"\x488; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x488;\n"
+  "; Test error \"\x489; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x489;\n"
+  "; Test error \"\x660; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x660;\n"
+  "; Test error \"\x661; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x661;\n"
+  "; Test error \"\x662; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x662;\n"
+  "; Test error \"\x663; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x663;\n"
+  "; Test error \"\x664; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x664;\n"
+  "; Test error \"\x665; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x665;\n"
+  "; Test error \"\x666; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x666;\n"
+  "; Test error \"\x667; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x667;\n"
+  "; Test error \"\x668; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x668;\n"
+  "; Test error \"\x669; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x669;\n"
+  "; Test error \"\x6F0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F0;\n"
+  "; Test error \"\x6F1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F1;\n"
+  "; Test error \"\x6F2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F2;\n"
+  "; Test error \"\x6F3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F3;\n"
+  "; Test error \"\x6F4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F4;\n"
+  "; Test error \"\x6F5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F5;\n"
+  "; Test error \"\x6F6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F6;\n"
+  "; Test error \"\x6F7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F7;\n"
+  "; Test error \"\x6F8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F8;\n"
+  "; Test error \"\x6F9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x6F9;\n"
+  "; Test error \"\x7C0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C0;\n"
+  "; Test error \"\x7C1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C1;\n"
+  "; Test error \"\x7C2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C2;\n"
+  "; Test error \"\x7C3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C3;\n"
+  "; Test error \"\x7C4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C4;\n"
+  "; Test error \"\x7C5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C5;\n"
+  "; Test error \"\x7C6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C6;\n"
+  "; Test error \"\x7C7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C7;\n"
+  "; Test error \"\x7C8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C8;\n"
+  "; Test error \"\x7C9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x7C9;\n"
+  "; Test error \"\x903; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x903;\n"
+  "; Test error \"\x93E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x93E;\n"
+  "; Test error \"\x93F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x93F;\n"
+  "; Test error \"\x940; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x940;\n"
+  "; Test error \"\x949; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x949;\n"
+  "; Test error \"\x94A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x94A;\n"
+  "; Test error \"\x94B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x94B;\n"
+  "; Test error \"\x94C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x94C;\n"
+  "; Test error \"\x966; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x966;\n"
+  "; Test error \"\x967; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x967;\n"
+  "; Test error \"\x968; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x968;\n"
+  "; Test error \"\x969; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x969;\n"
+  "; Test error \"\x96A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x96A;\n"
+  "; Test error \"\x96B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x96B;\n"
+  "; Test error \"\x96C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x96C;\n"
+  "; Test error \"\x96D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x96D;\n"
+  "; Test error \"\x96E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x96E;\n"
+  "; Test error \"\x96F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x96F;\n"
+  "; Test error \"\x982; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x982;\n"
+  "; Test error \"\x983; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x983;\n"
+  "; Test error \"\x9BE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9BE;\n"
+  "; Test error \"\x9BF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9BF;\n"
+  "; Test error \"\x9C0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9C0;\n"
+  "; Test error \"\x9C7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9C7;\n"
+  "; Test error \"\x9C8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9C8;\n"
+  "; Test error \"\x9CB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9CB;\n"
+  "; Test error \"\x9CC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9CC;\n"
+  "; Test error \"\x9D7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9D7;\n"
+  "; Test error \"\x9E6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9E6;\n"
+  "; Test error \"\x9E7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9E7;\n"
+  "; Test error \"\x9E8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9E8;\n"
+  "; Test error \"\x9E9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9E9;\n"
+  "; Test error \"\x9EA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9EA;\n"
+  "; Test error \"\x9EB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9EB;\n"
+  "; Test error \"\x9EC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9EC;\n"
+  "; Test error \"\x9ED; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9ED;\n"
+  "; Test error \"\x9EE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9EE;\n"
+  "; Test error \"\x9EF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x9EF;\n"
+  "; Test error \"\xA03; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA03;\n"
+  "; Test error \"\xA3E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA3E;\n"
+  "; Test error \"\xA3F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA3F;\n"
+  "; Test error \"\xA40; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA40;\n"
+  "; Test error \"\xA66; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA66;\n"
+  "; Test error \"\xA67; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA67;\n"
+  "; Test error \"\xA68; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA68;\n"
+  "; Test error \"\xA69; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA69;\n"
+  "; Test error \"\xA6A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA6A;\n"
+  "; Test error \"\xA6B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA6B;\n"
+  "; Test error \"\xA6C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA6C;\n"
+  "; Test error \"\xA6D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA6D;\n"
+  "; Test error \"\xA6E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA6E;\n"
+  "; Test error \"\xA6F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA6F;\n"
+  "; Test error \"\xA83; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA83;\n"
+  "; Test error \"\xABE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xABE;\n"
+  "; Test error \"\xABF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xABF;\n"
+  "; Test error \"\xAC0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAC0;\n"
+  "; Test error \"\xAC9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAC9;\n"
+  "; Test error \"\xACB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xACB;\n"
+  "; Test error \"\xACC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xACC;\n"
+  "; Test error \"\xAE6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAE6;\n"
+  "; Test error \"\xAE7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAE7;\n"
+  "; Test error \"\xAE8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAE8;\n"
+  "; Test error \"\xAE9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAE9;\n"
+  "; Test error \"\xAEA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAEA;\n"
+  "; Test error \"\xAEB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAEB;\n"
+  "; Test error \"\xAEC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAEC;\n"
+  "; Test error \"\xAED; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAED;\n"
+  "; Test error \"\xAEE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAEE;\n"
+  "; Test error \"\xAEF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAEF;\n"
+  "; Test error \"\xB02; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB02;\n"
+  "; Test error \"\xB03; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB03;\n"
+  "; Test error \"\xB3E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB3E;\n"
+  "; Test error \"\xB40; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB40;\n"
+  "; Test error \"\xB47; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB47;\n"
+  "; Test error \"\xB48; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB48;\n"
+  "; Test error \"\xB4B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB4B;\n"
+  "; Test error \"\xB4C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB4C;\n"
+  "; Test error \"\xB57; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB57;\n"
+  "; Test error \"\xB66; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB66;\n"
+  "; Test error \"\xB67; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB67;\n"
+  "; Test error \"\xB68; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB68;\n"
+  "; Test error \"\xB69; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB69;\n"
+  "; Test error \"\xB6A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB6A;\n"
+  "; Test error \"\xB6B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB6B;\n"
+  "; Test error \"\xB6C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB6C;\n"
+  "; Test error \"\xB6D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB6D;\n"
+  "; Test error \"\xB6E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB6E;\n"
+  "; Test error \"\xB6F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xB6F;\n"
+  "; Test error \"\xBBE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBBE;\n"
+  "; Test error \"\xBBF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBBF;\n"
+  "; Test error \"\xBC1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBC1;\n"
+  "; Test error \"\xBC2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBC2;\n"
+  "; Test error \"\xBC6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBC6;\n"
+  "; Test error \"\xBC7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBC7;\n"
+  "; Test error \"\xBC8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBC8;\n"
+  "; Test error \"\xBCA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBCA;\n"
+  "; Test error \"\xBCB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBCB;\n"
+  "; Test error \"\xBCC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBCC;\n"
+  "; Test error \"\xBD7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBD7;\n"
+  "; Test error \"\xBE6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBE6;\n"
+  "; Test error \"\xBE7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBE7;\n"
+  "; Test error \"\xBE8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBE8;\n"
+  "; Test error \"\xBE9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBE9;\n"
+  "; Test error \"\xBEA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBEA;\n"
+  "; Test error \"\xBEB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBEB;\n"
+  "; Test error \"\xBEC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBEC;\n"
+  "; Test error \"\xBED; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBED;\n"
+  "; Test error \"\xBEE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBEE;\n"
+  "; Test error \"\xBEF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xBEF;\n"
+  "; Test error \"\xC01; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC01;\n"
+  "; Test error \"\xC02; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC02;\n"
+  "; Test error \"\xC03; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC03;\n"
+  "; Test error \"\xC41; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC41;\n"
+  "; Test error \"\xC42; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC42;\n"
+  "; Test error \"\xC43; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC43;\n"
+  "; Test error \"\xC44; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC44;\n"
+  "; Test error \"\xC66; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC66;\n"
+  "; Test error \"\xC67; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC67;\n"
+  "; Test error \"\xC68; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC68;\n"
+  "; Test error \"\xC69; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC69;\n"
+  "; Test error \"\xC6A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC6A;\n"
+  "; Test error \"\xC6B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC6B;\n"
+  "; Test error \"\xC6C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC6C;\n"
+  "; Test error \"\xC6D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC6D;\n"
+  "; Test error \"\xC6E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC6E;\n"
+  "; Test error \"\xC6F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC6F;\n"
+  "; Test error \"\xC82; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC82;\n"
+  "; Test error \"\xC83; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xC83;\n"
+  "; Test error \"\xCBE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCBE;\n"
+  "; Test error \"\xCC0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC0;\n"
+  "; Test error \"\xCC1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC1;\n"
+  "; Test error \"\xCC2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC2;\n"
+  "; Test error \"\xCC3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC3;\n"
+  "; Test error \"\xCC4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC4;\n"
+  "; Test error \"\xCC7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC7;\n"
+  "; Test error \"\xCC8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCC8;\n"
+  "; Test error \"\xCCA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCCA;\n"
+  "; Test error \"\xCCB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCCB;\n"
+  "; Test error \"\xCD5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCD5;\n"
+  "; Test error \"\xCD6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCD6;\n"
+  "; Test error \"\xCE6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCE6;\n"
+  "; Test error \"\xCE7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCE7;\n"
+  "; Test error \"\xCE8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCE8;\n"
+  "; Test error \"\xCE9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCE9;\n"
+  "; Test error \"\xCEA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCEA;\n"
+  "; Test error \"\xCEB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCEB;\n"
+  "; Test error \"\xCEC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCEC;\n"
+  "; Test error \"\xCED; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCED;\n"
+  "; Test error \"\xCEE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCEE;\n"
+  "; Test error \"\xCEF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xCEF;\n"
+  "; Test error \"\xD02; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD02;\n"
+  "; Test error \"\xD03; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD03;\n"
+  "; Test error \"\xD3E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD3E;\n"
+  "; Test error \"\xD3F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD3F;\n"
+  "; Test error \"\xD40; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD40;\n"
+  "; Test error \"\xD46; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD46;\n"
+  "; Test error \"\xD47; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD47;\n"
+  "; Test error \"\xD48; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD48;\n"
+  "; Test error \"\xD4A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD4A;\n"
+  "; Test error \"\xD4B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD4B;\n"
+  "; Test error \"\xD4C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD4C;\n"
+  "; Test error \"\xD57; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD57;\n"
+  "; Test error \"\xD66; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD66;\n"
+  "; Test error \"\xD67; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD67;\n"
+  "; Test error \"\xD68; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD68;\n"
+  "; Test error \"\xD69; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD69;\n"
+  "; Test error \"\xD6A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD6A;\n"
+  "; Test error \"\xD6B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD6B;\n"
+  "; Test error \"\xD6C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD6C;\n"
+  "; Test error \"\xD6D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD6D;\n"
+  "; Test error \"\xD6E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD6E;\n"
+  "; Test error \"\xD6F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD6F;\n"
+  "; Test error \"\xD82; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD82;\n"
+  "; Test error \"\xD83; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xD83;\n"
+  "; Test error \"\xDCF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDCF;\n"
+  "; Test error \"\xDD0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDD0;\n"
+  "; Test error \"\xDD1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDD1;\n"
+  "; Test error \"\xDD8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDD8;\n"
+  "; Test error \"\xDD9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDD9;\n"
+  "; Test error \"\xDDA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDDA;\n"
+  "; Test error \"\xDDB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDDB;\n"
+  "; Test error \"\xDDC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDDC;\n"
+  "; Test error \"\xDDD; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDDD;\n"
+  "; Test error \"\xDDE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDDE;\n"
+  "; Test error \"\xDDF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDDF;\n"
+  "; Test error \"\xDF2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDF2;\n"
+  "; Test error \"\xDF3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xDF3;\n"
+  "; Test error \"\xE50; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE50;\n"
+  "; Test error \"\xE51; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE51;\n"
+  "; Test error \"\xE52; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE52;\n"
+  "; Test error \"\xE53; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE53;\n"
+  "; Test error \"\xE54; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE54;\n"
+  "; Test error \"\xE55; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE55;\n"
+  "; Test error \"\xE56; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE56;\n"
+  "; Test error \"\xE57; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE57;\n"
+  "; Test error \"\xE58; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE58;\n"
+  "; Test error \"\xE59; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xE59;\n"
+  "; Test error \"\xED0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED0;\n"
+  "; Test error \"\xED1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED1;\n"
+  "; Test error \"\xED2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED2;\n"
+  "; Test error \"\xED3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED3;\n"
+  "; Test error \"\xED4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED4;\n"
+  "; Test error \"\xED5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED5;\n"
+  "; Test error \"\xED6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED6;\n"
+  "; Test error \"\xED7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED7;\n"
+  "; Test error \"\xED8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED8;\n"
+  "; Test error \"\xED9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xED9;\n"
+  "; Test error \"\xF20; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF20;\n"
+  "; Test error \"\xF21; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF21;\n"
+  "; Test error \"\xF22; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF22;\n"
+  "; Test error \"\xF23; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF23;\n"
+  "; Test error \"\xF24; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF24;\n"
+  "; Test error \"\xF25; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF25;\n"
+  "; Test error \"\xF26; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF26;\n"
+  "; Test error \"\xF27; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF27;\n"
+  "; Test error \"\xF28; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF28;\n"
+  "; Test error \"\xF29; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF29;\n"
+  "; Test error \"\xF3E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF3E;\n"
+  "; Test error \"\xF3F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF3F;\n"
+  "; Test error \"\xF7F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xF7F;\n"
+  "; Test error \"\x102B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x102B;\n"
+  "; Test error \"\x102C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x102C;\n"
+  "; Test error \"\x1031; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1031;\n"
+  "; Test error \"\x1038; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1038;\n"
+  "; Test error \"\x103B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x103B;\n"
+  "; Test error \"\x103C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x103C;\n"
+  "; Test error \"\x1040; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1040;\n"
+  "; Test error \"\x1041; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1041;\n"
+  "; Test error \"\x1042; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1042;\n"
+  "; Test error \"\x1043; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1043;\n"
+  "; Test error \"\x1044; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1044;\n"
+  "; Test error \"\x1045; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1045;\n"
+  "; Test error \"\x1046; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1046;\n"
+  "; Test error \"\x1047; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1047;\n"
+  "; Test error \"\x1048; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1048;\n"
+  "; Test error \"\x1049; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1049;\n"
+  "; Test error \"\x1056; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1056;\n"
+  "; Test error \"\x1057; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1057;\n"
+  "; Test error \"\x1062; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1062;\n"
+  "; Test error \"\x1063; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1063;\n"
+  "; Test error \"\x1064; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1064;\n"
+  "; Test error \"\x1067; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1067;\n"
+  "; Test error \"\x1068; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1068;\n"
+  "; Test error \"\x1069; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1069;\n"
+  "; Test error \"\x106A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x106A;\n"
+  "; Test error \"\x106B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x106B;\n"
+  "; Test error \"\x106C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x106C;\n"
+  "; Test error \"\x106D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x106D;\n"
+  "; Test error \"\x1083; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1083;\n"
+  "; Test error \"\x1084; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1084;\n"
+  "; Test error \"\x1087; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1087;\n"
+  "; Test error \"\x1088; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1088;\n"
+  "; Test error \"\x1089; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1089;\n"
+  "; Test error \"\x108A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x108A;\n"
+  "; Test error \"\x108B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x108B;\n"
+  "; Test error \"\x108C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x108C;\n"
+  "; Test error \"\x108F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x108F;\n"
+  "; Test error \"\x1090; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1090;\n"
+  "; Test error \"\x1091; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1091;\n"
+  "; Test error \"\x1092; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1092;\n"
+  "; Test error \"\x1093; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1093;\n"
+  "; Test error \"\x1094; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1094;\n"
+  "; Test error \"\x1095; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1095;\n"
+  "; Test error \"\x1096; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1096;\n"
+  "; Test error \"\x1097; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1097;\n"
+  "; Test error \"\x1098; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1098;\n"
+  "; Test error \"\x1099; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1099;\n"
+  "; Test error \"\x17B6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17B6;\n"
+  "; Test error \"\x17BE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17BE;\n"
+  "; Test error \"\x17BF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17BF;\n"
+  "; Test error \"\x17C0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C0;\n"
+  "; Test error \"\x17C1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C1;\n"
+  "; Test error \"\x17C2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C2;\n"
+  "; Test error \"\x17C3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C3;\n"
+  "; Test error \"\x17C4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C4;\n"
+  "; Test error \"\x17C5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C5;\n"
+  "; Test error \"\x17C7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C7;\n"
+  "; Test error \"\x17C8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17C8;\n"
+  "; Test error \"\x17E0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E0;\n"
+  "; Test error \"\x17E1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E1;\n"
+  "; Test error \"\x17E2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E2;\n"
+  "; Test error \"\x17E3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E3;\n"
+  "; Test error \"\x17E4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E4;\n"
+  "; Test error \"\x17E5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E5;\n"
+  "; Test error \"\x17E6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E6;\n"
+  "; Test error \"\x17E7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E7;\n"
+  "; Test error \"\x17E8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E8;\n"
+  "; Test error \"\x17E9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x17E9;\n"
+  "; Test error \"\x1810; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1810;\n"
+  "; Test error \"\x1811; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1811;\n"
+  "; Test error \"\x1812; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1812;\n"
+  "; Test error \"\x1813; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1813;\n"
+  "; Test error \"\x1814; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1814;\n"
+  "; Test error \"\x1815; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1815;\n"
+  "; Test error \"\x1816; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1816;\n"
+  "; Test error \"\x1817; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1817;\n"
+  "; Test error \"\x1818; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1818;\n"
+  "; Test error \"\x1819; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1819;\n"
+  "; Test error \"\x1923; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1923;\n"
+  "; Test error \"\x1924; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1924;\n"
+  "; Test error \"\x1925; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1925;\n"
+  "; Test error \"\x1926; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1926;\n"
+  "; Test error \"\x1929; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1929;\n"
+  "; Test error \"\x192A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x192A;\n"
+  "; Test error \"\x192B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x192B;\n"
+  "; Test error \"\x1930; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1930;\n"
+  "; Test error \"\x1931; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1931;\n"
+  "; Test error \"\x1933; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1933;\n"
+  "; Test error \"\x1934; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1934;\n"
+  "; Test error \"\x1935; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1935;\n"
+  "; Test error \"\x1936; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1936;\n"
+  "; Test error \"\x1937; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1937;\n"
+  "; Test error \"\x1938; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1938;\n"
+  "; Test error \"\x1946; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1946;\n"
+  "; Test error \"\x1947; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1947;\n"
+  "; Test error \"\x1948; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1948;\n"
+  "; Test error \"\x1949; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1949;\n"
+  "; Test error \"\x194A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x194A;\n"
+  "; Test error \"\x194B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x194B;\n"
+  "; Test error \"\x194C; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x194C;\n"
+  "; Test error \"\x194D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x194D;\n"
+  "; Test error \"\x194E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x194E;\n"
+  "; Test error \"\x194F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x194F;\n"
+  "; Test error \"\x19D0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D0;\n"
+  "; Test error \"\x19D1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D1;\n"
+  "; Test error \"\x19D2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D2;\n"
+  "; Test error \"\x19D3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D3;\n"
+  "; Test error \"\x19D4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D4;\n"
+  "; Test error \"\x19D5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D5;\n"
+  "; Test error \"\x19D6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D6;\n"
+  "; Test error \"\x19D7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D7;\n"
+  "; Test error \"\x19D8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D8;\n"
+  "; Test error \"\x19D9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x19D9;\n"
+  "; Test error \"\x1A19; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1A19;\n"
+  "; Test error \"\x1A1A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1A1A;\n"
+  "; Test error \"\x1B04; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B04;\n"
+  "; Test error \"\x1B35; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B35;\n"
+  "; Test error \"\x1B3B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B3B;\n"
+  "; Test error \"\x1B3D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B3D;\n"
+  "; Test error \"\x1B3E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B3E;\n"
+  "; Test error \"\x1B3F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B3F;\n"
+  "; Test error \"\x1B40; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B40;\n"
+  "; Test error \"\x1B41; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B41;\n"
+  "; Test error \"\x1B43; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B43;\n"
+  "; Test error \"\x1B44; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B44;\n"
+  "; Test error \"\x1B50; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B50;\n"
+  "; Test error \"\x1B51; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B51;\n"
+  "; Test error \"\x1B52; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B52;\n"
+  "; Test error \"\x1B53; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B53;\n"
+  "; Test error \"\x1B54; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B54;\n"
+  "; Test error \"\x1B55; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B55;\n"
+  "; Test error \"\x1B56; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B56;\n"
+  "; Test error \"\x1B57; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B57;\n"
+  "; Test error \"\x1B58; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B58;\n"
+  "; Test error \"\x1B59; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B59;\n"
+  "; Test error \"\x1B82; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1B82;\n"
+  "; Test error \"\x1BA1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BA1;\n"
+  "; Test error \"\x1BA6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BA6;\n"
+  "; Test error \"\x1BA7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BA7;\n"
+  "; Test error \"\x1BAA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BAA;\n"
+  "; Test error \"\x1BB0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB0;\n"
+  "; Test error \"\x1BB1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB1;\n"
+  "; Test error \"\x1BB2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB2;\n"
+  "; Test error \"\x1BB3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB3;\n"
+  "; Test error \"\x1BB4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB4;\n"
+  "; Test error \"\x1BB5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB5;\n"
+  "; Test error \"\x1BB6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB6;\n"
+  "; Test error \"\x1BB7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB7;\n"
+  "; Test error \"\x1BB8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB8;\n"
+  "; Test error \"\x1BB9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1BB9;\n"
+  "; Test error \"\x1C24; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C24;\n"
+  "; Test error \"\x1C25; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C25;\n"
+  "; Test error \"\x1C26; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C26;\n"
+  "; Test error \"\x1C27; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C27;\n"
+  "; Test error \"\x1C28; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C28;\n"
+  "; Test error \"\x1C29; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C29;\n"
+  "; Test error \"\x1C2A; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C2A;\n"
+  "; Test error \"\x1C2B; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C2B;\n"
+  "; Test error \"\x1C34; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C34;\n"
+  "; Test error \"\x1C35; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C35;\n"
+  "; Test error \"\x1C40; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C40;\n"
+  "; Test error \"\x1C41; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C41;\n"
+  "; Test error \"\x1C42; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C42;\n"
+  "; Test error \"\x1C43; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C43;\n"
+  "; Test error \"\x1C44; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C44;\n"
+  "; Test error \"\x1C45; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C45;\n"
+  "; Test error \"\x1C46; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C46;\n"
+  "; Test error \"\x1C47; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C47;\n"
+  "; Test error \"\x1C48; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C48;\n"
+  "; Test error \"\x1C49; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C49;\n"
+  "; Test error \"\x1C50; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C50;\n"
+  "; Test error \"\x1C51; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C51;\n"
+  "; Test error \"\x1C52; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C52;\n"
+  "; Test error \"\x1C53; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C53;\n"
+  "; Test error \"\x1C54; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C54;\n"
+  "; Test error \"\x1C55; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C55;\n"
+  "; Test error \"\x1C56; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C56;\n"
+  "; Test error \"\x1C57; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C57;\n"
+  "; Test error \"\x1C58; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C58;\n"
+  "; Test error \"\x1C59; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1C59;\n"
+  "; Test error \"\x20DD; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20DD;\n"
+  "; Test error \"\x20DE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20DE;\n"
+  "; Test error \"\x20DF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20DF;\n"
+  "; Test error \"\x20E0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20E0;\n"
+  "; Test error \"\x20E2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20E2;\n"
+  "; Test error \"\x20E3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20E3;\n"
+  "; Test error \"\x20E4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x20E4;\n"
+  "; Test error \"\xA620; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA620;\n"
+  "; Test error \"\xA621; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA621;\n"
+  "; Test error \"\xA622; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA622;\n"
+  "; Test error \"\xA623; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA623;\n"
+  "; Test error \"\xA624; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA624;\n"
+  "; Test error \"\xA625; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA625;\n"
+  "; Test error \"\xA626; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA626;\n"
+  "; Test error \"\xA627; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA627;\n"
+  "; Test error \"\xA628; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA628;\n"
+  "; Test error \"\xA629; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA629;\n"
+  "; Test error \"\xA670; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA670;\n"
+  "; Test error \"\xA671; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA671;\n"
+  "; Test error \"\xA672; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA672;\n"
+  "; Test error \"\xA823; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA823;\n"
+  "; Test error \"\xA824; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA824;\n"
+  "; Test error \"\xA827; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA827;\n"
+  "; Test error \"\xA880; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA880;\n"
+  "; Test error \"\xA881; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA881;\n"
+  "; Test error \"\xA8B4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8B4;\n"
+  "; Test error \"\xA8B5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8B5;\n"
+  "; Test error \"\xA8B6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8B6;\n"
+  "; Test error \"\xA8B7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8B7;\n"
+  "; Test error \"\xA8B8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8B8;\n"
+  "; Test error \"\xA8B9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8B9;\n"
+  "; Test error \"\xA8BA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8BA;\n"
+  "; Test error \"\xA8BB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8BB;\n"
+  "; Test error \"\xA8BC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8BC;\n"
+  "; Test error \"\xA8BD; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8BD;\n"
+  "; Test error \"\xA8BE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8BE;\n"
+  "; Test error \"\xA8BF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8BF;\n"
+  "; Test error \"\xA8C0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8C0;\n"
+  "; Test error \"\xA8C1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8C1;\n"
+  "; Test error \"\xA8C2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8C2;\n"
+  "; Test error \"\xA8C3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8C3;\n"
+  "; Test error \"\xA8D0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D0;\n"
+  "; Test error \"\xA8D1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D1;\n"
+  "; Test error \"\xA8D2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D2;\n"
+  "; Test error \"\xA8D3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D3;\n"
+  "; Test error \"\xA8D4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D4;\n"
+  "; Test error \"\xA8D5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D5;\n"
+  "; Test error \"\xA8D6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D6;\n"
+  "; Test error \"\xA8D7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D7;\n"
+  "; Test error \"\xA8D8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D8;\n"
+  "; Test error \"\xA8D9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA8D9;\n"
+  "; Test error \"\xA900; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA900;\n"
+  "; Test error \"\xA901; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA901;\n"
+  "; Test error \"\xA902; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA902;\n"
+  "; Test error \"\xA903; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA903;\n"
+  "; Test error \"\xA904; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA904;\n"
+  "; Test error \"\xA905; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA905;\n"
+  "; Test error \"\xA906; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA906;\n"
+  "; Test error \"\xA907; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA907;\n"
+  "; Test error \"\xA908; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA908;\n"
+  "; Test error \"\xA909; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA909;\n"
+  "; Test error \"\xA952; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA952;\n"
+  "; Test error \"\xA953; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xA953;\n"
+  "; Test error \"\xAA2F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA2F;\n"
+  "; Test error \"\xAA30; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA30;\n"
+  "; Test error \"\xAA33; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA33;\n"
+  "; Test error \"\xAA34; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA34;\n"
+  "; Test error \"\xAA4D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA4D;\n"
+  "; Test error \"\xAA50; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA50;\n"
+  "; Test error \"\xAA51; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA51;\n"
+  "; Test error \"\xAA52; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA52;\n"
+  "; Test error \"\xAA53; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA53;\n"
+  "; Test error \"\xAA54; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA54;\n"
+  "; Test error \"\xAA55; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA55;\n"
+  "; Test error \"\xAA56; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA56;\n"
+  "; Test error \"\xAA57; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA57;\n"
+  "; Test error \"\xAA58; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA58;\n"
+  "; Test error \"\xAA59; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xAA59;\n"
+  "; Test error \"\xFF10; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF10;\n"
+  "; Test error \"\xFF11; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF11;\n"
+  "; Test error \"\xFF12; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF12;\n"
+  "; Test error \"\xFF13; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF13;\n"
+  "; Test error \"\xFF14; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF14;\n"
+  "; Test error \"\xFF15; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF15;\n"
+  "; Test error \"\xFF16; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF16;\n"
+  "; Test error \"\xFF17; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF17;\n"
+  "; Test error \"\xFF18; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF18;\n"
+  "; Test error \"\xFF19; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \xFF19;\n"
+  "; Test error \"\x104A0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A0;\n"
+  "; Test error \"\x104A1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A1;\n"
+  "; Test error \"\x104A2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A2;\n"
+  "; Test error \"\x104A3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A3;\n"
+  "; Test error \"\x104A4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A4;\n"
+  "; Test error \"\x104A5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A5;\n"
+  "; Test error \"\x104A6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A6;\n"
+  "; Test error \"\x104A7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A7;\n"
+  "; Test error \"\x104A8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A8;\n"
+  "; Test error \"\x104A9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x104A9;\n"
+  "; Test error \"\x1D165; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D165;\n"
+  "; Test error \"\x1D166; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D166;\n"
+  "; Test error \"\x1D16D; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D16D;\n"
+  "; Test error \"\x1D16E; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D16E;\n"
+  "; Test error \"\x1D16F; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D16F;\n"
+  "; Test error \"\x1D170; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D170;\n"
+  "; Test error \"\x1D171; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D171;\n"
+  "; Test error \"\x1D172; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D172;\n"
+  "; Test error \"\x1D7CE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7CE;\n"
+  "; Test error \"\x1D7CF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7CF;\n"
+  "; Test error \"\x1D7D0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D0;\n"
+  "; Test error \"\x1D7D1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D1;\n"
+  "; Test error \"\x1D7D2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D2;\n"
+  "; Test error \"\x1D7D3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D3;\n"
+  "; Test error \"\x1D7D4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D4;\n"
+  "; Test error \"\x1D7D5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D5;\n"
+  "; Test error \"\x1D7D6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D6;\n"
+  "; Test error \"\x1D7D7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D7;\n"
+  "; Test error \"\x1D7D8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D8;\n"
+  "; Test error \"\x1D7D9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7D9;\n"
+  "; Test error \"\x1D7DA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7DA;\n"
+  "; Test error \"\x1D7DB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7DB;\n"
+  "; Test error \"\x1D7DC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7DC;\n"
+  "; Test error \"\x1D7DD; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7DD;\n"
+  "; Test error \"\x1D7DE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7DE;\n"
+  "; Test error \"\x1D7DF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7DF;\n"
+  "; Test error \"\x1D7E0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E0;\n"
+  "; Test error \"\x1D7E1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E1;\n"
+  "; Test error \"\x1D7E2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E2;\n"
+  "; Test error \"\x1D7E3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E3;\n"
+  "; Test error \"\x1D7E4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E4;\n"
+  "; Test error \"\x1D7E5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E5;\n"
+  "; Test error \"\x1D7E6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E6;\n"
+  "; Test error \"\x1D7E7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E7;\n"
+  "; Test error \"\x1D7E8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E8;\n"
+  "; Test error \"\x1D7E9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7E9;\n"
+  "; Test error \"\x1D7EA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7EA;\n"
+  "; Test error \"\x1D7EB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7EB;\n"
+  "; Test error \"\x1D7EC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7EC;\n"
+  "; Test error \"\x1D7ED; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7ED;\n"
+  "; Test error \"\x1D7EE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7EE;\n"
+  "; Test error \"\x1D7EF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7EF;\n"
+  "; Test error \"\x1D7F0; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F0;\n"
+  "; Test error \"\x1D7F1; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F1;\n"
+  "; Test error \"\x1D7F2; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F2;\n"
+  "; Test error \"\x1D7F3; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F3;\n"
+  "; Test error \"\x1D7F4; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F4;\n"
+  "; Test error \"\x1D7F5; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F5;\n"
+  "; Test error \"\x1D7F6; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F6;\n"
+  "; Test error \"\x1D7F7; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F7;\n"
+  "; Test error \"\x1D7F8; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F8;\n"
+  "; Test error \"\x1D7F9; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7F9;\n"
+  "; Test error \"\x1D7FA; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7FA;\n"
+  "; Test error \"\x1D7FB; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7FB;\n"
+  "; Test error \"\x1D7FC; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7FC;\n"
+  "; Test error \"\x1D7FD; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7FD;\n"
+  "; Test error \"\x1D7FE; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7FE;\n"
+  "; Test error \"\x1D7FF; symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs \x1D7FF;\n"
+ )
+
+(mat record-annotation
+ ; regression check: make sure annotations do not slip into records
+ ; by way of graph references
+  (let ([p (open-output-file "testfile.ss" 'truncate)])
+    (display "(define-record #{%foo %bar} (x y))
+(define $$rats (list '#0=(a b) #;'#1=(d e) '#[#{%foo %bar} #0# #1#]))
+" p)
+    (close-output-port p)
+    #t)
+  (begin
+    (load "testfile.ss")
+    #t)
+  (record? (cadr $$rats) (type-descriptor #{%foo %bar}))
+  (let ([r (cadr $$rats)])
+    (eq? (%foo-x r) (car $$rats))
+    (equal? (%foo-y r) '(d e)))
+ )
+
+(mat annotation-tests
+  (let ([x (read (open-input-string "#1=#2=(#1# . #2#)"))])
+    (and (eq? (car x) x) (eq? (cdr x) x)))
+  (let ([x (read (open-input-string "(#1=#1# . #1#)"))]
+        [y (read (open-input-string "#2=#2#"))])
+    (and (eq? (car x) (cdr x)) (eq? (car x) y)))
+  (vector? '#(annotation 3 #f 3))
+  (vector? (eval (read (open-input-string "'#(annotation #1=(a . #1#) #f #f)"))))
+  (load-test "(define-record #{$elmer fudd} (c))\n(define x '#[#{$elmer fudd} 3])\n")
+  (and ($elmer? x) (eq? ($elmer-c x) 3))
+  (compile-test "(define-record #{$bugs bunny} (c))\n(define x '#[#{$bugs bunny} 3])\n")
+  (and ($bugs? x) (eq? ($bugs-c x) 3))
+  (load-test "(define-syntax $kwote (lambda (x) `(,#'quote ,x)))\n(define $argh #1=($kwote . #1#))\n")
+  (eq? $argh (cdr $argh))
+  (compile-test "(define-syntax $kwoat (lambda (x) `(,#'quote ,x)))\n(define $argh #1=($kwoat #1#))\n")
+  (eq? $argh (cadr $argh))
+  (load-test "(define-syntax $quoat (lambda (x) `(,#'quote ,x)))\n(begin (define x #1=($quoat a)) (define y #1#))\n")
+  (eq? x y)
+  (load-test "(define x '#1=(17 . #1#))\n(define y '#1=#2=(#1# . #2#))\n(define z '(#1=#1# . #1#))\n(define w '#2=(#1# . #1=#2#))\n")
+  (and (eq? (car x) 17) (eq? (cdr x) x))
+  (and (eq? (car y) y) (eq? (cdr y) y))
+  (and (eq? (car z) (cdr z)) (eq? (car z) (read (open-input-string "#1=#1#"))))
+  (and (eq? (car w) w) (eq? (cdr w) w))
+  (compile-test "(define x1 '#1=(17 . #1#))\n(define y1 '#1=#2=(#1# . #2#))\n(define z1 '(#1=#1# . #1#))\n(define w1 '#2=(#1# . #1=#2#))\n")
+  (and (eq? (car x1) 17) (eq? (cdr x1) x1))
+  (and (eq? (car y1) y1) (eq? (cdr y1) y1))
+  (and (eq? (car z1) (cdr z1)) (eq? (car z1) (read (open-input-string "#1=#1#"))))
+  (and (eq? (car w1) w1) (eq? (cdr w1) w1))
+  (load-test "(define-record #{$eager beaver} ((immutable busy)))\n(define x '(#[#{$eager beaver} #1=(a b)] #1#))\n")
+  (and ($eager? (car x))
+       (equal? ($eager-busy (car x)) '(a b))
+       (eq? ($eager-busy (car x)) (cadr x)))
+  (compile-test "(define-record #{$beaver eager} ((immutable busy)))\n(define x '(#[#{$beaver eager} #1=(a b)] #1#))\n")
+  (and ($beaver? (car x))
+       (equal? ($beaver-busy (car x)) '(a b))
+       (eq? ($beaver-busy (car x)) (cadr x)))
+ ; w/quote on record
+  (load-test "(define-record #{$tony tiger} ((immutable great!)))\n(define x (list '#[#{$tony tiger} #1=(a b)] '#1#))\n")
+  (and ($tony? (car x))
+       (equal? ($tony-great! (car x)) '(a b))
+       (eq? ($tony-great! (car x)) (cadr x)))
+ ; missing quote on record; see if annotation still comes back
+  (load-test "(define-record #{$tiger tony} ((immutable great!)))\n(define x (list '#[#{$tiger tony} #1=(a b)] '#1#))\n")
+  (and ($tiger? (car x))
+       (equal? ($tiger-great! (car x)) '(a b))
+       (eq? ($tiger-great! (car x)) (cadr x)))
+  (load-test "(define-record #{$slow joe} ((double-float pokey)))\n(define x '#[#{$slow joe} 3.4])\n")
+  (and ($slow? x) (eqv? ($slow-pokey x) 3.4))
+  (load-test "(define-syntax $silly (syntax-rules () ((_ #(a b c) #2(d e)) (list 'a 'b 'c 'd 'e '#(a b c) '#2(d e) '#3(a b c) '#(d e)))))\n(define x ($silly #(#(1 2) #3(3 4 5) #()) #(#0() #3(#&8))))\n")
+  (equal?
+    x
+    '(#2(1 2)
+       #3(3 4 5)
+       #0()
+       #0()
+       #3(#&8)
+       #3(#2(1 2) #3(3 4 5) #0())
+       #2(#0() #3(#&8))
+       #3(#2(1 2) #3(3 4 5) #0())
+       #2(#0() #3(#&8))))
+  (load-test "(define-record #{james kirk} ((double-float girls)))\n(define x '(#2=253.5 . #[#{james kirk} #2#]))\n")
+  (and (= (car x) 253.5) (= (james-girls (cdr x)) 253.5))
+  (load-test "(define-syntax $peabrain (identifier-syntax (a 4) ((set! a b) (list a b))))\n(define x (+ $peabrain 1))\n(define y (set! $peabrain (* x $peabrain)))\n")
+  (and (equal? x 5) (equal? y '(4 20)))
+ )
+
+(mat symbol-printing
+  (equal? (format "~s" '\#foo\|bar) "\\x23;foo\\x7C;bar")
+  (eq? '\x23;foo\x7C;bar '\#foo\|bar)
+ )
+
+(mat with-source-path (parameters [current-directory *mats-dir*] [source-directories '(".")] [library-directories '(".")])
+  (equal? (separate-eval '(source-directories)) "(\".\")\n")
+  (equal?
+    (with-source-path 'test "I should not be here" list)
+    '("I should not be here"))
+  (equal?
+    (with-source-path 'test "/I/should/not/be/here" list)
+    '("/I/should/not/be/here"))
+  (equal?
+    (with-source-path 'test "fatfib.ss" list)
+    '("fatfib.ss"))
+  (equal?
+    (parameterize ([source-directories '("")])
+      (with-source-path 'test "fatfib.ss" list))
+    '("fatfib.ss"))
+  (error? ; Error in test: file "fatfib.ss" not found in source directories
+    (parameterize ([source-directories '("." ".")])
+      (with-source-path 'test "fatfib.ss" list)))
+  (error? ; Error in test: file "I should not be here" not found in source directories
+    (parameterize ([source-directories '("." "../examples")])
+      (with-source-path 'test "I should not be here" list)))
+  (equal?
+    (parameterize ([source-directories '("." "../examples")])
+      (with-source-path 'test "mat.ss" list))
+    '("mat.ss"))
+  (equal?
+    (with-source-path 'test "mat.ss" list)
+    '("mat.ss"))
+  (equal?
+    (parameterize ([source-directories '("" "../examples")])
+      (with-source-path 'test "mat.ss" list))
+    '("mat.ss"))
+  (error? ; Error in test: file "mat.ss" not found in source directories
+    (parameterize ([source-directories '()])
+      (with-source-path 'test "mat.ss" list)))
+  (error? ; Error in test: file "mat.ss" not found in source directories
+    (parameterize ([source-directories '("../examples")])
+      (with-source-path 'test "mat.ss" list)))
+  (equal?
+    (parameterize ([source-directories '("." "../examples")])
+      (with-source-path 'test "fatfib.ss" list))
+    '("../examples/fatfib.ss"))
+  (equal?
+    (parameterize ([source-directories '("." "../examples")])
+      (with-source-path 'test "./fatfib.ss" list))
+    '("./fatfib.ss"))
+  (begin
+    (parameterize ([source-directories '("." "../examples")])
+      (load "fatfib.ss" compile))
+    (procedure? fatfib))
+  (equal? ((inspect/object fatfib) 'type) 'procedure)
+  (equal? 
+    (call-with-values
+      (lambda () (((inspect/object fatfib) 'code) 'source-path))
+      list)
+    '("../examples/fatfib.ss" 16 4))
+  (equal? 
+    (parameterize ([source-directories '("." "../examples")])
+      (call-with-values
+        (lambda () (((inspect/object fatfib) 'code) 'source-path))
+        list))
+    '("../examples/fatfib.ss" 16 4))
+  (begin
+    (load "../examples/fatfib.ss" compile)
+    (procedure? fatfib))
+  (equal? ((inspect/object fatfib) 'type) 'procedure)
+  (equal?
+    (call-with-values
+      (lambda () (((inspect/object fatfib) 'code) 'source-path))
+      list)
+    '("../examples/fatfib.ss" 16 4))
+  (or (windows?)
+      (equal?
+       (parameterize ([cd "/"] [source-directories (list (cd))])
+         (call-with-values
+           (lambda () (((inspect/object fatfib) 'code) 'source-path))
+           list))
+       (list (format "~a/../examples/fatfib.ss" (cd)) 16 4)))
+  (begin
+    (parameterize ([source-directories (list (parameterize ([cd ".."]) (cd)))])
+      (load "examples/fatfib.ss" compile))
+    (procedure? fatfib))
+  (equal? ((inspect/object fatfib) 'type) 'procedure)
+  (equal?
+    (call-with-values
+      (lambda () (((inspect/object fatfib) 'code) 'source-path))
+      (lambda (x y z) (list (path-last x) y z)))
+    '("fatfib.ss" 16 4))
+  (equal?
+    (parameterize ([source-directories (list (parameterize ([cd ".."]) (cd)))])
+      (call-with-values
+        (lambda () (((inspect/object fatfib) 'code) 'source-path))
+        list))
+    (list (format "~a/examples/fatfib.ss" (parameterize ([cd ".."]) (cd))) 16 4))
+  (equal?
+    (parameterize ([cd ".."] [source-directories '("examples")])
+      (call-with-values
+        (lambda () (((inspect/object fatfib) 'code) 'source-path))
+        (lambda (x y z) (list (path-last x) y z))))
+    '("fatfib.ss" 16 4))
+  (or (windows?) (embedded?)
+      (begin
+        (system "ln -s ../examples .")
+        (load "examples/fatfib.ss" compile)
+        (system "rm -f examples")
+        #t))
+  (or (windows?) (embedded?)
+      (equal?
+        (call-with-values
+          (lambda () (((inspect/object fatfib) 'code) 'source-path))
+          list)
+        '("examples/fatfib.ss" 359)))
+  (or (windows?) (embedded?)
+      (equal?
+        (parameterize ([source-directories '("..")])
+          (call-with-values
+            (lambda () (((inspect/object fatfib) 'code) 'source-path))
+            list))
+        '("../examples/fatfib.ss" 16 4)))
+  (or (windows?) (embedded?)
+      (equal?
+        (parameterize ([source-directories '("../examples")])
+          (call-with-values
+            (lambda () (((inspect/object fatfib) 'code) 'source-path))
+            list))
+        '("../examples/fatfib.ss" 16 4)))
+  (or (windows?) (embedded?)
+      (equal?
+        (parameterize ([source-directories (list (format "~a/examples" (parameterize ([cd ".."]) (cd))))])
+          (call-with-values
+            (lambda () (((inspect/object fatfib) 'code) 'source-path))
+            list))
+        (list (format "~a/examples/fatfib.ss" (parameterize ([cd ".."]) (cd))) 16 4)))
+)
+
+(mat filesystem-operations
+  (eqv?
+    (directory-separator)
+    (if (windows?) #\\ #\/))
+  (directory-separator? #\/)
+  (or (not (windows?)) (directory-separator? #\\))
+  (error? (directory-separator? '/))
+  (error? (directory-separator? '"/"))
+  (begin
+    (delete-file "testfile.ss" #f)
+    (delete-file "testfile.ss" #f)
+    (delete-file "testfile.ss")
+    #t)
+  (begin
+    (with-output-to-file "testfile.ss" values)
+    (r6rs:delete-file "testfile.ss")
+    (not (file-exists? "testfile.ss")))
+  (error? (delete-file "testfile.ss" #t))
+  (error? (r6rs:delete-file "testfile.ss"))
+  (and
+    (not (file-exists? "testfile.ss"))
+    (not (file-exists? "testfile.ss" #t))
+    (not (file-exists? "testfile.ss" #f)))
+  (and
+    (not (file-regular? "testfile.ss"))
+    (not (file-regular? "testfile.ss" #t))
+    (not (file-regular? "testfile.ss" #f)))
+  (and
+    (not (file-directory? "testfile.ss"))
+    (not (file-directory? "testfile.ss" #t))
+    (not (file-directory? "testfile.ss" #f)))
+  (not (file-symbolic-link? "testfile.ss"))
+  (begin
+    (rm-rf "testdir")
+    #t)
+  (and
+    (not (file-exists? "testdir"))
+    (not (file-exists? "testdir" #t))
+    (not (file-exists? "testdir" #f)))
+  (and
+    (not (file-regular? "testdir"))
+    (not (file-regular? "testdir" #t))
+    (not (file-regular? "testdir" #f)))
+  (and
+    (not (file-directory? "testdir"))
+    (not (file-directory? "testdir" #t))
+    (not (file-directory? "testdir" #f)))
+  (not (file-symbolic-link? "testdir"))
+  (begin
+    (mkdir "testdir")
+    (and
+      (file-exists? "testdir")
+      (file-exists? "testdir" #t)
+      (file-exists? "testdir" #f)))
+  (and
+    (not (file-regular? "testdir"))
+    (not (file-regular? "testdir" #t))
+    (not (file-regular? "testdir" #f)))
+  (and
+    (file-directory? "testdir")
+    (file-directory? "testdir" #t)
+    (file-directory? "testdir" #f))
+  (not (file-symbolic-link? "testdir"))
+  (eqv? (directory-list "testdir") '())
+  (begin
+    (with-output-to-file "testdir/testfile.ss" values)
+    (and
+      (file-exists? "testdir/testfile.ss")
+      (file-exists? "testdir/testfile.ss" #t)
+      (file-exists? "testdir/testfile.ss" #f)))
+  (and
+    (file-regular? "testdir/testfile.ss")
+    (file-regular? "testdir/testfile.ss" #t)
+    (file-regular? "testdir/testfile.ss" #f))
+  (and
+    (not (file-directory? "testdir/testfile.ss"))
+    (not (file-directory? "testdir/testfile.ss" #t))
+    (not (file-directory? "testdir/testfile.ss" #f)))
+  (not (file-symbolic-link? "testdir/testfile.ss"))
+  (equal? (directory-list "testdir") '("testfile.ss"))
+  (begin
+    (with-output-to-file "testdir/foo" values)
+    (and
+      (file-exists? "testdir/foo")
+      (file-exists? "testdir/foo" #t)
+      (file-exists? "testdir/foo" #f)))
+  (begin
+    (with-output-to-file "testdir/bar" values)
+    (and
+      (file-exists? "testdir/bar")
+      (file-exists? "testdir/bar" #t)
+      (file-exists? "testdir/bar" #f)))
+  (file-regular? "testdir/foo")
+  (not (file-directory? "testdir/foo"))
+  (not (file-symbolic-link? "testdir/foo"))
+  (file-regular? "testdir/bar")
+  (not (file-directory? "testdir/bar"))
+  (not (file-symbolic-link? "testdir/bar"))
+  (equal?
+    (sort string (length (directory-list "~")) 0))
+  (or (embedded?) (> (length (directory-list "~/")) 0))
+  (or (not (windows?))
+      (> (length (directory-list "c:")) 0))
+  (or (not (windows?))
+      (> (length (directory-list "c:/")) 0))
+  (or (not (windows?))
+      (> (length (directory-list "\\\\?\\c:\\")) 0))
+  (or (not (windows?))
+      (> (length (directory-list "\\\\?\\C:\\")) 0))
+  (file-directory? "/")
+  (file-directory? "/.")
+  (file-exists? ".")
+  (file-exists? "./")
+  (if (windows?)
+      (and (file-directory? "c:")
+           (file-directory? "c:/")
+           (file-directory? "c:/."))
+      (not (file-directory? "c:")))
+  (if (windows?)
+      (and (not (file-directory? "\\\\?\\c:"))
+           (file-directory? "\\\\?\\c:\\"))
+      (not (file-directory? "\\\\?\\c:")))
+  (if (windows?)
+      (and (file-exists? "c:")
+           (file-exists? "c:/")
+           (file-exists? "c:/."))
+      (not (file-exists? "c:")))
+  (if (windows?)
+      (and (not (file-exists? "\\\\?\\c:"))
+           (file-exists? "\\\\?\\c:\\"))
+      (not (file-exists? "\\\\?\\c:")))
+  (if (windows?)
+      (and (not (file-regular? "\\\\?\\c:"))
+           (not (file-regular? "\\\\?\\c:\\"))
+           (or (not (file-exists? "\\\\?\\c:\\autoexec.bat"))
+               (file-regular? "\\\\?\\c:\\autoexec.bat")))
+      (not (file-regular? "\\\\?\\c:\\autoexec.bat")))
+  (error? (get-mode 'foo))
+  (error? (get-mode 'foo #t))
+  (error? (get-mode 'foo #f))
+  (error? (get-mode "probably/not/there"))
+  (error? (get-mode "probably/not/there" #f))
+  (error? (get-mode "probably/not/there" #t))
+  (error? (file-access-time "probably/not/there"))
+  (error? (file-access-time "probably/not/there" #f))
+  (error? (file-access-time "probably/not/there" #t))
+  (error? (file-change-time "probably/not/there"))
+  (error? (file-change-time "probably/not/there" #f))
+  (error? (file-change-time "probably/not/there" #t))
+  (error? (file-modification-time "probably/not/there"))
+  (error? (file-modification-time "probably/not/there" #f))
+  (error? (file-modification-time "probably/not/there" #t))
+  )
+
+(mat filesystem-operations2 (parameters [current-directory *mats-dir*])
+  (if (or (windows?) (embedded?))
+      (fixnum? (get-mode "mat.ss"))
+      (let ([m (get-mode "mat.ss")])
+        (and (logtest m #o400)
+             (not (logtest m #o111)))))
+  (or (not (windows?))
+      (and (fixnum? (get-mode "c:/"))
+           (eqv? (get-mode "c:/") (get-mode "C:\\"))
+           (eqv? (get-mode "c:/") (get-mode "c:\\."))))
+  (if (or (windows?) (embedded?))
+      (fixnum? (get-mode "../mats"))
+      (eqv? (logand (get-mode "../mats") #o700) #o700))
+  (and (eqv? (get-mode "../mats") (get-mode "../mats/"))
+       (eqv? (get-mode "../mats") (get-mode "../mats/.")))
+  ; access times are unreliable on contemporary file systems
+  (time? (file-access-time "../../mats/mat.ss"))
+  (time<=? (file-change-time "mat.ss") (file-change-time "mat.so"))
+  (time<=? (file-modification-time "mat.ss") (file-modification-time "mat.so"))
+  (equal?
+    (list (time? (file-access-time "../mats"))
+          (time? (file-change-time "../mats"))
+          (time? (file-modification-time "../mats")))
+    '(#t #t #t))
+  (equal?
+    (list (time? (file-access-time "../mats/"))
+          (time? (file-change-time "../mats/"))
+          (time? (file-modification-time "../mats/")))
+    '(#t #t #t))
+  (or (not (windows?))
+      (and (time? (file-access-time "c:"))
+           (time? (file-change-time "c:"))
+           (time? (file-modification-time "c:"))))
+  (or (not (windows?))
+      (and (time? (file-access-time "c:/"))
+           (time? (file-change-time "c:/"))
+           (time? (file-modification-time "c:/"))))
+  (or (not (windows?))
+      (and (time? (file-access-time "\\\\?\\C:\\"))
+           (time? (file-change-time "\\\\?\\C:\\"))
+           (time? (file-modification-time "\\\\?\\C:\\"))))
+  (or (not (windows?))
+      (and (time? (file-access-time "\\\\?\\c:\\"))
+           (time? (file-change-time "\\\\?\\c:\\"))
+           (time? (file-modification-time "\\\\?\\c:\\"))))
+  (or (windows?) (embedded?)
+      (time=? (file-access-time "Makefile") (file-access-time (format "Mf-~a" (machine-type)))))
+  (or (windows?) (embedded?)
+      (time=? (file-change-time "Makefile") (file-change-time (format "Mf-~a" (machine-type)))))
+  (or (windows?) (embedded?)
+      (time=? (file-modification-time "Makefile") (file-modification-time (format "Mf-~a" (machine-type)))))
+)
+
+(mat unicode-filesystem-operations
+  (begin
+    (delete-file "testfile\x3bb;.ss" #f)
+    (delete-file "testfile\x3bb;.ss" #f)
+    (delete-file "testfile\x3bb;.ss")
+    #t)
+  (begin
+    (with-output-to-file "testfile\x3bb;.ss" values)
+    (r6rs:delete-file "testfile\x3bb;.ss")
+    (not (file-exists? "testfile\x3bb;.ss")))
+  (error? (delete-file "testfile\x3bb;.ss" #t))
+  (error? (r6rs:delete-file "testfile\x3bb;.ss"))
+  (and
+    (not (file-exists? "testfile\x3bb;.ss"))
+    (not (file-exists? "testfile\x3bb;.ss" #t))
+    (not (file-exists? "testfile\x3bb;.ss" #f)))
+  (and
+    (not (file-regular? "testfile\x3bb;.ss"))
+    (not (file-regular? "testfile\x3bb;.ss" #t))
+    (not (file-regular? "testfile\x3bb;.ss" #f)))
+  (and
+    (not (file-directory? "testfile\x3bb;.ss"))
+    (not (file-directory? "testfile\x3bb;.ss" #t))
+    (not (file-directory? "testfile\x3bb;.ss" #f)))
+  (not (file-symbolic-link? "testfile\x3bb;.ss"))
+  (and
+    (not (file-exists? "testdir\x3bb;"))
+    (not (file-exists? "testdir\x3bb;" #t))
+    (not (file-exists? "testdir\x3bb;" #f)))
+  (and
+    (not (file-regular? "testdir\x3bb;"))
+    (not (file-regular? "testdir\x3bb;" #t))
+    (not (file-regular? "testdir\x3bb;" #f)))
+  (and
+    (not (file-directory? "testdir\x3bb;"))
+    (not (file-directory? "testdir\x3bb;" #t))
+    (not (file-directory? "testdir\x3bb;" #f)))
+  (not (file-symbolic-link? "testdir\x3bb;"))
+  (begin
+    (mkdir "testdir\x3bb;")
+    (and
+      (file-exists? "testdir\x3bb;")
+      (file-exists? "testdir\x3bb;" #t)
+      (file-exists? "testdir\x3bb;" #f)))
+  (and
+    (not (file-regular? "testdir\x3bb;"))
+    (not (file-regular? "testdir\x3bb;" #t))
+    (not (file-regular? "testdir\x3bb;" #f)))
+  (and
+    (file-directory? "testdir\x3bb;")
+    (file-directory? "testdir\x3bb;" #t)
+    (file-directory? "testdir\x3bb;" #f))
+  (not (file-symbolic-link? "testdir\x3bb;"))
+  (eqv? (directory-list "testdir\x3bb;") '())
+  (begin
+    (with-output-to-file "testdir\x3bb;/testfile\x3bb;.ss" values)
+    (and
+      (file-exists? "testdir\x3bb;/testfile\x3bb;.ss")
+      (file-exists? "testdir\x3bb;/testfile\x3bb;.ss" #t)
+      (file-exists? "testdir\x3bb;/testfile\x3bb;.ss" #f)))
+  (and
+    (file-regular? "testdir\x3bb;/testfile\x3bb;.ss")
+    (file-regular? "testdir\x3bb;/testfile\x3bb;.ss" #t)
+    (file-regular? "testdir\x3bb;/testfile\x3bb;.ss" #f))
+  (and
+    (not (file-directory? "testdir\x3bb;/testfile\x3bb;.ss"))
+    (not (file-directory? "testdir\x3bb;/testfile\x3bb;.ss" #t))
+    (not (file-directory? "testdir\x3bb;/testfile\x3bb;.ss" #f)))
+  (not (file-symbolic-link? "testdir\x3bb;/testfile\x3bb;.ss"))
+  (equal? (directory-list "testdir\x3bb;") '("testfile\x3bb;.ss"))
+  (begin
+    (with-output-to-file "testdir\x3bb;/foo" values)
+    (and
+      (file-exists? "testdir\x3bb;/foo")
+      (file-exists? "testdir\x3bb;/foo" #t)
+      (file-exists? "testdir\x3bb;/foo" #f)))
+  (begin
+    (with-output-to-file "testdir\x3bb;/bar" values)
+    (and
+      (file-exists? "testdir\x3bb;/bar")
+      (file-exists? "testdir\x3bb;/bar" #t)
+      (file-exists? "testdir\x3bb;/bar" #f)))
+  (file-regular? "testdir\x3bb;/foo")
+  (not (file-directory? "testdir\x3bb;/foo"))
+  (not (file-symbolic-link? "testdir\x3bb;/foo"))
+  (file-regular? "testdir\x3bb;/bar")
+  (not (file-directory? "testdir\x3bb;/bar"))
+  (not (file-symbolic-link? "testdir\x3bb;/bar"))
+  (equal?
+    (sort string")
+  (equal? (format "~s" (lambda (x) x)) "#")
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print '(define ($pn-q x) (lambda (y) (+ x y)))))
+      'replace)
+    (load "testfile.ss" compile)
+    #t)
+  (equal? (format "~s" $pn-q) "#")
+  (equal? (format "~s" ($pn-q 3)) "#")
+)
+
+(mat bignum-printing
+  (let ()
+    (define wrint
+      (let ([digit->char
+             (lambda (d)
+               (string-ref "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" d))])
+        (lambda (n b)
+          (if (< n b)
+              (write-char (digit->char n))
+              (begin
+                (wrint (quotient n b) b)
+                (write-char (digit->char (remainder n b))))))))
+    (do ([i 4000 (fx- i 1)])
+        ((fx= i 0))
+      (let ([n (random (expt 2 (random (* (fixnum-width) 30))))]
+            [b (+ 2 (random 35))])
+        (unless (let ([s (with-output-to-string (lambda () (wrint n b)))])
+                  (and (string=?
+                         (parameterize ([print-radix b]) (format "~a" n))
+                         s)
+                       (or (= n 0)
+                         (string=?
+                           (parameterize ([print-radix b]) (format "~a" (- n)))
+                           (format "-~a" s)))))
+          (errorf #f "failed in base ~s for ~s" b n))
+        (unless (string=?
+                  (format "~a" n)
+                  (with-output-to-string (lambda () (wrint n 10))))
+          (errorf #f "failed in base 10 for ~s" n))))
+    #t)
+)
+
+(mat process
+   (begin (set! p (process (patch-exec-path $cat_flush)))
+          (= (length p) 3))
+   (and (port? (car p)) (input-port? (car p))
+        (port? (cadr p)) (output-port? (cadr p))
+        (integer? (caddr p)))
+   (and (file-port? (car p)) (file-port? (cadr p)))
+   (and (fixnum? (port-file-descriptor (car p)))
+        (fixnum? (port-file-descriptor (cadr p))))
+   (let ([ip (car p)])
+     (and (not (port-has-port-position? ip))
+          (not (port-has-set-port-position!? ip))
+          (not (port-has-port-length? ip))
+          (not (port-has-set-port-length!? ip))))
+   (let ([op (car p)])
+     (and (not (port-has-port-position? op))
+          (not (port-has-set-port-position!? op))
+          (not (port-has-port-length? op))
+          (not (port-has-set-port-length!? op))))
+   (not (char-ready? (car p)))
+   (begin (display "hello " (cadr p))
+          (flush-output-port (cadr p))
+          #t)
+   (begin (sleep (make-time 'time-duration 0 3)) #t) ; wait for subprocess to catch up
+   (char-ready? (car p))
+   (eq? (read (car p)) 'hello)
+   (char-ready? (car p))
+   (char=? (read-char (car p)) #\space)
+   (not (char-ready? (car p)))
+   (begin (close-output-port (cadr p)) #t)
+   (begin (sleep (make-time 'time-duration 0 3)) #t) ; wait for subprocess to catch up
+   (sanitized-error? (write-char #\a (cadr p)))
+   (sanitized-error? (write-char #\newline (cadr p)))
+   (sanitized-error? (flush-output-port (cadr p)))
+   (char-ready? (car p))
+   (eof-object? (read-char (car p)))
+   (begin (close-input-port (car p)) #t)
+   (sanitized-error? (char-ready? (car p)))
+   (sanitized-error? (read-char (car p)))
+   (sanitized-error? (clear-input-port (cadr p)))
+ )
diff --git a/mats/7.ms b/mats/7.ms
new file mode 100644
index 0000000..fdc2a0a
--- /dev/null
+++ b/mats/7.ms
@@ -0,0 +1,6244 @@
+;;; 7.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; section 7-1:
+
+(mat load/compile-file
+   (error? (load "/file/not/there"))
+   (error? (compile-file "/file/not/there"))
+   (error? ; abc is not a string
+     (load-program 'abc))
+   (error? ; xxx is not a procedure
+     (load-program "/file/not/there" 'xxx))
+   (error? ; 3 is not a string
+     (parameterize ([source-directories '("/tmp" ".")]) (load-program 3)))
+   (error? ; 3 is not a string
+     (parameterize ([source-directories '("/tmp" ".")]) (load-program 3 values)))
+   (not (top-level-bound? 'aaaaa))
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (display "(let ((x 3) (y 4)) (set! aaaaa (+ x y)))" p)
+      (close-output-port p)
+      (load "testfile.ss")
+      (eqv? aaaaa 7))
+   (call/cc
+      (lambda (k)
+         (load "testfile.ss"
+               (lambda (x)
+                  (unless (equal? (annotation-stripped x)
+                            '(let ((x 3) (y 4))
+                               (set! aaaaa (+ x y))))
+                    (k #f))))
+         #t))
+   (begin
+     (printf "***** expect \"compile-file\" message:~%")
+     (compile-file "testfile")
+     (set! aaaaa 0)
+     (load "testfile.so")
+     (eqv? aaaaa 7))
+   (parameterize ([fasl-compressed #f])
+     (printf "***** expect \"compile-file\" message:~%")
+     (compile-file "testfile")
+     (set! aaaaa 0)
+     (load "testfile.so")
+     (eqv? aaaaa 7))
+   (let ((ip (open-input-string "(let ((x -3) (y -4)) (set! aaaaa (+ x y)))"))
+         (op (open-file-output-port "testfile.so" (file-options replace))))
+     (compile-port ip op)
+     (close-input-port ip)
+     (close-port op)
+     (set! aaaaa 0)
+     (load "testfile.so")
+     (eqv? aaaaa -7))
+   (let ((ip (open-input-string "(let ((x -3) (y -4)) (set! aaaaa (+ x y)))"))
+         (op (open-file-output-port "testfile.so" (file-options replace #;compressed))))
+     (compile-port ip op)
+     (close-input-port ip)
+     (close-port op)
+     (set! aaaaa 0)
+     (load "testfile.so")
+     (eqv? aaaaa -7))
+  ; test compiling a file containing most-negative-fixnum
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+     (printf "***** expect \"compile-file\" message:~%")
+     (display `(define $mnfixnum ,(most-negative-fixnum)) p)
+     (close-output-port p)
+     (compile-file "testfile")
+     (load "testfile.so")
+     (eqv? $mnfixnum (most-negative-fixnum)))
+ )
+
+(mat compile-to-port
+  (eqv?
+    (call-with-port (open-file-output-port "testfile.so" (file-options replace))
+      (lambda (op)
+        (compile-to-port '((define ctp1 'hello) (set! ctp1 (cons 'goodbye ctp1))) op)))
+    (void))
+  (begin
+    (load "testfile.so")
+    #t)
+  (equal? ctp1 '(goodbye . hello))
+  (begin
+    (with-output-to-file "testfile-ctp2a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ctp2a) (export fact) (import (chezscheme))
+             (define fact (lambda (x) (if (= x 0) 1 (* x (fact (- x 1)))))))))
+      'replace)
+    #t)
+  (equal?
+    (call-with-port (open-file-output-port "testfile.so" (file-options replace #;compressed))
+      (lambda (op)
+        (parameterize ([compile-imported-libraries #t])
+          (compile-to-port
+            '((top-level-program
+                (import (chezscheme) (testfile-ctp2a))
+                (pretty-print (fact 3))))
+            op))))
+    '((testfile-ctp2a)))
+  (equal?
+    (with-output-to-string (lambda () (load "testfile.so")))
+    "6\n")
+ )
+
+(mat load-compiled-from-port
+  (begin
+    (define-values (o get) (open-bytevector-output-port))
+    (compile-to-port '((define lcfp1 'worked) 'loaded) o)
+    (eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
+  (begin
+    (define lcfp-bv
+      (let-values ([(o get) (open-bytevector-output-port)])
+        (compile-to-port
+          '((printf "revisit\n")
+            (define-syntax $lcfp-a (begin (printf "visit\n") (lambda (x) 0)))
+            (eval-when (visit revisit) (printf "visit-revisit\n"))
+            (eval-when (visit) 'visit-return)
+            'revisit-return)
+          o)
+        (get)))
+    #t)
+  (equal?
+    (with-output-to-string (lambda () (printf "result = ~s\n" (load-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
+    "revisit\nvisit\nvisit-revisit\nresult = revisit-return\n")
+  (equal?
+    (with-output-to-string (lambda () (printf "result = ~s\n" (visit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
+    "visit\nvisit-revisit\nresult = visit-return\n")
+  (equal?
+    (with-output-to-string (lambda () (printf "result = ~s\n" (revisit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
+    "revisit\nvisit-revisit\nresult = revisit-return\n")
+)
+
+(mat compile-to-file
+  (begin
+    (delete-file (format "testfile.~s" (machine-type)))
+    (compile-to-file '((define ctf1 'hello) (set! ctf1 (cons ctf1 'goodbye))) "testfile.so")
+    #t)
+  (begin
+    (load "testfile.so")
+    #t)
+  ;; NB: should we protect the following in case we are actually cross compiling?
+  (not (file-exists? (format "testfile.~s" (machine-type))))
+  (equal? ctf1 '(hello . goodbye))
+  (begin
+    (with-output-to-file "testfile-ctf2a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ctf2a) (export fib) (import (chezscheme))
+             (define fib (lambda (x) (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))))))
+      'replace)
+    #t)
+  (equal?
+    (parameterize ([compile-imported-libraries #t])
+      (compile-to-file
+        '((top-level-program
+            (import (chezscheme) (testfile-ctf2a))
+            (pretty-print (fib 11))))
+        "testfile.so"))
+    '((testfile-ctf2a)))
+  (not (file-exists? (format "testfile-ctf2a.~s" (machine-type))))
+  (not (file-exists? (format "testfile.~s" (machine-type))))
+  (equal?
+    (with-output-to-string (lambda () (load "testfile.so")))
+    "89\n")
+  (begin
+    (compile-to-file
+      '((library (testfile-ctf2a) (export fib) (import (chezscheme))
+          (define fib (lambda (x) (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2))))))))
+        "testfile.so")
+    #t)
+  (not (file-exists? (format "testfile.~s" (machine-type))))
+ )
+
+(mat compile-script
+  (error? (compile-script "/file/not/there"))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "#! /usr/bin/scheme --script\n")
+        (pretty-print '(define $cs-x 14))
+        (pretty-print '(define $cs-y (lambda (q) (+ $cs-x q)))))
+      'replace)
+    (compile-script "testfile")
+    #t)
+  (error? $cs-x)
+  (error? $cs-y)
+  (begin
+    (load "testfile.so")
+    #t)
+  (eqv? $cs-x 14)
+  (eqv? ($cs-y -17) -3)
+  (eqv? (with-input-from-file "testfile.so" read-char) #\#)
+
+ ; test visit/revisit of compiled script
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (printf "#! /usr/bin/scheme --script\n")
+        (pretty-print '(eval-when (visit) (display "hello from testfile\n")))
+        (pretty-print '(display "hello again from testfile\n")))
+      'replace)
+    (compile-script "testfile")
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (visit "testfile.so")))
+    "hello from testfile\n")
+  (equal?
+    (with-output-to-string
+      (lambda () (revisit "testfile.so")))
+    "hello again from testfile\n")
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile.so")))
+    "hello from testfile\nhello again from testfile\n")
+)
+
+(mat load-program/compile-program
+  (error? (compile-program "/file/not/there"))
+  (error? (load-program "/file/not/there"))
+  (error? ; abc is not a string
+    (load-program 'abc))
+  (error? ; xxx is not a procedure
+    (load-program "/file/not/there" 'xxx))
+  (error? ; 3 is not a string
+    (parameterize ([source-directories '("/tmp" ".")]) (load-program 3)))
+  (error? ; 3 is not a string
+    (parameterize ([source-directories '("/tmp" ".")]) (load-program 3 values)))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "#! /usr/bin/scheme --program\n")
+        (pretty-print '(import (rnrs)))
+        (pretty-print '(define $cp-x 14))
+        (pretty-print '(define $cp-y (lambda (q) (+ $cp-x q))))
+        (pretty-print '(begin
+                         (when (file-exists? "testfile-cp.ss")
+                           (delete-file "testfile-cp.ss"))
+                         (with-output-to-file "testfile-cp.ss"
+                           (lambda () (write (cons $cp-x ($cp-y 35))))))))
+      'replace)
+    (compile-program "testfile")
+    #t)
+  (begin
+    (load-program "testfile.so")
+    #t)
+  (error? $cp-x)
+  (error? $cp-y)
+  (let ([p (with-input-from-file "testfile-cp.ss" read)])
+    (eqv? (car p) 14)
+    (eqv? (cdr p) 49))
+  (eqv? (with-input-from-file "testfile.so" read-char) #\#)
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "#! /usr/bin/scheme --program\n")
+        (pretty-print '(import (rnrs)))
+        (pretty-print '(begin
+                         (when (file-exists? "testfile-cp.ss")
+                           (delete-file "testfile-cp.ss"))
+                         (with-output-to-file "testfile-cp.ss"
+                           (lambda () (write "hello from testfile"))))))
+      'replace)
+    #t)
+  (begin
+    (load-program "testfile.ss")
+    #t)
+  (equal? (with-input-from-file "testfile-cp.ss" read) "hello from testfile")
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "#! /usr/bin/scheme --program\n")
+        (pretty-print '(import (rnrs)))
+        (pretty-print '(pretty-print 'hello)))
+      'replace)
+    #t)
+  (error? ; unbound variable pretty-print
+    (compile-program "testfile"))
+  (error? ; unbound variable pretty-print
+    (load-program "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "#! /usr/bin/scheme --program\n")
+        (pretty-print '(import (rnrs)))
+        (pretty-print '(#%write 'hello)))
+      'replace)
+    #t)
+  (error? ; invalid #% syntax in #!r6rs mode
+    (compile-program "testfile"))
+  (error? ; invalid #% syntax in #!r6rs mode
+    (load-program "testfile.ss"))
+)
+
+(mat maybe-compile
+  (error? ; not a procedure
+    (compile-program-handler 'ignore))
+  (procedure? (compile-program-handler))
+  (error? ; not a string
+    (maybe-compile-file '(spam)))
+  (error? ; not a string
+    (maybe-compile-file "spam" 'spam))
+  (error? ; not a string
+    (maybe-compile-file -2.5 "spam"))
+  (error? ; .ss file does not exist
+    (maybe-compile-file "probably-does-not-exist.ss"))
+  (error? ; .ss file does not exist
+    (maybe-compile-file "probably-does-not-exist.ss" "probably-does-not-exist.so"))
+  (begin
+    (with-output-to-file "testfile-mc.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme))
+            (pretty-print 'hello))))
+      'replace)
+    #t)
+  (error? ; cannot create .so file
+    (maybe-compile-file "testfile-mc.ss" "/probably/does/not/exist.so"))
+  (error? ; not a string
+    (maybe-compile-program '(spam)))
+  (error? ; not a string
+    (maybe-compile-program "spam" 'spam))
+  (error? ; not a string
+    (maybe-compile-program -2.5 "spam"))
+  (error? ; .ss file does not exist
+    (maybe-compile-program "probably-does-not-exist.ss"))
+  (error? ; .ss file does not exist
+    (maybe-compile-program "probably-does-not-exist.ss" "probably-does-not-exist.so"))
+  (begin
+    (with-output-to-file "testfile-mc.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme))
+            (pretty-print 'hello))))
+      'replace)
+    #t)
+  (error? ; cannot create .so file
+    (maybe-compile-program "testfile-mc.ss" "/probably/does/not/exist.so"))
+  (error? ; not a string
+    (maybe-compile-library '(spam)))
+  (error? ; not a string
+    (maybe-compile-library "spam" 'spam))
+  (error? ; not a string
+    (maybe-compile-library -2.5 "spam"))
+  (error? ; .ss file does not exist
+    (maybe-compile-library "probably-does-not-exist.ss"))
+  (error? ; .ss file does not exist
+    (maybe-compile-library "probably-does-not-exist.ss" "probably-does-not-exist.so"))
+  (begin
+    (with-output-to-file "testfile-mc.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc) (export) (import))))
+      'replace)
+    #t)
+  (error? ; cannot create .so file
+    (maybe-compile-library "testfile-mc.ss" "/probably/does/not/exist.so"))
+  (begin
+    (with-output-to-file "testfile-mc.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme))
+            (if))))
+      'replace)
+    #t)
+  (error? ; syntax error
+    (maybe-compile-file "testfile-mc.ss" "testfile-mc.so"))
+  (not (file-exists? "testfile-mc.so"))
+  (error? ; syntax error
+    (maybe-compile-program "testfile-mc.ss" "testfile-mc.so"))
+  (not (file-exists? "testfile-mc.so"))
+  (begin
+    (with-output-to-file "testfile-mc.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc) (export x) (import (chezscheme)) (define))))
+      'replace)
+    #t)
+  (error? ; syntax error
+    (maybe-compile-library "testfile-mc.ss" "testfile-mc.so"))
+  (not (file-exists? "testfile-mc.so"))
+  (begin
+    (for-each delete-file '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+    (with-output-to-file "testfile-mc-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc-a) (export a) (import (chezscheme)) (define a "a"))))
+      'replace)
+    (with-output-to-file "testfile-mc-b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc-b) (export a b) (import (chezscheme) (testfile-mc-a)) (define b "b"))))
+      'replace)
+    (with-output-to-file "testfile-mc-c.ss"
+      (lambda ()
+        (pretty-print
+          '(define c "c")))
+      'replace)
+    (with-output-to-file "testfile-mc-foo.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme) (testfile-mc-b))
+            (include "testfile-mc-c.ss")
+            (pretty-print (list a b c)))))
+      'replace)
+    (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\")\n")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = =))
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-b)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = =))
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-a)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = =))
+  (touch "testfile-mc-foo.so" "testfile-mc-foo.ss")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = >))
+  (equal?
+    (separate-eval '(load-program "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\")\n")
+  (touch "testfile-mc-foo.so" "testfile-mc-c.ss")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = >))
+  (equal?
+    (separate-eval '(load-program "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\")\n")
+  (touch "testfile-mc-foo.so" "testfile-mc-b.ss")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= > >))
+  (equal?
+    (separate-eval '(load-program "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\")\n")
+  (touch "testfile-mc-foo.so" "testfile-mc-a.ss")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (let ([s (separate-compile '(lambda (x) (parameterize ([compile-program-handler (lambda (ifn ofn) (printf "yippee!\n") (compile-program ifn ofn))]
+                                                             [compile-imported-libraries #t]
+                                                             [compile-file-message #f])
+                                                 (maybe-compile-program x)))
+                 'mc-foo)])
+        (cons
+          (map
+            (lambda (x y) (if (time=? x y) '= (if (time)))
+            (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+            mt*)
+          s)))
+    '((> > >) . "yippee!\n"))
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (let ([s (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t] [compile-file-message #f]) (maybe-compile-program x))) 'mc-foo)])
+        (cons
+          (map
+            (lambda (x y) (if (time=? x y) '= (if (time)))
+            (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+            mt*)
+          s)))
+    '((= = =) . ""))
+  (equal?
+    (separate-eval '(load-program "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\")\n")
+  (touch "testfile-mc-foo.so" "testfile-mc-b.ss")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-b)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= > =))
+  ; NB: create testfile-mc-a.ss newer than testfile-mc-1b.so, since testfile-mc-1b.so might be newer than testfile-mc-foo.so
+  (touch "testfile-mc-b.so" "testfile-mc-a.ss")
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (let ([s (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f] [import-notify #t]) (maybe-compile-library x))) 'mc-b)])
+        (cons
+          (map
+            (lambda (x y) (if (time=? x y) '= (if (time)))
+            (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+            mt*)
+          s)))
+    '((= = =) . "maybe-compile-library: object file is not older\nmaybe-compile-library: did not find source file \"testfile-mc-a.chezscheme.sls\"\nmaybe-compile-library: found source file \"testfile-mc-a.ss\"\nmaybe-compile-library: found corresponding object file \"testfile-mc-a.so\"\n"))
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-b)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(> > =))
+  (equal?
+    (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = >))
+  (equal?
+    (separate-eval '(load-program "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\")\n")
+  (begin
+    (for-each delete-file '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+    (with-output-to-file "testfile-mc-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc-a) (export a) (import (chezscheme)) (define a "a"))))
+      'replace)
+    (with-output-to-file "testfile-mc-b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc-b) (export a b) (import (chezscheme) (testfile-mc-a)) (define b "b"))))
+      'replace)
+    (with-output-to-file "testfile-mc-c.ss"
+      (lambda ()
+        (pretty-print
+          '(define c "c")))
+      'replace)
+    (with-output-to-file "testfile-mc-d.ss"
+      (lambda ()
+        (pretty-print
+          '(module M (d)
+             (import (testfile-mc-a) (testfile-mc-b) (chezscheme))
+             (define d (vector b a)))))
+      'replace)
+    (with-output-to-file "testfile-mc-e.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc-e) (export e-str) (import (chezscheme)) (define e-str "e"))))
+      'replace)
+    (with-output-to-file "testfile-mc-e-import.ss"
+      (lambda ()
+        (pretty-print
+          '(import (testfile-mc-e))))
+      'replace)
+    (with-output-to-file "testfile-mc-f.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mc-f) (export f-str) (import (chezscheme)) (define f-str "f"))))
+      'replace)
+    (with-output-to-file "testfile-mc-foo.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme) (testfile-mc-b))
+            (include "testfile-mc-c.ss")
+            (include "testfile-mc-d.ss")
+            (import M)
+            (meta define build-something-f
+              (lambda (k something)
+                (import (testfile-mc-f))
+                (datum->syntax k (string->symbol (string-append something "-" f-str)))))
+            (define-syntax e
+              (lambda (x)
+                (syntax-case x ()
+                  [(k) (let ()
+                         (include "testfile-mc-e-import.ss")
+                         #`'#,(build-something-f #'k e-str))])))
+            (pretty-print (list a b c d (e))))))
+      'replace)
+    (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-mc-foo.so"))
+    "(\"a\" \"b\" \"c\" #(\"b\" \"a\") e-f)\n")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = =))
+  (touch "testfile-mc-foo.so" "testfile-mc-foo.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = >))
+  (touch "testfile-mc-foo.so" "testfile-mc-a.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = =))
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(> > = = >))
+  (touch "testfile-mc-foo.so" "testfile-mc-c.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = >))
+  (touch "testfile-mc-foo.so" "testfile-mc-e.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = =))
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = > = >))
+  (touch "testfile-mc-foo.so" "testfile-mc-e-import.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = >))
+  (touch "testfile-mc-foo.so" "testfile-mc-f.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = = =))
+  (equal?
+    (let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
+        mt*))
+    '(= = = > >))
+  (begin
+    (rm-rf "testdir")
+    (mkdir "testdir")
+    (mkfile "testdir/testfile-mc-1a.ss"
+      '(define mcratfink 'abe))
+    (mkfile "testdir/testfile-mc-1b.ss"
+      '(library (testdir testfile-mc-1b)
+         (export mc-1b-x)
+         (import (chezscheme))
+         (include "testfile-mc-1a.ss")
+         (define mc-1b-x
+           (lambda ()
+             (list mcratfink)))))
+    (mkfile "testdir/testfile-mc-1c.ss"
+      '(library (testdir testfile-mc-1c)
+         (export mc-1b-x)
+         (import (testdir testfile-mc-1b))))
+    (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (compile-library x))) "testdir/testfile-mc-1c")
+    #t)
+  (equal?
+    (separate-eval '(let () (import (testdir testfile-mc-1c)) (mc-1b-x)))
+    "(abe)\n")
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(= =))
+  (touch "testdir/testfile-mc-1c.so" "testdir/testfile-mc-1a.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(= =))
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(> >))
+  (touch "testdir/testfile-mc-1c.so" "testdir/testfile-mc-1b.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(= =))
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(> >))
+  (touch "testdir/testfile-mc-1c.so" "testdir/testfile-mc-1c.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(= >))
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
+      (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
+        mt*))
+    '(= =))
+  (error? ; can't find testfile-mc-1a.ss
+    (separate-compile 'compile-library "testdir/testfile-mc-1b"))
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([source-directories (cons "testdir" (source-directories))])
+           (maybe-compile-library x)))
+      "testdir/testfile-mc-1b")
+    #t)
+  (error? ; can't find testfile-mc-1a.ss
+    (separate-compile 'maybe-compile-library "testdir/testfile-mc-1b"))
+  ; make sure maybe-compile-file wipes out b.so when it fails to find a.ss
+  (or (= (optimize-level) 3) (not (file-exists? "testdir/testfile-mc-1b.so")))
+  (begin
+    (separate-compile '(lambda (x)
+                         (parameterize ([source-directories (cons "testdir" (source-directories))])
+                           (maybe-compile-library x)))
+      "testdir/testfile-mc-1b")
+    #t)
+  (touch "testdir/testfile-mc-1b.so" "testdir/testfile-mc-1a.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
+      (separate-compile '(lambda (x)
+                           (parameterize ([source-directories (cons "testdir" (source-directories))])
+                             (maybe-compile-library x)))
+        "testdir/testfile-mc-1b")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so"))
+        mt*))
+    '(>))
+  (touch "testdir/testfile-mc-1b.so" "testdir/testfile-mc-1b.ss")
+  (equal?
+    (let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
+      (separate-compile '(lambda (x)
+                           (parameterize ([source-directories (cons "testdir" (source-directories))])
+                             (maybe-compile-library x)))
+        "testdir/testfile-mc-1b")
+      (map
+        (lambda (x y) (if (time=? x y) '= (if (time)))
+        (map file-modification-time '("testdir/testfile-mc-1b.so"))
+        mt*))
+    '(>))
+  (delete-file "testdir/testfile-mc-1a.ss")
+  (error? ; maybe-compile-library: can't find testfile-mc-1a.ss
+    (separate-compile '(lambda (x)
+                         (parameterize ([source-directories (cons "testdir" (source-directories))])
+                           (maybe-compile-library x)))
+      "testdir/testfile-mc-1b"))
+  ; make sure maybe-compile-file wipes out b.so when it fails to find a.ss
+  (or (= (optimize-level) 3) (not (file-exists? "testdir/testfile-mc-1b.so")))
+  (begin
+    (rm-rf "testdir")
+    #t)
+  ; make sure maybe-compile-file handles incomplete fasl files
+  (begin
+    (mkfile "testfile-mc-2a.ss"
+      '(library (testfile-mc-2a)
+         (export q)
+         (import (chezscheme))
+         (define f
+           (lambda ()
+             (printf "running f\n")
+             "x"))
+         (define-syntax q
+           (begin
+             (printf "expanding testfile-mc-2a\n")
+             (lambda (x)
+               (printf "expanding q\n")
+               #'(f))))))
+    (mkfile "testfile-mc-2.ss"
+      '(import (chezscheme) (testfile-mc-2a))
+      '(define-syntax qq
+         (begin
+           (printf "expanding testfile-mc-2\n")
+           (lambda (x)
+             (printf "expanding qq\n")
+             #'q)))
+      '(printf "qq => ~a\n" qq))
+    (delete-file "testfile-mc-2a.so")
+    (delete-file "testfile-mc-2.so")
+    (display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f]) (maybe-compile-program x))) 'mc-2))
+    #t)
+  (begin
+    (let ([p (open-file-input/output-port "testfile-mc-2a.so" (file-options no-create no-fail no-truncate))])
+      (set-port-length! p 73)
+      (close-port p))
+    (display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
+    #t)
+  (begin
+    (let ([p (open-file-input/output-port "testfile-mc-2.so" (file-options no-create no-fail no-truncate))])
+      (set-port-length! p 87)
+      (close-port p))
+    (display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
+    #t)
+  ; make sure maybe-compile-file handles missing include files gracefully
+  (begin
+    (mkfile "testfile-mc-3a.ss"
+      "hello from 3a!")
+    (mkfile "testfile-mc-3b.ss"
+      '(library (testfile-mc-3b)
+         (export q)
+         (import (chezscheme))
+         (define-syntax q
+           (begin
+             (printf "expanding testfile-mc-3b\n")
+             (lambda (x)
+               (printf "expanding q\n")
+               (include "./testfile-mc-3a.ss"))))))
+    (mkfile "testfile-mc-3.ss"
+      '(import (chezscheme) (testfile-mc-3b))
+      '(define-syntax qq
+         (begin
+           (printf "expanding testfile-mc-3\n")
+           (lambda (x)
+             (printf "expanding qq\n")
+             #'q)))
+      '(printf "qq => ~a\n" qq))
+    (delete-file "testfile-mc-3b.so")
+    (delete-file "testfile-mc-3.so")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t])
+           (maybe-compile-program x)))
+      'mc-3)
+    #t)
+  (begin
+    (delete-file "testfile-mc-3a.ss")
+    #t)
+  (error? ; separate-compile: no such file or directory: testfile-mc-3a.ss
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t])
+           (maybe-compile-program x)))
+      'mc-3))
+  ; make sure maybe-compile-file handles missing include files gracefully
+  (begin
+    (define-record-type hash-bang-chezscheme)
+    (record-writer (type-descriptor hash-bang-chezscheme) (lambda (x p wr) (display-string "#!chezscheme")))
+    (mkfile "testfile-mc-4a.ss"
+      "hello from 4a!")
+    (mkfile "testfile-mc-4b.ss"
+      (make-hash-bang-chezscheme)
+      '(library (testfile-mc-4b)
+         (export b)
+         (import (chezscheme))
+         (define-syntax q
+           (lambda (x)
+             (if (file-exists? "testfile-mc-4a.ss")
+                 (begin
+                   (printf "HEY!\n")
+                   (#%$require-include "./testfile-mc-4a.ss")
+                   (call-with-input-file "testfile-mc-4a.ss" read))
+                 (begin
+                   (printf "BARLEY!\n")
+                   "testfile-mc-4a is no more"))))
+         (define (b) q)))
+    (mkfile "testfile-mc-4.ss"
+      '(import (chezscheme) (testfile-mc-4b))
+      '(printf "q => ~a\n" (b)))
+    (delete-file "testfile-mc-4b.so")
+    (delete-file "testfile-mc-4.so")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t])
+           (maybe-compile-program x)))
+      'mc-4)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-4.so"))
+    "q => hello from 4a!\n")
+  (begin
+    (mkfile "testfile-mc-4a.ss"
+      "goodbye from 4a!")
+    (touch "testfile-mc-4.so" "testfile-mc-4a.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
+           (maybe-compile-program x)))
+      'mc-4)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-4.so"))
+    "q => goodbye from 4a!\n")
+  (begin
+    (delete-file "testfile-mc-4a.ss")
+    #t)
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
+           (maybe-compile-program x)))
+      'mc-4)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-4.so"))
+    "q => testfile-mc-4a is no more\n")
+  ; make sure maybe-compile-file handles missing include files gracefully
+  (begin
+    (define-record-type hash-bang-chezscheme)
+    (record-writer (type-descriptor hash-bang-chezscheme) (lambda (x p wr) (display-string "#!chezscheme")))
+    (mkfile "testfile-mc-5a.ss"
+      "hello from 5a!")
+    (mkfile "testfile-mc-5b.ss"
+      (make-hash-bang-chezscheme)
+      '(library (testfile-mc-5b)
+         (export q)
+         (import (chezscheme))
+         (define-syntax q
+           (lambda (x)
+             (if (file-exists? "testfile-mc-5a.ss")
+                 (begin
+                   (printf "HEY!\n")
+                   (#%$require-include "./testfile-mc-5a.ss")
+                   (call-with-input-file "testfile-mc-5a.ss" read))
+                 (begin
+                   (printf "BARLEY!\n")
+                   "testfile-mc-5a is no more"))))))
+    (mkfile "testfile-mc-5.ss"
+      '(import (chezscheme) (testfile-mc-5b))
+      '(define-syntax qq (lambda (x) #'q))
+      '(printf "qq => ~a\n" qq))
+    (delete-file "testfile-mc-5b.so")
+    (delete-file "testfile-mc-5.so")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t])
+           (maybe-compile-program x)))
+      'mc-5)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-5.so"))
+    "qq => hello from 5a!\n")
+  (begin
+    (mkfile "testfile-mc-5a.ss"
+      "goodbye from 5a!")
+    (touch "testfile-mc-5.so" "testfile-mc-5a.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
+           (maybe-compile-program x)))
+      'mc-5)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-5.so"))
+    "qq => goodbye from 5a!\n")
+  (begin
+    (delete-file "testfile-mc-5a.ss")
+    #t)
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
+           (maybe-compile-program x)))
+      'mc-5)
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-mc-5.so"))
+    "qq => testfile-mc-5a is no more\n")
+ )
+
+(mat make-boot-file
+  (eq? (begin
+         (with-output-to-file "testfile-1.ss"
+           (lambda ()
+             (pretty-print '(display "hello 1\n")))
+           'replace)
+         (with-output-to-file "testfile-2.ss"
+           (lambda ()
+             (pretty-print '(display "hello 2\n")))
+           'replace)
+         (with-output-to-file "testfile-3.ss"
+           (lambda ()
+             (pretty-print '(display "hello 3\n")))
+           'replace)
+         (with-output-to-file "testfile-4.ss"
+           (lambda ()
+             (pretty-print '(display "hello 4\n")))
+           '(replace))
+         (with-output-to-file "testfile-5.ss"
+           (lambda ()
+             (pretty-print '(display "hello 5\n")))
+           '(replace))
+         (parameterize ([optimize-level 2])
+           (compile-script "testfile-1")
+           (compile-script "testfile-2")
+           (compile-file "testfile-3")
+           (compile-file "testfile-4")
+           (compile-file "testfile-5")))
+       (void))
+  (equal?
+    (begin
+      (parameterize ([optimize-level 2])
+        (make-boot-file "testfile.boot" '("petite")
+          "testfile-1.so"
+          "testfile-2.ss"
+          "testfile-3.so"
+          "testfile-4.so"
+          "testfile-5.ss"))
+      (let-values ([(to-stdin from-stdout from-stderr pid)
+                    (open-process-ports
+                      (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
+                      (buffer-mode block)
+                      (native-transcoder))])
+        (close-output-port to-stdin)
+        (let ([out (get-string-all from-stdout)]
+              [err (get-string-all from-stderr)])
+          (close-input-port from-stdout)
+          (close-input-port from-stderr)
+          (unless (eof-object? err) (error 'bootfile-test1 err))
+          out)))
+    "hello 1\nhello 2\nhello 3\nhello 4\nhello 5\n")
+  (equal?
+    (begin
+      (parameterize ([optimize-level 2])
+        (compile-to-file
+         '((library (A) (export a) (import (scheme)) (define a 'aye))
+           (library (B) (export b) (import (A) (scheme)) (define b (list a 'captain))))
+         "testfile-libs.so")
+        (make-boot-file "testfile.boot" '("petite") "testfile-libs.so"))
+      (let-values ([(to-stdin from-stdout from-stderr pid)
+                    (open-process-ports
+                      (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
+                      (buffer-mode block)
+                      (native-transcoder))])
+        (pretty-print '(let () (import (B)) (printf "~s\n" b)) to-stdin)
+        (close-output-port to-stdin)
+        (let ([out (get-string-all from-stdout)]
+              [err (get-string-all from-stderr)])
+          (close-input-port from-stdout)
+          (close-input-port from-stderr)
+          (unless (eof-object? err) (error 'bootfile-test1 err))
+          out)))
+    "(aye captain)\n")
+  (equal?
+    (begin
+      (unless (or (embedded?) (equal? *scheme* (format "~a/bin/~a/scheme~a" (path-parent *mats-dir*) (machine-type) (if (windows?) ".exe" ""))))
+        (errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a"
+          (machine-type) (machine-type) (if (windows?) ".exe" "")))
+      (parameterize ([optimize-level 2])
+        (make-boot-file "testfile.boot" '()
+          (format "~a/boot/~a/petite.boot" (path-parent *mats-dir*) (machine-type))
+          "testfile-1.so"
+          "testfile-2.so"
+          "testfile-3.ss"
+          "testfile-4.ss"
+          "testfile-5.so"))
+      (let-values ([(to-stdin from-stdout from-stderr pid)
+                    (open-process-ports
+                      (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
+                      (buffer-mode block)
+                      (native-transcoder))])
+        (close-output-port to-stdin)
+        (let ([out (get-string-all from-stdout)]
+              [err (get-string-all from-stderr)])
+          (close-input-port from-stdout)
+          (close-input-port from-stderr)
+          (unless (eof-object? err) (error 'bootfile-test2 err))
+          out)))
+    "hello 1\nhello 2\nhello 3\nhello 4\nhello 5\n")
+  ; regression test to verify that we can evaluate a foreign-callable form inside the procedure to
+  ; which scheme-start is set, which was failing because its relocation information was discarded
+  ; by the static-generation collection.
+  (equal?
+    (begin
+      (unless (or (embedded?) (equal? *scheme* (format "~a/bin/~a/scheme~a" (path-parent *mats-dir*) (machine-type) (if (windows?) ".exe" ""))))
+        (errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a"
+          (machine-type) (machine-type) (if (windows?) ".exe" "")))
+      (mkfile "testfile.ss"
+        '(scheme-start
+           (lambda ()
+             (let ([x 0])
+               (printf "~s\n" (foreign-callable (lambda () (set! x (+ x 1)) x) () void))))))
+      (make-boot-file "testfile.boot" '("petite") "testfile.ss")
+      (let-values ([(to-stdin from-stdout from-stderr pid)
+                    (open-process-ports
+                      (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
+                      (buffer-mode block)
+                      (native-transcoder))])
+        (close-output-port to-stdin)
+        (let ([out (get-string-all from-stdout)]
+              [err (get-string-all from-stderr)])
+          (close-input-port from-stdout)
+          (close-input-port from-stderr)
+          (unless (eof-object? err) (error 'bootfile-test2 err))
+          out)))
+    "#\n")
+)
+
+(mat hostop
+  (begin
+    (separate-compile
+      `(lambda (x)
+         (call-with-port
+           (open-file-output-port (format "~a.so" x) (file-options #;compressed replace))
+           (lambda (op)
+             (call-with-port
+               (open-file-output-port (format "~a.host" x) (file-options #;compressed replace))
+               (lambda (hostop)
+                 (compile-to-port
+                   '((library (testfile-hop1)
+                       (export a b c)
+                       (import (chezscheme))
+                       (define-syntax a (identifier-syntax 17))
+                       (module b (b1 b2)
+                         (define b1 "23.5")
+                         (define-syntax b2 (identifier-syntax (cons b1 b1))))
+                       (define c (lambda (x) (import b) (vector b2 x)))))
+                   op #f #f #f ',(machine-type) hostop))))))
+      "testfile-hop1")
+    (with-output-to-file "testfile-hop2.ss"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (load "testfile-hop1.so")))
+        (pretty-print '(eval-when (compile) (import (testfile-hop1))))
+        (pretty-print '(eval-when (compile) (import b)))
+        (pretty-print '(pretty-print (list a b1 b2 (c 55)))))
+      'replace)
+    (with-output-to-file "testfile-hop3.ss"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (load "testfile-hop1.host")))
+        (pretty-print '(eval-when (compile) (import (testfile-hop1))))
+        (pretty-print '(eval-when (compile) (import b)))
+        (pretty-print '(pretty-print (list a b1 b2 (c 55)))))
+      'replace)
+    (for-each separate-compile '(hop2 hop3))
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-hop1.so")
+      '(import (testfile-hop1))
+      'a
+      '(import b)
+      'b1
+      'b2
+      '(c 55))
+    "17\n\
+     \"23.5\"\n\
+     (\"23.5\" . \"23.5\")\n\
+     #((\"23.5\" . \"23.5\") 55)\n\
+     ")
+  (equal?
+    (separate-eval
+      '(visit "testfile-hop1.so") ; visit now---$invoke-library will revisit later
+      '(import (testfile-hop1))
+      'a
+      '(import b)
+      'b1
+      'b2
+      '(c 55))
+    "17\n\
+     \"23.5\"\n\
+     (\"23.5\" . \"23.5\")\n\
+     #((\"23.5\" . \"23.5\") 55)\n\
+     ")
+  (equal?
+    (separate-eval
+      '(revisit "testfile-hop1.so")
+      '(expand 'a)
+      '(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
+      '(expand 'b1)
+      '(expand 'b2)
+      '(load "testfile-hop2.so"))
+    "a\n\
+     Exception: unknown module b\n\
+     b1\n\
+     b2\n\
+     (17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
+     ")
+  (equal?
+    (separate-eval
+      '(revisit "testfile-hop1.so")
+      '(expand 'a)
+      '(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
+      '(expand 'b1)
+      '(expand 'b2)
+      '(load "testfile-hop3.so"))
+    "a\n\
+     Exception: unknown module b\n\
+     b1\n\
+     b2\n\
+     (17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
+     ")
+  (equal?
+    (separate-eval
+      '(load "testfile-hop1.host")
+      '(import (testfile-hop1))
+      'a
+      '(import b)
+      'b1
+      'b2
+      '(c 55))
+    "17\n\
+     \"23.5\"\n\
+     (\"23.5\" . \"23.5\")\n\
+     #((\"23.5\" . \"23.5\") 55)\n\
+     ")
+  (equal?
+    (separate-eval
+      '(revisit "testfile-hop1.host")
+      '(expand 'a)
+      '(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
+      '(expand 'b1)
+      '(expand 'b2)
+      '(load "testfile-hop2.so"))
+    "a\n\
+     Exception: unknown module b\n\
+     b1\n\
+     b2\n\
+     (17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
+     ")
+  (equal?
+    (separate-eval
+      '(revisit "testfile-hop1.host")
+      '(expand 'a)
+      '(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
+      '(expand 'b1)
+      '(expand 'b2)
+      '(load "testfile-hop3.so"))
+    "a\n\
+     Exception: unknown module b\n\
+     b1\n\
+     b2\n\
+     (17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
+     ")
+  (begin
+    (#%$compile-host-library 'moi "testfile-hop1.host")
+    (define bv (call-with-port (open-file-input-port "testfile-hop1.host") get-bytevector-all))
+    #t)
+  (begin
+    ; doing it a second time should be a no-op
+    (#%$compile-host-library 'moi "testfile-hop1.host")
+    (bytevector=?
+      (call-with-port (open-file-input-port "testfile-hop1.host") get-bytevector-all)
+      bv))
+  (begin
+    (set! bv #f)
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-hop1.host")
+      '(import (testfile-hop1))
+      'a
+      '(import b)
+      'b1
+      'b2
+      '(c 55))
+    "17\n\
+     \"23.5\"\n\
+     (\"23.5\" . \"23.5\")\n\
+     #((\"23.5\" . \"23.5\") 55)\n\
+     ")
+  (equal?
+    (separate-eval
+      '(revisit "testfile-hop1.host")
+      '(expand 'a)
+      '(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
+      '(expand 'b1)
+      '(expand 'b2)
+      '(load "testfile-hop2.so"))
+    "a\n\
+     Exception: unknown module b\n\
+     b1\n\
+     b2\n\
+     (17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
+     ")
+  (equal?
+    (separate-eval
+      '(revisit "testfile-hop1.host")
+      '(expand 'a)
+      '(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
+      '(expand 'b1)
+      '(expand 'b2)
+      '(load "testfile-hop3.so"))
+    "a\n\
+     Exception: unknown module b\n\
+     b1\n\
+     b2\n\
+     (17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
+     ")
+  (equal?
+    (separate-eval
+      '(visit "testfile-hop1.so")
+      '(delete-file "testfile-hop1.so") ; prevent import from revisiting testfile-hop1.so
+      '(import (testfile-hop1))
+      'a
+      '(import b)
+      '(guard (c [else (display-condition c) (newline)]) (eval 'b1))
+      '(guard (c [else (display-condition c) (newline)]) (eval 'b2))
+      '(guard (c [else (display-condition c) (newline)]) (eval 'c)))
+    "#t\n\
+     17\n\
+     Exception: failed for testfile-hop1.so: no such file or directory\n\
+     Exception: failed for testfile-hop1.so: no such file or directory\n\
+     Exception: failed for testfile-hop1.so: no such file or directory\n\
+     ")
+)
+
+(mat eval
+   (error? ; 7 is not an environment (should be reported by compile or interpret)
+     (eval 3 7))
+   (error? ; 7 is not an environment
+     (interpret 3 7))
+   (error? ; 7 is not an environment
+     (compile 3 7))
+   (eqv? (eval '(+ 3 4)) 7)
+   (eq? (eval '(define foo (lambda (x) x))) (void))
+   (eval '(let ([x '(a b c)]) (eq? (foo x) x)))
+ )
+
+(mat expand ; tested in mats extend-syntax & with in 8.ms
+   (error? ; 7 is not an environment (should be reported by sc-expand)
+     (expand 3 7))
+   (error? ; 7 is not an environment
+     (sc-expand 3 7))
+   (procedure? expand)
+ )
+
+(mat eval-when
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (display "
+(eval-when (eval) (set! aaa 'eval))
+(eval-when (load) (set! aaa 'load))
+(eval-when (compile) (set! aaa 'compile))
+" p)
+      (close-output-port p)
+      #t)
+   (begin (set! aaa #f) (load "testfile.ss") (eq? aaa 'eval))
+   (begin (printf "***** expect \"compile-file\" message:~%")
+          (set! aaa #f)
+          (compile-file "testfile")
+          (eq? aaa 'compile))
+   (begin (set! aaa #f) (load "testfile.so") (eq? aaa 'load))
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (display "
+(eval-when (eval)
+   (eval-when (eval) (set! aaa 'eval@eval))
+   (eval-when (load) (set! aaa 'load@eval))
+   (eval-when (compile) (set! aaa 'compile@eval)))
+(eval-when (load)
+   (eval-when (eval) (set! bbb 'eval@load))
+   (eval-when (load) (set! bbb 'load@load))
+   (eval-when (compile) (set! bbb 'compile@load)))
+(eval-when (compile)
+   (eval-when (eval) (set! ccc 'eval@compile))
+   (eval-when (load) (set! ccc 'load@compile))
+   (eval-when (compile) (set! ccc 'compile@compile)))
+" p)
+      (close-output-port p)
+      #t)
+   (begin (set! aaa #f)
+          (set! bbb #f)
+          (set! ccc #f)
+          (load "testfile.ss")
+          (equal? (list aaa bbb ccc) '(eval@eval #f #f)))
+   (begin (printf "***** expect \"compile-file\" message:~%")
+          (set! aaa #f)
+          (set! bbb #f)
+          (set! ccc #f)
+          (compile-file "testfile")
+          (equal? (list aaa bbb ccc) '(#f compile@load eval@compile)))
+   (begin (set! aaa #f)
+          (set! bbb #f)
+          (set! ccc #f)
+          (load "testfile.so")
+          (equal? (list aaa bbb ccc) '(#f load@load #f)))
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (display "
+(eval-when (eval) (pretty-print 'evaluating))
+(eval-when (compile) (pretty-print 'compiling))
+(eval-when (load) (pretty-print 'loading))
+(eval-when (visit) (pretty-print 'visiting))
+(eval-when (revisit) (pretty-print 'revisiting))
+(eval-when (visit revisit) (pretty-print 'visit/revisit))
+(eval-when (compile)
+  (eval-when (eval)
+    (pretty-print 'oops)))
+(eval-when (load eval)
+  (eval-when (compile)
+    (pretty-print 'foo6)))
+" p)
+      (close-output-port p)
+      #t)
+   (let ()
+     (define with-output-to-string
+       (lambda (p)
+         (parameterize ([current-output-port (open-output-string)])
+           (p)
+           (get-output-string (current-output-port)))))
+     (and
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (compile-file "testfile")))
+"compiling testfile.ss with output to testfile.so
+compiling
+oops
+foo6
+"
+       )
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (visit "testfile.so")))
+"visiting
+visit/revisit
+"
+       )
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (revisit "testfile.so")))
+"loading
+revisiting
+visit/revisit
+"
+       )
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (load "testfile.so")))
+"loading
+visiting
+revisiting
+visit/revisit
+"
+       )))
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (display "
+(define-syntax $a (identifier-syntax 'b))
+(define $foo)
+(eval-when (visit) (define visit-x 17))
+(eval-when (revisit) (define-syntax revisit-x (identifier-syntax 23)))
+" p)
+      (close-output-port p)
+      #t)
+   (begin (define-syntax $foo (syntax-rules ())) #t)
+   (begin (define-syntax $a (syntax-rules ())) #t)
+   (begin (define-syntax visit-x (syntax-rules ())) #t)
+   (begin (define-syntax revisit-x (syntax-rules ())) #t)
+   (error? $foo)
+   (error? $a)
+   (error? visit-x)
+   (error? revisit-x)
+   (begin (compile-file "testfile") #t)
+   (eq? $a 'b)
+   (error? $foo)
+   (error? visit-x)
+   (error? revisit-x)
+   (begin (define-syntax $foo (syntax-rules ())) #t)
+   (begin (define-syntax $a (syntax-rules ())) #t)
+   (begin (define-syntax visit-x (syntax-rules ())) #t)
+   (begin (define-syntax revisit-x (syntax-rules ())) #t)
+   (begin (visit "testfile.so") #t)
+   (eq? $a 'b)
+   (error? $foo)
+   (eq? visit-x 17)
+   (error? revisit-x)
+   (begin (revisit "testfile.so") #t)
+   (eq? $a 'b)
+   (eq? $foo (void))
+   (eq? visit-x 17)
+   (eq? revisit-x 23)
+   (begin (define get-$foo (lambda () $foo)) (eq? (get-$foo) (void)))
+   (begin (define-syntax $foo (syntax-rules ())) #t)
+   (begin (define-syntax $a (syntax-rules ())) #t)
+   (begin (define-syntax visit-x (syntax-rules ())) #t)
+   (begin (define-syntax revisit-x (syntax-rules ())) #t)
+   (begin (revisit "testfile.so") #t)
+   (error? $a)
+   (error? $foo)
+   (eq? (get-$foo) (void))
+   (error? visit-x)
+   (eq? revisit-x 23)
+   (begin (visit "testfile.so") #t)
+   (eq? $a 'b)
+   (eq? $foo (void))
+   (eq? (get-$foo) (void))
+   (eq? visit-x 17)
+   (eq? revisit-x 23)
+   (begin (define-syntax $foo (syntax-rules ())) #t)
+   (begin (define-syntax $a (syntax-rules ())) #t)
+   (begin (define-syntax visit-x (syntax-rules ())) #t)
+   (begin (define-syntax revisit-x (syntax-rules ())) #t)
+   (begin (load "testfile.so") #t)
+   (eq? $a 'b)
+   (eq? $foo (void))
+   (eq? (get-$foo) (void))
+   (eq? visit-x 17)
+   (eq? revisit-x 23)
+   (begin (define-syntax $foo (syntax-rules ())) #t)
+   (begin (define-syntax $a (syntax-rules ())) #t)
+   (begin (define-syntax visit-x (syntax-rules ())) #t)
+   (begin (define-syntax revisit-x (syntax-rules ())) #t)
+   (begin (load "testfile.ss") #t)
+   (eq? $a 'b)
+   (eq? $foo (void))
+   (error? visit-x)
+   (error? revisit-x)
+   (eqv?
+     (let ((x 77))
+       (eval-when (eval)
+         (define x 88))
+       x)
+     88)
+   (eqv?
+     (let ((x 77))
+       (eval-when (compile visit load revisit)
+         (define x 88))
+       x)
+     77)
+   (begin
+     (define $qlist '())
+     (define-syntax $qdef
+       (syntax-rules ()
+         [(_ x e)
+          (begin
+            (eval-when (compile)
+              (set! $qlist (cons 'x $qlist)))
+            (eval-when (load eval)
+              (define x e)))]))
+     ($qdef $bar 33)
+     (and (null? $qlist) (eqv? $bar 33)))
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+     (pretty-print '($qdef $baz (lambda () ($qdef x 44) x)) p)
+     (close-output-port p)
+     #t)
+   (begin (compile-file "testfile") #t)
+   (equal? $qlist '($baz))
+   (begin (load "testfile.so") #t)
+   (equal? $qlist '($baz))
+   (eq? ($baz) 44)
+  ; regression: make sure that visit doesn't evaluate top-level module
+  ; inits and definition right-hand-sides
+   (let ([p (open-output-file "testfile.ss" 'replace)])
+      (display
+"(eval-when (visit) (printf \"visit A\\n\"))
+(eval-when (revisit) (printf \"revisit A\\n\"))
+(eval-when (load compile) (printf \"compile load A\\n\"))
+(define foo (printf \"evaluating top-level foo rhs\\n\"))
+(printf \"evaluating top-level init\\n\") 
+
+(eval-when (visit) (printf \"visit B\\n\"))
+(eval-when (revisit) (printf \"revisit B\\n\"))
+(eval-when (load compile) (printf \"compile load B\\n\"))
+(module ()
+  (define foo (printf \"evaluating module foo rhs\\n\"))
+  (printf \"evaluating module init\\n\"))
+" p)
+      (close-output-port p)
+      #t)
+   (let ()
+     (define with-output-to-string
+       (lambda (p)
+         (parameterize ([current-output-port (open-output-string)])
+           (p)
+           (get-output-string (current-output-port)))))
+     (and
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (compile-file "testfile")))
+"compiling testfile.ss with output to testfile.so
+compile load A
+compile load B
+"
+       )
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (visit "testfile.so")))
+"visit A
+visit B
+")
+       (string=?
+         (with-output-to-string
+           (lambda ()
+             (revisit "testfile.so")))
+"revisit A
+compile load A
+evaluating top-level foo rhs
+evaluating top-level init
+revisit B
+compile load B
+evaluating module foo rhs
+evaluating module init
+")))
+ )
+
+(mat compile-whole-program
+  (error? ; no such file or directory nosuchfile.wpo
+    (compile-whole-program "nosuchfile.wpo" "testfile-wpo-ab-all.so"))
+  (error? ; incorrect number of arguments 
+    (compile-whole-program "testfile-wpo-ab.wpo"))
+  (begin
+    (with-output-to-file "testfile-wpo-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-a)
+             (export make-tree tree tree? tree-left tree-right tree-value)
+             (import (chezscheme))
+
+             (define-record-type tree
+               (nongenerative)
+               (fields (mutable left) (mutable value) (mutable right)))
+             (record-writer (record-type-descriptor tree)
+               (lambda (r p wr)
+                 (display "#[tree " p)
+                 (wr (tree-left r) p)
+                 (display " " p)
+                 (wr (tree-value r) p)
+                 (display " " p)
+                 (wr (tree-right r) p)
+                 (display "]" p))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-b)
+             (export make-constant-tree make-tree tree? tree-left tree-right
+               tree-value tree->list)
+             (import (rnrs) (testfile-wpo-a))
+             (define-syntax make-constant-tree
+               (lambda (x)
+                 (define build-tree
+                   (lambda (tree-desc)
+                     (syntax-case tree-desc ()
+                       [(l v r)
+                        (make-tree (build-tree #'l) (syntax->datum #'v) (build-tree #'r))]
+                       [v (make-tree #f (syntax->datum #'v) #f)])))
+                 (syntax-case x ()
+                   [(_ tree-desc) #`'#,(build-tree #'tree-desc)])))
+             (define tree->list
+               (lambda (t)
+                 (let f ([t t] [s '()])
+                   (if (not t)
+                       s
+                       (f (tree-left t) (cons (tree-value t) (f (tree-right t) s))))))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-ab.ss"
+      (lambda ()
+        (pretty-print '(import (chezscheme) (testfile-wpo-b)))
+        (pretty-print '(define a (make-constant-tree ((1 2 4) 5 (8 10 12)))))
+        (pretty-print '(printf "constant tree: ~s~%" a))
+        (pretty-print '(printf "constant tree value: ~s~%" (tree-value a)))
+        (pretty-print '(printf "constant tree walk: ~s~%" (tree->list a))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      "testfile-wpo-ab")
+    #t)
+
+  (file-exists? "testfile-wpo-a.wpo")
+  (file-exists? "testfile-wpo-b.wpo")
+  (file-exists? "testfile-wpo-ab.wpo")
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-ab.so"))
+    "constant tree: #[tree #[tree #[tree #f 1 #f] 2 #[tree #f 4 #f]] 5 #[tree #[tree #f 8 #f] 10 #[tree #f 12 #f]]]\nconstant tree value: 5\nconstant tree walk: (1 2 4 5 8 10 12)\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x)))
+      "testfile-wpo-ab")
+    "()\n")
+
+  (delete-file "testfile-wpo-a.so")
+  (delete-file "testfile-wpo-b.so")
+  (delete-file "testfile-wpo-ab.so")
+  
+  (equal? 
+    (separate-eval '(load-program "testfile-wpo-ab-all.so"))
+    "constant tree: #[tree #[tree #[tree #f 1 #f] 2 #[tree #f 4 #f]] 5 #[tree #[tree #f 8 #f] 10 #[tree #f 12 #f]]]\nconstant tree value: 5\nconstant tree walk: (1 2 4 5 8 10 12)\n")
+
+  (begin
+    (load-program "testfile-wpo-ab-all.so")
+    #t)
+
+  (not (memq '(testfile-wpo-a) (library-list)))
+  (not (memq '(testfile-wpo-b) (library-list)))
+
+  (begin
+    (with-output-to-file "testfile-wpo-lib.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-lib)
+             (export f)
+             (import (chezscheme))
+             (define (f n) (if (zero? n) 1 (* n (f (- n 1))))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-wpo-lib")
+    (file-exists? "testfile-wpo-lib.wpo"))
+
+  (begin
+    (with-output-to-file "testfile-wpo-prog.ss"
+      (lambda ()
+        (pretty-print '(import (chezscheme)))
+        (pretty-print '(pretty-print (let () (import (testfile-wpo-lib)) (f 10))))
+        (pretty-print '(pretty-print ((top-level-value 'f (environment '(testfile-wpo-lib))) 10))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-program x)))
+      "testfile-wpo-prog")
+    (file-exists? "testfile-wpo-prog.wpo"))
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-prog.so"))
+    "3628800\n3628800\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t))
+      "testfile-wpo-prog")
+    "()\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a-none.so" x) #f))
+      "testfile-wpo-prog")
+    "()\n")
+
+  (delete-file "testfile-wpo-lib.ss")
+  (delete-file "testfile-wpo-lib.so")
+  (delete-file "testfile-wpo-lib.wpo")
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-prog-all.so"))
+    "3628800\n3628800\n")
+
+  (error?
+    (separate-eval '(load-program "testfile-wpo-prog-none.so")))
+
+  (begin
+    (with-output-to-file "testfile-wpo-a3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-a3)
+             (export ! z?)
+             (import (rnrs))
+             (define (z? n) (= n 0))
+             (define (! n) (if (z? n) 1 (* n (! (- n 1))))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-b3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-b3)
+             (export fib !)
+             (import (rnrs) (testfile-wpo-a3))
+             (define (fib n)
+               (cond
+                 [(z? n) 1]
+                 [(z? (- n 1)) 1]
+                 [else (+ (fib (- n 1)) (fib (- n 2)))])))))
+      'replace)
+    (with-output-to-file "testfile-wpo-c3.ss"
+      (lambda ()
+        (pretty-print '(import (testfile-wpo-b3) (chezscheme)))
+        (pretty-print '(pretty-print
+                         (list (fib 10) (! 10)
+                           ((top-level-value 'fib (environment '(testfile-wpo-b3))) 10)
+                           ((top-level-value '! (environment '(testfile-wpo-b3))) 10)
+                           ((top-level-value 'z? (environment '(testfile-wpo-a3))) 10)))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      "testfile-wpo-c3")
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-c3.so"))
+    "(89 3628800 89 3628800 #f)\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
+      "testfile-wpo-c3")
+    "()\n")
+
+  (delete-file "testfile-wpo-a3.ss")
+  (delete-file "testfile-wpo-a3.so")
+  (delete-file "testfile-wpo-a3.wpo")
+  (delete-file "testfile-wpo-b3.ss")
+  (delete-file "testfile-wpo-b3.so")
+  (delete-file "testfile-wpo-b3.wpo")
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-c3-all.so"))
+    "(89 3628800 89 3628800 #f)\n")
+
+  (begin
+    (with-output-to-file "testfile-wpo-a4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-a4)
+             (export !)
+             (import (chezscheme))
+             (define (! n) (if (= n 0) 1 (* n (! (- n 1))))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-b4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-b4)
+             (export fib)
+             (import (chezscheme))
+             (define (fib n) (if (or (= n 0) (= n 1)) 1 (+ (fib (- n 1)) (fib (- n 2))))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-c4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-c4)
+             (export !fib)
+             (import (chezscheme) (testfile-wpo-a4) (testfile-wpo-b4))
+             (define (!fib n) (! (fib n))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-prog4.ss"
+      (lambda ()
+        (pretty-print '(import (chezscheme) (testfile-wpo-c4)))
+        (pretty-print '(pretty-print (!fib 5))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      "testfile-wpo-prog4")
+    #t)
+
+  (delete-file "testfile-wpo-a4.wpo")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
+      'wpo-prog4)
+    "((testfile-wpo-a4))\n")
+
+  (begin
+    (rename-file "testfile-wpo-a4.ss" "testfile-wpo-a4.ss.spam")
+    (rename-file "testfile-wpo-b4.ss" "testfile-wpo-b4.ss.spam")
+    (rename-file "testfile-wpo-c4.ss" "testfile-wpo-c4.ss.spam")
+    (rename-file "testfile-wpo-prog4.ss" "testfile-wpo-prog4.ss.spam")
+    #t)
+
+  (delete-file "testfile-wpo-b4.so")
+  (delete-file "testfile-wpo-b4.wpo")
+  (delete-file "testfile-wpo-c4.so")
+  (delete-file "testfile-wpo-c4.wpo")
+  (delete-file "testfile-wpo-prog4.so")
+  (delete-file "testfile-wpo-prog4.wpo")
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-prog4-all.so"))
+    "40320\n")
+
+  (delete-file "testfile-wpo-a4.so")
+
+  (error? ; library (testfile-wpo-a4) not found
+    (separate-eval '(load-program "testfile-wpo-prog4-all.so")))
+
+  (delete-file "testfile-wpo-prog4-all.so")
+
+  (begin
+    (rename-file "testfile-wpo-a4.ss.spam" "testfile-wpo-a4.ss")
+    (rename-file "testfile-wpo-b4.ss.spam" "testfile-wpo-b4.ss")
+    (rename-file "testfile-wpo-c4.ss.spam" "testfile-wpo-c4.ss")
+    (rename-file "testfile-wpo-prog4.ss.spam" "testfile-wpo-prog4.ss")
+    #t)
+
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      "testfile-wpo-prog4")
+    #t)
+
+  (delete-file "testfile-wpo-c4.wpo")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
+      'wpo-prog4)
+    "((testfile-wpo-c4))\n")
+
+  (delete-file "testfile-wpo-a4.ss")
+  (delete-file "testfile-wpo-b4.ss")
+  (delete-file "testfile-wpo-c4.ss")
+  (delete-file "testfile-wpo-prog4.ss")
+  (delete-file "testfile-wpo-a4.so")
+  (delete-file "testfile-wpo-a4.wpo")
+  (delete-file "testfile-wpo-b4.so")
+  (delete-file "testfile-wpo-b4.wpo")
+  (delete-file "testfile-wpo-prog4.so")
+  (delete-file "testfile-wpo-prog4.wpo")
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-prog4-all.so"))
+    "40320\n")
+
+  (eqv?
+    (separate-eval
+      '(verify-loadability 'load "testfile-wpo-prog4-all.so"))
+    "")
+
+  (delete-file "testfile-wpo-c4.so")
+
+  (error? ; library (testfile-wpo-c4) not found
+    (separate-eval '(load-program "testfile-wpo-prog4-all.so")))
+
+  (begin
+    (with-output-to-file "testfile-wpo-a5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-a5)
+             (export a)
+             (import (chezscheme))
+             (define a
+               (lambda (n)
+                 (+ ((top-level-value 'c (environment '(testfile-wpo-c5)))) n))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-b5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-b5)
+             (export b)
+             (import (chezscheme) (testfile-wpo-a5))
+             (define b (a 10)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-c5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-c5)
+             (export c)
+             (import (chezscheme) (testfile-wpo-a5) (testfile-wpo-b5))
+             (define c (lambda () (+ (a 10) b))))))
+      'replace)
+    (with-output-to-file "testfile-wpo-prog5.ss"
+      (lambda ()
+        (pretty-print '(import (chezscheme) (testfile-wpo-b5) (testfile-wpo-c5)))
+        (pretty-print '(pretty-print (cons (b) c))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      "testfile-wpo-prog5")
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
+      'wpo-prog5)
+    "()\n")
+
+  (error? ; attempt to invoke library (testfile-wpo-c5) while it is still being loaded
+    (separate-eval '(load-program "testfile-wpo-prog5-all.so")))
+
+  (begin
+    (with-output-to-file "testfile-wpo-a6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-a6)
+             (export x a)
+             (import (rnrs))
+             (define x 3)
+             (define z 17)
+             (define-syntax a (identifier-syntax z))
+             (display "invoke a\n"))))
+      'replace)
+    (with-output-to-file "testfile-wpo-b6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-b6)
+             (export y)
+             (import (rnrs) (testfile-wpo-a6))
+             (define counter 9)
+             (define (y) (set! counter (+ counter 5)) (list x counter a))
+             (display "invoke b\n"))))
+      'replace)
+    (with-output-to-file "testfile-wpo-prog6.ss"
+      (lambda ()
+        (pretty-print '(import (testfile-wpo-b6) (rnrs) (only (chezscheme) printf)))
+        (pretty-print '(printf "==== ~s ====" (y)))
+        (pretty-print '(printf "==== ~s ====" (y))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-prog6)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-prog6.so"))
+    "invoke a\ninvoke b\n==== (3 14 17) ======== (3 19 17) ====")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x))))
+      'wpo-prog6)
+    "()\n")
+
+  (delete-file "testfile-wpo-a6.ss")
+  (delete-file "testfile-wpo-a6.so")
+  (delete-file "testfile-wpo-a6.wpo")
+  (delete-file "testfile-wpo-b6.ss")
+  (delete-file "testfile-wpo-b6.so")
+  (delete-file "testfile-wpo-b6.wpo")
+
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-prog6-all.so"))
+    "invoke a\ninvoke b\n==== (3 14 17) ======== (3 19 17) ====")
+
+  (eqv?
+    (separate-eval
+      '(verify-loadability 'load "testfile-wpo-prog6-all.so"))
+    "")
+
+  (begin
+    (with-output-to-file "testfile-wpo-aa7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-aa7)
+             (export ax)
+             (import (chezscheme))
+             (define ax (gensym))
+             (printf "invoking aa\n"))))
+      'replace)
+    (with-output-to-file "testfile-wpo-a7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-a7)
+             (export x)
+             (import (chezscheme) (testfile-wpo-aa7))
+             (define x (cons ax (gensym)))
+             (printf "invoking a\n"))))
+      'replace)
+    (with-output-to-file "testfile-wpo-b7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-b7)
+             (export z)
+             (import (chezscheme) (testfile-wpo-c7))
+             (define z (cons 'b y))
+             (printf "invoking b\n"))))
+      'replace)
+    (with-output-to-file "testfile-wpo-c7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-c7)
+             (export y)
+             (import (chezscheme) (testfile-wpo-a7))
+             (define y (cons 'c x))
+             (printf "invoking c\n"))))
+      'replace)
+    (with-output-to-file "testfile-wpo-ab7.ss"
+      (lambda ()
+        (for-each pretty-print 
+          '((import (chezscheme) (testfile-wpo-c7) (testfile-wpo-a7) (testfile-wpo-b7))
+            (pretty-print (eq? (cdr y) x))
+            (pretty-print (eq? (cdr z) y))
+            (pretty-print (and (eq? (car y) 'c) (eq? (car z) 'b))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-ab7)
+    #t)
+
+  (equal?
+    (separate-eval '(load "testfile-wpo-ab7.so"))
+    "invoking aa\ninvoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
+
+  (delete-file "testfile-wpo-c7.ss")
+  (delete-file "testfile-wpo-c7.wpo")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x))))
+      'wpo-ab7)
+    "((testfile-wpo-c7))\n")
+
+  (equal?
+    (separate-eval '(load "testfile-wpo-ab7-all.so"))
+    "invoking aa\ninvoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
+
+  (begin
+    (with-output-to-file "testfile-wpo-extlib.chezscheme.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-extlib)
+             (export magic)
+             (import (rnrs))
+             (define magic (cons 9 5)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-ext.ss"
+      (lambda ()
+        (pretty-print '(import (chezscheme) (testfile-wpo-extlib)))
+        (pretty-print '(pretty-print magic)))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-ext)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x))))
+      'wpo-ext)
+    "()\n")
+
+  (equal?
+    (separate-eval '(load "testfile-wpo-ext-all.so"))
+    "(9 . 5)\n")
+
+  ; test propagation of #! shell-script line
+  (begin
+    (define $hash-bang-line "#! /usr/bin/scheme --program\n")
+    (delete-file "testfile-wpo-c8.so")
+    (delete-file "testfile-wpo-c8-all.so")
+    (delete-file "testfile-wpo-c8.wpo")
+    (with-output-to-file "testfile-wpo-c8.ss"
+      (lambda ()
+        (display-string $hash-bang-line)
+        (for-each pretty-print
+          '((import (chezscheme))
+            (printf "hello\n"))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-c8)
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x)))
+      'wpo-c8)
+    #t)
+
+  (equal?
+    (separate-eval '(load "testfile-wpo-c8.so"))
+    "hello\n")
+
+  (equal?
+    (separate-eval '(load "testfile-wpo-c8-all.so"))
+    "hello\n")
+
+  (equal?
+    (call-with-port (open-file-input-port "testfile-wpo-c8-all.so")
+      (lambda (ip)
+        (get-bytevector-n ip (string-length $hash-bang-line))))
+    (string->utf8 $hash-bang-line))
+
+  (eqv?
+    (separate-eval
+      '(verify-loadability 'load "testfile-wpo-c8-all.so"))
+    "")
+
+  (begin
+    (mkfile "testfile-wpo-a9.ss"
+      '(library (testfile-wpo-a9)
+         (export x)
+         (import (chezscheme))
+         (define x (eval 'x (environment '(testfile-wpo-a9))))))
+    (mkfile "testfile-wpo-b9.ss"
+      '(import (chezscheme) (testfile-wpo-a9))
+      '(printf "x = ~s\n" x))
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t] [compile-imported-libraries #t])
+           (compile-program x)))
+      'wpo-b9)
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t))
+      'wpo-b9)
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-library (format "~a.wpo" x) (format "~a-all.so" x)))
+      'wpo-a9)
+    #t)
+
+  (error? ; invoke cycle
+    (separate-eval
+      '(load-library "testfile-wpo-a9.so")
+      '(let () (import (testfile-wpo-a9)) x)))
+
+  (error? ; invoke cycle
+    (separate-eval
+      '(load-library "testfile-wpo-a9-all.so")
+      '(let () (import (testfile-wpo-a9)) x)))
+
+  (error? ; invoke cycle
+    (separate-eval
+      '(load-program "testfile-wpo-b9.so")))
+
+  (error? ; invoke cycle
+    (separate-eval
+      '(load-program "testfile-wpo-b9-all.so")))
+
+  (begin
+    (mkfile "testfile-wpo-a10.ss"
+      '(library (testfile-wpo-a10)
+         (export ax)
+         (import (chezscheme))
+         (define ax (cons 'a '()))))
+    (mkfile "testfile-wpo-b10.ss"
+      '(library (testfile-wpo-b10)
+         (export bx)
+         (import (chezscheme) (testfile-wpo-a10))
+         (define bx (cons 'b ax))))
+    (mkfile "testfile-wpo-c10.ss"
+      '(library (testfile-wpo-c10)
+         (export cx)
+         (import (chezscheme) (testfile-wpo-b10))
+         (define cx (cons 'c bx))))
+    (mkfile "testfile-wpo-d10.ss"
+      '(import (chezscheme) (testfile-wpo-c10))
+      '(printf "d: cx = ~s\n" cx))
+    (mkfile "testfile-wpo-e10.ss"
+      '(import (chezscheme) (testfile-wpo-a10))
+      '(printf "e: ax = ~s\n" ax))
+    (mkfile "testfile-wpo-f10.ss"
+      '(import (chezscheme) (testfile-wpo-c10))
+      '(printf "f: cx = ~s\n" cx))
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t]
+                        [compile-imported-libraries #t])
+           (compile-program x)))
+      'wpo-d10)
+    (separate-compile 'compile-program 'wpo-e10)
+    (separate-compile 'compile-program 'wpo-f10)
+    #t)
+  
+  ; cause b10 to be excluded from the whole program
+  (delete-file "testfile-wpo-b10.wpo")
+  
+  (equal?
+    (separate-eval
+      '(compile-whole-program "testfile-wpo-d10.wpo"
+         "testfile-wpo-d10-all.so" #f))
+    "((testfile-wpo-b10))\n")
+  
+  (equal?
+    (separate-eval '(verify-loadability 'visit "testfile-wpo-d10-all.so"))
+    "")
+
+  (equal?
+    (separate-eval '(verify-loadability 'revisit "testfile-wpo-d10-all.so"))
+    "")
+
+  (equal?
+    (separate-eval '(verify-loadability 'load "testfile-wpo-d10-all.so"))
+    "")
+  
+  (equal?
+    (separate-eval '(load-program "testfile-wpo-d10-all.so"))
+    "d: cx = (c b a)\n")
+  
+  ; library a10 must be visible for (excluded library)
+  ; b10's benefit, so e10 can reference its export
+  (equal?
+    (separate-eval
+      '(load-program "testfile-wpo-d10-all.so")
+      '(load-program "testfile-wpo-e10.so"))
+    "d: cx = (c b a)\ne: ax = (a)\n")
+  
+  ; library c10 need not and should not be visible, so f10
+  ; shouldn't be able to reference its export.
+  (error?
+    (separate-eval
+      '(load-program "testfile-wpo-d10-all.so")
+      '(load-program "testfile-wpo-f10.so")))
+
+  (error? ; testfile-wpo-c10 is not visible
+    (separate-eval
+      '(load-program "testfile-wpo-d10-all.so")
+      '(import (testfile-wpo-c10))))
+
+  (equal?
+    (separate-eval
+      '(load-program "testfile-wpo-d10-all.so")
+      '(verify-loadability 'visit "testfile-wpo-f10.so"))
+    "d: cx = (c b a)\n")
+
+  ; verify-loadability should error out trying to invoke
+  ; c10 because c10 is not visible
+  (error? ; not visible
+    (separate-eval
+      '(load-program "testfile-wpo-d10-all.so")
+      '(verify-loadability 'revisit "testfile-wpo-f10.so")))
+
+  (error? ; not visible
+    (separate-eval
+      '(load-program "testfile-wpo-d10-all.so")
+      '(verify-loadability 'load "testfile-wpo-f10.so")))
+
+  (begin
+    (mkfile "testfile-wpo-a11.ss"
+      '(library (testfile-wpo-a11)
+         (export ax)
+         (import (chezscheme))
+         (define ax (cons 'a '()))
+         (printf "invoking a\n")))
+    (parameterize ([generate-wpo-files #t])
+      (compile-library "testfile-wpo-a11"))
+    #t)
+
+  (equal?
+    (compile-whole-library "testfile-wpo-a11.wpo" "testfile-wpo-a11-all.so")
+    '())
+
+  (equal?
+    (separate-eval
+      '(load-library "testfile-wpo-a11.so"))
+    "")
+
+  (equal?
+    (separate-eval
+      '(load-library "testfile-wpo-a11.so")
+      '(let () (import (testfile-wpo-a11)) ax))
+    "invoking a\n(a)\n")
+
+  (equal?
+    (separate-eval
+      '(load-library "testfile-wpo-a11-all.so"))
+    "")
+
+  (equal?
+    (separate-eval
+      '(load-library "testfile-wpo-a11-all.so")
+      '(let () (import (testfile-wpo-a11)) ax))
+    "invoking a\n(a)\n")
+
+  (begin
+    (mkfile "testfile-wpo-a12.ss"
+      '(library (testfile-wpo-a12)
+         (export ax)
+         (import (chezscheme))
+         (define ax (cons 'a '()))))
+    (mkfile "testfile-wpo-b12.ss"
+      '(library (testfile-wpo-b12)
+         (export bx)
+         (import (chezscheme) (testfile-wpo-a12))
+         (define bx (eval 'cx (environment '(testfile-wpo-c12))))))
+    (mkfile "testfile-wpo-c12.ss"
+      '(library (testfile-wpo-c12)
+         (export cx)
+         (import (chezscheme) (testfile-wpo-b12))
+         (define cx (cons 'c bx))))
+    (mkfile "testfile-wpo-d12.ss"
+      '(import (chezscheme) (testfile-wpo-c12))
+      '(printf "d: cx = ~s\n" cx))
+    (parameterize ([generate-wpo-files #t]
+                   [compile-imported-libraries #t])
+      (compile-program "testfile-wpo-d12"))
+    #t)
+  
+  (error? ; cyclc
+    (separate-eval '(load-program "testfile-wpo-d12.so")))
+
+  ; cause b12 to be excluded from the whole library and program
+  (delete-file "testfile-wpo-b12.wpo")
+
+  (equal?
+    (separate-eval
+      '(compile-whole-library "testfile-wpo-c12.wpo"
+         "testfile-wpo-c12-all.so"))
+    "((testfile-wpo-b12))\n")
+  
+  (equal?
+    (separate-eval
+      '(compile-whole-program "testfile-wpo-d12.wpo"
+         "testfile-wpo-d12-all.so" #t))
+    "((testfile-wpo-b12))\n")
+  
+  (equal?
+    (separate-eval
+      '(load-library "testfile-wpo-c12-all.so"))
+    "")
+
+  (error? ; cycle
+    (separate-eval
+      '(load-library "testfile-wpo-c12-all.so")
+      '(let () (import (testfile-wpo-c12)) cx)))
+  
+  (error? ; cycle
+    (separate-eval '(load-program "testfile-wpo-d12-all.so")))
+  
+  ; verify-loadability doesn't catch (dynamic) cycles
+  (equal?
+    (separate-eval
+      '(verify-loadability 'visit "testfile-wpo-c12.so"))
+    "")
+
+  (equal?
+    (separate-eval
+      '(verify-loadability 'revisit "testfile-wpo-c12.so"))
+    "")
+
+  (equal?
+    (separate-eval
+      '(verify-loadability 'load "testfile-wpo-c12.so"))
+    "")
+  
+  ; verify-loadability doesn't catch (dynamic) cycles
+  (equal?
+    (separate-eval
+      '(verify-loadability 'visit "testfile-wpo-d12.so"))
+    "")
+
+  (equal?
+    (separate-eval
+      '(verify-loadability 'revisit "testfile-wpo-d12.so"))
+    "")
+
+  (equal?
+    (separate-eval
+      '(verify-loadability 'load "testfile-wpo-d12.so"))
+    "")
+)
+
+(mat compile-whole-library
+  (begin
+    (with-output-to-file "testfile-cwl-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a1)
+             (export x a)
+             (import (rnrs))
+             (define x 3)
+             (define z 17)
+             (define-syntax a (identifier-syntax z))
+             (display "invoke a\n"))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b1)
+             (export y)
+             (import (rnrs) (testfile-cwl-a1))
+             (define counter 9)
+             (define (y) (set! counter (+ counter 5)) (list x counter a))
+             (display "invoke b\n"))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-cwl-b1")
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-b1)
+    "()\n")
+
+  (begin
+    (rename-file "testfile-cwl-a1.ss" "testfile-cwl-a1.ss.spam")
+    #t)
+
+  (delete-file "testfile-cwl-a1.so")
+  (delete-file "testfile-cwl-a1.wpo")
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b1))
+         (printf ">~s\n" (y))
+         (printf ">~s\n" (y))))
+    "invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
+
+  (eqv?
+    (separate-eval
+      '(verify-loadability 'load "testfile-cwl-b1.so"))
+    "")
+
+  (error? ; library (testfile-cwl-a1) not found
+    (separate-eval
+      '(begin
+         (import (testfile-cwl-a1))
+         (import (testfile-cwl-b1)))))
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b1))
+         (import (testfile-cwl-a1))
+         (printf ">~s\n" (y))
+         (printf ">~s\n" (list a x))))
+    "invoke a\ninvoke b\n>(3 14 17)\n>(17 3)\n")
+
+  (begin
+    (rename-file "testfile-cwl-a1.ss.spam" "testfile-cwl-a1.ss")
+    (with-output-to-file "testfile-cwl-d1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-d1)
+             (export z)
+             (import (rnrs) (testfile-cwl-a1))
+             (define counter 7)
+             (define (z) (set! counter (+ counter 5)) (list x counter a))
+             (display "invoke d\n"))))
+      'replace)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-d1)
+    "compiling testfile-cwl-d1.ss with output to testfile-cwl-d1.so\ncompiling testfile-cwl-a1.ss with output to testfile-cwl-a1.so\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-a2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a2)
+             (export f)
+             (import (chezscheme))
+             (define (f n) (if (zero? n) 1 (* n (f (- n 1))))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-a2)
+    (file-exists? "testfile-cwl-a2.wpo"))
+
+  (begin
+    (with-output-to-file "testfile-cwl-b2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b2)
+             (export main)
+             (import (chezscheme))
+             (define (main)
+               (import (testfile-cwl-a2))
+               ((top-level-value 'f (environment '(testfile-cwl-a2))) 10)))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-cwl-b2")
+    (file-exists? "testfile-cwl-b2.wpo"))
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b2))
+         (main)))
+    "3628800\n")
+
+  (eqv?
+    (separate-eval
+      '(verify-loadability 'load "testfile-cwl-b2.so"))
+    "")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-library (format "~a.wpo" x) (format "~a.so" x)))
+      "testfile-cwl-b2")
+    "()\n")
+
+  (delete-file "testfile-cwl-a2.ss")
+  (delete-file "testfile-cwl-a2.so")
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b2))
+         (main)))
+    "3628800\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-c1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-c1)
+             (export main)
+             (import (chezscheme))
+             (define (main)
+               (import (testfile-cwl-b1))
+               (printf ">~s\n" ((top-level-value 'y (environment '(testfile-cwl-b1)))))
+               (printf ">~s\n" ((top-level-value 'y (environment '(testfile-cwl-b1)))))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-cwl-c1")
+    #t)
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-c1))
+         (main)))
+    "invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-library (format "~a.wpo" x) (format "~a.so" x)))
+      "testfile-cwl-c1")
+    "()\n")
+
+  (delete-file "testfile-cwl-a1.so")
+  (delete-file "testfile-cwl-a1.ss")
+  (delete-file "testfile-cwl-b1.so")
+  (delete-file "testfile-cwl-b1.ss")
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-c1))
+         (main)))
+    "invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-a3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a3)
+             (export ! z?)
+             (import (rnrs))
+             (define (z? n) (= n 0))
+             (define (! n) (if (z? n) 1 (* n (! (- n 1))))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b3)
+             (export fib !)
+             (import (rnrs) (testfile-cwl-a3))
+             (define (fib n)
+               (cond
+                 [(z? n) 1]
+                 [(z? (- n 1)) 1]
+                 [else (+ (fib (- n 1)) (fib (- n 2)))])))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-cwl-b3")
+    #t)
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b3))
+         (import (testfile-cwl-a3))
+         (pretty-print (list (! 10) (fib 10) (z? 10)))))
+    "(3628800 89 #f)\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      "testfile-cwl-b3")
+    "()\n")
+
+  (delete-file "testfile-cwl-a3.so")
+  (delete-file "testfile-cwl-a3.wpo")
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b3))
+         (import (testfile-cwl-a3))
+         (pretty-print (list (! 10) (fib 10) (z? 10)))))
+    "(3628800 89 #f)\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-x4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-x4)
+             (export ack)
+             (import (rnrs))
+             (define (ack m n)
+               (if (= m 0)
+                   (+ n 1)
+                   (if (= n 0)
+                       (ack (- m 1) 1)
+                       (ack (- m 1) (ack m (- n 1)))))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-y4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-y4)
+             (export fact)
+             (import (rnrs))
+             (define (fact n) (if (= n 0) 1 (* n (fact (- n 1))))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-z4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-z4)
+             (export fib)
+             (import (rnrs))
+             (define (fib n)
+               (cond
+                 [(= n 0) 1]
+                 [(= n 1) 1]
+                 [else (+ (fib (- n 1)) (fib (- n 2)))])))))
+      'replace)
+    (with-output-to-file "testfile-cwl-w4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-w4)
+             (export mult)
+             (import (rnrs))
+             (define (mult n m) (if (= n 1) m (+ m (mult (- n 1) m)))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-a4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a4)
+             (export a-stuff)
+             (import (rnrs) (testfile-cwl-x4) (testfile-cwl-y4) (testfile-cwl-z4) (testfile-cwl-b4) (testfile-cwl-c4))
+             (define (a-stuff) (list (ack 3 4) (fib 5) (fact 10))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b4)
+             (export b-stuff)
+             (import (rnrs) (testfile-cwl-x4) (testfile-cwl-w4))
+             (define (b-stuff) (mult 3 (ack 3 4))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-c4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-c4)
+             (export c-stuff)
+             (import (rnrs) (testfile-cwl-y4) (testfile-cwl-w4))
+             (define (c-stuff) (mult 5 (fact 10))))))
+      'replace)
+    #t)
+
+  (begin
+    (define (separate-compile-cwl4)
+      (separate-compile
+        '(lambda (x)
+           (parameterize ([compile-imported-libraries #t]
+                          [generate-wpo-files #t])
+             (compile-library x)))
+        "testfile-cwl-b4")
+      (separate-compile
+        '(lambda (x)
+           (parameterize ([compile-imported-libraries #t]
+                          [generate-wpo-files #t])
+             (compile-library x)))
+        "testfile-cwl-c4")
+      (separate-compile
+        '(lambda (x)
+           (parameterize ([compile-imported-libraries #t]
+                          [generate-wpo-files #t])
+             (compile-library x)))
+        "testfile-cwl-a4")
+      (andmap
+        (lambda (n)
+          (and (file-exists? (format "testfile-cwl-~s4.wpo" n))
+               (file-exists? (format "testfile-cwl-~s4.so" n))))
+        '(a b c x y z w)))
+    #t)
+
+  (begin
+    (define (clear-cwl4-output)
+      (andmap
+        (lambda (n)
+          (and (delete (format "testfile-cwl-~s4.wpo" n))
+               (delete (format "testfile-cwl-~s4.so" n))))
+        '(a b c x y z w)))
+    #t)
+
+  (separate-compile-cwl4)
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-a4))
+         (import (testfile-cwl-b4) (testfile-cwl-c4))
+         (pretty-print (a-stuff))
+         (pretty-print (b-stuff))
+         (pretty-print (c-stuff))))
+    "(125 8 3628800)\n375\n18144000\n")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      "testfile-cwl-a4")
+    "()\n")
+
+  (andmap
+    (lambda (name)
+      (andmap
+        (lambda (ext)
+          (delete-file (format "testfile-cwl-~s4.~s" name ext)))
+        '(so ss wpo)))
+    '(b c x y z w))
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-a4))
+         (import (testfile-cwl-b4) (testfile-cwl-c4))
+         (pretty-print (a-stuff))
+         (pretty-print (b-stuff))
+         (pretty-print (c-stuff))))
+    "(125 8 3628800)\n375\n18144000\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-a5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a5)
+             (export fact)
+             (import (rnrs))
+             (define (fact n) (if (= n 0) 1 (* n (fact (- n 1))))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b5)
+             (export fib+fact)
+             (import (rnrs) (testfile-cwl-a5))
+             (define (fib n) (if (or (= n 0) (= n 1)) 1 (+ (fib (- n 1)) (fib (- n 2)))))
+             (define (fib+fact n) (+ (fib n) (fact n))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-c5.ss"
+      (lambda ()
+        (pretty-print
+          `(library (testfile-cwl-c5)
+             (export ack+fact)
+             (import (rnrs) (testfile-cwl-a5))
+             (define (ack m n)
+               (cond
+                 [(= m 0) (+ n 1)]
+                 [(= n 0) (ack (- m 1) 1)]
+                 [else (ack (- m 1) (ack m (- n 1)))]))
+             (define (ack+fact m n) (+ (ack m n) (fact m) (fact n))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (for-each compile-library x)))
+      '(quote ("testfile-cwl-b5" "testfile-cwl-c5")))
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      "testfile-cwl-b5")
+    "()\n")
+
+  (delete-file "testfile-cwl-a5.ss")
+  (delete-file "testfile-cwl-a5.so")
+  (delete-file "testfile-cwl-a5.wpo")
+
+  (equal?
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b5))
+         (import (testfile-cwl-c5))
+         (list (fib+fact 10) (ack+fact 3 4))))
+    "(3628889 155)\n")
+
+
+  (begin
+    (with-output-to-file "testfile-cwl-a5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a5)
+             (export fact)
+             (import (rnrs))
+             (define (fact n) (if (= n 0) 1 (* n (fact (- n 1))))))))
+      'replace)
+
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (for-each compile-library x)))
+      '(quote ("testfile-cwl-b5" "testfile-cwl-c5")))
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      "testfile-cwl-b5")
+    "()\n")
+
+  (error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-c5))
+         (import (testfile-cwl-b5))
+         (list (fib+fact 10) (ack+fact 3 4)))))
+
+  (error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
+    (separate-eval
+      '(eval '(list (fib+fact 10) (ack+fact 3 4))
+             (environment '(chezscheme) '(testfile-cwl-c5) '(testfile-cwl-b5)))))
+
+  (equal?
+    (separate-eval
+      '(eval '(list (fib+fact 10) (ack+fact 3 4))
+             (environment '(chezscheme) '(testfile-cwl-b5) '(testfile-cwl-c5))))
+    "(3628889 155)\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-d5.ss"
+      (lambda ()
+        (pretty-print
+          '(eval '(list (fib+fact 10) (ack+fact 3 4))
+             (environment '(chezscheme) '(testfile-cwl-c5) '(testfile-cwl-b5)))))
+      'replace)
+    (separate-compile 'cwl-d5)
+    #t)
+
+  (error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
+    (separate-eval '(load "testfile-cwl-d5.so")))
+
+  (begin
+    (with-output-to-file "testfile-cwl-d5.ss"
+      (lambda ()
+        (pretty-print
+          '(eval '(list (fib+fact 10) (ack+fact 3 4))
+             (environment '(chezscheme) '(testfile-cwl-b5) '(testfile-cwl-c5)))))
+      'replace)
+    (separate-compile 'cwl-d5)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      "testfile-cwl-c5")
+    "()\n")
+
+  (delete-file "testfile-cwl-a5.ss")
+  (delete-file "testfile-cwl-a5.so")
+  (delete-file "testfile-cwl-a5.wpo")
+
+  (error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-c5))
+         (import (testfile-cwl-b5))
+         (list (fib+fact 10) (ack+fact 3 4)))))
+
+  (error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
+    (separate-eval
+      '(let ()
+         (import (testfile-cwl-b5))
+         (import (testfile-cwl-c5))
+         (list (fib+fact 10) (ack+fact 3 4)))))
+
+  (begin
+    (with-output-to-file "testfile-cwl-a6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a6)
+             (export !)
+             (import (chezscheme))
+             (define (! n) (if (= n 0) 1 (* n (! (- n 1))))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b6)
+             (export fib)
+             (import (chezscheme))
+             (define (fib n) (if (or (= n 0) (= n 1)) 1 (+ (fib (- n 1)) (fib (- n 2))))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-c6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-c6)
+             (export !fib)
+             (import (chezscheme) (testfile-cwl-a6) (testfile-cwl-b6))
+             (define (!fib n) (! (fib n))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-d6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-d6)
+             (export runit)
+             (import (chezscheme) (testfile-cwl-c6))
+             (define (runit) (pretty-print (!fib 5)))
+             (display "invoking d6\n"))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-cwl-d6")
+    #t)
+
+  (delete-file "testfile-cwl-a6.wpo")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-d6)
+    "((testfile-cwl-a6))\n")
+
+  (begin
+    (rename-file "testfile-cwl-a6.ss" "testfile-cwl-a6.ss.spam")
+    (rename-file "testfile-cwl-b6.ss" "testfile-cwl-b6.ss.spam")
+    (rename-file "testfile-cwl-c6.ss" "testfile-cwl-c6.ss.spam")
+    (rename-file "testfile-cwl-d6.ss" "testfile-cwl-d6.ss.spam")
+    #t)
+
+  (delete-file "testfile-cwl-b6.so")
+  (delete-file "testfile-cwl-b6.wpo")
+  (delete-file "testfile-cwl-c6.so")
+  (delete-file "testfile-cwl-c6.wpo")
+  (delete-file "testfile-cwl-d6.wpo")
+
+  (equal?
+    (separate-eval '(begin (import (testfile-cwl-d6)) (runit)))
+    "invoking d6\n40320\n")
+
+  (delete-file "testfile-cwl-a6.so")
+
+  (error? ; cannot find a6
+    (separate-eval '(begin (import (testfile-cwl-d6)) (runit))))
+
+  (delete-file "testfile-cwl-d6.so")
+
+  (begin
+    (rename-file "testfile-cwl-a6.ss.spam" "testfile-cwl-a6.ss")
+    (rename-file "testfile-cwl-b6.ss.spam" "testfile-cwl-b6.ss")
+    (rename-file "testfile-cwl-c6.ss.spam" "testfile-cwl-c6.ss")
+    (rename-file "testfile-cwl-d6.ss.spam" "testfile-cwl-d6.ss")
+    #t)
+
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      "testfile-cwl-d6")
+    #t)
+
+  (delete-file "testfile-cwl-c6.wpo")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-d6)
+    "((testfile-cwl-c6))\n")
+
+  (delete-file "testfile-cwl-a6.so")
+  (delete-file "testfile-cwl-a6.wpo")
+  (delete-file "testfile-cwl-b6.so")
+  (delete-file "testfile-cwl-b6.wpo")
+  (delete-file "testfile-cwl-d6.wpo")
+  (delete-file "testfile-cwl-a6.ss")
+  (delete-file "testfile-cwl-b6.ss")
+  (delete-file "testfile-cwl-c6.ss")
+  (delete-file "testfile-cwl-d6.ss")
+
+  (equal?
+    (separate-eval '(begin (import (testfile-cwl-d6)) (runit)))
+    "invoking d6\n40320\n")
+
+  (delete-file "testfile-cwl-c6.so")
+
+  (error? ; cannot find c6
+    (separate-eval '(begin (import (testfile-cwl-d6)) (runit))))
+
+  (begin
+    (with-output-to-file "testfile-cwl-a7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a7)
+             (export x)
+             (import (chezscheme))
+             (define $x (make-parameter 1))
+             (define-syntax x (identifier-syntax ($x)))
+             (printf "invoking a\n"))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b7)
+             (export z)
+             (import (chezscheme) (testfile-cwl-c7))
+             (define $z (make-parameter (+ y 1)))
+             (define-syntax z (identifier-syntax ($z)))
+             (printf "invoking b\n"))))
+      'replace)
+    (with-output-to-file "testfile-cwl-c7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-c7)
+             (export y)
+             (import (chezscheme) (testfile-cwl-a7))
+             (define $y (make-parameter (+ x 1)))
+             (define-syntax y (identifier-syntax ($y)))
+             (printf "invoking c\n"))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-b7)
+    #t)
+
+  (delete-file "testfile-cwl-c7.wpo")
+  (delete-file "testfile-cwl-c7.ss")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) "testfile-cwl-ab7.so")))
+      'cwl-b7)
+    "((testfile-cwl-c7))\n")
+
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-a7))
+      '(write x)
+      '(newline)
+      '(import (testfile-cwl-b7))
+      '(write z)
+      '(newline)
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+    "invoking a\n1\ninvoking c\ninvoking b\n3\n2\n")
+
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-a7))
+      '(write x)
+      '(newline)
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline)
+      '(import (testfile-cwl-b7))
+      '(write z)
+      '(newline))
+    "invoking a\n1\ninvoking c\n2\ninvoking b\n3\n")
+
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-a7))
+      '(write x)
+      '(newline)
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+  "invoking a\n1\ninvoking c\n2\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-b7))
+      '(write z)
+      '(newline)
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+    "invoking a\ninvoking c\ninvoking b\n3\n2\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-a7))
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+    "invoking a\ninvoking c\n2\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-b7))
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+    "invoking a\ninvoking c\n2\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-a7) (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+    "invoking a\ninvoking c\n2\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-c7) (testfile-cwl-b7))
+      '(write y)
+      '(newline))
+    "invoking a\ninvoking c\n2\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cwl-ab7.so")
+      '(import (testfile-cwl-c7))
+      '(write y)
+      '(newline))
+    "invoking a\ninvoking c\n2\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-a8.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a8)
+             (export x)
+             (import (chezscheme))
+             (define x (gensym))
+             (printf "invoking a\n"))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b8.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b8)
+             (export z)
+             (import (chezscheme) (testfile-cwl-c8))
+             (define z (cons 'b y))
+             (printf "invoking b\n"))))
+      'replace)
+    (with-output-to-file "testfile-cwl-c8.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-c8)
+             (export y)
+             (import (chezscheme) (testfile-cwl-a8))
+             (define y (cons 'c x))
+             (printf "invoking c\n"))))
+      'replace)
+    (with-output-to-file "testfile-cwl-d8.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-cwl-d8)
+             (export runit)
+             (import (chezscheme) (testfile-cwl-c8) (testfile-cwl-a8) (testfile-cwl-b8))
+             (define (runit yes?)
+               (pretty-print (eq? (cdr y) x))
+               (pretty-print (eq? (cdr z) y))
+               (pretty-print (and (eq? (car y) 'c) (eq? (car z) 'b)))
+               (when yes? (eq? (eval 'x (environment '(testfile-cwl-a8))) x))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-d8)
+    #t)
+
+  (equal?
+    (separate-eval '(begin (import (testfile-cwl-d8)) (runit #f)))
+    "invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
+
+  (equal?
+    (separate-eval '(begin (import (testfile-cwl-d8)) (runit #t)))
+    "invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n#t\n")
+
+  (delete-file "testfile-cwl-c8.ss")
+  (delete-file "testfile-cwl-c8.wpo")
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-d8)
+    "((testfile-cwl-c8))\n")
+
+  (equal?
+     (separate-eval '(begin (import (testfile-cwl-d8)) (runit #f)))
+    "invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
+
+  (equal?
+    (separate-eval '(begin (import (testfile-cwl-d8)) (runit #t)))
+    "invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n#t\n")
+
+  (begin
+    (with-output-to-file "testfile-cwl-a9.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when (visit)
+             (library (testfile-cwl-a9)
+               (export x)
+               (import (chezscheme))
+               (define x 5)))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-a9)
+    #t)
+
+  (error? ; found visit-only run-time library (testfile-cwl-a9)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-a9))
+
+  (begin
+    (with-output-to-file "testfile-cwl-a10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a10)
+             (export f x)
+             (import (chezscheme) (testfile-cwl-b10))
+             (define f (lambda (x) (* x 17)))
+             (define x 5))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b10)
+             (export g y)
+             (import (chezscheme))
+             (define g (lambda (x) (+ x 23)))
+             (define y 37))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-a10)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-a10)
+    #t)
+
+  (delete-file "testfile-cwl-a10.ss")
+  (delete-file "testfile-cwl-a10.wpo")
+  (delete-file "testfile-cwl-b10.ss")
+  (delete-file "testfile-cwl-b10.so")
+  (delete-file "testfile-cwl-b10.wpo")
+
+  (test-cp0-expansion
+    `(let ()
+       (import (testfile-cwl-a10) (testfile-cwl-b10))
+       (+ (f (g y)) x))
+    `(begin
+       (#3%$invoke-library '(testfile-cwl-b10) '() ',gensym?)
+       (#3%$invoke-library '(testfile-cwl-a10) '() ',gensym?)
+       1025))
+
+  (begin
+    (with-output-to-file "testfile-cwl-a11.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a11)
+             (export f x)
+             (import (chezscheme) (testfile-cwl-b11))
+             (define f (lambda (x) (* x 17)))
+             (define x 5))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b11.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b11)
+             (export g y)
+             (import (chezscheme))
+             (define g (lambda (x) (+ x 23)))
+             (define y 37))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-a11)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t] [run-cp0 (lambda (cp0 x) x)])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-a11)
+    #t)
+
+  (delete-file "testfile-cwl-a11.ss")
+  (delete-file "testfile-cwl-a11.wpo")
+  (delete-file "testfile-cwl-b11.ss")
+  (delete-file "testfile-cwl-b11.so")
+  (delete-file "testfile-cwl-b11.wpo")
+
+  (test-cp0-expansion
+    `(let ()
+       (import (testfile-cwl-a11) (testfile-cwl-b11))
+       (+ (f (g y)) x))
+    `(begin
+       (#3%$invoke-library '(testfile-cwl-b11) '() ',gensym?)
+       (#3%$invoke-library '(testfile-cwl-a11) '() ',gensym?)
+       ,(lambda (x) (not (eqv? x 1025)))))
+
+  (begin
+    (delete-file "testfile-cwl-a12.so")
+    (delete-file "testfile-cwl-a12.wpo")
+    (delete-file "testfile-cwl-b12.so")
+    (delete-file "testfile-cwl-b12.wpo")
+    (with-output-to-file "testfile-cwl-a12.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a12)
+             (export f)
+             (import (chezscheme))
+             (define f (lambda (x) (* x 17))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b12.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b12)
+             (export g f)
+             (import (chezscheme) (testfile-cwl-a12))
+             (define g (lambda (x) (+ x 23))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-b12)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'cwl-b12)
+    #t)
+  
+  (equal?
+    (separate-eval '(let () (import (testfile-cwl-b12)) (list (f 3) (g 5))))
+    "(51 28)\n")
+
+  (begin
+    (delete-file "testfile-cwl-a13.so")
+    (delete-file "testfile-cwl-a13.wpo")
+    (delete-file "testfile-cwl-b13.so")
+    (delete-file "testfile-cwl-b13.wpo")
+    (delete-file "testfile-cwl-c13.so")
+    (delete-file "testfile-cwl-c13.wpo")
+    (with-output-to-file "testfile-cwl-a13.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-a13)
+             (export a)
+             (import (chezscheme))
+             (define-syntax a (identifier-syntax f))
+             (define f (lambda (x) (* x 17))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-b13.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-cwl-b13)
+             (export g a)
+             (import (chezscheme) (testfile-cwl-a13))
+             (define g (lambda (x) (a x))))))
+      'replace)
+    (with-output-to-file "testfile-cwl-c13.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme) (testfile-cwl-b13))
+            (pretty-print (list (g 3) (a 5) (eval '(a 7) (environment '(testfile-cwl-a13))))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-library x)))
+      'cwl-a13)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f])
+           (compile-library x)))
+      'cwl-b13)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-program x)))
+      'cwl-c13)
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a.so" x)))
+      'cwl-c13)
+    #t)
+  
+  (equal?
+    (separate-eval '(load-program "testfile-cwl-c13.so"))
+    "(51 85 119)\n")
+
+  (begin
+    (with-output-to-file "testfile-wpo-extlib-1.chezscheme.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-extlib-1)
+             (export magic)
+             (import (rnrs))
+             (define magic (cons 9 5)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-extlib-2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-extlib-2)
+             (export p)
+             (import (chezscheme) (testfile-wpo-extlib))
+             (define p
+               (lambda ()
+                 (pretty-print magic))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-library x)))
+      'wpo-extlib-2)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #t])
+           (compile-whole-library (format "~a.wpo" x) (format "~a-all.so" x))))
+      'wpo-extlib-2)
+    "()\n")
+
+  (equal?
+    (separate-eval '(let () (import (testfile-wpo-extlib-2)) (p)))
+    "(9 . 5)\n")
+
+  ;; regression tests from @owaddell generated to fix problems he encountered
+  ;; with compile-whole-library from a test generator.
+  (begin
+    (with-output-to-file "testfile-wpo-coconut.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-coconut)
+             (export coconut apple->coconut)
+             (import (scheme))
+             (define $init (list '_))
+             (define apple->coconut (cons 'apple->coconut $init))
+             (define coconut (list 'coconut apple->coconut $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-banana.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-banana)
+             (export banana apple->banana)
+             (import (scheme))
+             (define $init (list '_))
+             (define apple->banana (cons 'apple->banana $init))
+             (define banana (list 'banana apple->banana $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-apple.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-apple)
+             (export apple)
+             (import (scheme) (testfile-wpo-banana) (testfile-wpo-coconut))
+             (define $init
+               (list
+                 '_
+                 (cons 'apple->banana apple->banana)
+                 (cons 'apple->coconut apple->coconut)))
+             (define apple (list 'apple $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-main.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-wpo-banana) (testfile-wpo-coconut) (testfile-wpo-apple)))
+        (pretty-print '(pretty-print banana))
+        (pretty-print '(pretty-print coconut))
+        (pretty-print '(pretty-print apple)))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-main)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-coconut)
+    "()\n")
+
+  (begin
+    (delete-file "testfile-wpo-coconut.wpo")
+    #t)
+  
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-apple)
+    "((testfile-wpo-coconut))\n")
+
+  (begin
+    (delete-file "testfile-wpo-banana.wpo")
+    (delete-file "testfile-wpo-apple.wpo")
+    (delete-file "testfile-wpo-banana.so")
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([library-search-handler
+                         (let ([lsh (library-search-handler)])
+                           (lambda (who name dirs exts)
+                             (lsh who (if (equal? name '(testfile-wpo-banana))
+                                          '(testfile-wpo-apple)
+                                          name)
+                               dirs exts)))])
+           (compile-whole-program (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-main)
+    "((testfile-wpo-apple)\n  (testfile-wpo-banana)\n  (testfile-wpo-coconut))\n")
+
+  (equal?
+    (separate-eval 
+      '(parameterize ([library-search-handler
+                        (let ([lsh (library-search-handler)])
+                          (lambda (who name dirs exts)
+                            (lsh who (if (equal? name '(testfile-wpo-banana))
+                                         '(testfile-wpo-apple)
+                                         name)
+                                 dirs exts)))])
+         (load-program "testfile-wpo-main.so")))
+    (string-append
+      "(banana (apple->banana _) (_))\n"
+      "(coconut (apple->coconut _) (_))\n"
+      "(apple\n  (_ (apple->banana apple->banana _)\n     (apple->coconut apple->coconut _)))\n"))
+
+  (begin
+    ;; clean-up to make sure previous builds don't get in the way.
+    (delete-file "testfile-wpo-coconut.ss")
+    (delete-file "testfile-wpo-coconut.so")
+    (delete-file "testfile-wpo-coconut.wpo")
+
+    (delete-file "testfile-wpo-banana.ss")
+    (delete-file "testfile-wpo-banana.so")
+    (delete-file "testfile-wpo-banana.wpo")
+
+    (delete-file "testfile-wpo-apple.ss")
+    (delete-file "testfile-wpo-apple.so")
+    (delete-file "testfile-wpo-apple.wpo")
+
+    (delete-file "testfile-wpo-main.ss")
+    (delete-file "testfile-wpo-main.so")
+    (delete-file "testfile-wpo-main.wpo")
+
+    #t)
+
+  (begin
+    (with-output-to-file "testfile-wpo-coconut.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-coconut)
+             (export coconut banana->coconut apple->coconut)
+             (import (scheme))
+             (define $init (list '_))
+             (define banana->coconut (cons 'banana->coconut $init))
+             (define apple->coconut (cons 'apple->coconut $init))
+             (define coconut
+               (list 'coconut banana->coconut apple->coconut $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-date.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-date)
+             (export date apple->date)
+             (import (scheme))
+             (define $init (list '_))
+             (define apple->date (cons 'apple->date $init))
+             (define date (list 'date apple->date $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-apple.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-apple)
+             (export apple)
+             (import (scheme) (testfile-wpo-date) (testfile-wpo-coconut))
+             (define $init
+               (list
+                 '_
+                 (cons 'apple->date apple->date)
+                 (cons 'apple->coconut apple->coconut)))
+             (define apple (list 'apple $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-banana.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-banana)
+             (export banana)
+             (import (scheme) (testfile-wpo-coconut))
+             (define $init
+               (list '_ (cons 'banana->coconut banana->coconut)))
+             (define banana (list 'banana $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-main.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-wpo-date)
+                         (testfile-wpo-banana) (testfile-wpo-coconut)
+                         (testfile-wpo-apple)))
+        (pretty-print '(pretty-print date))
+        (pretty-print '(pretty-print banana))
+        (pretty-print '(pretty-print coconut))
+        (pretty-print '(pretty-print apple)))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-main)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-coconut)
+    "()\n")
+
+  (begin
+    (delete-file "testfile-wpo-coconut.wpo")
+    #t)
+  
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-apple)
+    "((testfile-wpo-coconut))\n")
+
+  (begin
+    (delete-file "testfile-wpo-date.wpo")
+    (delete-file "testfile-wpo-apple.wpo")
+    (delete-file "testfile-wpo-date.so")
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([library-search-handler
+                         (let ([lsh (library-search-handler)])
+                           (lambda (who name dirs exts)
+                             (lsh who (if (equal? name '(testfile-wpo-date))
+                                          '(testfile-wpo-apple)
+                                          name)
+                               dirs exts)))])
+           (compile-whole-program (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-main)
+    "((testfile-wpo-apple)\n  (testfile-wpo-date)\n  (testfile-wpo-coconut))\n")
+
+  (equal?
+    (separate-eval 
+      '(parameterize ([library-search-handler
+                       (let ([lsh (library-search-handler)])
+                         (lambda (who name dirs exts)
+                           (lsh who (if (equal? name '(testfile-wpo-date))
+                                        '(testfile-wpo-apple)
+                                        name)
+                             dirs exts)))])
+         (load-program "testfile-wpo-main.so")))
+    (string-append
+      "(date (apple->date _) (_))\n"
+      "(banana (_ (banana->coconut banana->coconut _)))\n"
+      "(coconut (banana->coconut _) (apple->coconut _) (_))\n"
+      "(apple\n"
+      "  (_ (apple->date apple->date _)\n"
+      "     (apple->coconut apple->coconut _)))\n"))
+
+  (begin
+    ;; clean-up to make sure previous builds don't get in the way.
+    (delete-file "testfile-wpo-coconut.ss")
+    (delete-file "testfile-wpo-coconut.so")
+    (delete-file "testfile-wpo-coconut.wpo")
+
+    (delete-file "testfile-wpo-date.ss")
+    (delete-file "testfile-wpo-date.so")
+    (delete-file "testfile-wpo-date.wpo")
+
+    (delete-file "testfile-wpo-banana.ss")
+    (delete-file "testfile-wpo-banana.so")
+    (delete-file "testfile-wpo-banana.wpo")
+
+    (delete-file "testfile-wpo-apple.ss")
+    (delete-file "testfile-wpo-apple.so")
+    (delete-file "testfile-wpo-apple.wpo")
+
+    (delete-file "testfile-wpo-main.ss")
+    (delete-file "testfile-wpo-main.so")
+    (delete-file "testfile-wpo-main.wpo")
+
+    #t)
+
+  (begin
+    (with-output-to-file "testfile-wpo-date.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-date)
+             (export date apple->date)
+             (import (scheme))
+             (define $init (list '_))
+             (define apple->date (cons 'apple->date $init))
+             (define date (list 'date apple->date $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-eel.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-eel)
+             (export eel coconut->eel apple->eel)
+             (import (scheme))
+             (define $init (list '_))
+             (define coconut->eel (cons 'coconut->eel $init))
+             (define apple->eel (cons 'apple->eel $init))
+             (define eel (list 'eel coconut->eel apple->eel $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-coconut.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-coconut)
+             (export coconut banana->coconut apple->coconut)
+             (import (scheme) (testfile-wpo-eel))
+             (define $init (list '_ (cons 'coconut->eel coconut->eel)))
+             (define banana->coconut (cons 'banana->coconut $init))
+             (define apple->coconut (cons 'apple->coconut $init))
+             (define coconut
+               (list 'coconut banana->coconut apple->coconut $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-apple.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-apple)
+             (export apple)
+             (import (scheme) (testfile-wpo-date) (testfile-wpo-coconut)
+               (testfile-wpo-eel))
+             (define $init
+               (list
+                 '_
+                 (cons 'apple->date apple->date)
+                 (cons 'apple->coconut apple->coconut)
+                 (cons 'apple->eel apple->eel)))
+             (define apple (list 'apple $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-banana.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-wpo-banana)
+             (export banana)
+             (import (scheme) (testfile-wpo-coconut))
+             (define $init
+               (list '_ (cons 'banana->coconut banana->coconut)))
+             (define banana (list 'banana $init)))))
+      'replace)
+    (with-output-to-file "testfile-wpo-main.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-wpo-date)
+                         (testfile-wpo-banana) (testfile-wpo-coconut)
+                         (testfile-wpo-apple) (testfile-wpo-eel)))
+        (pretty-print '(pretty-print date))
+        (pretty-print '(pretty-print banana))
+        (pretty-print '(pretty-print coconut))
+        (pretty-print '(pretty-print apple))
+        (pretty-print '(pretty-print eel)))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t]
+                        [generate-wpo-files #t])
+           (compile-program x)))
+      'wpo-main)
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-coconut)
+    "()\n")
+
+  (begin
+    (delete-file "testfile-wpo-eel.wpo")
+    (delete-file "testfile-wpo-coconut.wpo")
+    (delete-file "testfile-wpo-eel.so")
+    #t)
+  
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-wpo-files #f]
+                        [library-search-handler
+                         (let ([lsh (library-search-handler)])
+                           (lambda (who name dirs exts)
+                             (lsh who (if (equal? name '(testfile-wpo-eel))
+                                          '(testfile-wpo-coconut)
+                                          name)
+                               dirs exts)))])
+           (compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-apple)
+    "((testfile-wpo-coconut) (testfile-wpo-eel))\n")
+
+  (begin
+    (delete-file "testfile-wpo-date.wpo")
+    (delete-file "testfile-wpo-apple.wpo")
+    (delete-file "testfile-wpo-date.so")
+    #t)
+
+  (equal?
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([library-search-handler
+                         (let ([lsh (library-search-handler)])
+                           (lambda (who name dirs exts)
+                             (lsh who (cond
+                                        [(equal? name '(testfile-wpo-date)) '(testfile-wpo-apple)]
+                                        [(equal? name '(testfile-wpo-eel)) '(testfile-wpo-coconut)]
+                                        [else name])
+                               dirs exts)))])
+           (compile-whole-program (format "~a.wpo" x) (format "~a.so" x))))
+      'wpo-main)
+    "((testfile-wpo-apple)\n  (testfile-wpo-date)\n  (testfile-wpo-coconut)\n  (testfile-wpo-eel))\n")
+
+  (equal?
+    (separate-eval 
+      '(parameterize ([library-search-handler
+                       (let ([lsh (library-search-handler)])
+                         (lambda (who name dirs exts)
+                           (lsh who (cond
+                                      [(equal? name '(testfile-wpo-date)) '(testfile-wpo-apple)]
+                                      [(equal? name '(testfile-wpo-eel)) '(testfile-wpo-coconut)]
+                                      [else name])
+                             dirs exts)))])
+         (load-program "testfile-wpo-main.so")))
+    (string-append
+      "(date (apple->date _) (_))\n"
+      "(banana\n"
+      "  (_ (banana->coconut\n"
+      "       banana->coconut\n"
+      "       _\n"
+      "       (coconut->eel coconut->eel _))))\n"
+      "(coconut\n"
+      "  (banana->coconut _ (coconut->eel coconut->eel _))\n"
+      "  (apple->coconut _ (coconut->eel coconut->eel _))\n"
+      "  (_ (coconut->eel coconut->eel _)))\n"
+      "(apple\n"
+      "  (_ (apple->date apple->date _)\n"
+      "     (apple->coconut\n"
+      "       apple->coconut\n"
+      "       _\n"
+      "       (coconut->eel coconut->eel _))\n"
+      "     (apple->eel apple->eel _)))\n"
+      "(eel (coconut->eel _) (apple->eel _) (_))\n"))
+
+  (begin
+    ;; clean-up to make sure previous builds don't get in the way.
+    (delete-file "testfile-wpo-coconut.ss")
+    (delete-file "testfile-wpo-coconut.so")
+    (delete-file "testfile-wpo-coconut.wpo")
+
+    (delete-file "testfile-wpo-eel.ss")
+    (delete-file "testfile-wpo-eel.so")
+    (delete-file "testfile-wpo-eel.wpo")
+
+    (delete-file "testfile-wpo-date.ss")
+    (delete-file "testfile-wpo-date.so")
+    (delete-file "testfile-wpo-date.wpo")
+
+    (delete-file "testfile-wpo-banana.ss")
+    (delete-file "testfile-wpo-banana.so")
+    (delete-file "testfile-wpo-banana.wpo")
+
+    (delete-file "testfile-wpo-apple.ss")
+    (delete-file "testfile-wpo-apple.so")
+    (delete-file "testfile-wpo-apple.wpo")
+
+    (delete-file "testfile-wpo-main.ss")
+    (delete-file "testfile-wpo-main.so")
+    (delete-file "testfile-wpo-main.wpo")
+
+    #t)
+
+  (begin
+    (with-output-to-file "testfile-deja-vu-one.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-deja-vu-one)
+            (export a)
+            (import (scheme))
+            (define a 3))))
+      'replace)
+    (with-output-to-file "testfile-deja-vu-two.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-deja-vu-two)
+            (export b)
+            (import (scheme) (testfile-deja-vu-one))
+            (define b (list 'b a)))))
+      'replace)
+    (with-output-to-file "testfile-deja-vu-dup.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-deja-vu-dup)
+            (export d)
+            (import (scheme) (testfile-deja-vu-one))
+            (define d (list a 'd)))))
+      'replace)
+    (with-output-to-file "testfile-deja-vu-main.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (scheme) (testfile-deja-vu-one) (testfile-deja-vu-two) (testfile-deja-vu-dup))
+            (pretty-print (list a b d)))))
+      'replace)
+    (separate-eval
+     '(parameterize ([generate-wpo-files #t])
+        (compile-library "testfile-deja-vu-one")
+        (compile-library "testfile-deja-vu-two")
+        (compile-library "testfile-deja-vu-dup")
+        (compile-program "testfile-deja-vu-main")
+        (compile-whole-library "testfile-deja-vu-one.wpo" "testfile-deja-vu-one.done")
+        (compile-whole-library "testfile-deja-vu-two.wpo" "testfile-deja-vu-two.done")
+        (compile-whole-library "testfile-deja-vu-dup.wpo" "testfile-deja-vu-dup.done")))
+    #t)
+
+  (error?
+   (separate-eval
+    '(compile-whole-program "testfile-deja-vu-main.wpo" "testfile-deja-vu-main.done")))
+
+  (begin
+    (do ([stem '("one" "two" "dup" "main") (cdr stem)]) ((null? stem))
+      (do ([ext '("ss" "so" "wpo" "done") (cdr ext)]) ((null? ext))
+        (delete-file (format "testfile-deja-vu-~a.~a" (car stem) (car ext)))))
+    #t)
+
+  ; verify compatibility of generate-covin-files and generate-wpo-files
+  (begin
+    (mkfile "testfile-cwl-a14.ss"
+      '(library (testfile-cwl-a14) (export a) (import (scheme)) (define a 123)))
+    (parameterize ([generate-covin-files #t]
+                   [generate-wpo-files #t])
+      (compile-library "testfile-cwl-a14")
+      (compile-whole-library "testfile-cwl-a14.wpo" "testfile-cwl-a14.library"))
+    #t)
+
+  (file-exists? "testfile-cwl-a14.covin")
+
+  (eqv?
+    (let () (import (testfile-cwl-a14)) a)
+    123)
+
+  (eqv?
+    (separate-eval
+      '(verify-loadability 'load "testfile-cwl-a14.library"))
+    "")
+)
+
+(mat maybe-compile-whole
+  (begin
+    (delete-file "testfile-mcw-a1.so")
+    (delete-file "testfile-mcw-a1.wpo")
+    (delete-file "testfile-mcw-b1.so")
+    (delete-file "testfile-mcw-b1.wpo")
+    (delete-file "testfile-mcw-c1.so")
+    (delete-file "testfile-mcw-c1.wpo")
+    (with-output-to-file "testfile-mcw-ha1.ss"
+      (lambda ()
+        (pretty-print
+          '(define minor-msg-number 97)))
+      'replace)
+    (with-output-to-file "testfile-mcw-hb1.ss"
+      (lambda ()
+        (pretty-print
+          '(define major-msg-number 113)))
+      'replace)
+    (with-output-to-file "testfile-mcw-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mcw-a1)
+             (export a)
+             (import (chezscheme))
+             (define a "hello from a"))))
+      'replace)
+    (with-output-to-file "testfile-mcw-b1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mcw-b1)
+             (export b)
+             (import (chezscheme) (testfile-mcw-a1))
+             (include "testfile-mcw-ha1.ss")
+             (define b (lambda () (format "~a and b [~s]" a minor-msg-number))))))
+      'replace)
+    (with-output-to-file "testfile-mcw-c1.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (chezscheme) (testfile-mcw-b1))
+            (include "testfile-mcw-hb1.ss")
+            (printf "~a and c [~s]\n" (b) major-msg-number))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (compile-program x)))
+      'mcw-c1)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-mcw-c1.so"))
+    "hello from a and b [97] and c [113]\n")
+
+  (begin
+    (with-output-to-file "testfile-mcw-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mcw-a1)
+             (export a)
+             (import (chezscheme))
+             (define a "greetings from a"))))
+      'replace)
+    (touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (maybe-compile-program x)))
+      'mcw-c1)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-mcw-c1.so"))
+    "greetings from a and b [97] and c [113]\n")
+
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (compile-whole-program (format "~a.wpo" x) (format "~a.so" x)) #f)
+      'mcw-c1)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-mcw-c1.so"))
+    "greetings from a and b [97] and c [113]\n")
+
+  (begin
+    (with-output-to-file "testfile-mcw-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mcw-a1)
+             (export a)
+             (import (chezscheme))
+             (define a "salutations from a"))))
+      'replace)
+    (touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (parameterize ([compile-program-handler
+                            (lambda (ifn ofn)
+                              (compile-program ifn ofn)
+                              (compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
+             (maybe-compile-program x))))
+      'mcw-c1)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-mcw-c1.so"))
+    "salutations from a and b [97] and c [113]\n")
+
+  (begin
+    (with-output-to-file "testfile-mcw-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mcw-a1)
+             (export a)
+             (import (chezscheme))
+             (define a "goodbye from a"))))
+      'replace)
+    (touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (parameterize ([compile-program-handler
+                            (lambda (ifn ofn)
+                              (compile-program ifn ofn)
+                              (compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
+             (maybe-compile-program x))))
+      'mcw-c1)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-mcw-c1.so"))
+    "goodbye from a and b [97] and c [113]\n")
+
+  (begin
+    (with-output-to-file "testfile-mcw-hb1.ss"
+      (lambda ()
+        (pretty-print
+          '(define major-msg-number 773)))
+      'replace)
+    (touch "testfile-mcw-c1.so" "testfile-mcw-hb1.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (parameterize ([compile-program-handler
+                            (lambda (ifn ofn)
+                              (compile-program ifn ofn)
+                              (compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
+             (maybe-compile-program x))))
+      'mcw-c1)
+    #t)
+
+  (equal?
+    (separate-eval '(load-program "testfile-mcw-c1.so"))
+    "goodbye from a and b [97] and c [773]\n")
+
+  (begin
+    (with-output-to-file "testfile-mcw-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mcw-a1)
+             (export a)
+             (import (chezscheme))
+             (define a "hello again from a"))))
+      'replace)
+    (touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (parameterize ([compile-library-handler
+                            (lambda (ifn ofn)
+                              (compile-library ifn ofn)
+                              (compile-whole-library (format "~a.wpo" (path-root ofn)) ofn))])
+             (maybe-compile-library x))))
+      'mcw-b1)
+    #t)
+
+  (equal?
+    (separate-eval '(let () (import (testfile-mcw-b1)) (printf "~a\n" (b))))
+    "hello again from a and b [97]\n")
+
+  (begin
+    (with-output-to-file "testfile-mcw-ha1.ss"
+      (lambda ()
+        (pretty-print
+          '(define minor-msg-number -53)))
+      'replace)
+    (touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+           (parameterize ([compile-library-handler
+                            (lambda (ifn ofn)
+                              (compile-library ifn ofn)
+                              (compile-whole-library (format "~a.wpo" (path-root ofn)) ofn))])
+             (maybe-compile-library x))))
+      'mcw-b1)
+    #t)
+
+  (equal?
+    (separate-eval '(let () (import (testfile-mcw-b1)) (printf "~a\n" (b))))
+    "hello again from a and b [-53]\n")
+)
+
+(mat library-manager
+  (begin
+    (with-output-to-file "testfile-lm-a.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-lm-a)
+            (export ct-a rt-a)
+            (import (scheme))
+            (meta define ct-a (begin (display "ct-a rhs\n") 123))
+            (define rt-a (begin (display "rt-a rhs\n") 456)))))
+      'replace)
+    (with-output-to-file "testfile-lm-b.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-lm-b)
+            (export b)
+            (import (scheme) (testfile-lm-a))
+            (define-syntax (use-ct-val x) (if (odd? ct-a) #'"odd" #'"even"))
+            (define b use-ct-val))))
+      'replace)
+    (with-output-to-file "testfile-lm-c.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-lm-c)
+            (export c)
+            (import (scheme) (testfile-lm-a))
+            (define use-rt-val rt-a)
+            (define c use-rt-val))))
+      'replace)
+    (with-output-to-file "testfile-lm-combined.ss"
+      (lambda ()
+        (pretty-print
+         '(begin
+            (include "testfile-lm-a.ss")
+            (include "testfile-lm-b.ss")
+            (include "testfile-lm-c.ss"))))
+      'replace)
+    (with-output-to-file "testfile-lm-use-b.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-lm-use-b)
+            (export x)
+            (import (scheme) (testfile-lm-b))
+            (meta define x b))))
+      'replace)
+    (with-output-to-file "testfile-lm-use-c.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-lm-use-c)
+            (export x)
+            (import (scheme) (testfile-lm-c))
+            (define-syntax (x x) c))))
+      'replace)
+    #t)
+  (equal?
+   (separate-eval
+    '(import-notify #t)
+    '(compile-library "testfile-lm-a"))
+   (string-append
+    "compiling testfile-lm-a.ss with output to testfile-lm-a.so\n"
+    "ct-a rhs\n"))
+  (equal?
+   (separate-eval
+    '(import-notify #t)
+    '(library-extensions '((".ss" . ".so")))
+    '(compile-library "testfile-lm-b")
+    '(printf "b = ~s\n" (let () (import (testfile-lm-b)) b)))
+   (string-append
+    "compiling testfile-lm-b.ss with output to testfile-lm-b.so\n"
+    "import: found source file \"testfile-lm-a.ss\"\n"
+    "import: found corresponding object file \"testfile-lm-a.so\"\n"
+    "import: object file is not older\n"
+    "import: visiting object file \"testfile-lm-a.so\"\n"
+    "ct-a rhs\n"
+    "b = \"odd\"\n"))
+  (equal?
+   (separate-eval
+    '(import-notify #t)
+    '(library-extensions '((".ss" . ".so")))
+    '(compile-library "testfile-lm-c")
+    '(printf "c = ~s\n" (let () (import (testfile-lm-c)) c)))
+   (string-append
+    "compiling testfile-lm-c.ss with output to testfile-lm-c.so\n"
+    "import: found source file \"testfile-lm-a.ss\"\n"
+    "import: found corresponding object file \"testfile-lm-a.so\"\n"
+    "import: object file is not older\n"
+    "import: visiting object file \"testfile-lm-a.so\"\n"
+    "attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
+    "rt-a rhs\n"
+    "c = 456\n"))
+  (equal?
+   ;; library manager revisits object file containing a single library
+   ;; to resolve dependencies after earlier visit
+   (separate-eval
+    '(import-notify #t)
+    '(library-extensions '((".ss" . ".so")))
+    '(visit "testfile-lm-a.so")
+    '(let () (import (testfile-lm-c)) c))
+   (string-append
+    "import: found source file \"testfile-lm-c.ss\"\n"
+    "import: found corresponding object file \"testfile-lm-c.so\"\n"
+    "import: object file is not older\n"
+    "import: visiting object file \"testfile-lm-c.so\"\n"
+    "import: attempting to 'revisit' previously 'visited' \"testfile-lm-c.so\" for library (testfile-lm-c) run-time info\n"
+    "import: attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
+    "rt-a rhs\n"
+    "456\n"))
+  (equal?
+   ;; library manager visits object file containing a single library
+   ;; to resolve dependencies after earlier revisit
+   (separate-eval
+    '(import-notify #t)
+    '(library-extensions '((".ss" . ".so")))
+    '(revisit "testfile-lm-a.so")
+    '(let () (import (testfile-lm-b)) b))
+   (string-append
+    "import: found source file \"testfile-lm-b.ss\"\n"
+    "import: found corresponding object file \"testfile-lm-b.so\"\n"
+    "import: object file is not older\n"
+    "import: visiting object file \"testfile-lm-b.so\"\n"
+    "import: attempting to 'visit' previously 'revisited' \"testfile-lm-a.so\" for library (testfile-lm-a) compile-time info\n"
+    "import: attempting to 'revisit' previously 'visited' \"testfile-lm-b.so\" for library (testfile-lm-b) run-time info\n"
+    "\"odd\"\n"))
+  (equal?
+   (separate-eval
+    '(import-notify #t)
+    '(library-extensions '((".ss" . ".so")))
+    '(compile-file "testfile-lm-combined"))
+   (string-append
+    "compiling testfile-lm-combined.ss with output to testfile-lm-combined.so\n"
+    "ct-a rhs\n"))
+  (equal?
+   ;; library manager revisits object file containing related libraries
+   ;; to resolve dependencies after earlier visit
+   (separate-eval
+    '(import-notify #t)
+    '(visit "testfile-lm-combined.so")
+    '(let ()
+       (import (testfile-lm-a))
+       (define-syntax (foo x) ct-a)
+       (printf "foo = ~s\n" foo))
+    '(let () (import (testfile-lm-c)) c))
+   (string-append
+    "ct-a rhs\n"
+    "foo = 123\n"
+    "import: attempting to 'revisit' previously 'visited' \"testfile-lm-combined.so\" for library (testfile-lm-c) run-time info\n"
+    "rt-a rhs\n"
+    "456\n"))
+  (equal?
+   ;; library manager visits object file containing related libraries
+   ;; to resolve dependencies after earlier revisit
+   (separate-eval
+    '(import-notify #t)
+    '(revisit "testfile-lm-combined.so")
+    '(let ()
+       (import (testfile-lm-a))
+       (define foo rt-a)
+       (printf "foo = ~s\n" foo))
+    '(let () (import (testfile-lm-b)) b))
+   (string-append
+    "import: attempting to 'visit' previously 'revisited' \"testfile-lm-combined.so\" for library (testfile-lm-a) compile-time info\n"
+    "rt-a rhs\n"
+    "foo = 456\n"
+    "\"odd\"\n"))
+  (equal?
+   ;; library manager does not revisit due to earlier load
+   (separate-eval
+    '(import-notify #t)
+    '(load "testfile-lm-combined.so")
+    '(let ()
+       (import (testfile-lm-a))
+       (define-syntax (foo x) ct-a)
+       (printf "foo = ~s\n" foo))
+    '(let () (import (testfile-lm-c)) c))
+   (string-append
+    "ct-a rhs\n"
+    "foo = 123\n"
+    "rt-a rhs\n"
+    "456\n"))
+  (equal?
+   ;; library manager does not revisit due to earlier load
+   (separate-eval
+    '(import-notify #t)
+    '(load "testfile-lm-combined.so")
+    '(let ()
+       (import (testfile-lm-a))
+       (define foo rt-a)
+       (printf "foo = ~s\n" foo))
+    '(let () (import (testfile-lm-b)) b))
+   (string-append
+    "rt-a rhs\n"
+    "foo = 456\n"
+    "\"odd\"\n"))
+  )
+
+(mat verify-loadability
+  (error? ; invalid argument
+    (verify-loadability 'never))
+  (error? ; invalid argument
+    (verify-loadability 'never "hello.so"))
+  (error? ; invalid argument
+    (verify-loadability #f "hello.so" "goodbye.so"))
+  (error? ; invalid argument
+    (verify-loadability 'load 'hello))
+  (error? ; invalid argument
+    (verify-loadability 'load '(a . "testdir")))
+  (error? ; invalid argument
+    (verify-loadability 'load '#("a" "testdir")))
+  (error? ; invalid argument
+    (verify-loadability 'load "testfile1.so" "testfile2.so" 'hello))
+  (error? ; invalid argument
+    (verify-loadability 'load "testfile1.so" "testfile2.so" '(a . "testdir")))
+  (error? ; invalid argument
+    (verify-loadability 'load '("a" . hello)))
+  (error? ; invalid argument
+    (verify-loadability 'load '("a" . ("src" . "obj"))))
+  (error? ; invalid argument
+    (verify-loadability 'load '("a" . (("src" "obj")))))
+  (error? ; invalid argument
+    (verify-loadability 'load '("a" . ((("src" "obj"))))))
+  (begin
+    (define install
+      (lambda (dir . fn*)
+        (for-each
+          (lambda (fn)
+            (call-with-port (open-file-input-port fn)
+              (lambda (ip)
+                (call-with-port (open-file-output-port (format "~a/~a" dir (path-last fn)))
+                  (lambda (op)
+                    (put-bytevector op (get-bytevector-all ip)))))))
+          fn*)))
+    #t)
+  (eq? (verify-loadability 'visit) (void))
+  (eq? (verify-loadability 'revisit) (void))
+  (eq? (verify-loadability 'load) (void))
+  (error? ; not found
+    (verify-loadability 'load "probably not found"))
+  (begin
+    (mkfile "testfile-clA.ss"
+      '(import (chezscheme) (testfile-clB) (testfile-clC))
+      '(printf "~a, ~a\n" b c))
+    (mkfile "testfile-clB.ss"
+      '(library (testfile-clB)
+         (export b)
+         (import (chezscheme) (testfile-clB1))
+         (define-syntax go (lambda (x) (datum->syntax #'* (b1))))
+         (define b (go))))
+    (mkfile "testfile-clB1.ss"
+      '(library (testfile-clB1)
+         (export b1)
+         (import (chezscheme))
+         (define b1 (lambda () "hello from B1"))))
+    (mkfile "testfile-clC.ss"
+      '(library (testfile-clC)
+         (export c)
+         (import (chezscheme) (testfile-clC1))
+         (define c (c1))))
+    (mkfile "testfile-clC1.ss"
+      '(library (testfile-clC1)
+         (export c1)
+         (import (chezscheme))
+         (define-syntax c1 (syntax-rules () [(_) "hello from C1"]))))
+    (rm-rf "testdir-obj1")
+    (rm-rf "testdir-obj2")
+    (mkdir "testdir-obj1")
+    (mkdir "testdir-obj2")
+    (separate-eval
+      '(parameterize ([library-directories '(("." . "testdir-obj1"))] [compile-imported-libraries #t])
+         (compile-program "testfile-clA.ss" "testdir-obj1/testfile-clA.so")))
+    (separate-eval
+      '(parameterize ([library-directories '(("." . "testdir-obj2"))] [compile-imported-libraries #t])
+         (compile-program "testfile-clA.ss" "testdir-obj2/testfile-clA.so")))
+    #t)
+  (begin
+    (rm-rf "testdir-dist1")
+    (mkdir "testdir-dist1")
+    (install "testdir-dist1" "testdir-obj1/testfile-clA.so" "testdir-obj1/testfile-clB.so" "testdir-obj1/testfile-clC.so")
+    #t)
+  (eqv?
+    (separate-eval
+      '(parameterize ([cd "testdir-dist1"])
+         (verify-loadability 'visit "testfile-clA.so")
+         (verify-loadability 'revisit "testfile-clA.so")
+         (verify-loadability 'load "testfile-clA.so")))
+    "")
+  (equal?
+    (separate-eval
+      '(parameterize ([cd "testdir-dist1"])
+         (load-program "testfile-clA.so")))
+    "hello from B1, hello from C1\n")
+  (error? ; missing B1
+    (separate-eval
+      '(parameterize ([cd "testdir-dist1"])
+         (verify-loadability 'visit "testfile-clB.so"))))
+  (error? ; missing B1
+    (separate-eval
+      '(parameterize ([cd "testdir-dist1"])
+         (verify-loadability 'load "testfile-clB.so"))))
+  (error? ; missing C1
+    (separate-eval
+      '(parameterize ([cd "testdir-dist1"])
+         (verify-loadability 'visit "testfile-clC.so"))))
+  (error? ; missing C1
+    (separate-eval
+      '(parameterize ([cd "testdir-dist1"])
+         (verify-loadability 'load "testfile-clC.so"))))
+  (begin
+    (rm-rf "testdir-dist2")
+    (mkdir "testdir-dist2")
+    (install "testdir-dist2" "testdir-obj2/testfile-clA.so" "testdir-obj2/testfile-clB.so" "testdir-obj2/testfile-clC.so")
+    #t)
+  (equal?
+    (separate-eval
+      '(parameterize ([cd "testdir-dist2"])
+         (load-program "testfile-clA.so")))
+    "hello from B1, hello from C1\n")
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(verify-loadability 'revisit
+         '("testdir-dist1/testfile-clA.so" . "testdir-dist1")
+         '("testdir-dist2/testfile-clA.so" . "testdir-dist2"))))
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(verify-loadability 'load
+         '("testdir-dist1/testfile-clA.so" . "testdir-dist1")
+         '("testdir-dist2/testfile-clA.so" . "testdir-dist2"))))
+  (begin
+    (rm-rf "testdir-dist3")
+    (mkdir "testdir-dist3")
+    (install "testdir-dist3" "testdir-obj1/testfile-clA.so" "testdir-obj1/testfile-clB.so" "testdir-obj2/testfile-clC.so")
+    #t)
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(parameterize ([cd "testdir-dist3"])
+         (load-program "testfile-clA.so"))))
+  (eqv? ; no compile-time requirements, so no problem
+    (separate-eval
+      '(parameterize ([cd "testdir-dist3"])
+         (verify-loadability 'visit "testfile-clA.so")))
+    "")
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(parameterize ([cd "testdir-dist3"])
+         (verify-loadability 'revisit "testfile-clA.so"))))
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(parameterize ([cd "testdir-dist3"])
+         (verify-loadability 'load "testfile-clA.so"))))
+  (equal?
+    (separate-eval
+      '(parameterize ([cd "testdir-dist3"])
+         (unless (guard (c [else (printf "yes\n")]) (verify-loadability 'load "testfile-clA.so") #f)
+           (errorf #f "oops")))
+      '(parameterize ([cd "testdir-dist1"])
+         (printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
+      '(parameterize ([cd "testdir-dist2"])
+         (printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
+      '(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
+         (printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1)))))
+      '(parameterize ([cd "testdir-dist1"])
+         (load-program "testfile-clA.so"))
+      '(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
+         (printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1))))))
+    "yes\n#\n#\n(#f #f #f #f)\nhello from B1, hello from C1\n(#t #f #t #f)\n")
+  (equal?
+    (separate-eval
+      '(parameterize ([cd "testdir-dist3"])
+         (unless (guard (c [else (printf "yes\n")]) (verify-loadability 'load "testfile-clA.so") #f)
+           (errorf #f "oops")))
+      '(parameterize ([cd "testdir-dist1"])
+         (printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
+      '(parameterize ([cd "testdir-dist2"])
+         (printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
+      '(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
+         (printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1)))))
+      '(parameterize ([cd "testdir-dist2"])
+         (load-program "testfile-clA.so"))
+      '(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
+         (printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1))))))
+    "yes\n#\n#\n(#f #f #f #f)\nhello from B1, hello from C1\n(#t #f #t #f)\n")
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(parameterize ([library-directories '(("testdir-dist1" . "testdir-dist1"))])
+         (verify-loadability 'load "testdir-dist2/testfile-clA.so"))))
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(parameterize ([library-directories '(("testdir-dist1" . "testdir-dist1"))])
+         (verify-loadability 'load "testdir-dist1/testfile-clA.so" "testdir-dist2/testfile-clA.so"))))
+  (begin
+    (mkfile "testfile-clPD.ss"
+      '(import (chezscheme) (testfile-clD))
+      '(printf "~s\n" (make-Q)))
+    (mkfile "testfile-clPE.ss"
+      '(import (chezscheme) (testfile-clE))
+      '(printf "~s\n" (make-Q 73)))
+    (mkfile "testfile-clD.ss"
+      '(library (testfile-clD) (export make-Q Q? Q-x) (import (chezscheme) (testfile-clF))
+         (define-record-type Q
+           (nongenerative Q)
+           (fields x)
+           (protocol (lambda (new) (lambda () (new f)))))))
+    (mkfile "testfile-clE.ss"
+      '(library (testfile-clE) (export make-Q Q? Q-x) (import (chezscheme) (testfile-clG))
+         (define-record-type Q
+           (nongenerative Q)
+           (fields x y)
+           (protocol (lambda (new) (lambda (y) (new g y)))))))
+    (mkfile "testfile-clF.ss"
+      '(library (testfile-clF) (export f) (import (chezscheme)) (define f 77)))
+    (mkfile "testfile-clG.ss"
+      '(library (testfile-clG) (export g) (import (chezscheme)) (define g 123)))
+    (rm-rf "testdir-obj")
+    (mkdir "testdir-obj")
+    (separate-eval
+      '(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
+         (compile-program "testfile-clPD.ss" "testdir-obj/testfile-clPD.so")))
+    (separate-eval
+      '(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
+         (compile-program "testfile-clPE.ss" "testdir-obj/testfile-clPE.so")))
+    #t)
+  (begin
+    (rm-rf "testdir-dist")
+    (mkdir "testdir-dist")
+    (install "testdir-dist" "testdir-obj/testfile-clPD.so" "testdir-obj/testfile-clD.so" "testdir-obj/testfile-clF.so")
+    (install "testdir-dist" "testdir-obj/testfile-clPE.so" "testdir-obj/testfile-clE.so" "testdir-obj/testfile-clG.so")
+    #t)
+  (error? ; incompatible record-type Q
+    (separate-eval
+      '(cd "testdir-dist")
+      '(load-program "testfile-clPD.so")
+      '(load-program "testfile-clPE.so")))
+  (equal?
+    (separate-eval
+      '(cd "testdir-dist")
+      '(verify-loadability 'visit "testfile-clPD.so" "testfile-clPE.so")
+      '(verify-loadability 'visit "testfile-clD.so" "testfile-clE.so")
+      '(verify-loadability 'visit "testfile-clF.so" "testfile-clG.so")
+      '(verify-loadability 'revisit "testfile-clPD.so" "testfile-clPE.so")
+      '(verify-loadability 'revisit "testfile-clD.so" "testfile-clE.so")
+      '(verify-loadability 'revisit "testfile-clF.so" "testfile-clG.so")
+      '(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so")
+      '(verify-loadability 'load "testfile-clD.so" "testfile-clE.so")
+      '(verify-loadability 'load "testfile-clF.so" "testfile-clG.so")
+      '(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so" "testfile-clD.so" "testfile-clE.so" "testfile-clF.so" "testfile-clG.so")
+      '(load-program "testfile-clPD.so")
+      '(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so"))
+    "#[Q 77]\n")
+  (equal?
+    (separate-eval
+      '(cd "testdir-dist")
+      '(verify-loadability 'visit "testfile-clPD.so" "testfile-clE.so")
+      '(verify-loadability 'visit "testfile-clD.so" "testfile-clE.so")
+      '(verify-loadability 'visit "testfile-clF.so" "testfile-clG.so")
+      '(verify-loadability 'revisit "testfile-clPD.so" "testfile-clE.so")
+      '(verify-loadability 'revisit "testfile-clD.so" "testfile-clE.so")
+      '(verify-loadability 'revisit "testfile-clF.so" "testfile-clG.so")
+      '(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so")
+      '(verify-loadability 'load "testfile-clD.so" "testfile-clE.so")
+      '(verify-loadability 'load "testfile-clF.so" "testfile-clG.so")
+      '(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so" "testfile-clD.so" "testfile-clE.so" "testfile-clF.so" "testfile-clG.so")
+      '(load-program "testfile-clPE.so")
+      '(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so"))
+    "#[Q 123 73]\n")
+  (begin
+    (mkfile "testfile-clH0.ss"
+      '(library (testfile-clH0) (export h0) (import (chezscheme))
+         (define h0 (lambda (x) (cons x 'a)))))
+    (mkfile "testfile-clH1.ss"
+      '(top-level-program
+         (import (chezscheme) (testfile-clH0))
+         (printf "~s\n" (h0 73))))
+    (mkfile "testfile-clH2.ss"
+      '(include "testfile-clH0.ss")
+      '(top-level-program
+         (import (chezscheme) (testfile-clH0))
+         (printf "~s\n" (h0 37))))
+    (rm-rf "testdir-obj")
+    (mkdir "testdir-obj")
+    (separate-eval
+      '(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
+         (compile-file "testfile-clH1.ss" "testdir-obj/testfile-clH1.so")))
+    (separate-eval
+      '(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
+         (compile-file "testfile-clH2.ss" "testdir-obj/testfile-clH2.so")))
+    #t)
+  (equal?
+    (separate-eval
+      '(parameterize ([library-directories '(("testdir-obj" . "testdir-obj"))])
+         (revisit "testdir-obj/testfile-clH1.so")))
+    "(73 . a)\n")
+  (equal?
+    (separate-eval
+      '(parameterize ([library-directories '(("testdir-obj" . "testdir-obj"))])
+         (revisit "testdir-obj/testfile-clH2.so")))
+    "(37 . a)\n")
+  (eqv?
+    (separate-eval
+      '(let ([libdirs '(("testdir-obj" . "testdir-obj"))])
+         (verify-loadability 'revisit (cons "testdir-obj/testfile-clH1.so" libdirs) (cons "testdir-obj/testfile-clH2.so" libdirs))))
+    "")
+  (error? ; mismatched compilation instance
+    (separate-eval
+      '(let ([libdirs '(("testdir-obj" . "testdir-obj"))])
+         (verify-loadability 'revisit (cons "testdir-obj/testfile-clH2.so" libdirs) (cons "testdir-obj/testfile-clH1.so" libdirs)))))
+
+  ; make sure verify-loadability respects eval-when forms
+  (begin
+    (mkfile "testfile-clI0.ss"
+      '(library (testfile-clI0) (export x) (import (chezscheme)) (define x 10) (printf "invoking I0\n")))
+    (mkfile "testfile-clI1.ss"
+      '(eval-when (visit)
+         (top-level-program
+           (import (chezscheme) (testfile-clI0))
+           (printf "running I1, x = ~s\n" x))))
+    (separate-eval
+      '(parameterize ([compile-imported-libraries #t])
+         (compile-file "testfile-clI1")))
+    #t)
+  (equal?
+    (separate-eval '(visit "testfile-clI1.so"))
+    "invoking I0\nrunning I1, x = 10\n")
+  (equal?
+    (separate-eval '(revisit "testfile-clI1.so"))
+    "")
+  (equal?
+    (separate-eval '(load "testfile-clI1.so"))
+    "invoking I0\nrunning I1, x = 10\n")
+  (eq?
+    (verify-loadability 'visit "testfile-clI1.so")
+    (void))
+  (eq?
+    (verify-loadability 'revisit "testfile-clI1.so")
+    (void))
+  (eq?
+    (verify-loadability 'load "testfile-clI1.so")
+    (void))
+  (delete-file "testfile-clI0.ss")
+  (delete-file "testfile-clI0.so")
+  (error?
+    (verify-loadability 'visit "testfile-clI1.so"))
+  (eq?
+    (verify-loadability 'revisit "testfile-clI1.so")
+    (void))
+  (error?
+    (verify-loadability 'load "testfile-clI1.so"))
+
+  ; make sure compile-whole-program preserves the information verify-loadability needs
+  (begin
+    (mkfile "testfile-clJ0.ss"
+      '(library (testfile-clJ0) (export x0) (import (chezscheme)) (define x0 'eat) (printf "invoking J0\n")))
+    (mkfile "testfile-clJ1.ss"
+      '(library (testfile-clJ1) (export x1) (import (chezscheme) (testfile-clJ0)) (define x1 (list x0 'oats)) (printf "invoking J1\n")))
+    (mkfile "testfile-clJ2.ss"
+      '(library (testfile-clJ2) (export x2) (import (chezscheme) (testfile-clJ1)) (define x2 (cons 'mares x1)) (printf "invoking J2\n")))
+    (mkfile "testfile-clJ3.ss"
+      '(import (chezscheme) (testfile-clJ2))
+      '(printf "running J3, x2 = ~s\n" x2))
+    (separate-eval
+      '(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+         (compile-program "testfile-clJ3")))
+    #t)
+
+  (equal?
+    (separate-eval '(verify-loadability 'load "testfile-clJ3.so"))
+    "")
+
+  (equal?
+    (separate-eval '(load-program "testfile-clJ3.so"))
+    "invoking J0\ninvoking J1\ninvoking J2\nrunning J3, x2 = (mares eat oats)\n")
+
+  (delete-file "testfile-clJ0.ss")
+  (delete-file "testfile-clJ0.wpo")
+  (delete-file "testfile-clJ2.ss")
+  (delete-file "testfile-clJ2.wpo")
+
+  ((lambda (x ls) (and (member x ls) #t))
+    (separate-eval
+      '(compile-whole-program "testfile-clJ3.wpo" "testfile-clJ3-all.so"))
+    '("((testfile-clJ0) (testfile-clJ2))\n"
+      "((testfile-clJ2) (testfile-clJ0))\n"))
+
+  (delete-file "testfile-clJ1.ss")
+  (delete-file "testfile-clJ1.wpo")
+  (delete-file "testfile-clJ1.so")
+
+  (equal?
+    (separate-eval '(verify-loadability 'load "testfile-clJ3-all.so"))
+    "")
+
+  (equal?
+    (separate-eval '(load-program "testfile-clJ3-all.so"))
+    "invoking J0\ninvoking J1\ninvoking J2\nrunning J3, x2 = (mares eat oats)\n")
+
+  (eq?
+    (rename-file "testfile-clJ0.so" "testfile-clJ0.sav")
+    (void))
+
+  (error? ; missing testfile-clJ0.so
+    (separate-eval '(verify-loadability 'load "testfile-clJ3-all.so")))
+
+  (error? ; missing testfile-clJ0.so
+    (separate-eval '(load-program "testfile-clJ3-all.so")))
+
+  (eq?
+    (rename-file "testfile-clJ0.sav" "testfile-clJ0.so")
+    (void))
+
+  (delete-file "testfile-clJ2.so")
+
+  (error? ; missing testfile-clJ2.so
+    (separate-eval '(verify-loadability 'load "testfile-clJ3-all.so")))
+
+  (error? ; missing testfile-clJ2.so
+    (separate-eval '(load-program "testfile-clJ3-all.so")))
+
+  (begin
+    (mkfile "testfile-clK0.ss"
+      '(library (testfile-clK0) (export x0) (import (chezscheme)) (define x0 "chocolate") (printf "invoking K0\n")))
+    (mkfile "testfile-clK1.ss"
+      '(library (testfile-clK1) (export x1) (import (chezscheme) (testfile-clK0)) (define x1 (format "~a chip" x0)) (printf "invoking K1\n")))
+    (mkfile "testfile-clK2.ss"
+      '(import (chezscheme) (testfile-clK1))
+      '(printf "running K2, x1 = ~s\n" x1))
+    (separate-eval
+      '(parameterize ([compile-imported-libraries #t])
+         (compile-program "testfile-clK2")))
+    #t)
+  (eq?
+    (verify-loadability 'visit "testfile-clK1.so")
+    (void))
+  (eq?
+    (verify-loadability 'revisit "testfile-clK1.so")
+    (void))
+  (eq?
+    (verify-loadability 'load "testfile-clK1.so")
+    (void))
+  (eq?
+    (verify-loadability 'visit "testfile-clK1.so" "testfile-clK2.so")
+    (void))
+  (eq?
+    (verify-loadability 'revisit "testfile-clK1.so" "testfile-clK2.so")
+    (void))
+  (eq?
+    (verify-loadability 'load "testfile-clK1.so" "testfile-clK2.so")
+    (void))
+  (eq?
+    (verify-loadability 'visit "testfile-clK2.so" "testfile-clK1.so")
+    (void))
+  (eq?
+    (verify-loadability 'revisit "testfile-clK2.so" "testfile-clK1.so")
+    (void))
+  (eq?
+    (verify-loadability 'load "testfile-clK2.so" "testfile-clK1.so")
+    (void))
+  (equal?
+    (separate-eval
+      '(visit "testfile-clK1.so")
+      '(let () (import (testfile-clK1)) x1))
+    "invoking K0\ninvoking K1\n\"chocolate chip\"\n")
+  (equal?
+    (separate-eval '(revisit "testfile-clK2.so"))
+    "invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
+  (eq?
+    (strip-fasl-file "testfile-clK0.so" "testfile-clK0.so"
+      (fasl-strip-options compile-time-information))
+    (void))
+  (error? ; missing compile-time info for K0
+    (verify-loadability 'visit "testfile-clK1.so"))
+  (eq?
+    (verify-loadability 'revisit "testfile-clK1.so")
+    (void))
+  (error? ; missing compile-time info for K0
+    (verify-loadability 'load "testfile-clK1.so"))
+  (error? ; missing compile-time info
+    (separate-eval
+      '(visit "testfile-clK1.so")
+      '(let () (import (testfile-clK1)) x1)))
+  (equal?
+    (separate-eval '(revisit "testfile-clK2.so"))
+    "invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
+)
+
+(mat concatenate-object-files
+  (begin
+    (define install
+      (lambda (dir . fn*)
+        (for-each
+          (lambda (fn)
+            (call-with-port (open-file-input-port fn)
+              (lambda (ip)
+                (call-with-port (open-file-output-port (format "~a/~a" dir (path-last fn)))
+                  (lambda (op)
+                    (put-bytevector op (get-bytevector-all ip)))))))
+          fn*)))
+    (define test-isolated-load
+      (lambda (fn lib val)
+        (rm-rf "testdir-isolated")
+        (mkdir "testdir-isolated")
+        (install "testdir-isolated" fn)
+        (separate-eval
+          `(cd "testdir-isolated")
+          `(load ,fn)
+          `(let ()
+             (import ,lib)
+             ,val))))
+    #t)
+  (begin
+    (mkfile "testfile-catlibA.ss"
+      '(library (testfile-catlibA)
+         (export a)
+         (import (chezscheme))
+         (define a 1)))
+    (mkfile "testfile-catlibB.ss"
+      '(library (testfile-catlibB)
+         (export a b)
+         (import (chezscheme) (testfile-catlibA))
+         (define b 2)))
+    (mkfile "testfile-catlibC.ss"
+      '(library (testfile-catlibC)
+         (export c)
+         (import (chezscheme) (testfile-catlibB))
+         (define c (+ a b))))
+    (separate-eval
+      '(compile-library "testfile-catlibA.ss" "testfile-catlibA.so"))
+    (separate-eval
+      '(compile-library "testfile-catlibB.ss" "testfile-catlibB.so"))
+    (separate-eval
+      '(compile-library "testfile-catlibC.ss" "testfile-catlibC.so"))
+    #t)
+  (eqv?
+    (separate-eval
+      '(begin
+         (concatenate-object-files "testfile-catlibAB.so" "testfile-catlibA.so" "testfile-catlibB.so")
+         (concatenate-object-files "testfile-catlibBC.so" "testfile-catlibB.so" "testfile-catlibC.so")
+         (concatenate-object-files "testfile-catlibABC.so" "testfile-catlibA.so" "testfile-catlibB.so" "testfile-catlibC.so")))
+    "")
+  (equal?
+    (test-isolated-load "testfile-catlibA.so" '(testfile-catlibA) 'a)
+    "1\n")
+  (error? ; can't find (testfile-catlibA)
+    (test-isolated-load "testfile-catlibB.so" '(testfile-catlibB) 'b))
+  (error? ; can't find (testfile-catlibA)
+    (test-isolated-load "testfile-catlibBC.so" '(testfile-catlibC) 'c))
+  (equal?
+    (test-isolated-load "testfile-catlibABC.so" '(testfile-catlibA) 'a)
+    "1\n")
+  (equal?
+    (test-isolated-load "testfile-catlibABC.so" '(testfile-catlibB) 'b)
+    "2\n")
+  (equal?
+    (test-isolated-load "testfile-catlibABC.so" '(testfile-catlibC) 'c)
+    "3\n")
+  (equal?
+    (test-isolated-load "testfile-catlibAB.so" '(testfile-catlibB) 'b)
+    "2\n")
+  (begin
+    (mkfile "testfile-cof1A.ss"
+      '(library (testfile-cof1A) (export a) (import (chezscheme))
+         (define-syntax a (identifier-syntax 45))))
+    (mkfile "testfile-cof1B.ss"
+      '(library (testfile-cof1B) (export b) (import (chezscheme) (testfile-cof1A))
+         (define b (lambda () (* a 2)))))
+    (mkfile "testfile-cof1P.ss"
+      '(import (chezscheme) (testfile-cof1A) (testfile-cof1B))
+      '(printf "a = ~s, (b) = ~s\n" a (b)))
+    (mkfile "testfile-cof1foo.ss"
+      '(printf "hello from foo!\n"))
+    (mkfile "testfile-cof1bar.ss"
+      '(printf "hello from bar!\n"))
+    (parameterize ([compile-imported-libraries #t]) (compile-program "testfile-cof1P"))
+    (compile-file "testfile-cof1foo")
+    (compile-file "testfile-cof1bar")
+    (let ()
+      (define fake-concatenate-object-files
+        (lambda (outfn infn . infn*)
+          (call-with-port (open-file-output-port outfn (file-options #;compressed replace))
+            (lambda (op)
+              (for-each
+                (lambda (infn)
+                  (put-bytevector op
+                    (call-with-port (open-file-input-port infn (file-options #;compressed)) get-bytevector-all)))
+                (cons infn infn*))))))
+      (fake-concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
+      (fake-concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so"))
+    #t)
+  ; using separate-eval since A and B already loaded in the compiling process:
+  (equal?
+    (separate-eval '(load "testfile-cof1fooP.so"))
+    "hello from foo!\na = 45, (b) = 90\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cof1barB.so")
+      '(printf "~s\n" (and (member '(testfile-cof1B) (library-list)) 'yes)))
+    "hello from bar!\nyes\n")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "")
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "")
+  (delete-file "testfile-cof1A.so")
+  ; NB: this should be an error, but isn't because we're using the fake concatenate-object-files
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "") ; requires testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "") ; doesn't require testfile-cof1A.so
+  
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (delete-file "testfile-cof1B.so")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so or testfile-cof1B.so
+  ; NB: this should be an error, but isn't because we're using the fake concatenate-object-files
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; requires testfile-cof1B.so
+
+  ; now with the real concatenate-object-files
+  (begin
+    (separate-eval '(parameterize ([compile-imported-libraries #t]) (compile-program "testfile-cof1P")))
+    (concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
+    (concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so")
+    #t)
+  ; using separate-eval since A and B already loaded in the compiling process:
+  (equal?
+    (separate-eval '(load "testfile-cof1fooP.so"))
+    "hello from foo!\na = 45, (b) = 90\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cof1barB.so")
+      '(printf "~s\n" (and (member '(testfile-cof1B) (library-list)) 'yes)))
+    "hello from bar!\nyes\n")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "")
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "")
+  (delete-file "testfile-cof1A.so")
+  (error? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so"))) ; requires testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "") ; doesn't require testfile-cof1A.so
+  
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (delete-file "testfile-cof1B.so")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so or testfile-cof1B.so
+  (error? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so"))) ; requires testfile-cof1B.so
+)
+
+;;; section 7.2:
+
+(mat top-level-value-functions
+  (error? (top-level-bound? "hello"))
+  (error? (top-level-bound?))
+  (error? (top-level-bound? 45 'hello))
+  (error? (top-level-bound? 'hello 'hello))
+  (error? (top-level-bound? (scheme-environment) (scheme-environment)))
+  (error? (top-level-mutable? "hello"))
+  (error? (top-level-mutable?))
+  (error? (top-level-mutable? 45 'hello))
+  (error? (top-level-mutable? 'hello 'hello))
+  (error? (top-level-mutable? (scheme-environment) (scheme-environment)))
+  (error? (top-level-value "hello"))
+  (error? (top-level-value))
+  (error? (top-level-value 'hello 'hello))
+  (error? (top-level-value (scheme-environment) (scheme-environment)))
+  (error? (set-top-level-value! "hello" "hello"))
+  (error? (set-top-level-value!))
+  (error? (set-top-level-value! 15))
+  (error? (set-top-level-value! 'hello 'hello 'hello))
+  (error? (set-top-level-value! (scheme-environment) (scheme-environment) (scheme-environment)))
+  (error? (define-top-level-value "hello" "hello"))
+  (error? (define-top-level-value))
+  (error? (define-top-level-value 15))
+  (error? (define-top-level-value 'hello 'hello 'hello))
+  (error? (define-top-level-value (scheme-environment) (scheme-environment) (scheme-environment)))
+
+  (top-level-bound? 'cons (scheme-environment))
+  (not (top-level-mutable? 'cons (scheme-environment)))
+  (eq? (top-level-bound? 'probably-not-bound (scheme-environment)) #f)
+  (equal? (top-level-value 'top-level-value) top-level-value)
+  (equal?
+    (parameterize ([interaction-environment
+                    (copy-environment (scheme-environment) #t)])
+      (eval '(define cons *))
+      (eval
+        '(list
+           (cons 3 4)
+           (fluid-let ([cons list])
+             (list (cons 1 2)
+                   ((top-level-value 'cons) 1 2)
+                   ((top-level-value 'cons (scheme-environment)) 1 2)
+                   (top-level-mutable? 'cons)
+                   (top-level-mutable? 'cons (scheme-environment))
+                   (top-level-mutable? 'car)
+                   (top-level-mutable? 'car (scheme-environment)))))))
+    '(12 ((1 2) (1 2) (1 . 2) #t #f #f #f)))
+  (let ([abcde 4])
+     (and (not (top-level-bound? 'abcde))
+          (begin (define-top-level-value 'abcde 3)
+                 (eqv? (top-level-value 'abcde) 3))
+          (top-level-bound? 'abcde)
+          (begin (set-top-level-value! 'abcde 9)
+                 (eqv? (top-level-value 'abcde) 9))
+          (eqv? abcde 4)))
+  (eqv? abcde 9)
+  (let ([x (gensym)])
+     (and (not (top-level-bound? x))
+          (begin (define-top-level-value x 'hi)
+                 (eq? (top-level-value x) 'hi))
+          (top-level-bound? x)
+          (begin (set-top-level-value! x 'there)
+                 (eq? (top-level-value x) 'there))
+          (eq? (eval x) 'there)))
+  (error? (top-level-value 'i-am-not-bound-i-hope))
+  (error? (top-level-value 'let))
+  (equal?
+    (parameterize ([interaction-environment
+                    (copy-environment (scheme-environment) #t)])
+      (eval '(define cons (let () (import scheme) cons)))
+      (eval
+        '(fluid-let ([cons 'notcons])
+           (list (top-level-value 'cons)
+                 (parameterize ([optimize-level 0]) (eval 'cons))
+                 (parameterize ([interaction-environment (scheme-environment)])
+                   ((top-level-value 'cons) 3 4))))))
+    '(notcons notcons (3 . 4)))
+  (error? (set-top-level-value! 'let 45))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (eval '(define let 45) (scheme-environment))))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (eval '(set! let 45) (scheme-environment))))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (define-top-level-value 'let 45)))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (set-top-level-value! 'let 45)))
+  (error? (define-top-level-value 'let 45 (scheme-environment)))
+  (error? (set-top-level-value! 'let 45 (scheme-environment)))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (eval '(define cons 45) (scheme-environment))))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (eval '(set! cons 45) (scheme-environment))))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (define-top-level-value 'cons 45)))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (set-top-level-value! 'cons 45)))
+  (error? (define-top-level-value 'cons 45 (scheme-environment)))
+  (error? (set-top-level-value! 'cons 45 (scheme-environment)))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (eval '(define foo 45) (scheme-environment))))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (eval '(set! foo 45) (scheme-environment))))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (define-top-level-value 'foo 45)))
+  (error? (parameterize ([interaction-environment (scheme-environment)])
+            (set-top-level-value! 'foo 45)))
+  (error? (define-top-level-value 'foo 45 (scheme-environment)))
+  (error? (set-top-level-value! 'foo 45 (scheme-environment)))
+  (begin
+    (define-syntax $let (identifier-syntax let))
+    (equal?
+      ($let ((x 3) (y 4)) (cons x y))
+      '(3 . 4)))
+  (eqv? (define-top-level-value '$let 76) (void))
+  (eqv? (top-level-value '$let) 76)
+  (eqv? $let 76)
+
+ ; make sure implicit treatment of top-level identifiers as variables
+ ; works when assignment occurs in loaded object file
+  (equal?
+    (begin
+      (with-output-to-file "testfile.ss"
+        (lambda () (pretty-print '(set! $fribblefratz 17)))
+        'replace)
+      (compile-file "testfile")
+      (load "testfile.so")
+      (list (top-level-bound? '$fribblefratz) (top-level-value '$fribblefratz)))
+    '(#t 17))
+  (eqv? $fribblefratz 17)
+  (equal?
+    (begin
+      (with-output-to-file "testfile.ss"
+        (lambda () (pretty-print '(set! $notfribblefratz -17)))
+        'replace)
+     ; compile in a separate Scheme process
+      (if (windows?)
+          (system (format "echo (compile-file \"testfile\") | ~a" (patch-exec-path *scheme*)))
+          (system (format "echo '(compile-file \"testfile\")' | ~a" *scheme*)))
+      (load "testfile.so")
+      (list (top-level-bound? '$notfribblefratz) (top-level-value '$notfribblefratz)))
+    '(#t -17))
+  (eqv? $notfribblefratz -17)
+ )
+
+;;; section 7.3:
+
+(mat new-cafe
+   (procedure? new-cafe)
+   (equal?
+     (guard (c [else #f])
+       (let ([ip (open-string-input-port "(+ 3 4)")])
+         (let-values ([(op get) (open-string-output-port)])
+           (parameterize ([console-input-port ip]
+                          [console-output-port op]
+                          [console-error-port op]
+                          [#%$cafe 0]
+                          [waiter-prompt-string "Huh?"])
+             (new-cafe))
+           (get))))
+     "Huh? 7\nHuh? \n")
+   (equal?
+     (guard (c [else #f])
+       (let ([ip (open-string-input-port "(if)")])
+         (let-values ([(op get) (open-string-output-port)])
+           (parameterize ([console-input-port ip]
+                          [console-output-port op]
+                          [console-error-port op]
+                          [#%$cafe 0]
+                          [waiter-prompt-string "Huh?"])
+             (new-cafe))
+           (get))))
+     "Huh? \nException: invalid syntax (if)\nHuh? \n")
+   (equal?
+     (separate-eval
+       `(let ([ip (open-string-input-port "
+                    (base-exception-handler
+                      (lambda (c)
+                        (fprintf (console-output-port) \"~%>>> \")
+                        (display-condition c (console-output-port))
+                        (fprintf (console-output-port) \" <<<~%\")
+                        (reset)))
+                    (if)")])
+          (let-values ([(op get) (open-string-output-port)])
+            (parameterize ([console-input-port ip]
+                           [console-output-port op]
+                           [console-error-port op]
+                           [#%$cafe 0]
+                           [waiter-prompt-string "Huh?"])
+              (new-cafe))
+            (get))))
+     "\"Huh? Huh? \\n>>> Exception: invalid syntax (if) <<<\\nHuh? \\n\"\n")
+ )
+
+(mat reset
+  (procedure? (reset-handler))
+  (eqv?
+    (call/cc
+      (lambda (k)
+        (parameterize ([reset-handler (lambda () (k 17))])
+          (reset))))
+    17)
+  (error? ; unexpected return from handler
+    (guard (c [else (raise-continuable c)])
+      (parameterize ([reset-handler values])
+        (reset))))
+ )
+
+(mat exit
+  (procedure? (exit-handler))
+  (eqv?
+    (call/cc
+      (lambda (k)
+        (parameterize ([exit-handler (lambda () (k 17))])
+          (exit))))
+    17)
+  (eqv?
+    (call/cc
+      (lambda (k)
+        (parameterize ([exit-handler (lambda (q) (k 17))])
+          (exit -1))))
+    17)
+  (error? ; unexpected return from handler
+    (parameterize ([exit-handler values])
+      (exit)))
+  (error? ; unexpected return from handler
+    (parameterize ([exit-handler values])
+      (exit 5)))
+  (begin
+    (define (exit-code expr)
+      (if (windows?)
+          (system (format "echo ~s | ~a -q" expr (patch-exec-path *scheme*)))
+          (system (format "echo '~s' | ~a -q" expr *scheme*))))
+    #t)
+  (eqv? (exit-code '(exit)) 0)
+  (eqv? (exit-code '(exit 15)) 15)
+  (eqv? (exit-code '(exit 0)) 0)
+  (eqv? (exit-code '(exit 24 7)) 24)
+  (eqv? (exit-code '(exit 0 1 2)) 0)
+  (eqv? (exit-code '(exit 3.14)) 1)
+  (eqv? (exit-code '(exit 9.8 3.14)) 1)
+  (begin
+    (with-output-to-file "testfile-exit.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (scheme))
+            (apply exit (map string->number (command-line-arguments))))))
+      'replace)
+    #t)
+  (eqv? (system (format "~a --script testfile-exit.ss" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --script testfile-exit.ss 5" (patch-exec-path *scheme*))) 5)
+  (eqv? (system (format "~a --script testfile-exit.ss 0 1 2" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --script testfile-exit.ss 3 4 5" (patch-exec-path *scheme*))) 3)
+  (eqv? (system (format "~a --program testfile-exit.ss" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --program testfile-exit.ss 2" (patch-exec-path *scheme*))) 2)
+  (eqv? (system (format "~a --program testfile-exit.ss 0 1 2" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --program testfile-exit.ss 6 7 8" (patch-exec-path *scheme*))) 6)
+ )
+
+(mat abort
+  (procedure? (abort-handler))
+  (eqv?
+    (call/cc
+      (lambda (k)
+        (parameterize ([abort-handler (lambda () (k 17))])
+          (abort))))
+    17)
+  (error? ; unexpected return from handler
+    (parameterize ([abort-handler values])
+      (abort)))
+ )
+
+(mat command-line
+  (equal? (command-line) '(""))
+  (equal? (r6rs:command-line) (command-line))
+  (parameterize ([command-line '("cp" "x" "y")])
+    (and (equal? (command-line) '("cp" "x" "y"))
+         (equal? (r6rs:command-line) '("cp" "x" "y"))))
+)
+
+(mat command-line-arguments
+  (null? (command-line-arguments))
+  (parameterize ([command-line-arguments '("x" "y")])
+    (equal? (command-line-arguments) '("x" "y")))
+)
+
+;;; section 7.4:
+
+(mat transcript-on/transcript-off ; check output
+  (begin
+    (delete-file "testscript")
+    (printf "***** expect transcript output:~%")
+    (parameterize ([console-input-port (open-input-string "(transcript-off)\n")])
+      (transcript-on "testscript")
+      (let repl ()
+        (display "OK, " (console-output-port))
+        (let ([x (read (console-input-port))])
+          (unless (eof-object? x)
+            (let ([x (eval x)])
+              (pretty-print x (console-output-port)))
+            (repl)))))
+    (not (eof-object? (with-input-from-file "testscript" read-char))))
+ )
+
+;;; section 7.5:
+
+(mat collect
+  (error? ; invalid generation
+    (collect-maximum-generation -1))
+  (error? ; invalid generation
+    (collect-maximum-generation 10000))
+  (error? ; invalid generation
+    (collect-maximum-generation 'static))
+  (error? ; invalid generation
+    (release-minimum-generation -1))
+  (error? ; invalid generation
+    (release-minimum-generation (+ (collect-maximum-generation) 1)))
+  (error? ; invalid generation
+    (release-minimum-generation 'static))
+  (let ([g (+ (collect-maximum-generation) 1)])
+    (guard (c [(and (message-condition? c)
+                    (equal? (condition-message c) "invalid generation ~s")
+                    (irritants-condition? c)
+                    (equal? (condition-irritants c) (list g)))])
+      (collect g)
+      #f))
+  (let ([g (+ (collect-maximum-generation) 1)])
+    (guard (c [(and (message-condition? c)
+                    (equal? (condition-message c) "invalid target generation ~s for generation ~s")
+                    (irritants-condition? c)
+                    (equal? (condition-irritants c) (list g 0)))])
+      (collect 0 g)
+      #f))
+  (error? (collect 0 -1))
+  (error? (collect -1 0))
+  (error? (collect 1 0))
+  (error? (collect 'static))
+  (with-interrupts-disabled
+    (collect (collect-maximum-generation))
+    (let ([b1 (bytes-allocated)])
+      (let loop ([n 1000] [x '()])
+        (or (= n 0) (loop (- n 1) (cons x x))))
+      (let ([b2 (bytes-allocated)])
+        (collect (collect-maximum-generation))
+        (let ([b3 (bytes-allocated)])
+          (and (> b2 b1) (< b3 b2))))))
+  (error? ; invalid generation
+    (collect 'static 1 'static))
+  (error? ; invalid generation
+    (collect 'static 1 'static))
+  (error? ; invalid generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 17 1 17)))
+  (error? ; invalid generation
+    (collect -1 1 'static))
+  (error? ; invalid maximum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 3 1 2)))
+  (error? ; invalid maximum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 3 1 'dynamic)))
+  (error? ; invalid minimum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 0 0 3)))
+  (error? ; invalid minimum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 0 'static 3)))
+  (error? ; invalid minimum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 0 2 1)))
+  (error? ; invalid minimum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect 0 2 0)))
+  (error? ; invalid minimum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect (collect-maximum-generation) 0 'static)))
+  (error? ; invalid minimum target generation
+    (parameterize ([collect-maximum-generation 4])
+      (collect (collect-maximum-generation) -1 'static)))
+  (parameterize ([collect-maximum-generation (max (collect-maximum-generation) 2)])
+    (with-interrupts-disabled
+      (collect (collect-maximum-generation))
+      (let ([b0-0 (bytes-allocated 0)]
+            [b1-0 (bytes-allocated 1)]
+            [bm-0 (bytes-allocated (collect-maximum-generation))])
+        (let* ([v (make-vector 2000)] [n (compute-size v)])
+          (let ([b0-1 (bytes-allocated 0)]
+                [b1-1 (bytes-allocated 1)]
+                [bm-1 (bytes-allocated (collect-maximum-generation))])
+            (unless (>= (- b0-1 b0-0) n) (errorf 'oops1 "b0-0 = ~s, b0-1 = ~s, b0-2 = ~s" b0-0 b0-1 b0-2))
+            (unless (< (- b1-1 b1-0) n) (errorf 'oops2 "b1-0 = ~s, b1-1 = ~s, b1-2 = ~s" b1-0 b1-1 b1-2))
+            (unless (< (- bm-1 bm-0) n) (errorf 'oops3 "bm-0 = ~s, bm-1 = ~s, bm-2 = ~s" bm-0 bm-1 bm-2))
+            (collect (collect-maximum-generation) 1 (collect-maximum-generation))
+            (let ([b0-2 (bytes-allocated 0)]
+                  [b1-2 (bytes-allocated 1)]
+                  [bm-2 (bytes-allocated (collect-maximum-generation))])
+              (unless (< (- b0-2 b0-0) n) (errorf 'oops4 "b0-0 = ~s, b0-1 = ~s, b0-2 = ~s" b0-0 b0-1 b0-2))
+              (unless (>= (- b1-2 b1-0) n) (errorf 'oops5 "b1-0 = ~s, b1-1 = ~s, b1-2 = ~s" b1-0 b1-1 b1-2))
+              (unless (< (- bm-2 bm-0) n) (errorf 'oops6 "bm-0 = ~s, bm-1 = ~s, bm-2 = ~s" bm-0 bm-1 bm-2))
+              (parameterize ([print-vector-length #t]) (pretty-print v))
+              #t))))))
+  (parameterize ([collect-maximum-generation 4]
+                 [collect-generation-radix 4]
+                 [collect-trip-bytes (expt 2 20)])
+    (collect (collect-maximum-generation))
+    (let ([b0 (maximum-memory-bytes)])
+      (define tail-spin
+        (lambda (n)
+          (do ([i 1 (fx+ i 1)] [next (cons 0 '()) (cdr next)])
+              ((fx= i n))
+            (set-cdr! next (cons i '())))))
+      (tail-spin 50000000)
+      (let ([b1 (maximum-memory-bytes)])
+        (or (< (- b1 b0) (expt 2 24))
+            (errorf #f "b0 = ~s, b1 = ~s, b1-b0 = ~s" b0 b1 (- b1 b0))))))
+ )
+
+(mat object-counts
+  ; basic structural checks
+  (let ([hc (object-counts)])
+    (begin
+      (assert (list? hc))
+      (for-each (lambda (a) (assert (pair? a))) hc)
+      (for-each (lambda (a) (assert (or (symbol? (car a)) (record-type-descriptor? (car a))))) hc)
+      (for-each (lambda (a) (assert (list? (cdr a)))) hc)
+      (for-each
+        (lambda (a)
+          (for-each
+            (lambda (a)
+              (and (or (and (fixnum? (car a)) (<= 0 (car a) (collect-maximum-generation)))
+                       (eq? (car a) 'static))
+                   (and (fixnum? (cadr a)) (>= (cadr a) 0))
+                   (and (fixnum? (cddr a)) (>= (cddr a) (cadr a)))))
+            (cdr a)))
+        hc)
+      (assert (assq 'pair hc))
+      (assert (assq 'procedure hc))
+      (assert (assq 'symbol hc))
+      (assert (assp record-type-descriptor? hc))
+      #t))
+  ; a few idiot checks including verification of proper behavior when changing collect-maximum-generation
+  (parameterize ([enable-object-counts #t] [collect-maximum-generation (collect-maximum-generation)])
+    (pair?
+      (with-interrupts-disabled
+        (let ([cmg (collect-maximum-generation)])
+          (collect-maximum-generation 4)
+          (collect 4 4)
+          (let ()
+            (define (locate type gen ls)
+              (cond
+                [(assq type ls) =>
+                 (lambda (a)
+                   (cond
+                     [(assv gen (cdr a)) => cadr]
+                     [else #f]))]
+                [else #f]))
+            (define-record-type flub (fields x))
+            (define q0 (make-flub 0))
+            (define b0 (box 0))
+            (collect 0 0)
+            (let ([hc (object-counts)])
+              (assert (locate 'box 0 hc))
+              (assert (locate (record-type-descriptor flub) 0 hc))
+              (collect-maximum-generation 7)
+              (let ([hc (object-counts)])
+                (assert (locate 'box 0 hc))
+                (assert (locate (record-type-descriptor flub) 0 hc))
+                (collect 7 7)
+                (let ()
+                  (define q1 (make-flub q0))
+                  (define b1 (box b0))
+                  (collect 6 6)
+                  (let ()
+                    (define q2 (make-flub q1))
+                    (define b2 (box b1))
+                    (collect 5 5)
+                    (let ([hc (object-counts)])
+                      (assert (locate 'box 5 hc))
+                      (assert (locate 'box 6 hc))
+                      (assert (locate 'box 7 hc))
+                      (assert (locate (record-type-descriptor flub) 5 hc))
+                      (assert (locate (record-type-descriptor flub) 6 hc))
+                      (assert (locate (record-type-descriptor flub) 7 hc))
+                      (collect-maximum-generation 5)
+                      (let ([hc (object-counts)])
+                        (assert (locate 'box 5 hc))
+                        (assert (not (locate 'box 6 hc)))
+                        (assert (not (locate 'box 7 hc)))
+                        (assert (locate (record-type-descriptor flub) 5 hc))
+                        (assert (not (locate (record-type-descriptor flub) 6 hc)))
+                        (assert (not (locate (record-type-descriptor flub) 7 hc)))
+                        (collect 5 5)
+                        (let ([hc (object-counts)])
+                          (assert (locate 'box 5 hc))
+                          (assert (not (locate 'box 6 hc)))
+                          (assert (not (locate 'box 7 hc)))
+                          (assert (locate (record-type-descriptor flub) 5 hc))
+                          (assert (not (locate (record-type-descriptor flub) 6 hc)))
+                          (assert (not (locate (record-type-descriptor flub) 7 hc)))
+                          (collect-maximum-generation cmg)
+                          (collect cmg cmg)
+                          (cons q2 b2)))))))))))))
+  ; make sure we can handle turning enable-object-counts on and off
+  (equal?
+    (parameterize ([collect-request-handler void])
+      (define-record-type frob (fields x))
+      (define x (list (make-frob 3)))
+      (parameterize ([enable-object-counts #t]) (collect 0 0))
+      (parameterize ([enable-object-counts #f]) (collect 0 1))
+      (do ([n 100000 (fx- n 1)])
+        ((fx= n 0))
+        (set! x (cons n x)))
+      (parameterize ([enable-object-counts #t]) (collect 1 1))
+      (cons (length x) (cadr (assq 1 (cdr (assq (record-type-descriptor frob) (object-counts)))))))
+    `(100001 . 1))
+  (let ([a (assq 'reloc-table (object-counts))])
+    (or (not a) (not (assq 'static (cdr a)))))
+)
+
+(mat collect-rendezvous
+  (begin
+    (define (check-working-gc collect)
+      (with-interrupts-disabled
+       (let ([p (weak-cons (gensym) #f)])
+         (collect)
+         (eq? (car p) #!bwp))))
+    (and (check-working-gc collect)
+         (check-working-gc collect-rendezvous)))
+      
+  (or (not (threaded?))
+      (let ([m (make-mutex)]
+            [c (make-condition)]
+            [done? #f])
+        (fork-thread
+         (lambda ()
+           (let loop ()
+             (mutex-acquire m)
+             (cond
+              [done?
+               (condition-signal c)
+               (mutex-release m)]
+              [else
+               (mutex-release m)
+               (loop)]))))
+        (and (check-working-gc collect-rendezvous)
+             ;; End thread:
+             (begin
+               (mutex-acquire m)
+               (set! done? #t)
+               (condition-wait c m)
+               (mutex-release m)
+               ;; Make sure the thread is really done
+               (let loop ()
+                 (unless (= 1 (#%$top-level-value '$active-threads))
+                   (loop)))
+               ;; Plain `collect` should work again:
+               (check-working-gc collect)))))
+  )
+
+;;; section 7.6:
+
+(mat time
+   (begin (printf "***** expect time output (nonzero allocation):~%")
+          (time (let loop ([n 1000] [x '()])
+                   (or (= n 0) (loop (- n 1) (cons x x))))))
+   (begin (printf "***** expect time output (nonzero cpu & real time):~%")
+          (time (letrec ([tak (lambda (x y z)
+                                 (if (>= y x)
+                                     z
+                                     (tak (tak (1- x) y z)
+                                          (tak (1- y) z x)
+                                          (tak (1- z) x y))))])
+                   (tak 18 12 6)))
+          #t)
+   (begin (printf "***** expect time output (>= 2 collections):~%")
+          (time (begin (collect) (collect)))
+          #t)
+ )
+
+(mat sstats
+  (begin 
+    (define exact-integer? 
+      (lambda (x) 
+        (and (exact? x) (integer? x))))
+    (define exact-nonnegative-integer? 
+      (lambda (x) 
+        (and (exact-integer? x) (nonnegative? x))))
+    (define sstats-time?
+      (lambda (t type)
+        (and (time? t) (eq? (time-type t) type))))
+    #t)
+  (error? ; invalid cpu time
+    (make-sstats 0 (make-time 'time-monotonic 0 0) 0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
+  (error? ; invalid real time
+    (make-sstats (make-time 'time-duration 0 0) 0 0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
+  (error? ; invalid bytes
+    (make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0.0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
+  (error? ; invalid gc-count
+    (make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 "oops" (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
+  (error? ; invalid gc-cpu
+    (make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 0 0 (make-time 'time-collector-real 0 0) 0))
+  (error? ; invalid gc-real
+    (make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 0 (make-time 'time-collector-cpu 0 0) 0 0))
+  (error? ; invalid gc-bytes
+    (make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0.0))
+  (begin
+    (define sstats
+      (make-sstats
+        (make-time 'time-process 0 0)
+        (make-time 'time-monotonic 0 0)
+        0
+        0
+        (make-time 'time-collector-cpu 0 0)
+        (make-time 'time-collector-real 0 0)
+        0))
+    #t)
+  (sstats? sstats)
+  (error? ; not an sstats record
+    (sstats-cpu 'it))
+  (error? ; not an sstats record
+    (sstats-real 'is))
+  (error? ; not an sstats record
+    (sstats-bytes 'fun))
+  (error? ; not an sstats record
+    (sstats-gc-count 'to))
+  (error? ; not an sstats record
+    (sstats-gc-cpu 'write))
+  (error? ; not an sstats record
+    (sstats-gc-real 'mats))
+  (error? ; not an sstats record
+    (sstats-gc-bytes '(not really)))
+  (sstats-time? (sstats-cpu sstats) 'time-process)
+  (sstats-time? (sstats-real sstats) 'time-monotonic)
+  (eqv? (sstats-bytes sstats) 0)
+  (eqv? (sstats-gc-count sstats) 0)
+  (sstats-time? (sstats-gc-cpu sstats) 'time-collector-cpu)
+  (sstats-time? (sstats-gc-real sstats) 'time-collector-real)
+  (eqv? (sstats-gc-bytes sstats) 0)
+
+  (error? ; not an sstats record
+    (set-sstats-cpu! 'it (make-time 'time-duration 1 0)))
+  (error? ; not an sstats record
+    (set-sstats-real! 'is (make-time 'time-duration 1 0)))
+  (error? ; not an sstats record
+    (set-sstats-bytes! 'fun 11))
+  (error? ; not an sstats record
+    (set-sstats-gc-count! 'to 13))
+  (error? ; not an sstats record
+    (set-sstats-gc-cpu! 'write (make-time 'time-duration 1 0)))
+  (error? ; not an sstats record
+    (set-sstats-gc-real! 'mats (make-time 'time-duration 1 0)))
+  (error? ; not an sstats record
+    (set-sstats-gc-bytes! '(not really) 17))
+  (error? ; 12 is not a time
+    (set-sstats-cpu! sstats 12))
+  (error? ; 12 is not a time
+    (set-sstats-real! sstats 12))
+  (error? ; 12 is not a time
+    (set-sstats-gc-cpu! sstats 12))
+  (error? ; 12 is not a time
+    (set-sstats-gc-real! sstats 12))
+  (error? ; #[time whatsit] is not a time
+    (set-sstats-gc-real! sstats (make-assertion-violation)))
+  (begin
+    (set-sstats-cpu! sstats (make-time 'time-utc 12 3))
+    (set-sstats-cpu! sstats (make-time 'time-monotonic 12 3))
+    (set-sstats-cpu! sstats (make-time 'time-duration 12 3))
+    (set-sstats-cpu! sstats (make-time 'time-thread 12 3))
+    (set-sstats-cpu! sstats (make-time 'time-collector-cpu 12 3))
+    (set-sstats-cpu! sstats (make-time 'time-collector-real 12 3))
+    (set-sstats-real! sstats (make-time 'time-utc 12 3))
+    (set-sstats-real! sstats (make-time 'time-duration 12 3))
+    (set-sstats-real! sstats (make-time 'time-process 12 3))
+    (set-sstats-real! sstats (make-time 'time-thread 12 3))
+    (set-sstats-real! sstats (make-time 'time-collector-cpu 12 3))
+    (set-sstats-real! sstats (make-time 'time-collector-real 12 3))
+    (set-sstats-gc-cpu! sstats (make-time 'time-utc 12 3))
+    (set-sstats-gc-cpu! sstats (make-time 'time-monotonic 12 3))
+    (set-sstats-gc-cpu! sstats (make-time 'time-duration 12 3))
+    (set-sstats-gc-cpu! sstats (make-time 'time-process 12 3))
+    (set-sstats-gc-cpu! sstats (make-time 'time-thread 12 3))
+    (set-sstats-gc-cpu! sstats (make-time 'time-collector-real 12 3))
+    (set-sstats-gc-real! sstats (make-time 'time-utc 12 3))
+    (set-sstats-gc-real! sstats (make-time 'time-monotonic 12 3))
+    (set-sstats-gc-real! sstats (make-time 'time-duration 12 3))
+    (set-sstats-gc-real! sstats (make-time 'time-process 12 3))
+    (set-sstats-gc-real! sstats (make-time 'time-thread 12 3))
+    (set-sstats-gc-real! sstats (make-time 'time-collector-cpu 12 3))
+    #t)
+  (eq? (set-sstats-cpu! sstats (make-time 'time-process 12 3)) (void))
+  (eq? (set-sstats-real! sstats (make-time 'time-monotonic 12 3)) (void))
+  (eq? (set-sstats-gc-cpu! sstats (make-time 'time-collector-cpu 12 3)) (void))
+  (eq? (set-sstats-gc-real! sstats (make-time 'time-collector-real 12 3)) (void))
+
+  (error? (set-sstats-bytes! sstats 12.3))
+  (error? (set-sstats-bytes! sstats 12.0))
+  (error? (set-sstats-gc-count! sstats 3+4i))
+  (error? (set-sstats-gc-count! sstats #f))
+  (error? (set-sstats-gc-bytes! sstats 8/3))
+  (error? (set-sstats-gc-bytes! sstats 'twelve))
+  (eq? (set-sstats-bytes! sstats 12) (void))
+  (eq? (set-sstats-gc-count! sstats 3) (void))
+  (eq? (set-sstats-gc-bytes! sstats 8) (void))
+
+  (begin
+    (define sstats-diff
+      (sstats-difference
+        (make-sstats
+          (make-time 'time-process 83 5)
+          (make-time 'time-monotonic 12 1)
+          5
+          23
+          (make-time 'time-collector-cpu (expt 2 8) 0)
+          (make-time 'time-collector-real 735 1000007)
+          29)
+        (make-sstats
+          (make-time 'time-process 3 0)
+          (make-time 'time-monotonic 10333221 2)
+          20
+          3
+          (make-time 'time-collector-cpu 0 0)
+          (make-time 'time-collector-real 0 0)
+          4)))
+    #t)
+  (sstats? sstats-diff)
+  (sstats-time? (sstats-cpu sstats-diff) 'time-duration)
+  (time=? (sstats-cpu sstats-diff) (make-time 'time-duration 80 5))
+  (sstats-time? (sstats-real sstats-diff) 'time-duration)
+  (time=? (sstats-real sstats-diff) (make-time 'time-duration 989666791 -2))
+  (eqv? (sstats-bytes sstats-diff) -15)
+  (eqv? (sstats-gc-count sstats-diff) 20)
+  (sstats-time? (sstats-gc-cpu sstats-diff) 'time-duration)
+  (time=? (sstats-gc-cpu sstats-diff) (make-time 'time-duration (expt 2 8) 0))
+  (sstats-time? (sstats-gc-real sstats-diff) 'time-duration)
+  (time=? (sstats-gc-real sstats-diff) (make-time 'time-duration 735 1000007))
+  (eqv? (sstats-gc-bytes sstats-diff) 25)
+
+  (let ([sstats (statistics)])
+    (and
+      (sstats? sstats)
+      (sstats-time? (sstats-cpu sstats) 'time-thread)
+      (sstats-time? (sstats-real sstats) 'time-monotonic)
+      (exact-nonnegative-integer? (sstats-bytes sstats))
+      (exact-nonnegative-integer? (sstats-gc-count sstats))
+      (sstats-time? (sstats-gc-cpu sstats) 'time-collector-cpu)
+      (sstats-time? (sstats-gc-real sstats) 'time-collector-real)
+      (exact-nonnegative-integer? (sstats-gc-bytes sstats))))
+
+  (let ([sstats (sstats-difference (statistics) (statistics))])
+    (and
+      (sstats? sstats)
+      (sstats-time? (sstats-cpu sstats) 'time-duration)
+      (sstats-time? (sstats-real sstats) 'time-duration)
+      (exact-integer? (sstats-bytes sstats))
+      (exact-integer? (sstats-gc-count sstats))
+      (sstats-time? (sstats-gc-cpu sstats) 'time-duration)
+      (sstats-time? (sstats-gc-real sstats) 'time-duration)
+      (exact-integer? (sstats-gc-bytes sstats))))
+ )
+
+(mat display-statistics ; check output
+  (let ([s (with-output-to-string display-statistics)])
+    (and (string? s) (> (string-length s) 50)))
+ )
+
+(mat cpu-time
+   (> (cpu-time) 0)
+   (let ([x (cpu-time)])
+      (<= x (cpu-time)))
+ )
+
+(mat real-time
+   (> (real-time) 0)
+   (let ([x (real-time)])
+      (<= x (real-time)))
+ )
+
+(mat bytes-allocated
+   (error? (bytes-allocated 'yuk))
+   (error? (bytes-allocated -1))
+   (error? (bytes-allocated (+ (collect-maximum-generation) 1)))
+   (error? (bytes-allocated (+ (most-positive-fixnum) 1)))
+   (error? (bytes-allocated #f))
+   (error? (bytes-allocated (+ (collect-maximum-generation) 1) 'new))
+   (error? (bytes-allocated (+ (collect-maximum-generation) 1) #f))
+   (error? (bytes-allocated 0 'gnu))
+   (error? (bytes-allocated #f 'gnu))
+   (error? (bytes-allocated 'static 'gnu))
+   (> (bytes-allocated) 0)
+   (andmap (lambda (g) (>= (bytes-allocated g) 0)) (iota (+ (collect-maximum-generation) 1)))
+   (>= (bytes-allocated 'static) 0)
+   (let ([x (bytes-allocated)])
+      (<= x (bytes-allocated)))
+   (>= (initial-bytes-allocated) 0)
+   (>= (collections) 0)
+   (>= (bytes-deallocated) 0)
+   (let ([b (bytes-deallocated)] [c (collections)])
+     (let ([x (make-list 10 'a)])
+       (pretty-print x)
+       (collect)
+       (and (> (collections) c) (> (bytes-deallocated) b))))
+   (>= (bytes-allocated #f #f) 0)
+   (andmap (lambda (space)
+          (>= (bytes-allocated #f space) 0))
+     (#%$spaces))
+   (let ()
+     (define fudge 2000)
+     (define ~=
+       (lambda (x y)
+         (<= (abs (- x y)) fudge)))
+     (define all-gen 
+       (append (iota (+ (collect-maximum-generation) 1)) '(static)))
+     (for-each
+       (lambda (space)
+         (critical-section
+           (let ([n1 (bytes-allocated #f space)]
+                 [n2 (fold-left (lambda (bytes gen)
+                                  (+ bytes (bytes-allocated gen space)))
+                       0
+                       all-gen)])
+             (unless (~= n1 n2)
+               (errorf #f "discrepancy for space ~s: ~d vs ~d" space n1 n2)))))
+       (#%$spaces))
+     (for-each
+       (lambda (gen)
+         (critical-section
+           (let ([n1 (bytes-allocated gen #f)]
+                 [n2 (fold-left (lambda (bytes space)
+                                  (+ bytes (bytes-allocated gen space)))
+                       0
+                       (#%$spaces))])
+             (unless (~= n1 n2)
+               (errorf #f "discrepancy for generation ~s: ~d vs ~d" gen n1 n2)))))
+       all-gen)
+     (critical-section
+       (let ([n1 (bytes-allocated #f #f)]
+             [n2 (fold-left (lambda (bytes gen)
+                              (fold-left (lambda (bytes space)
+                                           (+ bytes (bytes-allocated gen space)))
+                                bytes
+                                (#%$spaces)))
+                   0
+                   all-gen)])
+         (unless (~= n1 n2)
+           (errorf #f "discrepancy in bytes-allocated: ~d vs ~d" n1 n2))))
+     #t)
+ )
+
+(mat memory-bytes
+  (critical-section
+    (let ([x (maximum-memory-bytes)])
+      (<= (current-memory-bytes) x)))
+  (critical-section
+    (let ([x (maximum-memory-bytes)])
+      (reset-maximum-memory-bytes!)
+      (let ([y (maximum-memory-bytes)])
+        (<= y x))))
+)
+
+(mat date-and-time
+   (let ([s (date-and-time)])
+      (printf "***** check date-and-time: ~s~%" s)
+      (string? s))
+ )
+
+;;; section 7-7:
+
+(mat trace-lambda ; check output
+   (letrec ([fact (trace-lambda fact (x)
+                     (if (= x 0)
+                         1
+                         (* x (fact (- x 1)))))])
+      (printf "***** expect trace of (fact 3):~%")
+      (eqv? (fact 3) 6))
+ )
+
+(mat trace-let ; check output
+   (begin (printf "***** expect trace of (fib 3):~%")
+          (eqv? (trace-let fib ([x 3])
+                   (if (< x 2)
+                       1
+                       (+ (fib (- x 1)) (fib (- x 2)))))
+                3))
+ )
+
+(mat trace/untrace
+   (begin (set! lslen
+             (lambda (ls)
+                (if (null? ls)
+                    0
+                    (+ (lslen (cdr ls)) 1))))
+          (and (equal? (trace lslen) '(lslen))
+               (equal? (trace) '(lslen))
+               (begin (printf "***** expect trace of (lslen '(a b c)):~%")
+                      (eqv? (lslen '(a b c)) 3))
+               (equal? (untrace lslen) '(lslen))
+               (equal? (trace) '())
+               (equal? (trace lslen) '(lslen))
+               (equal? (trace lslen) '(lslen))
+               (begin (set! lslen (lambda (x) x))
+                      (printf "***** do *not* expect output:~%")
+                      (eqv? (lslen 'a) 'a))
+               (equal? (trace lslen) '(lslen))
+               (begin (printf "***** expect trace of (lslen 'a):~%")
+                      (eqv? (lslen 'a) 'a))
+               (equal? (untrace) '(lslen))
+               (equal? (trace) '())
+               (begin (printf "***** do *not* expect output:~%")
+                      (eqv? (lslen 'a) 'a))))
+ )
+
+;;; section 7-8:
+
+(mat error
+   (error? (errorf 'a "hit me!"))
+   (error? (let f ([n 10]) (if (= n 0) (errorf 'f "n is ~s" n) (f (- n 1)))))
+ )
+
+(mat keyboard-interrupt-handler ; must be tested by hand
+   (procedure? (keyboard-interrupt-handler))
+ )
+
+(mat collect-request-handler
+   (procedure? (collect-request-handler))
+   (call/cc
+      (lambda (k)
+         (parameterize ([collect-request-handler
+                         (lambda ()
+                            (collect)
+                            (k #t))])
+            (let f ([x '()]) (f (list-copy (cons 'a x)))))))
+ )
+
+(mat timer-interrupt-handler ; tested in mat set-timer below
+   (procedure? (timer-interrupt-handler))
+ )
+
+
+;;; section 7-9:
+
+(mat set-timer
+   (let ([count1 0])
+      (timer-interrupt-handler (lambda () (set! count1 (+ count1 1))))
+      (set-timer (+ 10 (random 10)))
+      (let loop2 ([count2 1])
+         (cond
+            [(= count2 100)]
+            [(= count1 count2)
+             (set-timer (+ 10 (random 10)))
+             (loop2 (+ count2 1))]
+            [else (loop2 count2)])))
+ )
+
+(mat disable-interrupts-enable-interrupts
+   (and (= (disable-interrupts) 1)
+        (= (disable-interrupts) 2)
+        (= (enable-interrupts) 1)
+        (= (enable-interrupts) 0))
+   (call/cc
+      (lambda (k)
+         (timer-interrupt-handler (lambda () (k #t)))
+         (disable-interrupts)
+         (parameterize ([timer-interrupt-handler (lambda () (k #f))])
+           (set-timer 1)
+           (let loop ([n 1000]) (or (= n 0) (loop (- n 1)))))
+         (enable-interrupts)
+         (let loop ([n 1000]) (or (= n 0) (loop (- n 1))))
+         #f))
+ )
+
+(mat with-interrupts-disabled
+   (call/cc
+      (lambda (k)
+         (timer-interrupt-handler (lambda () (k #t)))
+         (with-interrupts-disabled
+            (parameterize ([timer-interrupt-handler (lambda () (k #f))])
+              (set-timer 1)
+              (let loop ([n 1000]) (or (= n 0) (loop (- n 1))))))
+         (let loop ([n 1000]) (or (= n 0) (loop (- n 1))))
+         #f))
+  ; test old name
+   (call/cc
+      (lambda (k)
+         (timer-interrupt-handler (lambda () (k #t)))
+         (critical-section
+            (parameterize ([timer-interrupt-handler (lambda () (k #f))])
+              (set-timer 1)
+              (let loop ([n 1000]) (or (= n 0) (loop (- n 1))))))
+         (let loop ([n 1000]) (or (= n 0) (loop (- n 1))))
+         #f))
+ )
diff --git a/mats/8.ms b/mats/8.ms
new file mode 100644
index 0000000..27ac137
--- /dev/null
+++ b/mats/8.ms
@@ -0,0 +1,11903 @@
+;;; 8.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat define-syntax
+   (begin (define-syntax foo
+            (syntax-rules ()
+              [(foo a b) (list a b)]))
+          #t)
+   (error? (expand '(foo)))
+   (error? (expand '(foo . a)))
+   (error? (expand '(foo a)))
+   (error? (expand '(foo a . b)))
+   (equal? (foo 3 4) '(3 4))
+;;   (equal? (expand-once '(foo 3 4)) '(list 3 4))
+   (equal? (foo 3 4) '(3 4))
+   (error? (expand '(foo a b . c)))
+   (error? (expand '(foo a b c)))
+   (begin (define-syntax foo
+            (syntax-rules (bar)
+              [(foo) '()]
+              [(foo (bar x)) x]
+              [(foo x) (cons x '())]
+              [(foo x y ...) (cons x (foo y ...))]))
+          #t)
+   (equivalent-expansion? (expand '(foo)) ''())
+   (equivalent-expansion? (expand '(foo (bar a))) 'a)
+   (equal? (foo 'a) '(a))
+;;   (equal? (expand-once '(foo a b c)) '(cons a (foo b c)))
+   (equal? (foo 'a 'b 'c) '(a b c))
+   (equal? (foo 'a 'b (bar 'c)) '(a b . c))
+   (equal? (foo 'a 'b 'c 'd) '(a b c d))
+   (equal? (foo 'a 'b 'c (bar 'd)) '(a b c . d))
+   (begin (define-syntax foo
+            (lambda (x)
+              (syntax-case x ()
+                [(_ ((x v) ...) e1 e2 ...)
+                 (andmap symbol? '(x ...))
+                 (syntax ((lambda (x ...) e1 e2 ...) v ...))]
+                [(_ ((lambda (x ...) e1 e2 ...) v ...))
+                 (= (length '(x ...)) (length '(v ...)))
+                 (syntax (foo ((x v) ...) e1 e2 ...))])))
+          #t)
+   (equal? (foo ((a 3) (b 4)) (cons a b)) '(3 . 4))
+   (error? (expand '(foo ((1 b) (c d)) e f g)))
+   (error? (expand '(foo ((lambda (a c) e f g) b))))
+   (error? (define-syntax foo (syntax-rules (...) [(foo ...) 0])))
+  ; no longer an error:
+   #;(error? (define-syntax foo (syntax-rules () [(foo x ... y) 0])))
+   (error? (define-syntax foo (syntax-rules () [(foo x . ...) 0])))
+   (error? (define-syntax foo (syntax-rules () [(foo (...)) 0])))
+   (error? (define-syntax foo (syntax-rules () [(foo x x) 0])))
+   (begin (define-syntax foo (syntax-rules () [(foo foo) 0])) #t)
+   (begin (define-syntax foo
+            (lambda (x)
+              (syntax-case x ()
+                [(_ keys)
+                 (with-syntax ([x `,(syntax keys)]) (syntax x))])))
+          (equivalent-expansion? (expand '(foo (a b c))) '(a b c)))
+   (begin (define-syntax foo ; test exponential "with" time problem
+            (lambda (x)
+              (syntax-case x ()
+                [(_)
+                 (with-syntax
+                   ([a1 1] [b1 2] [c1 3] [d1 4] [e1 5] [f1 6] [g1 7] [h1 8]
+                    [a2 1] [b2 2] [c2 3] [d2 4] [e2 5] [f2 6] [g2 7] [h2 8]
+                    [a3 1] [b3 2] [c3 3] [d3 4] [e3 5] [f3 6] [g3 7] [h3 8]
+                    [a4 1] [b4 2] [c4 3] [d4 4] [e4 5] [f4 6] [g4 7] [h4 8]
+                    [a5 1] [b5 2] [c5 3] [d5 4] [e5 5] [f5 6] [g5 7] [h5 8]
+                    [a6 1] [b6 2] [c6 3] [d6 4] [e6 5] [f6 6] [g6 7] [h6 8]
+                    [a7 1] [b7 2] [c7 3] [d7 4] [e7 5] [f7 6] [g7 7] [h7 8]
+                    [a8 1] [b8 2] [c8 3] [d8 4] [e8 5] [f8 6] [g8 7] [h8 8])
+                   (syntax (list a1 b2 c3 d4 e5 f6 g7 h8)))])))
+          (equal? (foo) '(1 2 3 4 5 6 7 8)))
+   (eqv? (let ()
+           (let-syntax () (define x 3) (define y 4))
+           (define z (lambda () (+ x y)))
+           (z))
+         7)
+   (eqv? (let ()
+           (let-syntax ((a (syntax-rules ()
+                             ((_ x v) (define x v))))
+                        (b (syntax-rules ()
+                             ((_ x v) (define-syntax x
+                                        (syntax-rules ()
+                                          ((_) v)))))))
+             (a x 3)
+             (b y 4))
+           (define z (lambda () (+ x (y))))
+           (z))
+         7)
+  (eqv?
+    (let-syntax ((a (eval '(lambda (x) (let ((x x)) (syntax 3))))))
+      (a))
+    3)
+  (error?
+    (begin
+      (define-syntax x (let ((a 3)) (identifier-syntax (define a 4))))
+      x))
+  (error?
+    (begin
+      (define-syntax x (let ((a 3)) (identifier-syntax (set! a 4))))
+      x))
+  (error?
+    (begin
+      (define-syntax x
+        (let ((a 3))
+          (identifier-syntax
+            (fluid-let-syntax ((a (identifier-syntax 4)))
+              3))))
+      x))
+  ;; transformers expressions can reference local keywords
+  (eqv?
+    (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3))))))
+      (let-syntax ((b a))
+        b))
+    3)
+  (eqv?
+    (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3))))))
+      (letrec-syntax ((b a))
+        b))
+    3)
+  (eqv?
+    (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3))))))
+      (fluid-let-syntax ((b a))
+        b))
+    3)
+  (eqv?
+    (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3))))))
+      (let ()
+        (define-syntax b a)
+        b))
+    3)
+  (let-syntax ((a (lambda (x) #'(lambda (x) #'3))))
+    (define-syntax top-level-b a)
+    (eqv? top-level-b 3))
+  ;; transformers expressions cannot reference local variables
+  (error?
+    (let ((a (lambda (x) x)))
+      (let-syntax ((b a))
+        b)))
+  (error?
+    (let ((a (lambda (x) x)))
+      (letrec-syntax ((b a))
+        b)))
+  (error?
+    (let ((a (lambda (x) x)))
+      (fluid-let-syntax ((b a))
+        b)))
+  (error?
+    (let ((a (lambda (x) x)))
+      (let ()
+        (define-syntax b a)
+        b)))
+  ;; transformers expressions cannot reference pattern variables
+  (error?
+    (let-syntax ([foo
+                  (lambda (x)
+                    (syntax-case x ()
+                      [(_ z ...)
+                       (let-syntax ([bar (lambda (y) #'(z ...))])
+                         (bar))]))])
+      (foo + 8 9 10)))
+  ;; but can expand into syntax forms containing pattern variable references
+  (equal?
+    (let-syntax ([foo
+                  (lambda (x)
+                    (syntax-case x ()
+                      [(_ z ...)
+                       (let-syntax ([bar (lambda (y) #'#'(z (... ...)))])
+                         (bar))]))])
+      (foo + 8 9 10))
+    27)
+
+  (procedure? (eval (expand '(rec f (lambda (x) x)))))
+ ; make sure we're using the right environment for evaluating transformers
+  (eq? (let ()
+         (define x 3)
+         (let-syntax ((x (identifier-syntax (identifier-syntax 4))))
+           (define-syntax a x))
+         a)
+       4)
+ ; make sure local-syntax bindings aren't visible outside their scope
+  (equal?
+    (let ([a 14])
+      (module (x y)
+        (let-syntax ((a (identifier-syntax 3)))
+          (define x a))
+        (define y a))
+      (cons x y))
+    '(3 . 14))
+  (begin
+    (define $ds-a 14)
+    (module ($ds-x $ds-y)
+      (letrec-syntax ((a (identifier-syntax 3)))
+        (define $ds-x a))
+      (define $ds-y $ds-a))
+    (equal? (cons $ds-x $ds-y) '(3 . 14)))
+ ; make sure both introduced references and defines are scoped the same
+  (eq? (let ()
+         (define-syntax a (identifier-syntax (begin (define x 3) x)))
+         (let () a))
+       3)
+
+  (begin
+    (define $a 'aaa)
+    (define $x 'xxx) 
+    (define-syntax $introduce-module
+      (identifier-syntax
+        (begin (module $a ($x) (define $x 73))
+               (import $a)
+               (eq? $x 73))))
+    $introduce-module)
+  (eq? $a 'aaa) ; make sure introduced module binding isn't visible
+  (eq? $x 'xxx) ; make sure introduced and imported variable isn't visible
+  (eq? (top-level-value '$a) 'aaa)
+  (eq? (top-level-value '$x) 'xxx)
+  (begin
+    (define-syntax $dsmat-foo1
+      (lambda (x)
+        (syntax-case x ()
+          ((_ name arg ...)
+           (with-syntax (($... (syntax (... ...))))
+             (syntax
+               (begin
+                 (define $dsmat-y 10)
+                 (define-syntax name
+                   (lambda (z)
+                     (syntax-case z ()
+                       ((_ a $...)
+                        (syntax (list
+                                  $dsmat-y
+                                  a $...)))))))))))))
+    #t)
+  (begin ($dsmat-foo1 $dsmat-bar) #t)
+  (error? ($dsmat-bar $dsmat-y))
+  (begin (define $dsmat-y 77) #t)
+  (equal? ($dsmat-bar $dsmat-y) '(10 77))
+  (error? ; misplaced ellipsis
+    (with-syntax ([x 3]) #'#(... (x))))
+  (error? ; missing ellipsis
+    (syntax-case '((1 2) (3 4)) () [((x y) ...) #'(quote (x y ...))]))
+  (error? ; missing ellipsis
+    (syntax-case '((1 2) (3 4)) () [((v w) ...) #'(quote (v ... w))]))
+  (equal?
+    (let ()
+      (define b)
+      (define d)
+      (define-syntax a
+        (lambda (x)
+          (syntax-case x (b c)
+            [(_ b) "b"]
+            [(_ c) "c"]
+            [(_ bar) (free-identifier=? #'bar #'d) "d"]
+            [(_ bar) (free-identifier=? #'bar #'e) "e"]
+            [(_ bar bee)
+             (bound-identifier=? #'bar #'bee)
+             (symbol->string (datum bar))]
+            [_ "nope"])))
+      (list (a b) (a c) (a d) (a e) (a b b) (a c c) (a f)))
+    '("b" "c" "d" "e" "b" "c" "nope"))
+  (equal?
+    (let ()
+      (define-syntax letrec
+        (lambda (x)
+          (syntax-case x ()
+            [(_ ((i v) ...) e1 e2 ...)
+             (with-syntax ([(t ...) (generate-temporaries #'(i ...))])
+               #'(let ([i #f] ...)
+                   (let ([t v] ...)
+                     (set! i t)
+                     ...
+                     (let () e1 e2 ...))))])))
+      (list
+        (letrec ([f (lambda (x)
+                      (if (zero? x) 'odd (g (- x 1))))]
+                 [g (lambda (x) (if (zero? x) 'even (f (- x 1))))])
+          (and (eq? (g 10) 'even)
+               (eq? (g 13) 'odd)
+               (eq? (f 13) 'even)))
+        (letrec ([v 0] [k (call/cc (lambda (x) x))])
+          (set! v (+ v 1))
+          (k (lambda (x) v)))))
+    '(#t 1))
+  (equal?
+    (let ()
+      (define-syntax main ; Anton's example
+        (lambda (stx)
+          (let ((make-swap
+                 (lambda (x y)
+                   (with-syntax ((x x) (y y) ((t) (generate-temporaries '(*))))
+                     (syntax
+                       (let ((t1 x))
+                         (set! x y)
+                         (set! y t1)))))))
+            (syntax-case stx ()
+              ((_)
+               (with-syntax ((swap (make-swap (syntax s) (syntax t))))
+                 (syntax
+                   (let ((s 1) (t 2))
+                     swap
+                     (list s t)))))))))
+      (main))
+    '(2 1))
+ ; make sure second definition of marked id works like set!
+  (begin
+    (define $ds-b '())
+    (define-syntax $ds-a
+      (lambda (x)
+        #'(begin
+            (define q 33)
+            (define (f) q)
+            (set! $ds-b (cons (f) $ds-b))
+            (define q 55)
+            (set! $ds-b (cons (f) $ds-b))
+            (set! $ds-b (cons q $ds-b))
+            #t)))
+    #t)
+  $ds-a
+  (equal? $ds-b '(55 55 33))
+
+ ; check underscore as wildcard
+  (equal?
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (syntax-case x ()
+            [(_ id e)
+             #'(let ()
+                 (define-syntax id
+                   (lambda (x)
+                     (syntax-case x ()
+                       [(_ q _) #'(list q '_)])))
+                 e)])))
+      (a xxx (xxx (cons (xxx 3 (/ 1 0)) 4) (/ 1 0))))
+    '(((3 _) . 4) _))
+
+  (equal?
+    (let ([b 1] [c 2] [d 3] [e 4] [f 5] [g 6])
+      (define-syntax a
+        (syntax-rules ()
+          [(_ x _ y _ z _)
+           (list x y 'z '_)]))
+      (a b c d e f g))
+    '(1 3 f _))
+ ; test syntax-rules fender
+  (eqv?
+    (let ()
+      (define-syntax k
+        (syntax-rules ()
+          [(_ a b) (identifier? #'a) (let ((a (+ b 1))) (* a b))]))
+      (let ([x 4]) (k x (+ x 3))))
+    88)
+  ; test for mishandling of underscore introduced by syntax-rules
+  (equal?
+    (let ([_ 3])
+      (define-syntax a (lambda (x) (syntax-case x (_) [(k _) 4] [(k x) #'(* x x)])))
+      (list (a _)))
+    '(4))
+  (equal?
+    (let ([_ 3])
+      (define-syntax a (syntax-rules (_) [(k _) 4] [(k x) (* x x)]))
+      (list (a _)))
+    '(4))
+)
+
+(mat r6rs:syntax-rules
+  (equal?
+    (let ([b 1] [c 2] [d 3] [e 4] [f 5] [g 6])
+      (import (rnrs))
+      (define-syntax a
+        (syntax-rules ()
+          [(_ x _ y _ z _)
+           (list x y 'z '_)]))
+      (a b c d e f g))
+    '(1 3 f _))
+  (equal?
+    (let ()
+      (import (rnrs))
+      (define-syntax a
+        (syntax-rules (b)
+          [(_ b) "yup"]
+          [(_ c) (list c)]))
+      (list (a b) (a 3)))
+    '("yup" (3)))
+ ; test syntax-rules fender
+  (error?
+    (let ()
+      (import (rnrs))
+      (define-syntax k
+        (syntax-rules ()
+          [(_ a b) (identifier? #'a) (let ((a (+ b 1))) (* a b))]))
+      (let ([x 4]) (k x (+ x 3)))))
+  (error?
+    (let ()
+      (import (rnrs))
+      (syntax-rules (_))))
+  (error? (syntax-rules (_)))
+  (error?
+    (let ()
+      (import (rnrs))
+      (syntax-rules (...))))
+  (error? (syntax-rules (...)))
+  ; test for mishandling of underscore introduced by syntax-rules
+  (equal?
+    (let ()
+      (import (rnrs))
+      (let ([_ 3])
+        (define-syntax a (syntax-rules (_) [(k _) 4] [(k x) (* x x)]))
+        (list (a _))))
+    '(4))
+)
+
+(mat definition-not-permitted
+ ; top level
+  (error? ; definition not permitted
+    (let-syntax ((frob (lambda (x) #'(void))))
+      (define frob 15)))
+  (error? ; definition not permitted
+    (let-syntax ((frob (lambda (x) #'(void))))
+      (define-syntax frob (identifier-syntax 15))))
+  (error? ; definition not permitted
+    (let-syntax ((frob (lambda (x) #'(void))))
+      (module frob (x) (define x 15))))
+  (error? ; definition not permitted
+    (let-syntax ((frob (lambda (x) #'(void))))
+      (alias frob cons)))
+ ; top level module body
+  (error? ; definition not permitted
+    (module (frob)
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (define frob -15))))
+  (error? ; definition not permitted
+    (module (frob)
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (define-syntax frob (identifier-syntax -15)))))
+  (error? ; definition not permitted
+    (module (frob)
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (module frob (x) (define x -15)))))
+  (error? ; definition not permitted
+    (module (frob)
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (alias frob cons))))
+ ; body
+  (error? ; definition not permitted
+    (let ()
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (define frob 'xxx))
+      frob))
+  (error? ; definition not permitted
+    (let ()
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (define-syntax frob (identifier-syntax 'xxx)))
+      frob))
+  (error? ; definition not permitted
+    (let ()
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (module frob (x) (define x 'xxx)))
+      (import frob)
+      x))
+  (error? ; definition not permitted
+    (let ()
+      (let-syntax ((frob (lambda (x) #'(void))))
+        (alias frob cons))
+      (cons 3 4)))
+)
+
+(mat invalid-bindings
+  (error? (let-syntax ([x '(global)]) x))
+  (error? (letrec-syntax ([x '(global)]) x))
+  (error? (fluid-let-syntax ([x '(global)]) x))
+  (error? (begin (define-syntax x '(global)) x))
+  (error? (let () (define-syntax x '(global)) x))
+  (error? (let () (let-syntax ([x '(global)]) x)))
+  (error? (let () (letrec-syntax ([x '(global)]) x)))
+  (error? (let-syntax ([x '(lexical . #\a)]) x))
+  (error? (letrec-syntax ([x '(lexical . #\a)]) x))
+  (error? (fluid-let-syntax ([x '(lexical . #\a)]) x))
+  (error? (begin (define-syntax x '(lexical . #\a)) x))
+  (error? (let () (define-syntax x '(lexical . #\a)) x))
+  (error? (let () (let-syntax ([x '(lexical . #\a)]) x)))
+  (error? (let () (letrec-syntax ([x '(lexical . #\a)]) x)))
+  (error? (let-syntax ([x '(macro . cond)]) x))
+  (error? (letrec-syntax ([x '(macro . cond)]) x))
+  (error? (fluid-let-syntax ([x '(macro . cond)]) x))
+  (error? (begin (define-syntax x '(macro . cond)) x))
+  (error? (let () (define-syntax x '(macro . cond)) x))
+  (error? (let () (let-syntax ([x '(macro . cond)]) x)))
+  (error? (let () (letrec-syntax ([x '(macro . cond)]) x)))
+)
+
+(mat generalized-pattern
+  (begin
+    (define-syntax gp$a (syntax-rules () [(_ x ... y) (list y x ...)]))
+    #t)
+  (error? gp$a)
+  (error? (gp$a))
+  (error? (gp$a . b))
+  (equal? (gp$a 1 2 3 4 5) '(5 1 2 3 4))
+  (equal? (gp$a 1) '(1))
+  (equal? (gp$a 1 2) '(2 1))
+  (begin
+    (define-syntax gp$b
+      (lambda (x)
+        (syntax-case x ()
+          [(_ x ... y) #'(list y x ...)])))
+    #t)
+  (error? gp$b)
+  (error? (gp$b))
+  (error? (gp$b . b))
+  (equal? (gp$b 1 2 3 4 5) '(5 1 2 3 4))
+  (equal? (gp$b 1) '(1))
+  (equal? (gp$b 1 2) '(2 1))
+  (begin
+    (define-syntax gp$c
+      (syntax-rules ()
+        [(_ x ... y z . w) '((x ...) y z w)]))
+    #t)
+  (error? (gp$c))
+  (error? (gp$c 1))
+  (equal? (gp$c 1 2) '(() 1 2 ()))
+  (equal? (gp$c 1 2 3 4 5) '((1 2 3) 4 5 ()))
+  (equal? (gp$c 1 2 . 3) '(() 1 2 3))
+  (equal? (gp$c 1 2 3 4 5 . 6) '((1 2 3) 4 5 6))
+  (begin
+    (define-syntax gp$d
+      (syntax-rules (foo)
+        [(_ x ... (y z) . #(foo w1 w2)) '((x ...) y z w1 w2)]))
+    #t)
+  (error? (gp$d 1 2 . #(foo 6 7)))
+  (error? (gp$d 1 2))
+  (error? (gp$d 1 2 (3 4)))
+  (equal? (gp$d (4 5) . #(foo 6 7)) '(() 4 5 6 7))
+  (equal? (gp$d 1 (4 5) . #(foo 6 7)) '((1) 4 5 6 7))
+  (equal? (gp$d 1 2 3 (4 5) . #(foo 6 7)) '((1 2 3) 4 5 6 7))
+  (begin
+    (define-syntax gp$e
+      (syntax-rules (rats)
+        [(_ x ... . rats) '(x ...)]))
+    #t)
+  (error? (gp$e))
+  (error? (gp$e 1))
+  (error? (gp$e 1 2))
+  (error? (gp$e rats))
+  (equal? (gp$e . rats) '())
+  (equal? (gp$e 1 . rats) '(1))
+  (equal? (gp$e 1 2 3 4 5 . rats) '(1 2 3 4 5))
+  (begin
+    (define-syntax gp$f
+      (syntax-rules (rats)
+        [(_ (x ... y) ...) '(x ... ... y ...)]))
+    #t)
+  (equal? (gp$f) '())
+  (equal? (gp$f (1 2 3 4 5) (6 7 8)) '(1 2 3 4 6 7 5 8))
+  (error? 
+    (define-syntax gp$g
+      (syntax-rules ()
+        [(_ x ... y ...) '(x ... y ...)])))
+  (begin
+    (define-syntax gp$h
+      (syntax-rules (rats)
+        [(_ #(x ... y) ...) '(x ... ... y ...)]))
+    #t)
+  (error? (gp$h (1 2 3)))
+  (error? (gp$h . 4))
+  (equal? (gp$h) '())
+  (equal? (gp$h #(1 2 3 4 5) #(6 7 8)) '(1 2 3 4 6 7 5 8))
+)
+
+(mat define-integrable
+  (begin
+    (define-syntax define-integrable
+      (lambda (x)
+        (define make-residual-name
+          (lambda (name)
+            (datum->syntax name
+              (string->symbol
+                (string-append "residual-"
+                  (symbol->string (syntax->datum name)))))))
+        (syntax-case x (lambda)
+          ((_ name (lambda formals form1 form2 ...))
+           (identifier? (syntax name))
+           (with-syntax ((xname (make-residual-name (syntax name))))
+             (syntax
+               (begin
+                 (define-syntax name
+                   (lambda (x)
+                     (syntax-case x ()
+                       (_ (identifier? x) (syntax xname))
+                       ((_ arg (... ...))
+                        (syntax
+                          ((fluid-let-syntax
+                             ((name (identifier-syntax xname)))
+                             (lambda formals form1 form2 ...))
+                           arg (... ...)))))))
+                 (define xname
+                   (fluid-let-syntax ((name (identifier-syntax xname)))
+                     (lambda formals form1 form2 ...))))))))))
+    #t)
+  (let ()
+    (define-integrable even? (lambda (x) (if (= x 0) #t (odd? (- x 1)))))
+    (define-integrable odd? (lambda (x) (if (= x 0) #f (even? (- x 1)))))
+    (and (even? 20) (not (odd? 20))))
+  (begin
+    (define-syntax define-integrable
+      (lambda (x)
+        (syntax-case x (lambda)
+          [(_ name (lambda formals form1 form2 ...))
+           (identifier? #'name)
+           #'(begin
+               (define-syntax name
+                 (lambda (x)
+                   (syntax-case x ()
+                     [_ (identifier? x) #'xname]
+                     [(_ arg (... ...))
+                      #'((fluid-let-syntax ([name (identifier-syntax xname)])
+                           (lambda formals form1 form2 ...))
+                          arg
+                          (... ...))])))
+               (define xname
+                 (fluid-let-syntax ([name (identifier-syntax xname)])
+                   (lambda formals form1 form2 ...))))])))
+    #t)
+  (let ()
+    (define-integrable even? (lambda (x) (if (= x 0) #t (odd? (- x 1)))))
+    (define-integrable odd? (lambda (x) (if (= x 0) #f (even? (- x 1)))))
+    (and (even? 20) (not (odd? 20))))
+  (begin
+    (define-integrable $di-foo
+      (lambda (x) (if (list? x) (map $di-foo x) (list x))))
+    (define-integrable $di-bar
+      (lambda (x) (if (vector? x) (vector-map $di-bar x) (vector ($di-foo x)))))
+    (equal?
+      (list ($di-bar '#(a b c)) ($di-bar '(1 2 3)))
+      '(#(#((a)) #((b)) #((c))) #(((1) (2) (3))))))
+)
+
+(mat identifier-syntax
+  (eqv?
+    (let ([x 0])
+      (define-syntax frob
+        (identifier-syntax
+          [id (begin (set! x (+ x 1)) x)]
+          [(set! id v) (set! x v)]))
+      (let ([n (+ frob frob frob)])
+        (set! frob 15)
+        (+ n frob)))
+    22)
+  (begin
+    (module (($is-frob x))
+      (define x 'initial-x)
+      (define-syntax $is-frob
+        (make-variable-transformer
+          (lambda (z)
+            (syntax-case z (set!)
+              [(set! id e)
+               (identifier? #'id)
+               #'(set! x e)]
+              [id (identifier? #'id) #'(vector x)]
+              [(_ a b c ...) #'(set! x (list (cons a b) c ...))])))))
+    (equal? $is-frob '#(initial-x)))
+  (error? ; invalid syntax
+    ($is-frob))
+  (error? ; invalid syntax
+    ($is-frob 3))
+  (error? ; invalid syntax
+    (set! $is-frob))
+  (error? ; invalid syntax
+    (set! $is-frob 3 4))
+  (equal?
+    (begin
+      ($is-frob 3 4)
+      $is-frob)
+    '#(((3 . 4))))
+  (equal?
+    (begin
+      ($is-frob 3 4 5 6 7)
+      $is-frob)
+    '#(((3 . 4) 5 6 7)))
+  (equal?
+    (let ()
+      (set! $is-frob 55)
+      $is-frob)
+    '#(55))
+  (equal?
+    (let ()
+      ($is-frob 'q 'p 'doll)
+      $is-frob)
+    '#(((q . p) doll)))
+  (equal?
+    (let ([z (void)])
+      (set! $is-frob 44)
+      (let ([set! (lambda args (set! z args))])
+        (set! $is-frob 15)
+        (list z $is-frob)))
+    '((#(44) 15) #(44)))
+)
+
+(mat with-syntax
+   (begin (define-syntax foo
+            (lambda (x)
+              (syntax-case x ()
+                [(_ x ...)
+                 (with-syntax ([n (length (syntax (x ...)))])
+                   (syntax (list n 'x ...)))])))
+          #t)
+   (equal? (foo 3 2 1) '(3 3 2 1))
+   (equal? (foo 3 2 1) '(3 3 2 1))
+   (begin (define-syntax foo
+            (lambda (x)
+              (syntax-case x ()
+                [(_ (x ...) ...)
+                 (with-syntax
+                   (((len ...) (map length (syntax ((x ...) ...))))
+                    (((z ...) ...) (map reverse (syntax ((x ...) ...)))))
+                   (syntax '((len z ...) ...)))])))
+          #t)
+   (equal? (foo) '())
+   (equal? (foo (a b) (c d e)) '((2 b a) (3 e d c)))
+   (error? (expand '(foo . a)))
+   (error? (expand '(foo a)))
+   (error? (expand '(foo (a b . c) (d e f))))
+   (error? (expand '(foo (a b c) . d)))
+   (begin (define-syntax foo
+            (lambda (x)
+              (syntax-case x ()
+                [(_ x ...)
+                 (with-syntax ([(y1 y2 ...) (syntax (x ...))])
+                   (with-syntax ([(z1 z2) (syntax y1)])
+                     (syntax '(z2 z1))))])))
+          #t)
+   (equal? (foo (a b) (c d) (e f)) '(b a))
+   (error? (expand '(foo)))       ;oops: "car: incorrect list structure"
+   (error? (expand '(foo a b c))) ;oops: "cadr: incorrect list structure"
+   (error? (define-syntax foo
+             (lambda (x)
+               (syntax-case x ()
+                 [(_) (with-syntax ([(x x) '(1 2)]) 0)]))))
+   (error? (define-syntax foo
+             (lambda (x)
+               (syntax-case x ()
+                 [(_) (with-syntax ([x 1] [x 2]) 0)]))))
+   (equal? (with-syntax ((x 3)) #'#&x) '#&3)
+   (equal? (with-syntax ((x 3)) #'#(x)) '#(3))
+   (equal? (list (with-syntax () (define x 3) x) 4) '(3 4))
+   (equal? (list (with-syntax ([q 3]) (define x #'q) x) 4) '(3 4))
+   (equal? (list (with-syntax ([q 3] [r 5]) (define x #'q) (cons x #'r)) 4) '((3 . 5) 4))
+ )
+
+(mat generate-temporaries
+  (error? (generate-temporaries))
+  (error? (generate-temporaries '(a b c) '(d e f)))
+  (error? (generate-temporaries '(a b . c)))
+  (error? (generate-temporaries (let ([x (list 'a 'b 'c)]) (set-cdr! (cddr x) (cdr x)) x)))
+  (andmap identifier? (generate-temporaries '(a b c)))
+  (= (length (generate-temporaries '(a b c))) 3)
+  (andmap identifier? (generate-temporaries #'(a b c)))
+  (= (length (generate-temporaries #'(a b c))) 3)
+  (andmap identifier? (generate-temporaries (cons 'q #'(1 2 3))))
+  (= (length (generate-temporaries (cons 'q #'(1 2 3)))) 4)
+ ; make sure generate-temporaries isn't confused by annotations
+  (begin
+    (let ((op (open-output-file "testfile.ss" 'replace)))
+      (pretty-print
+        '(begin
+           (define-syntax $gt-a
+             (lambda (x)
+               (syntax-case x ()
+                 [(_ x)
+                  (with-syntax ([(t1 t2 t3) (generate-temporaries #'(1 1 1))])
+                    #'(define x (let ([t1 17] [t2 53] [t3 -10]) (cons* t2 t3 t1))))])))
+           ($gt-a $gt-x))
+        op)
+        (close-output-port op)
+        (compile-file "testfile.ss"))
+    #t)
+  (begin
+    (load "testfile.so")
+    #t)
+  (equal? $gt-x '(53 -10 . 17))
+)
+
+(mat syntax->list
+  (error? (syntax->list #'a))
+  (error? (syntax->list #'(a b . e)))
+  (eq? (syntax->list #'()) '())
+  (andmap bound-identifier=? (syntax->list #'(a b c)) (list #'a #'b #'c))
+  (not (pair? (car (syntax->list #'((a . b))))))
+ ; just for comparison
+  (pair? (car (syntax->datum #'((a . b)))))
+)
+
+(mat syntax->vector
+  (error? (syntax->vector #'a))
+  (error? (syntax->vector #'(a b . e)))
+  (eq? (syntax->vector #'#()) '#())
+  (andmap bound-identifier=? (vector->list (syntax->vector #'#(a b c))) (list #'a #'b #'c))
+  (not (pair? (vector-ref (syntax->vector #'#((a . b))) 0)))
+ ; just for comparison
+  (pair? (vector-ref (syntax->datum #'#((a . b))) 0))
+)
+
+(mat syntax-errors
+  (begin
+    (define $do-one
+      (lambda (x)
+        (collect (collect-maximum-generation)) ; close ports left open by load/compile-file w/mat's error handler
+        (let ((op (open-output-file "testfile.ss" 'replace)))
+          (fprintf op "   ~%     ")
+          (if (string? x)
+              (fprintf op "~a~%" x)
+              (parameterize ((pretty-initial-indent 5))
+                (pretty-print x op)))
+          (close-output-port op))
+        (load "testfile.ss")))
+    #t)
+
+ ; fix "missing definition for exports" error to be like duplicate-id-error
+ ; as is, no character position information is given
+  (error? ($do-one '(module (y) (define x 3))))
+
+ ; get no character position information for this
+  (error? ($do-one '(let () (define x 3) (define-syntax x (identifier-syntax 4)) x)))
+
+ ; these should possibly give position of invalid/duplicate id, not whole form
+  (error? ($do-one '(let () (module (x) (define x 3) (define-syntax x (identifier-syntax 4))) x)))
+
+  (error? ($do-one '(module (x) (define x 3) (define-syntax x (identifier-syntax 4)))))
+
+  (error? ($do-one '(letrec ((3 4)) 5)))
+
+  (error? ($do-one '(letrec-syntax ((3 4)) 5)))
+
+ ; these should be okay:
+  (error? ($do-one
+            '(module (x)
+               (module (x) (define a 1) (define a 2) (define x 3) (define x 4)))))
+
+  (error? ($do-one '(a . b)))
+
+  (error? ($do-one '(module (x) (define x 3) (define x 4))))
+
+  (error? ($do-one '(module (x) (module (x) (define x 3) (define x 4)))))
+
+  (error? ($do-one '(letrec ((x 3) (x 4)) x)))
+
+  (error? ($do-one '(letrec-syntax ((x 3) (x 4)) x)))
+
+  (error? ($do-one '(let () (module (x) (define x 3) (define x 4)) x)))
+
+  (error? ($do-one '(let () (define x 3) (define x 4) x)))
+
+  (error? ($do-one '(cond (a . b))))
+
+  (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ b b) (syntax b)))))
+
+  (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ a ...) 3 4 5))))
+
+  (error? ($do-one '(syntax-case (list 'a 'b) (a ...) ((_ a ...) 3))))
+
+  (error? ($do-one '(syntax a b)))
+
+  (error? ($do-one '(if a b c d)))
+
+  (error? ($do-one '(letrec ((x 3) (y 4) . (z 5)) (list x y z))))
+
+  (error? ($do-one '(let () ($primitive 4 car))))
+
+  (error? ($do-one '(syntax-case x)))
+
+  (error? ($do-one '(quote a b)))
+
+  (error? ($do-one '(fluid-let-syntax)))
+
+  (error? ($do-one '(letrec-syntax () . 3)))
+
+  (error? ($do-one '(lambda (x x) x)))
+
+  (error? ($do-one '(lambda (x y) . z)))
+
+  (error? ($do-one '(lambda (3) 3)))
+
+  (error? ($do-one '(let ((x 4)) (set! x 3 5) x)))
+
+  (error? ($do-one '(set! x 3 5)))
+
+  (error? ($do-one '(let () (import . x) 3)))
+
+  (error? ($do-one '(import . x)))
+
+  (error? ($do-one '(let () (import (just scheme cons)))))
+
+  (error? ($do-one '(import (just scheme cons))))
+
+  (error? ($do-one '(module ((a . b)) c)))
+
+  (error? ($do-one '(module (a . b) c)))
+
+  (error? ($do-one '(define x y z)))
+
+  (error? ($do-one '(define-syntax x y z)))
+
+  (error? ($do-one '(case-lambda (()))))
+
+  (error? ($do-one '(import m-not-defined)))
+
+  (error? ($do-one '(let () (import m-not-defined) 3)))
+
+  (error? ($do-one '(module () (import m-not-defined))))
+
+  (error? ($do-one '(lambda (x) (define x 3))))
+
+  (begin
+    (define-syntax muck (lambda (x) 'x))
+    #t)
+
+  (error? ($do-one '(muck)))
+
+  (error? ($do-one '(eval-when (compile load foo) bar)))
+
+  (error? ($do-one '(let ((x 3) (y . 4)) (+ x y))))
+
+  (error? ($do-one '(begin
+                        (define-syntax $a
+                          (lambda (x)
+                            (syntax-case x ()
+                              ((_ a b c)
+                               (syntax-case #'(a b c) ()
+                                 [(_ x y z) (quote (x y z))])))))
+                        ($a 1 2 3))))
+ ; [
+  (error? ($do-one "'(a b (c d])")) ; )
+
+  (error? ($do-one '(let () 
+                      (define-syntax a
+                        (lambda (x)
+                          (syntax-case x ()
+                            [a (datum->syntax #'a '(if 1))])))
+                      a)))
+
+  (error? ($do-one '(let ()
+                      (define-syntax a
+                        (syntax-rules ()
+                          [(_ m i)
+                           (module m (i)
+                             (import m1))]))
+                      (module m1 (xxx) (define xxx 155))
+                      (a m2 xxx)
+                      (let () (import m2) xxx))))
+
+  (error? ($do-one '(let ()
+                      (define-syntax a
+                        (lambda (q)
+                          #'(let ()
+                              (define x 5)
+                              (define-syntax x
+                                (identifier-syntax 5))
+                              x)))
+                      a)))
+
+  (error? ; attempt to assign immutable variable cons
+    ($do-one '(begin
+                (set! cons list)
+                (cons 1 2 3))))
+
+  (error? ; attempt to assign immutable variable x
+    ($do-one
+       '(begin
+          (library ($selib1) (export (rename (a $selib1-a)))
+            (import (rnrs))
+            (define x 0)
+            (define-syntax a 
+              (syntax-rules ()
+                [(_ n) (begin (set! x (+ x n)) x)])))
+          (import ($selib1))
+          ($selib1-a 17))))
+
+  (error? ; attempt to assign immutable variable x
+    ($do-one
+       '(begin
+          (library ($selib1) (export (rename (a $selib1-a)))
+            (import (rnrs))
+            (define x 0)
+            (define-syntax a 
+              (syntax-rules ()
+                [(_) (begin (set! x (+ x 1)) x)])))
+          (import ($selib1))
+          ($selib1-a))))
+
+  (error?
+    (mat/cf
+      (begin
+        (define-syntax err-test
+          (syntax-rules ()
+            [(_ a b c) (list 'a 'b 'c)]))
+        (err-test "wrong # args"))))
+
+  (error? ($do-one '(let () 3 (module foo ()) 4)))
+  (error? ($do-one '(let () 3 (module ()) 4)))
+  (error? ($do-one '(let () 3 (import scheme) 4)))
+  (error? ($do-one '(let () 3 (import-only scheme) 4)))
+  (error? ($do-one '(let () 3 (module . foo) 4)))
+  (error? ($do-one '(let () 3 (module) 4)))
+  (error? ($do-one '(let () 3 (import . scheme) 4)))
+  (error? ($do-one '(let () 3 (import-only . scheme) 4)))
+
+  (error? ($do-one '(let () (define-syntax foo (syntax-rules () [(_ e) (if e)])) (foo 17))))
+
+  (error? ($do-one
+            `(let ()
+               (define-syntax spam
+                 (lambda (x)
+                   #`(assert (let-syntax ([q '#,(lambda (x) #f)]) q))))
+               spam)))
+  (error? ($do-one
+            '(let ()
+               (define-syntax spam
+                 (lambda (x)
+                   #`(let-values ([(a b) (let-syntax ([q '#,(lambda (x) 3)]) q)])
+                       (list a b))))
+               spam)))
+  (error? ($do-one
+            '(let ()
+               (define-syntax spam
+                 (lambda (x)
+                   #'(let ()
+                       (define x 0)
+                       (define y 1)
+                       (define-property x y sort)
+                       (let-values ([(a b c) (values x y)])
+                         (list a b)))))
+               spam)))
+ )
+
+; this is identical to the preceding except that $do-one calls compile-file instead
+; of load.
+(mat syntax-errors2
+  (begin
+    (define $do-one
+      (lambda (x)
+        (collect (collect-maximum-generation)) ; close ports left open by load/compile-file w/mat's error handler
+        (let ((op (open-output-file "testfile.ss" 'replace)))
+          (fprintf op "   ~%     ")
+          (if (string? x)
+              (fprintf op "~a~%" x)
+              (parameterize ((pretty-initial-indent 5))
+                (pretty-print x op)))
+          (close-output-port op))
+        (compile-file "testfile.ss")
+        (load "testfile.so")))
+    #t)
+
+ ; fix "missing definition for exports" error to be like duplicate-id-error
+ ; as is, no character position information is given
+  (error? ($do-one '(module (y) (define x 3))))
+
+ ; get no character position information for this
+  (error? ($do-one '(let () (define x 3) (define-syntax x (identifier-syntax 4)) x)))
+
+ ; these should possibly give position of invalid/duplicate id, not whole form
+  (error? ($do-one '(let () (module (x) (define x 3) (define-syntax x (identifier-syntax 4))) x)))
+
+  (error? ($do-one '(module (x) (define x 3) (define-syntax x (identifier-syntax 4)))))
+
+  (error? ($do-one '(letrec ((3 4)) 5)))
+
+  (error? ($do-one '(letrec-syntax ((3 4)) 5)))
+
+ ; these should be okay:
+  (error? ($do-one
+            '(module (x)
+               (module (x) (define a 1) (define a 2) (define x 3) (define x 4)))))
+
+  (error? ($do-one '(a . b)))
+
+  (error? ($do-one '(module (x) (define x 3) (define x 4))))
+
+  (error? ($do-one '(module (x) (module (x) (define x 3) (define x 4)))))
+
+  (error? ($do-one '(letrec ((x 3) (x 4)) x)))
+
+  (error? ($do-one '(letrec-syntax ((x 3) (x 4)) x)))
+
+  (error? ($do-one '(let () (module (x) (define x 3) (define x 4)) x)))
+
+  (error? ($do-one '(let () (define x 3) (define x 4) x)))
+
+  (error? ($do-one '(cond (a . b))))
+
+  (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ b b) (syntax b)))))
+
+  (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ a ...) 3 4 5))))
+
+  (error? ($do-one '(syntax-case (list 'a 'b) (a ...) ((_ a ...) 3))))
+
+  (error? ($do-one '(syntax a b)))
+
+  (error? ($do-one '(if a b c d)))
+
+  (error? ($do-one '(letrec ((x 3) (y 4) . (z 5)) (list x y z))))
+
+  (error? ($do-one '(let () ($primitive 4 car))))
+
+  (error? ($do-one '(syntax-case x)))
+
+  (error? ($do-one '(quote a b)))
+
+  (error? ($do-one '(fluid-let-syntax)))
+
+  (error? ($do-one '(letrec-syntax () . 3)))
+
+  (error? ($do-one '(lambda (x x) x)))
+
+  (error? ($do-one '(lambda (x y) . z)))
+
+  (error? ($do-one '(lambda (3) 3)))
+
+  (error? ($do-one '(let ((x 4)) (set! x 3 5) x)))
+
+  (error? ($do-one '(set! x 3 5)))
+
+  (error? ($do-one '(let () (import . x) 3)))
+
+  (error? ($do-one '(import . x)))
+
+  (error? ($do-one '(let () (import (just scheme cons)))))
+
+  (error? ($do-one '(import (just scheme cons))))
+
+  (error? ($do-one '(module ((a . b)) c)))
+
+  (error? ($do-one '(module (a . b) c)))
+
+  (error? ($do-one '(define x y z)))
+
+  (error? ($do-one '(define-syntax x y z)))
+
+  (error? ($do-one '(case-lambda (()))))
+
+  (error? ($do-one '(import m-not-defined)))
+
+  (error? ($do-one '(let () (import m-not-defined) 3)))
+
+  (error? ($do-one '(module () (import m-not-defined))))
+
+  (error? ($do-one '(lambda (x) (define x 3))))
+
+  (begin
+    (define-syntax muck (lambda (x) 'x))
+    #t)
+
+  (error? ($do-one '(muck)))
+
+  (error? ($do-one '(eval-when (compile load foo) bar)))
+
+  (error? ($do-one '(let ((x 3) (y . 4)) (+ x y))))
+
+  (error? ($do-one '(begin
+                        (define-syntax $a
+                          (lambda (x)
+                            (syntax-case x ()
+                              ((_ a b c)
+                               (syntax-case #'(a b c) ()
+                                 [(_ x y z) (quote (x y z))])))))
+                        ($a 1 2 3))))
+ ; [
+  (error? ($do-one "'(a b (c d])")) ; )
+
+  (error? ($do-one '(let () 
+                      (define-syntax a
+                        (lambda (x)
+                          (syntax-case x ()
+                            [a (datum->syntax #'a '(if 1))])))
+                      a)))
+
+  (error? ($do-one '(let ()
+                      (define-syntax a
+                        (syntax-rules ()
+                          [(_ m i)
+                           (module m (i)
+                             (import m1))]))
+                      (module m1 (xxx) (define xxx 155))
+                      (a m2 xxx)
+                      (let () (import m2) xxx))))
+
+  (error? ($do-one '(let ()
+                      (define-syntax a
+                        (lambda (q)
+                          #'(let ()
+                              (define x 5)
+                              (define-syntax x
+                                (identifier-syntax 5))
+                              x)))
+                      a)))
+
+  (error? ; ris #f: attempt to assign immutable variable cons
+          ; ris #t: incorrect number of arguments to cons
+    ($do-one '(begin
+                (set! cons list)
+                (set! cons #%cons)
+                (cons 1 2 3))))
+
+  (error? ; attempt to assign immutable variable x
+    ($do-one
+       '(begin
+          (library ($selib1) (export (rename (a $selib1-a)))
+            (import (rnrs))
+            (define x 0)
+            (define-syntax a 
+              (syntax-rules ()
+                [(_ n) (begin (set! x (+ x n)) x)])))
+          (import ($selib1))
+          ($selib1-a 17))))
+
+  (error? ; attempt to assign immutable variable x
+    ($do-one
+       '(begin
+          (library ($selib1) (export (rename (a $selib1-a)))
+            (import (rnrs))
+            (define x 0)
+            (define-syntax a 
+              (syntax-rules ()
+                [(_) (begin (set! x (+ x 1)) x)])))
+          (import ($selib1))
+          ($selib1-a))))
+
+  (error?
+    (mat/cf
+      (begin
+        (define-syntax err-test
+          (syntax-rules ()
+            [(_ a b c) (list 'a 'b 'c)]))
+        (err-test "wrong # args"))))
+
+  (error? ($do-one '(let () 3 (module foo ()) 4)))
+  (error? ($do-one '(let () 3 (module ()) 4)))
+  (error? ($do-one '(let () 3 (import scheme) 4)))
+  (error? ($do-one '(let () 3 (import-only scheme) 4)))
+  (error? ($do-one '(let () 3 (module . foo) 4)))
+  (error? ($do-one '(let () 3 (module) 4)))
+  (error? ($do-one '(let () 3 (import . scheme) 4)))
+  (error? ($do-one '(let () 3 (import-only . scheme) 4)))
+
+  (error? ($do-one '(let () (define-syntax foo (syntax-rules () [(_ e) (if e)])) (foo 17))))
+
+  ; make sure we don't get complaints from fasl writer due to procedures in the source
+  ; information residualzied for the production of errors
+  (error? ($do-one
+            `(let ()
+               (define-syntax spam
+                 (lambda (x)
+                   #`(assert (let-syntax ([q '#,(lambda (x) #f)]) q))))
+               spam)))
+  (error? ($do-one
+            '(let ()
+               (define-syntax spam
+                 (lambda (x)
+                   #`(let-values ([(a b) (let-syntax ([q '#,(lambda (x) 3)]) q)])
+                       (list a b))))
+               spam)))
+  (error? ($do-one
+            '(let ()
+               (define-syntax spam
+                 (lambda (x)
+                   #'(let ()
+                       (define x 0)
+                       (define y 1)
+                       (define-property x y sort)
+                       (let-values ([(a b c) (values x y)])
+                         (list a b)))))
+               spam)))
+ )
+
+(mat define-structure
+   (begin
+     (define-structure ($tree left node right))
+     #t)
+   ($tree? (make-$tree 3 4 5))
+   (let ((tr (make-$tree 'a 'b 'c)))
+      (and (eq? ($tree-left tr) 'a)
+           (eq? ($tree-node tr) 'b)
+           (eq? ($tree-right tr) 'c)))
+   (begin
+     (define-structure (pare kar kdr)
+        ((original-kar kar) (original-kdr kdr)))
+     #t)
+   (andmap procedure?
+           (list make-pare
+                 pare?
+                 pare-kar
+                 pare-kdr
+                 pare-original-kar
+                 pare-original-kdr
+                 set-pare-kar!
+                 set-pare-kdr!
+                 set-pare-original-kar!
+                 set-pare-original-kdr!))
+   (pare? (make-pare 3 4))
+   (eq? (pare-kar (make-pare 'a 'b)) 'a)
+   (eq? (pare-kdr (make-pare 'a 'b)) 'b)
+   (eq? (pare-original-kar (make-pare 'a 'b)) 'a)
+   (eq? (pare-original-kdr (make-pare 'a 'b)) 'b)
+   (let ((p (make-pare 'a 'b)))
+      (set-pare-kar! p 'c)
+      (set-pare-kdr! p 'd)
+      (and (eq? (pare-kar p) 'c)
+           (eq? (pare-kdr p) 'd)
+           (eq? (pare-original-kar p) 'a)
+           (eq? (pare-original-kdr p) 'b)))
+ )
+
+(mat module1
+  (begin
+    (module $foo ($a) (define $a 4) (define $b 5))
+    (import $foo)
+    (eq? $a 4))
+  (error?
+    (begin
+      (module $foo ($a) (define $a 4) (define $b 5))
+      (import $foo)
+      $b))
+  (eq? (let ()
+         (module $foo ($a) (define $a 4) (define $b 5))
+         (import $foo)
+         $a)
+       4)
+  (error?
+    (let ()
+      (module $foo ($a) (define $a 4) (define $b 5))
+      (import $foo)
+      $b))
+  (begin
+    (module $foo ($a)
+      (define-syntax $a (identifier-syntax 4))
+      (define-syntax $b (identifier-syntax 5)))
+    (import $foo)
+    (eq? $a 4))
+  (error?
+    (begin
+      (module $foo ($a)
+        (define-syntax $a (identifier-syntax 4))
+        (define-syntax $b (identifier-syntax 5)))
+      (import $foo)
+      $b))
+  (eq? (let ()
+         (module $foo ($a)
+           (define-syntax $a (identifier-syntax 4))
+           (define-syntax $b (identifier-syntax 5)))
+         (import $foo)
+         $a)
+       4)
+  (error?
+    (let ()
+      (module $foo ($a)
+        (define-syntax $a (identifier-syntax 4))
+        (define-syntax $b (identifier-syntax 5)))
+      (import $foo)
+      $b))
+  (begin
+    (module $foo (($a $b))
+      (define-syntax $a (identifier-syntax $b))
+      (define $b 400))
+    (import $foo)
+    (eq? $a 400))
+  (error?
+    (begin
+      (module $foo ($a)
+        (define-syntax $a (identifier-syntax $b))
+        (define $b 400))
+      (import $foo)
+      $a))
+  (eq? (let ()
+         (module $foo (($a $b))
+           (define-syntax $a (identifier-syntax $b))
+           (define $b 400))
+         (import $foo)
+         $a)
+       400)
+  (eq? (let ()
+         (module $foo ($a)
+           (define-syntax $a (identifier-syntax $b))
+           (define $b 400))
+         (import $foo)
+         $a)
+       400)
+  (begin
+    (define-syntax anonymous-module
+      (syntax-rules ()
+        ((_ (exp ...) def ...)
+         (begin
+           (module $tmp (exp ...) def ...)
+           (import $tmp)))))
+    (anonymous-module ($x) (define $x 3))
+    (eq? $x 3))
+  (eq? (let () (anonymous-module ($x) (define $x 3)) $x) 3)
+  (begin
+    (define $y (lambda () $x))
+    (anonymous-module ($x) (define $x 3))
+    (eq? ($y) 3))
+  (eq? (let ()
+         (define $y (lambda () $x))
+         (anonymous-module ($x) (define $x 3))
+         ($y))
+       3)
+  (begin
+    (anonymous-module (ok)
+      (define $y 4)
+      (define ok (lambda () $y)))
+    (define $y (lambda () (ok)))
+    (eq? ($y) 4))
+ ; was an error before change to treat top-level begin like a 
+  (begin
+    (define $y (lambda () (rats)))
+    (anonymous-module (rats)
+      (define $y 4)
+      (define rats (lambda () $y)))
+    (eqv? ($y) 4))
+  (eq? (let ()
+         (define $y (lambda () ($x)))
+         (anonymous-module ($x)
+           (define $y 4)
+           (define $x (lambda () $y)))
+         ($y))
+       4)
+  (begin
+    (anonymous-module ($a)
+      (anonymous-module ($a)
+        (define $a 3)))
+    (eq? $a 3))
+  (begin
+    (anonymous-module ($a)
+      (anonymous-module (($a $b))
+        (define-syntax $a (identifier-syntax $b))
+        (define $b 77)))
+    (eq? $a 77))
+  (begin
+    (define-syntax defconst
+      (syntax-rules ()
+        ((_ $x e)
+         (anonymous-module (($x t)) 
+           (define-syntax $x (identifier-syntax t))
+           (define t e)))))
+    (defconst $a 3)
+    (eq? $a 3))
+  (error? (set! $a 4))
+  (begin
+    (module $qq ($q) (defconst $q 53))
+    (eq? (let () (import $qq) $q) 53))
+  (error? (let () (import $qq) (set! $q 4)))
+  (begin (import $qq) (eq? $q 53))
+  (error? (set! $q 4))
+ ; repeat last set of tests for built-in anonymous modules
+  (begin
+    (module ($x) (define $x 3))
+    (eq? $x 3))
+  (eq? (let () (module ($x) (define $x 3)) $x) 3)
+  (begin
+    (define $y (lambda () $x))
+    (module ($x) (define $x 3))
+    (eq? ($y) 3))
+  (eq? (let ()
+         (define $y (lambda () $x))
+         (module ($x) (define $x 3))
+         ($y))
+       3)
+  (begin
+    (module (ok)
+      (define $y 4)
+      (define ok (lambda () $y)))
+    (define $y (lambda () (ok)))
+    (eq? ($y) 4))
+ ; was an error before change to treat top-level begin like a 
+  (begin
+    (define $y (lambda () (mice)))
+    (module (mice)
+      (define $y 4)
+      (define mice (lambda () $y)))
+    (eqv? ($y) 4))
+  (eq? (let ()
+         (define $y (lambda () ($x)))
+         (module ($x)
+           (define $y 4)
+           (define $x (lambda () $y)))
+         ($y))
+       4)
+  (begin
+    (module ($a)
+      (module ($a)
+        (define $a 3)))
+    (eq? $a 3))
+  (begin
+    (module ($a)
+      (module (($a $b))
+        (define-syntax $a (identifier-syntax $b))
+        (define $b 77)))
+    (eq? $a 77))
+  (begin
+    (define-syntax defconst
+      (syntax-rules ()
+        ((_ $x e)
+         (module (($x t)) 
+           (define-syntax $x (identifier-syntax t))
+           (define t e)))))
+    (defconst $a 3)
+    (eq? $a 3))
+  (error? (set! $a 4))
+  (begin
+    (module $qq ($q) (defconst $q 53))
+    (eq? (let () (import $qq) $q) 53))
+  (error? (let () (import $qq) (set! $q 4)))
+  (begin (import $qq) (eq? $q 53))
+  (error? (set! $q 4))
+  (begin
+    (module $prom ((del make-$prom) frc)
+      (define-syntax del
+        (syntax-rules ()
+          ((_ exp) (make-$prom (lambda () exp)))))
+      (define frc (lambda ($prom) ($prom)))
+      (define make-$prom
+        (lambda (th)
+          (let ([val #f] [forced? #f])
+            (lambda ()
+              (if forced?
+                  val
+                  (let ([e (th)]) (set! forced? #t) (set! val e) e)))))))
+    (module $tofu ($lazy-let)
+      (import $prom)
+      (define-syntax $lazy-let
+        (lambda (form)
+          (syntax-case form ()
+            [(_ ((v e) ...) e1 e2 ...)
+             #'(let ([v (del e)] ...)
+                 (let-syntax ((v (identifier-syntax (frc v))) ...)
+                   e1 e2 ...))]))))
+    (module $test ($a)
+      (import $tofu)
+      (define-syntax push!
+        (syntax-rules ()
+          ((_ $x ls) (set! ls (cons $x ls)))))
+      (define $a
+        (lambda ()
+          (let ((ls '()))
+            (let ((w ($lazy-let (($x (begin (push! '$x ls) '$x))
+                                 ($y (begin (push! '$y ls) '$y))
+                                 ($z (begin (push! '$z ls) '$z)))
+                       (if $x (list $x $y) $z))))
+              (append w ls))))))
+    (equal? (let () (import $test) ($a)) '($x $y $y $x)))
+  (begin (import $test) (equal? ($a) '($x $y $y $x)))
+  (error? (let () (module () (define $a 3) (define-syntax $a list)) 5))
+  (eqv?
+    (let ()
+      (module $a ($x) (define $x 3) (set! $x (+ $x 1)))
+      (import $a)
+      $x)
+    4)
+  (eq? (let ()
+         (module $foo ($a)
+           (module $a ($b)
+             (define-syntax $a (identifier-syntax $b))
+             (define-syntax $b (identifier-syntax $c))
+             (define $c 7)))
+         (import $foo)
+         (import $a)
+         $b)
+       7)
+  (eq? (let ()
+         (module $foo ($a) (module $a ($x) (define $x 3)))
+         (import $foo)
+         (import $a)
+         $x)
+       3)
+  (begin
+    (module $foo ($a) (module $a ($x) (define $x 3)))
+    (import $foo)
+    (import $a)
+    (eq? $x 3))
+  (error?
+    (begin
+      (module $foo ($a)
+        (module $a ($b)
+          (define-syntax $a (identifier-syntax $b))
+          (define-syntax $b (identifier-syntax $c))
+          (define $c 7)))
+      (import $foo)
+      (import $a)
+      $b))
+  (begin
+    (module $foo ($a)
+      (module $a (($b $c))
+        (define-syntax $a (identifier-syntax $b))
+        (define-syntax $b (identifier-syntax $c))
+        (define $c 7)))
+    (import $foo)
+    (import $a)
+    (eq? $b 7))
+  (error?
+    (begin
+      (module $foo ($a)
+        (module $a (($b $c))
+          (define-syntax $a (identifier-syntax $c))
+          (define-syntax $b (identifier-syntax $a))
+          (define $c 7)))
+      (import $foo)
+      (import $a)
+      (eq? $b 7)))
+  (error?
+   (begin
+    (module $foo ($a)
+      (module $a (($b $a))
+        (define-syntax $a (identifier-syntax $c))
+        (define-syntax $b (identifier-syntax $a))
+        (define $c 7)))
+    (import $foo)
+    (import $a)
+    (eq? $b 7)))
+  (begin
+    (module $foo ($a)
+      (module $a (($b ($a $c)))
+        (define-syntax $a (identifier-syntax $c))
+        (define-syntax $b (identifier-syntax $a))
+        (define $c 7)))
+    (import $foo)
+    (import $a)
+    (eq? $b 7))
+  (begin
+    (module $foo ($a)
+      (module $a (($b $a $c))
+        (define-syntax $a (identifier-syntax $c))
+        (define-syntax $b (identifier-syntax $a))
+        (define $c 7)))
+    (import $foo)
+    (import $a)
+    (eq? $b 7))
+  (begin
+    (module $foo ($a)
+      (module $a (($b $a))
+        (module (($a $c))
+          (define-syntax $a (identifier-syntax $c))
+          (define $c 7))
+        (define-syntax $b (identifier-syntax $a))))
+    (import $foo)
+    (import $a)
+    (eq? $b 7))
+  (error?
+    (begin
+      (module $foo ($a)
+        (define-syntax $a (identifier-syntax $b))
+        (define-syntax $b (identifier-syntax 4)))
+      (import $foo)
+      $a))
+  (eq? (let ()
+         (module $foo ($a)
+           (define-syntax $a (identifier-syntax $b))
+           (define-syntax $b (identifier-syntax $c))
+           (define $c 7))
+         (import $foo)
+         $a)
+       7)
+  (eq? (let ()
+         (module $foo ($y)
+           (module $x ($y)
+             (define-syntax $y (identifier-syntax $z))
+             (define $z 4))
+           (import $x))
+         (import $foo)
+         $y)
+       4)
+  (eq? (let ()
+         (module $foo ($y)
+           (module $x (($y $z))
+             (define-syntax $y (identifier-syntax $z))
+             (define $z 4))
+           (import $x))
+         (import $foo)
+         $y)
+       4)
+  (error?
+    (begin
+      (module $foo ($y)
+        (module $x ($y)
+          (define-syntax $y (identifier-syntax $z))
+          (define $z 4))
+        (import $x))
+      (import $foo)
+      $y))
+  (begin
+    (module $foo ($y)
+      (module $x (($y $z))
+        (define-syntax $y (identifier-syntax $z))
+        (define $z 4))
+      (import $x))
+    (import $foo)
+    (eq? $y 4))
+  (eq? (let ()
+         (module $foo ($y)
+           (module $x ($y $z)
+             (define-syntax $y (identifier-syntax $z))
+             (define $z 4))
+           (import $x))
+         (import $foo)
+         $y)
+       4)
+  (error?
+    (begin
+      (module $foo ($y)
+        (module $x ($y $z)
+          (define-syntax $y (identifier-syntax $z))
+          (define $z 44))
+        (import $x))
+      (import $foo)
+      (eq? $y 44)))
+  (begin
+    (module $foo ($y)
+      (module $x (($y $z) $z)
+        (define-syntax $y (identifier-syntax $z))
+        (define $z 44))
+      (import $x))
+    (import $foo)
+    (eq? $y 44))
+  (begin
+    (module $foo (($y $z))
+      (module $x ($y $z)
+        (define-syntax $y (identifier-syntax $z))
+        (define $z 44))
+      (import $x))
+    (import $foo)
+    (eq? $y 44))
+  (error?
+    (let ()
+      (module $foo (($y $z))
+        (module (($y $z))
+          (define-syntax $y (identifier-syntax $z))
+          (define $z 4)))
+      (import $foo)
+      $y))
+  (error? ; undefined export $y
+    (let ()
+      (module $foo (($y $z))
+        (define-syntax $y (identifier-syntax $z))
+        (module ($y))
+        (define $z 4))
+      (import $foo)
+      $y))
+  (error? ; undefined export $z
+    (let ()
+      (module $foo ($y)
+        (module (($y $z))
+          (define-syntax $y (identifier-syntax $z)))
+        (define $z 4))
+      (import $foo)
+      $y))
+ ; following demonstrates "recursive" modules
+  (equal?
+    (let ()
+      (module $one ($e)
+        (define $e (lambda ($x) (or (zero? $x) ($o (- $x 1))))))
+      (module $two ($o)
+        (define $o (lambda ($x) (not ($e $x)))))
+      (import $one)
+      (import $two)
+      (map (lambda ($x) (list ($o $x) ($e $x))) '(0 1 2 3 4 5)))
+    '((#f #t) (#t #f) (#f #t) (#t #f) (#f #t) (#t #f)))
+ ; "recursive" modules don't work at top level ...
+  (error?
+    (begin
+      (module $one ($e)
+        (define $e (lambda ($x) (or (zero? $x) ($o (- $x 1))))))
+      (module $two ($o)
+        (define $o (lambda ($x) (not ($e $x)))))
+      (import $one)
+      (import $two)
+      (map (lambda ($x) ($o $x)) '(0 1 2 3 4 5))))
+ ; ... unless encapsulated within a top-level module
+  (begin
+    (module ($e $o)
+      (module $one ($e)
+        (define $e (lambda ($x) (or (zero? $x) ($o (- $x 1))))))
+      (module $two ($o)
+        (define $o (lambda ($x) (not ($e $x)))))
+      (import $one)
+      (import $two))
+    (equal?
+      (map (lambda ($x) (list ($o $x) ($e $x))) '(0 1 2 3 4 5))
+      '((#f #t) (#t #f) (#f #t) (#t #f) (#f #t) (#t #f))))
+ ; the following set of tests, as with many others above, highlights the
+ ; difference between the flexibility of local and rigidness of global
+ ; export rules.  for the global, we need to explicitly list the implicit
+ ; exports; for the global, we do not.
+  (eq? (let ()
+         (module $a ($alpha)
+           (define-syntax $alpha (identifier-syntax $x))
+           (module $b ($x) (define $x 3))
+           (import $b))
+         (import $a)
+         $alpha)
+       3)
+  (error?
+    (begin
+      (module $a ($alpha)
+        (define-syntax $alpha (identifier-syntax $x))
+        (module $b ($x) (define $x 3))
+        (import $b))
+      (import $a)
+      $alpha))
+  (begin
+    (module $a (($alpha $x))
+      (define-syntax $alpha (identifier-syntax $x))
+      (module $b ($x) (define $x 3))
+      (import $b))
+    (import $a)
+    (eq? $alpha 3))
+  (equal?
+    (let ()
+      (define $x "current outer value of $x")
+      (let ()
+        (module $a ($alpha)
+          (define-syntax $alpha (identifier-syntax $x))
+          (module $b ($y) (define $y 445) (define $x 3))
+          (import $b))
+        (import $a)
+        $alpha))
+    "current outer value of $x")
+  (begin
+    (define $x "current outer value of $x")
+    (module $a ($alpha)
+      (define-syntax $alpha (identifier-syntax $x))
+      (module $b ($y) (define $y 445) (define $x 3))
+      (import $b))
+    (import $a)
+    (equal? $alpha "current outer value of $x"))
+  (begin
+    (define-syntax $beta
+      (syntax-rules ()
+        ((_ x y)
+         (begin
+           (module x ($beta-a) (define $beta-a 666))
+           (import x)
+           (define-syntax y (identifier-syntax $beta-a))))))
+    (eqv? (let () ($beta q t) t) 666))
+  (error? (let () ($beta q t) $beta-a))
+  (begin
+    (define-syntax $gamma
+      (syntax-rules ()
+        ((_ x y)
+         (begin
+           (module x ($aaa) (define $aaa 666))
+           (define y (lambda () (import x) $aaa))))))
+    (eq? (let () ($gamma q t) (t)) 666))
+  (error? (let () ($gamma q t) (import q) $aaa))
+  (begin ($gamma $q $t) #t)
+  (eqv? ($t) 666)
+  (error? (let () (import $q) $aaa))
+  (error? (begin (import $q) (eq? $aaa 666)))
+  (error?
+    (begin
+      (define-syntax a
+        (lambda (x)
+          (syntax-case x ()
+            ((_ e) #'(define x e)))))
+      (a 3)))
+  (error?
+    (begin
+      (define-syntax a
+        (lambda (x)
+          (syntax-case x ()
+            ((_ e) #'(define-syntax x e)))))
+      (a (identifier-syntax 4))))
+  (error?
+    (begin
+      (define-syntax a
+          (lambda (x)
+            (syntax-case x ()
+              ((_ i e) #'(module x (i) (define i e))))))
+      (a b 'c)))
+  (error? ; defnie not defined
+    (module (y) (import-only (rnrs)) (defnie x 3) (define y 4)))
+)
+
+(mat module2
+  (begin
+    (define-syntax $define-structure
+      (lambda (x)
+        (define construct-name
+          (lambda (template-identifier . args)
+            (datum->syntax
+              template-identifier
+              (string->symbol
+                (apply string-append
+                       (map (lambda (x)
+                              (if (string? x)
+                                  x
+                                  (symbol->string (syntax->datum x))))
+                            args))))))
+        (syntax-case x ()
+          ((_ (name id1 ...))
+           (andmap identifier? (syntax (name id1 ...)))
+           (with-syntax
+             ((constructor (construct-name (syntax name) "make-" (syntax name)))
+              (predicate (construct-name (syntax name) (syntax name) "?"))
+              ((access ...)
+               (map (lambda (x) (construct-name x (syntax name) "-" x))
+                    (syntax (id1 ...))))
+              ((assign ...)
+               (map (lambda (x)
+                      (construct-name x "set-" (syntax name) "-" x "!"))
+                    (syntax (id1 ...))))
+              (structure-length
+               (+ (length (syntax (id1 ...))) 1))
+              ((index ...)
+               (let f ((i 1) (ids (syntax (id1 ...))))
+                  (if (null? ids)
+                      '()
+                      (cons i (f (+ i 1) (cdr ids)))))))
+             (syntax (begin
+                       (module name (constructor access ...)
+                         (define constructor
+                           (lambda (id1 ...)
+                             (vector 'name id1 ... )))
+                         (define access
+                           (lambda (x)
+                             (vector-ref x index)))
+                         ...)
+                       (import name))))))))
+    (module $foo ($foos build-$foos)
+      ($define-structure ($foos x))
+      (define (build-$foos) (make-$foos 3)))
+    (let ()
+      (import $foo)
+      (import $foos)
+      (define x (build-$foos))
+      (define y (make-$foos 4))
+      (equal? (list ($foos-x x) ($foos-x y)) '(3 4))))
+  (begin
+    (import $foo)
+    (import $foos)
+    (define $x (build-$foos))
+    (define $y (make-$foos 4))
+    (equal? (list ($foos-x $x) ($foos-x $y)) '(3 4)))
+  (let ()
+    (define-syntax $define-structure
+      (lambda (x)
+        (define construct-name
+          (lambda (template-identifier . args)
+            (datum->syntax
+              template-identifier
+              (string->symbol
+                (apply string-append
+                       (map (lambda (x)
+                              (if (string? x)
+                                  x
+                                  (symbol->string (syntax->datum x))))
+                            args))))))
+        (syntax-case x ()
+          ((_ (name id1 ...))
+           (andmap identifier? (syntax (name id1 ...)))
+           (with-syntax
+             ((constructor (construct-name (syntax name) "make-" (syntax name)))
+              (predicate (construct-name (syntax name) (syntax name) "?"))
+              ((access ...)
+               (map (lambda (x) (construct-name x (syntax name) "-" x))
+                    (syntax (id1 ...))))
+              ((assign ...)
+               (map (lambda (x)
+                      (construct-name x "set-" (syntax name) "-" x "!"))
+                    (syntax (id1 ...))))
+              (structure-length
+               (+ (length (syntax (id1 ...))) 1))
+              ((index ...)
+               (let f ((i 1) (ids (syntax (id1 ...))))
+                  (if (null? ids)
+                      '()
+                      (cons i (f (+ i 1) (cdr ids)))))))
+             (syntax (begin
+                       (module name (constructor access ...)
+                         (define constructor
+                           (lambda (id1 ...)
+                             (vector 'name id1 ... )))
+                         (define access
+                           (lambda (x)
+                             (vector-ref x index)))
+                         ...)
+                       (import name))))))))
+    (module $foo ($foos build-$foos)
+      ($define-structure ($foos x))
+      (define (build-$foos) (make-$foos 3)))
+    (import $foo)
+    (import $foos)
+    (let ()
+      (define x (build-$foos))
+      (define y (make-$foos 4))
+      (equal? (list ($foos-x x) ($foos-x y)) '(3 4))))
+ )
+
+(mat module3
+  (equal? (let ()
+            (module foo (thing) (define thing #f))
+            (define set (lambda (x) (import foo) (set! thing x)))
+            (define get (lambda () (import foo) thing))
+            (let ([before (get)])
+              (set 37)
+              (list before (get))))
+          '(#f 37))
+  (eqv? (let ()
+          (module foo (thing) (define thing #f))
+          (define get (lambda () (import foo) thing))
+          (import foo)
+          (set! thing 37)
+          (get))
+        37)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax def (identifier-syntax (define x 123)))
+          (define-syntax fof (identifier-syntax (let () def x)))
+          fof)
+        45)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax def (identifier-syntax (define x 123)))
+          (define-syntax fof (identifier-syntax (let () def x)))
+          (let () fof))
+        45)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax fof (identifier-syntax (let () (define x 123) x)))
+          (let () fof))
+        123)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax def
+            (identifier-syntax
+              (begin (define x 123) (set! x (+ x x)))))
+          (define-syntax fof (identifier-syntax (let () def x)))
+          (let () fof))
+        45)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax def
+            (syntax-rules ()
+              ((_ id) (define id 123))))
+          (define-syntax fof (identifier-syntax (let () (def x) x)))
+          (let () fof))
+        123)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax fof
+            (identifier-syntax
+              (let ()
+                (define-syntax def (identifier-syntax (define x 123)))
+                def
+                x)))
+          (let () fof))
+        45)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax def (identifier-syntax (define x 123)))
+          (define-syntax ref (identifier-syntax x))
+          (let () def ref))
+        45)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax fof
+            (identifier-syntax
+              (let ()
+                (define-syntax def
+                  (lambda (x)
+                    (syntax-case x ()
+                      [id
+                       (identifier? #'id)
+                       (with-syntax ([var (datum->syntax #'id 'x)])
+                         #'(define var 123))])))
+                def
+                x)))
+          (let () fof))
+        123)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax zorpon (identifier-syntax define))
+          (define-syntax fof (identifier-syntax (let () (zorpon x 123) x)))
+          (let () fof))
+        123)
+  (eqv? (let ()
+          (define x 45)
+          (define-syntax def (identifier-syntax (zorpon x 123)))
+          (define-syntax fof (identifier-syntax (let () def x)))
+          (let () (fluid-let-syntax ((zorpon (identifier-syntax define))) fof)))
+        45)
+  (equal? (let ()
+            (module foo (x) (define x 3))
+            (define-syntax blah
+              (lambda (x)
+                (syntax-case x ()
+                  [id
+                   (identifier? #'id)
+                   (with-syntax ([output
+                                  (datum->syntax #'id
+                                    '(let () (import foo) x))])
+                     #'output)])))
+            (cons blah (let () blah)))
+        '(3 . 3))
+  (equal? (let ()
+            (module foo (x) (define x 3))
+            (module bar (x) (define x 5))
+            (define-syntax get
+              (lambda (x)
+                (syntax-case x ()
+                  [(_ mod)
+                   (identifier? #'mod)
+                   (with-syntax ([var (datum->syntax #'mod 'x)])
+                     #'(let () (import mod) var))])))
+            (cons (get bar) (let () (get foo))))
+          '(5 . 3))
+  (equal? (let ()
+            (module foo (x) (define x 3))
+            (module bar (x) (define x 5))
+            (define-syntax get
+              (syntax-rules ()
+                ((_ mod id) (let () (import mod) id))))
+            (cons (get bar x) (let () (get foo x))))
+          '(5 . 3))
+  (equal? (let ((x 1))
+            (module foo (x) (define x 3))
+            (module bar (x) (define x 5))
+            (define-syntax get-x
+              (syntax-rules ()
+                ((_ mod) (let () (import mod) x))))
+            (cons (get-x bar) (let () (get-x foo))))
+          '(1 . 1))
+)
+
+(mat module4
+  (equal?
+    (let ()
+      (define-syntax import*
+        (lambda (x)
+          (syntax-case x ()
+            [(_ mid) #'(import mid)]
+            [(_ mid s1 s2 ...)
+             (with-syntax ((((id ...) d ...)
+                            (let f ((ls #'(s1 s2 ...)))
+                              (if (null? ls)
+                                  '(())
+                                  (let ((rest (f (cdr ls))))
+                                    (syntax-case (car ls) (as)
+                                      [(as id1 id2)
+                                       (cons (cons #'id2 (car rest))
+                                             (cons #'(define-syntax id2
+                                                       (identifier-syntax id1))
+                                                   (cdr rest)))]
+                                      [id (identifier? #'id)
+                                       (cons (cons #'id (car rest))
+                                             (cdr rest))]))))))
+               #'(module (id ...) (import mid) d ...))])))
+      (module m1 (x y) (define x 'x) (define y 'y))
+      (list (let () (import* m1) (cons x y))
+            (let () (import* m1 x y) (cons x y))
+            (let () (import* m1 x) (define y 'yy) (cons x y))
+            (let ((x 'outer)) (import* m1 (as x xx) y) (list* x xx y))))
+    '((x . y) (x . y) (x . yy) (outer x . y)))
+)
+
+(mat module5
+  (begin
+    (module $zip (a b c)
+      (define a 1)
+      (define b 123)
+      (define-syntax c (identifier-syntax (list a b))))
+    (equal? (let () (import $zip) (list a b c))
+            '(1 123 (1 123))))
+  (eq? (let () (import-only $zip) a) 1)
+  (error? (let () (import-only $zip) (list a b c)))
+  (error? (let ((z list)) (import-only $zip) (z a b c)))
+  (equal?
+    (let ()
+      (module bar (q r s)
+        (import $zip)
+        (define q (lambda () a))
+        (define-syntax r (identifier-syntax b))
+        (define s (lambda () c)))
+      (list
+        (let () (import bar) (q))
+        (let () (import bar) r)
+        (let () (import bar) (s))
+        (let () (module (r) (import bar)) r)))
+    '(1 123 (1 123) 123))
+  (error?
+    (let ()
+      (module bar (q r s)
+        (import $zip)
+        (define q (lambda () a))
+        (define-syntax r (identifier-syntax b))
+        (define s (lambda () c)))
+      (let ((q "outer")) (module (r) (import bar)) (q))))
+  (begin
+    (module $zoom (m1 x)
+      (define x "this is x")
+      (module m1 (x (z y))
+        (define x "this is m1's x")
+        (define y "this is m1's y")
+        (define-syntax z (identifier-syntax y))))
+    (equal? (let () (import $zoom) (let ((q x)) (import m1) (list q x z)))
+            '("this is x" "this is m1's x" "this is m1's y")))
+  (error? (let () (import $zoom) (define q x) (import m1) (list q x z)))
+ ; check that we get the right x even though x (et al.) have
+ ; multiple properties in the implementation.
+  (begin
+    (module $foo (x a b c)
+      (define x "this is foo's X")
+      (define a "this is foo's A")
+      (define b "this is foo's B")
+      (define c "this is foo's C"))
+    (equal?
+      (list (let () (import $foo) (list x a))
+            (let () (import $foo) (list b c)))
+      '(("this is foo's X" "this is foo's A")
+        ("this is foo's B" "this is foo's C"))))
+  (error? (let () (import $foo) (import $zip) #t))
+)
+
+(mat module6
+  (begin
+    (define-syntax $from1
+      (syntax-rules ()
+        ((_ m id)
+         (let () (import-only m) id))))
+    (define-syntax $from2
+      (syntax-rules ()
+        ((_ m id)
+         (let () (module (id) (import m)) id))))
+    (define-syntax $from3
+      (syntax-rules ()
+        [(_ m id)
+         (let ([z (cons 1 2)])
+           (let ([id z])
+             (import m)
+             (let ([t id])
+               (if (eq? t z) (errorf 'from "~s undefined" 'id) t))))]))
+    (module $frappe (wire (whip egg))
+      (define wire 3)
+      (define-syntax whip (identifier-syntax egg))
+      (define egg 'whites))
+    (equal?
+      (list (cons ($from1 $frappe wire) ($from1 $frappe whip))
+            (cons ($from2 $frappe wire) ($from2 $frappe whip))
+            (cons ($from3 $frappe wire) ($from3 $frappe whip)))
+      '((3 . whites) (3 . whites) (3 . whites))))
+  (equal?
+    (let ()
+      (module q (m from)
+        (module m (f) (define f "this is f"))
+        (define-syntax from
+          (syntax-rules () [(_ m id) (let () (import-only m) id)])))
+      (let () (import-only q) (from m f)))
+    "this is f")
+  (begin
+    (module $q (m from)
+      (module m (f) (define f "this is f"))
+      (define-syntax from
+        (syntax-rules () [(_ m id) (let () (import-only m) id)])))
+    (equal? (let () (import-only $q) (from m f)) "this is f"))
+  (eqv? (let ()
+          (module p ((d m) f)
+            (define-syntax d
+              (syntax-rules ()
+                ((_ e) (m (lambda () e)))))
+            (define m (lambda (x) x))
+            (define f (lambda (th) (th))))
+          (let () (import-only p) (f (d 2))))
+        2)
+  (begin
+    (module $p ((d m) f)
+      (define-syntax d
+        (syntax-rules ()
+          ((_ e) (m (lambda () e)))))
+      (define m (lambda (x) x))
+      (define f (lambda (th) (th))))
+    (eqv? (let () (import-only $p) (f (d 2))) 2))
+  (error? (let () (import-only $p) (f (d cons))))
+)
+
+(mat module7
+  (begin (module ($x) (define $x 3) (set! $x (+ $x $x)))
+    (eq? $x 6))
+  (eq? (let () (module ($x) (define $x 3) (set! $x (+ $x $x))) $x) 6)
+)
+
+(mat module8
+  (begin
+    (module $m ($a $b)
+      (define-syntax $a (identifier-syntax 3))
+      (define-syntax $b (identifier-syntax $a)))
+    (eq? (let ()
+           (import $m)
+           (fluid-let-syntax (($a (identifier-syntax 4))) $b))
+         4))
+  (eq? (let ()
+         (import $m)
+         (fluid-let-syntax (($a (identifier-syntax 4))) $a))
+       4)
+  (begin
+    (import $m)
+    (eq? (fluid-let-syntax (($a (identifier-syntax 4))) $b) 4))
+  (begin
+    (define-syntax $a
+      (syntax-rules ()
+        ((_ m y z)
+         (begin
+           (module m ($crazy-x) (define $crazy-x 3731))
+           (import m)
+           (define y (lambda () $crazy-x))
+           (define-syntax z (identifier-syntax $crazy-x))))))
+    #t)
+  (begin
+    ($a $crazy-p $crazy-q $crazy-r)
+    (eq? $crazy-r 3731))
+  (error? $crazy-x)
+  (eq? ($crazy-q) 3731)
+  (eq? $crazy-r 3731)
+  (begin
+    (define-syntax $a1
+      (syntax-rules ()
+        ((_ m y)
+         (module m
+           ($flash-x y)
+           (define $flash-x "flash")
+           (define y (lambda () $flash-x))))))
+    #t)
+  (begin ($a1 $flash-p $flash-q) #t)
+  (begin (import $flash-p) (procedure? $flash-q))
+  (error? $flash-x)
+  (equal? ($flash-q) "flash")
+  (begin
+    (define-syntax $c
+      (syntax-rules ()
+        ((_ y)
+         (begin
+           (define-syntax $blast-x (identifier-syntax "blast"))
+           (define-syntax y (identifier-syntax $blast-x))))))
+    #t)
+  (begin ($c $blast-y) (equal? $blast-y "blast"))
+  (equal? $blast-y "blast")
+  (error? $blast-x)
+  (begin
+    (define-syntax $b
+      (syntax-rules ()
+        ((_ y) (begin
+                 (define $crud-x "crud")
+                 (define y (lambda () $crud-x))))))
+    #t)
+  (begin ($b $crud-y) (procedure? $crud-y))
+  (equal? ($crud-y) "crud")
+  (error? $crud-x)
+  (begin
+    (define-syntax $b2
+      (syntax-rules ()
+        ((_ x y)
+         (begin
+           (define-syntax x
+             (identifier-syntax
+               (begin
+                 (define $idiot-x "idiot")
+                 $idiot-x)))
+           (define y (lambda () $idiot-x))))))
+    #t)
+  (begin ($b2 $idiot-q $idiot-p) (procedure? $idiot-p))
+  (equal? (let () $idiot-q) "idiot")
+  (begin $idiot-q #t)
+  (error? ($idiot-p))
+ ; the following should probably generate an error, but doesn't due to
+ ; our change in wraps (we apply only the most recent substitution)
+ ; (error?
+ ;   (begin
+ ;     (define-syntax a
+ ;       (lambda (?)
+ ;         (with-syntax ((xx ((lambda (x) #'x) 4)))
+ ;           #'(module (x) (define xx 3)))))
+ ;     a))
+  (eq? (let ((junk #f))
+         (module (a) (import scheme)
+            (define-syntax a
+              (lambda (x)
+                (syntax-case x (foo car)
+                  ((_ foo car bar-lit cons-lit)
+                   (and (free-identifier=? #'bar-lit #'bar)
+                        (free-identifier=? #'cons-lit #'cons))
+                   #''yup)))))
+         (module () (import scheme)
+           (set! junk (a foo car bar cons)))
+         junk)
+       'yup)
+  (error? (let ((junk #f))
+            (module (a) (import scheme)
+               (define-syntax a
+                 (lambda (x)
+                   (syntax-case x (foo car)
+                     ((_ foo car bar-lit cons-lit)
+                      (and (free-identifier=? #'bar-lit #'bar)
+                           (free-identifier=? #'cons-lit #'cons))
+                      #''yup)))))
+            (module () (import scheme)
+              (define car 3)
+              (set! junk (a foo car bar cons)))
+            junk))
+)
+
+(mat module9
+  (eq? (let () (import-only r5rs) (cond (else 0))) 0)
+  (eq? (let () (import-only r5rs-syntax) (cond (else 0))) 0)
+  (eq? (let () (import-only ieee) (cond (else 0))) 0)
+  (eq? (let () (import-only scheme) (cond (else 0))) 0)
+  (eq? (let () (import-only $system) (cond (else 0))) 0)
+  (eq? (eval '(cond (else 0)) (scheme-report-environment 5)) 0)
+  (eq? (eval '(cond (else 0)) (null-environment 5)) 0)
+  (eq? (eval '(cond (else 0)) (interaction-environment)) 0)
+  (eq? (eval '(cond (else 0)) (ieee-environment)) 0)
+  (equal?
+    (let ()
+      (import-only scheme)
+      (define-record foo ((immutable a)))
+      (foo-a (make-foo 3)))
+    3)
+  (equal? (let ()
+            (module foo (a b)
+              (define-syntax a
+                (syntax-rules (b)
+                  ((_ b) "yup")
+                  ((_ c) (list c))))
+              (define-syntax b
+                (lambda (x)
+                  (syntax-error x "misplaced aux keyword"))))
+            (let ()
+              (import-only foo)
+              (a (a b))))
+          '("yup"))
+  (equal? (let ()
+            (import-only scheme)
+            `(a b ,(+ 3 4) ,@(list 'd 'e)))
+          '(a b 7 d e))
+ ; assuming internal-defines-as-letrec* defaults to #t
+  (internal-defines-as-letrec*)
+ ; following tests assume it's set to #f
+  (begin (internal-defines-as-letrec* #f) (not (internal-defines-as-letrec*)))
+  (error? ; cookie undefined
+    (begin
+      (module ($b)
+        (module (($b getvar))
+          (define getvar (lambda () "it worked"))
+          (module (($b cookie tmp))
+            (define cookie "secret")
+            (define tmp cookie)
+            (define-syntax $b
+              (identifier-syntax
+                (if (eq? tmp cookie) (begin (set! tmp (getvar)) tmp) tmp))))))
+      (string=? $b "it worked")))
+  (begin (internal-defines-as-letrec* #t) (internal-defines-as-letrec*))
+  (begin
+    (module ($b)
+      (module (($b getvar))
+        (define getvar (lambda () "it worked"))
+        (module (($b cookie tmp))
+          (define tmp)
+          (define cookie "secret")
+          (define-syntax $b
+            (identifier-syntax
+              (if (eq? tmp cookie) (begin (set! tmp (getvar)) tmp) tmp)))
+          (set! tmp cookie))))
+    (string=? $b "it worked"))
+  (begin
+    (module $foo ($b)
+      (module bar (($b getvar))
+        (module baz (($b cookie tmp))
+          (define cookie "secret")
+          (define tmp)
+          (define-syntax $b
+            (identifier-syntax
+              (if (eq? tmp cookie) (begin (set! tmp (getvar)) tmp) tmp)))
+          (set! tmp cookie))
+        (define getvar (lambda () "this also worked"))
+        (import baz))
+      (import bar))
+    (import $foo)
+    (string=? $b "this also worked"))
+)
+
+(mat module10
+  (begin ; make sure we the right binding is exported
+    (module ($module10-foo)
+      (define $module10-foo "okay")
+      (module () (define $module10-foo 'oh-oh)))
+    #t)
+  (equal? $module10-foo "okay")
+  (begin
+    (module ($module10-bar)
+      (module () (define $module10-bar 'oh-oh))
+      (define $module10-bar "fine"))
+    #t)
+  (equal? $module10-bar "fine")
+  (begin
+    (module ($module10-qwerty)
+      (module ($module10-qwerty)
+        (define $module10-qwerty "dandy")))
+    #t)
+  (equal? $module10-qwerty "dandy")
+  (let ()
+    (module (foo)
+      (define foo "okay")
+      (module () (define foo 'oh-oh)))
+    (equal? foo "okay"))
+  (let ()
+    (module (bar)
+      (module () (define bar 'oh-oh))
+      (define bar "fine"))
+    (equal? bar "fine"))
+  (let ()
+    (module (qwerty)
+      (module (qwerty)
+        (define qwerty "dandy")))
+    (equal? qwerty "dandy"))
+)
+
+(mat module11
+  (error? ; identifier out of context
+    (module (x y)
+      (define x 3)
+      (define-syntax y (lambda (z) x))))
+  (error? ; identifier out of context
+    (let ()
+      (module (x y)
+        (define x 3)
+        (define-syntax y (lambda (z) x)))
+      y))
+)
+
+(mat with-implicit
+  (error? ; invalid syntax
+    (with-implicit))
+  (error? ; invalid syntax
+    (with-implicit foo (bar ...) e1 e2))
+  (error? ; invalid syntax
+    (with-implicit (a b c)))
+  (error? ; invalid syntax
+    (with-implicit (a b c) . d))
+  (error? ; invalid syntax
+    (with-implicit (a b c) d . e))
+  (error? ; invalid syntax
+    (with-implicit (1 2 3) d e))
+  (error? ; invalid syntax
+    (with-implicit (a 2 c) d e))
+  (error? ; 15 is not an identifier
+    (with-syntax ([a 15])
+      (with-implicit (a b c) d e)))
+  (eqv?
+    (let ((borf 'borf-outer))
+      (define-syntax frob
+        (lambda (x)
+          (syntax-case x ()
+            [k (with-implicit (k borf) #'borf)])))
+      frob)
+    'borf-outer)
+  (equal?
+    (let ([borf 'borf-outer])
+      (define-syntax frob
+        (lambda (x)
+          (syntax-case x ()
+            [(k e)
+             (with-implicit (k borf)
+               #'(let () (define borf 'borf-inner) e))])))
+      (list borf (frob (list borf))))
+    '(borf-outer (borf-inner)))
+  (equal?
+    (let ()
+      (define-syntax for
+        (lambda (x)
+          (syntax-case x ()
+            [(k (e0 e1 e2) b1 b2 ...)
+             (with-implicit (k break continue)
+               #'(call/cc
+                   (lambda (break)
+                     e0
+                     (let f ()
+                       (when e1
+                         (call/cc (lambda (continue) b1 b2 ...))
+                         e2
+                         (f))))))])))
+      (define ls-in) 
+      (define ls-out)
+      (for ((begin (set! ls-in '(a b c d e f g h i j)) (set! ls-out '()))
+            (not (null? ls-in))
+            (set! ls-in (cdr ls-in)))
+        (when (memq (car ls-in) '(c e)) (continue))
+        (set! ls-out (cons (car ls-in) ls-out))
+        (when (memq (car ls-in) '(g j)) (break)))
+      ls-out)
+    '(g f d b a))
+)
+
+(mat datum
+  (error? (datum))
+  (error? (datum a b c))
+  (error? (datum . b))
+  (equal? (datum (a b c)) '(a b c))
+  (equal?
+    (let ()
+      (define-syntax ralph
+        (lambda (x)
+          (syntax-case x ()
+            [(k a b)
+             (fixnum? (datum a))
+             (with-syntax ([q (datum->syntax #'k (make-list (datum a) 15))])
+               #'(cons b 'q))]
+            [(_ a b) #'(cons 'a 'b)])))
+      (list (ralph 3 4) (ralph 3.0 4.0)))
+    '((4 15 15 15) (3.0 . 4.0)))
+)
+
+(mat alias
+  (error? ; invalid syntax
+    (alias x "y"))
+  (error? ; invalid syntax
+    (alias 3 x))
+  (eq? (let ((x 2)) (alias y x) y) 2)
+  (equal?
+    (let ((x "x"))          
+      (define-syntax fool
+        (let ()
+          (alias y x)
+          (lambda (z) #'y)))
+      fool)
+    "x")
+  (equal?
+    (let ()
+      (define x "x")
+      (alias y x)
+      y)
+    "x")
+  (begin
+    (module (($alias-blue blue))
+      (define blue "bleu")
+      (alias $alias-blue blue))
+    (equal? $alias-blue "bleu"))
+  (begin
+    (define $alias-blot "blot")
+    (equal? (let () (alias y $alias-blot) y) "blot"))
+  (begin
+    (define $alias-f (let () (alias x $alias-blarg) (lambda () x)))
+    (procedure? $alias-f))
+  (error? ; $alias-blarg not bound
+    ($alias-f))
+  (begin
+    (define $alias-blarg "blarg")
+    (equal? ($alias-f) "blarg"))
+  (begin
+    (define-syntax $alias-blarg (lambda (x) "bloog"))
+    (equal? ($alias-f) "blarg"))
+  (begin
+    (define $alias-g (let () (alias x lambda) (x () "g")))
+    (equal? ($alias-g) "g"))
+  (begin
+    (define $alias-x 3)
+    (alias $alias-y $alias-x)
+    (eq? $alias-y 3))
+  (eq? (let ()
+         (define $alias-x 4)
+         (alias $alias-y $alias-x)
+         $alias-y)
+       4)
+ ; the following is no longer an error: binding for label is exported
+ ; if the alias's identifier is exported
+  (begin
+    (module ($alias-y)
+      (define $alias-x 5)
+      (alias $alias-y $alias-x))
+    (eq? $alias-y 5))
+  (begin
+    (module ($alias-y55)
+      (define $alias-x55 5)
+      (alias $alias-y55 $alias-x55)
+      (alias $alias-z55 $alias-x55))
+    (eq? $alias-y 5))
+  (error? $alias-x55)
+  (error? $alias-z55)
+  (begin
+    (module (($alias-y $alias-x))
+      (define $alias-x 6)
+      (alias $alias-y $alias-x))
+    (eq? $alias-y 6))
+  (begin
+    (module ($alias-y)
+      (module (($alias-y $alias-x))
+        (define $alias-x 66)
+        (alias $alias-y $alias-x)))
+    (eq? $alias-y 66))
+  (eq? (let ()
+         (module (($alias-y $alias-x))
+           (define $alias-x 7)
+           (alias $alias-y $alias-x))
+         $alias-y)
+       7)
+  (eq? (let ((x 8))
+         (module (y) (alias y x))
+         y)
+       8)
+  (error? ; read-only environment
+    (eval '(alias x cons) (scheme-environment)))
+  (error? ; read-only environment
+    (eval
+      '(begin
+         (import scheme)
+         (alias $alias-cons cons)
+         (set! $alias-cons 3))
+      (copy-environment (interaction-environment))))
+  (error? ; read-only environment
+    (eval
+      '(begin
+         (import scheme)
+         (set! cons 3))
+      (copy-environment (interaction-environment))))
+  (begin
+    (module (($i-foo foo))
+      (define-record foo ())
+      (alias $i-foo foo))
+    (define-record $i-bar $i-foo (x))
+    ($i-bar? (make-$i-bar 3)))
+  (begin
+    (module ($i-foo)
+      (module m (foo) (define-record foo ()))
+      (module g2 (($i-foo g3))
+        (module g2 ((g3 foo))
+          (import m)
+          (alias g3 foo))
+        (import g2)
+        (alias $i-foo g3))
+      (import g2))
+    (define-record $i-bar $i-foo (x))
+    ($i-bar? (make-$i-bar 3)))
+  (begin
+    (module $alias-m ($alias:car) (import scheme) (alias $alias:car car))
+    (import $alias-m)
+    (eqv? ($alias:car '(2.3 4.5 6.7)) 2.3))
+  (begin
+    (library ($alias-a)
+      (export x)
+      (import (chezscheme))
+      (define y 17)
+      (alias x y))
+    #t)
+  (eqv? (let () (import ($alias-a)) x) 17)
+  (error? ; attempt to create an alias to unbound identifier y
+    (library ($alias-b)
+      (export x)
+      (import (chezscheme))
+      (alias x y)))
+  (error? ; attempt to create an alias to unbound identifier y
+    (library ($alias-c)
+      (export y)
+      (import (chezscheme))
+      (alias x y)
+      (define y 17)))
+  (begin
+    (with-output-to-file "testfile-alias-d.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-alias-d)
+             (export x)
+             (import (chezscheme))
+             (alias x y)
+             (define y 17))))
+      'replace)
+    #t)
+  (error? ; attempt to create an alias to unbound identifier y
+    (compile-file "testfile-alias-d"))
+  (error? ; attempt to create an alias to unbound identifier y
+    (load "testfile-alias-d.ss"))
+  (error? ; attempt to create an alias to unbound identifier y
+    (library ($alias-b)
+      (export x)
+      (import (chezscheme))
+      (let () (alias x y) 'hello)))
+  (eqv?
+    (let ()
+      (import-only (chezscheme))
+      (define y 17)
+      (alias x y)
+      x)
+    17)
+  (error? ; attempt to create an alias to unbound identifier y
+    (let ()
+      (import-only (chezscheme))
+      (alias x y)
+      7))
+  (error? ; attempt to create an alias to unbound identifier y
+    (let ()
+      (import-only (chezscheme))
+      (alias x y)
+      (define y 3)
+      7))
+  (begin
+    (with-output-to-file "testfile-alias-e.ss"
+      (lambda ()
+        (pretty-print
+          '(let ()
+             (import-only (chezscheme))
+             (alias x y)
+             (define y 3)
+             7)))
+      'replace)
+    #t)
+  (error? ; attempt to create an alias to unbound identifier y
+    (compile-file "testfile-alias-e"))
+  (error? ; attempt to create an alias to unbound identifier y
+    (load "testfile-alias-e.ss"))
+)
+
+(mat extended-import
+  (begin
+    (module $notscheme (cons car cdr)
+      (define cons)
+      (define car)
+      (define-syntax cdr (identifier-syntax $cdr)))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import scheme)
+            (cons car cdr)))))
+    (if (= (optimize-level) 3)
+        '(#3%cons #3%car #3%cdr)
+        '(#2%cons #2%car #2%cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (only scheme car cdr))
+            (cons car cdr)))))
+    (if (= (optimize-level) 3)
+        '((#3%$top-level-value 'cons) #3%car #3%cdr)
+        '((#2%$top-level-value 'cons) #2%car #2%cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (except scheme car cdr))
+            (cons car cdr)))))
+    (if (= (optimize-level) 3)
+        '(#3%cons (#3%$top-level-value 'car) $cdr)
+        '(#2%cons (#2%$top-level-value 'car) $cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (only (except scheme cdr) car))
+            (cons car cdr)))))
+    (if (= (optimize-level) 3)
+        '((#3%$top-level-value 'cons) #3%car $cdr)
+        '((#2%$top-level-value 'cons) #2%car $cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (add-prefix (only scheme car cdr) scheme:))
+            (cons scheme:car cdr)))))
+    (if (= (optimize-level) 3)
+        '((#3%$top-level-value 'cons) #3%car $cdr)
+        '((#2%$top-level-value 'cons) #2%car $cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (drop-prefix (only scheme car cdr cons) c))
+            (ons ar dr)))))
+    (if (= (optimize-level) 3)
+        '(#3%cons #3%car #3%cdr)
+        '(#2%cons #2%car #2%cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (rename scheme [car xar] [cdr xdr]))
+            (cons xar cdr)))))
+    (if (= (optimize-level) 3)
+        '(#3%cons #3%car $cdr)
+        '(#2%cons #2%car $cdr)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f])
+      (expand '
+        (let ()
+          (import $notscheme)
+          (let ()
+            (import (alias scheme [car xar] [cdr xdr]))
+            (cons xar cdr)))))
+    (if (= (optimize-level) 3)
+        '(#3%cons #3%car #3%cdr)
+        '(#2%cons #2%car #2%cdr)))
+  ; no glob support yet
+  #;(equivalent-expansion?
+      (parameterize ([#%$suppress-primitive-inlining #f])
+        (expand '
+          (let ()
+            (import $notscheme)
+            (let ()
+              (import (glob scheme c*r))
+              (cons car cdr)))))
+    '(cons #2%car #2%cdr))
+  (begin
+    (module ($i-foo)
+      (module m (foo) (define foo 45))
+      (import (add-prefix m $i-)))
+    (eq? $i-foo 45))
+  (begin
+    (library ($s) (export $spam)
+      (import (scheme))
+      (module m (spam) (define spam 3))
+      (import (prefix m $)))
+    (import ($s))
+    (eqv? $spam 3))
+  (begin
+    (module ($i-foo)
+      (module m (m:$i-foo) (define m:$i-foo 57))
+      (import (drop-prefix m m:)))
+    (eq? $i-foo 57))
+  (begin
+    (module ($i-foo)
+      (module m (bar) (define bar 63))
+      (import (rename m (bar $i-foo))))
+    (eq? $i-foo 63))
+  (begin
+    (module ($i-foo)
+      (module m (bar) (define bar 75))
+      (import (alias m (bar $i-foo))))
+    (eq? $i-foo 75))
+  (begin
+    (module ($i-x $i-y)
+      (module m ($i-x $i-y) (define $i-x "x") (define $i-y "y"))
+      (import (rename m ($i-y $i-x) ($i-x $i-y))))
+    (equal? (list $i-x $i-y) '("y" "x")))
+  (error? ; duplicate identifiers $i-x and $i-y
+    (begin
+      (module ($i-x $i-y)
+        (module m ($i-x $i-y) (define $i-x "x") (define $i-y "y"))
+        (import (alias m ($i-x $i-y) ($i-y $i-x))))
+      (equal? (list $i-x $i-y) '("y" "x"))))
+  (error? ; duplicate identifiers $i-x and $i-y
+    (let ()
+      (module ($i-x $i-y)
+        (module m ($i-x $i-y) (define $i-x "x") (define $i-y "y"))
+        (import (alias m ($i-x $i-y) ($i-y $i-x))))
+      (equal? (list $i-x $i-y) '("y" "x"))))
+  (begin
+    (module ($i-foo)
+      (module m (foo) (define-record foo ()))
+      (import (rename m (foo $i-foo))))
+    (define-record $i-bar $i-foo (x))
+    ($i-bar? (make-$i-bar 3)))
+  (let ()
+    (module ($i-foo)
+      (module m (foo) (define-record foo ()))
+      (import (rename m (foo $i-foo))))
+    (define-record $i-bar $i-foo (x))
+    ($i-bar? (make-$i-bar 3)))
+  (begin
+    (module ($i-foo)
+      (module m (foo) (module foo ($i-x) (define $i-x 14)))
+      (import (rename m (foo $i-foo))))
+    (import $i-foo)
+    (eq? $i-x 14))
+  (let ()
+    (module ($i-foo)
+      (module m (foo) (module foo ($i-x) (define $i-x 14)))
+      (import (rename m (foo $i-foo))))
+    (import $i-foo)
+    (eq? $i-x 14))
+  (error? ; y not visible
+    (begin
+      (module m (x y) (define x 3) (define y 4))
+      (let ((x 5) (y 6)) (import-only (only m x)) y)))
+  (error? ; y not visible
+    (begin
+      (module m (x y) (define x 3) (define y 4))
+      (let ((x 5) (y 6))
+       ; equivalent of (import-only (only m x)):
+        (begin
+          (module g0 (x) (import-only m))
+          (import-only g0))
+        y)))
+  (begin ; keep with next
+    (define $i-grotto-x 7)
+    (define $i-grotto-y 8)
+    (define $i-grotto-z 9)
+    (equal? (list $i-grotto-x $i-grotto-y $i-grotto-z) '(7 8 9)))
+  (begin ; keep with preceding
+    (module $i-grotto ($i-grotto-x $i-grotto-y $i-grotto-z)
+      (define $i-grotto-x 3)
+      (define $i-grotto-y 4)
+      (define $i-grotto-z 5))
+    (import (only $i-grotto $i-grotto-x))
+    (equal? (list $i-grotto-x $i-grotto-y $i-grotto-z) '(3 8 9)))
+  (begin
+    (import (rename (only scheme car) [car $i-car-from-scheme]))
+    (eq? ($i-car-from-scheme '(a b c)) 'a))
+  (begin
+    (import (only (add-prefix scheme $i-scheme:) $i-scheme:list))
+    (equal? ($i-scheme:list 3 4 5) '(3 4 5)))
+  (begin
+    (import (add-prefix (only scheme list) $i-scheme:))
+    (equal? ($i-scheme:list 3 4 5) '(3 4 5)))
+)
+
+(mat import ; check import semantics changes May 05
+  (begin
+    (define $imp-x 0)
+    (module $imp-m ($imp-x) (define $imp-x 3))
+    (define-syntax $imp-from (syntax-rules () [(_ $imp-m $imp-x) (let () (import $imp-m) $imp-x)]))
+    (define-syntax $imp-from-m (syntax-rules () [(_ $imp-x) (let () (import $imp-m) $imp-x)]))
+    (define-syntax $imp-x-from (syntax-rules () [(_ $imp-m) (let () (import $imp-m) $imp-x)]))
+    (define-syntax $imp-x-from-m (syntax-rules () [(_) (let () (import $imp-m) $imp-x)]))
+    (define-syntax $imp-module*
+      (syntax-rules ()
+        [(_ (x ...) d ...)
+         (begin (module t (x ...) d ...) (import t))]))
+    (define-syntax $imp-import*
+      (syntax-rules () [(_ m) (import m)]))
+    #t)
+  (eqv? ($imp-from $imp-m $imp-x) 3)
+  (eqv? ($imp-from-m $imp-x) 0)
+  (eqv? ($imp-x-from $imp-m) 0)
+  (eqv? ($imp-x-from-m) 3)
+  (eqv? (let () ($imp-from $imp-m $imp-x)) 3)
+  (eqv? (let () ($imp-from-m $imp-x)) 0)
+  (eqv? (let () ($imp-x-from $imp-m)) 0)
+  (eqv? (let () ($imp-x-from-m)) 3)
+  (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-from $imp-m $imp-x)) 4)
+  (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-from-m $imp-x)) 0)
+  (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-x-from $imp-m)) 0)
+  (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-x-from-m)) 3)
+  (eqv? (let () (module m (x) (define x 4)) ($imp-import* m) x) 4)
+  (eqv? (let () ($imp-module* (x) (define y 5) (define x (lambda () y))) (x)) 5)
+  (equal?
+    (let ()
+      (define-syntax module*
+        (syntax-rules ()
+          [(_ (x ...) d ...)
+           (begin (module t (x ...) d ...) (import t))]))
+      (define-syntax import* (syntax-rules () [(_ m) (import m)]))
+      (define x 0)
+      (module m (x) (define x 3))
+      (define-syntax from (syntax-rules () [(_ m x) (let () (import m) x)]))
+      (define-syntax from-m (syntax-rules () [(_ x) (let () (import m) x)]))
+      (define-syntax x-from (syntax-rules () [(_ m) (let () (import m) x)]))
+      (define-syntax x-from-m (syntax-rules () [(_) (let () (import m) x)]))
+      (module* (a) (define b 'bee) (define a (lambda () b)))
+      (list
+        (let () (module m (x) (define x 4)) (from m x))
+        (let () (module m (x) (define x 4)) (from-m x))
+        (let () (module m (x) (define x 4)) (x-from m))
+        (let () (module m (x) (define x 4)) (x-from-m))
+        (let () (import* m) x)
+        (a)))
+    '(4 0 0 3 3 bee))
+  (equal?
+    (let ()
+      (define-syntax alpha
+        (syntax-rules ()
+          [(_ m v e)
+           (let ()
+             (module m (v x)
+               (define x 'introduced)
+               (define v 'supplied))
+             (list e (let () (import m) (list v x))))]))
+      (let () (alpha q x (let () (import q) x))))
+    '(supplied (supplied introduced)))
+  (begin
+    (module $imp-list ($imp-null? $imp-car $imp-cdr $imp-cons)
+      (import (add-prefix (only scheme null? car cdr cons) $imp-)))
+    (define-syntax $imp-a
+      (syntax-rules ()
+        ((_ x) (define-syntax x
+                 (lambda (q)
+                   (import (only $imp-list $imp-car))
+                   #'$imp-car)))))
+    ($imp-a $imp-foo)
+    (eqv? $imp-foo #%car))
+  (eqv?
+    (let ()
+      (module rat (fink dog) (define fink 'lestein) (define dog 'cat))
+      (define-syntax a
+        (syntax-rules ()
+          ((_ x) (define-syntax x
+                   (lambda (q)
+                     (import (only rat fink))
+                     #'fink)))))
+      (a foo)
+      foo)
+    'lestein)
+  (eqv?
+    (let ()
+      (module rat (fink dog) (define fink 'lestein) (define dog 'cat))
+      (define-syntax a
+        (syntax-rules ()
+          ((_ x) (define-syntax x
+                   (lambda (q)
+                     (import (add-prefix rat r:))
+                     #'r:fink)))))
+      (a foo)
+      foo)
+    'lestein)
+  (eqv?
+    (let ()
+      (module rat (fink dog) (define fink 'lestein) (define dog 'cat))
+      (define-syntax a
+        (syntax-rules ()
+          ((_ x) (define-syntax x
+                   (lambda (q)
+                     (import (except rat dog))
+                     #'fink)))))
+      (a foo)
+      foo)
+    'lestein)
+  (eqv?
+    (let ()
+      (module m (x) (define x 'x1))
+      (define-syntax a
+        (lambda (q)
+          #'(let ([x 'x2])
+              (module n (x) (import m))
+              (let () (import n) x))))
+      a)
+    'x1)
+  (eqv?
+    (let ()
+      (module m (x) (define x 'x1))
+      (define-syntax a
+        (lambda (q)
+          #'(let ([x 'x2])
+              (import m)
+              x)))
+      a)
+    'x1)
+  (error? ; duplicate definition for x
+    (let ()
+      (module m (x) (define x 'x1))
+      (define-syntax a
+        (lambda (q)
+          #'(let ()
+              (define x 'x2)
+              (import m)
+              x)))
+      a))
+  (error? ; duplicate definition for x
+    (let ()
+      (module m (x) (define x 'x1))
+      (define-syntax a
+        (lambda (q)
+          #'(let ()
+              (import m)
+              (define x 'x2)
+              x)))
+      a))
+  (equal?
+    (let ()
+      (import scheme)
+      (import scheme)
+      car)
+    car)
+  (error? ; "duplicate definition for car
+    (let ()
+      (import scheme)
+      (import (rename scheme (cdr car)))
+      car))
+  (error? ; duplicate definition for car
+    (let ()
+      (module (car) (define car 'edsel))
+      (import scheme)
+      car))
+  (error? ; duplicate definition for car
+    (let ()
+      (define-syntax a
+        (lambda (q)
+          #'(let ()
+              (module (car) (define car 'edsel))
+              (import scheme)
+              car)))
+      a))
+  (equal?
+    (let ()
+      (define-syntax a
+        (lambda (q)
+          #'(let ()
+              (import scheme)
+              (import scheme)
+              car)))
+      a)
+    car)
+  (error? ; duplicate definition for x
+    (let ()
+      (define-syntax a
+        (lambda (q)
+          #'(let ()
+              (define x 5)
+              (define-syntax x (identifier-syntax 5))
+              x)))
+      a))
+  (error? ; missing definition for export(s) (xxx).
+    (let ()
+      (define-syntax a
+        (syntax-rules ()
+          [(_ m i) (module m (i) (import m1))]))
+      (module m1 (xxx) (define xxx 155))
+      (a m2 xxx)
+      (let () (import m2) xxx)))
+  (equal?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))])
+      (expand/optimize
+        '(let-syntax ([a (lambda (x) #'(let () (import scheme) car))])
+           a)))
+    (if (= (optimize-level) 3) '#3%car '#2%car))
+  (equal?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))])
+      (expand/optimize
+        '(let-syntax ([a (syntax-rules ()
+                           [(_ x)
+                            (define-syntax x
+                              (lambda (q)
+                                (import scheme)
+                                #'car))])])
+           (a foo)
+           foo)))
+    (if (= (optimize-level) 3) '#3%car '#2%car))
+  (error? ; read-only environment
+    (eval '(import (rnrs)) (scheme-environment)))
+  (error? ; invalid context for import
+    (let ([x (import)]) x))
+ ; check 10/27/2010 change to make sense of multiple modules/libraries
+ ; within the same import-only form
+  (equal?
+    (let ()
+      (module m1 (x) (define x box))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import-only m1 m2)
+        (x y)))
+    '#&772)
+  (equal?
+    (let ()
+      (module m1 (x) (define x box))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import m1 m2)
+        (x y)))
+    '#&772)
+  (error? ; unbound identifier list
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import-only m1 m2)
+        (list x y))))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import m1 m2)
+        (list x y)))
+    '(29 772))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import-only scheme m1 m2)
+        (list x y)))
+    '(29 772))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import scheme m1 m2)
+        (list x y)))
+    '(29 772))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import-only (scheme) m1 m2)
+        (list x y)))
+    '(29 772))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import (scheme) m1 m2)
+        (list x y)))
+    '(29 772))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import-only m1 m2 (scheme))
+        (list x y)))
+    '(29 772))
+  (equal?
+    (let ()
+      (module m1 (x) (define x 29))
+      (module m2 (y) (define y 772))
+      (let ()
+        (import m1 m2 (scheme))
+        (list x y)))
+    '(29 772))
+  (begin
+    (library ($io A) (export p) (import (rnrs)) (define p 17))
+    (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x))))
+    (library ($io C) (export r) (import (chezscheme) ($io B))
+      (import-only ($io A) (only (rnrs) define *))
+      (define r (* p 2)))
+    #t)
+  (equal?
+    (let ()
+      (import-only ($io B) ($io C))
+      (q r))
+    '(q . 34))
+  (error? ; unbound identifier p
+    (let ()
+      (import ($io A))
+      (import-only ($io B) ($io C))
+      (q p)))
+  (begin
+    (library ($io A) (export p) (import (rnrs)) (define p 17))
+    (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x))))
+    (library ($io C) (export r) (import (chezscheme) ($io B))
+      (import ($io A) (only (rnrs) define *))
+      (define r (* p 2)))
+    #t)
+  (equal?
+    (let ()
+      (import ($io B) ($io C))
+      (q r))
+    '(q . 34))
+  (equal?
+    (let ()
+      (import ($io A))
+      (import ($io B) ($io C))
+      (q p))
+    '(q . 17))
+  (error? ; unbound identifier p
+    (begin
+      (library ($io A) (export p) (import (rnrs)) (define p 17))
+      (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x))))
+      (library ($io C) (export r) (import (chezscheme) ($io A))
+        (import-only ($io B) (only (rnrs) define *))
+        (define r (* p 2)))))
+  (begin
+    (library ($io A) (export p) (import (rnrs)) (define p 17))
+    (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x))))
+    (library ($io C) (export r) (import (chezscheme) ($io A))
+      (import ($io B) (only (rnrs) define *))
+      (define r (* p 2)))
+    #t)
+  (error? ; unbound identifier *
+    (begin
+      (library ($io A) (export p) (import (rnrs)) (define p 17))
+      (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x))))
+      (library ($io C) (export r) (import (chezscheme) ($io A))
+        (import-only ($io B) (only (rnrs) define))
+        (define r (* p 2)))))
+  (begin
+    (library ($io A) (export p) (import (rnrs)) (define p 17))
+    (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x))))
+    (library ($io C) (export r) (import (chezscheme) ($io A))
+      (import ($io B) (only (rnrs) define))
+      (define r (* p 2)))
+    #t)
+ ; check for let-like semantics for import w/multiple subforms
+  (eq?
+    (let ()
+      (module A (B) (module B (x) (define x 'a-b)))
+      (module B (x) (define x 'b))
+      (let ()
+        (import A B)
+        x))
+    'b)
+  (eq?
+    (let ()
+      (module A (B) (module B (x) (define x 'a-b)))
+      (module B (x) (define x 'b))
+      (let ()
+        (import-only A B)
+        x))
+    'b)
+)
+
+(mat export ; test stand-alone export form
+  (error? ; export outside module or library
+    (export))
+  (error? ; export outside module or library
+    (export cons))
+  (error? ; export outside module or library
+    (top-level-program
+      (import (chezscheme))
+      (export)))
+  (let ()
+    (export)
+    #t)
+  (error? ; nonempty export outside module or library
+    (let ()
+      (export cons)
+      #t))
+  (begin
+    (module ()
+      (define $ex-x 3)
+      (export (rename ($ex-x $ex-y) ($ex-y $ex-x)))
+      (define $ex-y 4))
+    #t)
+  (equal?
+    (cons $ex-x $ex-y)
+    '(4 . 3))
+  (begin
+    (library ($ex-A) (export) (import (chezscheme))
+      (define $ex-x 7)
+      (export (rename ($ex-x $ex-y) ($ex-y $ex-x)))
+      (define $ex-y 9))
+    #t)
+  (equal?
+    (let ()
+      (import ($ex-A))
+      (cons $ex-x $ex-y))
+    '(9 . 7))
+  (begin
+    (import ($ex-A))
+    #t)
+  (equal?
+    (cons $ex-x $ex-y)
+    '(9 . 7))
+  (equal?
+    (let ()
+      (module ()
+        (define $ex-x 3)
+        (export (rename ($ex-x $ex-y) ($ex-y $ex-x)))
+        (define $ex-y 4))
+      (cons $ex-x $ex-y))
+    '(4 . 3))
+  (begin
+    (module $ex-m (x x)
+      (define x 5)
+      (export x))
+    #t)
+  (eqv? (let () (import $ex-m) x) 5)
+  (eqv?
+    (let ()
+      (module (x x)
+        (define x 5)
+        (export x))
+      x)
+    5)
+  (eqv?
+    (let ()
+      (module (x)
+        (define x 5)
+        (export x))
+      x)
+    5)
+  (error? ; duplicate export
+    (module (x)
+      (define x 15)
+      (define y 117)
+      (export (rename (y x)))))
+  (begin
+   ; okay to export id twice as long as it has the same binding
+    (library ($ex-B) (export x x) (import (chezscheme))
+      (define x 25)
+      (export x))
+    #t)
+  (eqv? (let () (import ($ex-B)) x) 25)
+  (begin
+   ; okay to export id twice as long as it has the same binding
+    (library ($ex-B) (export x (rename (x x))) (import (chezscheme))
+      (define x 25)
+      (export x))
+    #t)
+  (eqv? (let () (import ($ex-B)) x) 25)
+  (begin
+   ; okay to export id twice as long as it has the same binding
+    (library ($ex-B) (export x (rename (y x))) (import (chezscheme))
+      (define x 25)
+      (alias y x)
+      (export x))
+    #t)
+  (eqv? (let () (import ($ex-B)) x) 25)
+  (begin
+    (library ($ex-B) (export x) (import (chezscheme))
+      (define x 35)
+      (export x))
+    #t)
+  (eqv? (let () (import ($ex-B)) x) 35)
+  (begin
+    (import ($ex-B))
+    (eqv? x 35))
+  (error? ; duplicate export
+    (library ($ex-C) (export x) (import (chezscheme))
+      (define x 5)
+      (define y 17)
+      (export (rename (y x)))))
+  (equal?
+    (let ()
+      (module f ((a x y))
+        (import (chezscheme))
+        (define x 3)
+        (define y 4)
+        (define-syntax a (identifier-syntax (cons x y)))
+        (export a))
+      (import f)
+      a)
+    '(3 . 4))
+  (equal?
+    (let ()
+      (module m ()
+        (define x 3)
+        (module m1 (x y)
+          (define x 4)
+          (define-syntax y (identifier-syntax x))
+          (indirect-export y x))
+        (export (import m1)))
+      (let ()
+        (import m)
+        (list x y)))
+    '(4 4))
+  (equal?
+    (let ()
+      (module m ()
+        (define x 3)
+        (module m1 (x y)
+          (define x 4)
+          (define-syntax y (identifier-syntax x))
+          (indirect-export y x))
+        (export (import (only m1 y)) x))
+      (let ()
+        (import m)
+        (list x y)))
+    '(3 4))
+  (begin
+    (define-syntax $ex-export1
+      (syntax-rules ()
+        [(_ (m id ...)) (export (import (only m id ...)))]
+        [(_ id) (export id)]))
+    (define-syntax $ex-export
+      (syntax-rules ()
+        [(_ frob ...) (begin ($ex-export1 frob) ...)]))
+    #t)
+  (begin
+    (module $ex-mm ()
+      ($ex-export)
+      (define x 3)
+      (module m1 ()
+        ($ex-export x y)
+        (define x 4)
+        (define-syntax y (identifier-syntax x))
+        (indirect-export y x))
+      ($ex-export (m1 y) x))
+    #t)
+  (equal?
+    (let ()
+      (import $ex-mm)
+      (list x y))
+    '(3 4))
+  (equal?
+    (let ()
+      (module m ()
+        ($ex-export)
+        (define x 3)
+        (module m1 ()
+          ($ex-export x y)
+          (define x 4)
+          (define-syntax y (identifier-syntax x))
+          (indirect-export y x))
+        ($ex-export (m1 y) x))
+      (let ()
+        (import m)
+        (list x y)))
+    '(3 4))
+  (begin
+    (with-output-to-file "testfile-ex1a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex1a)
+             (export q)
+             (import (chezscheme))
+             (define-syntax q (identifier-syntax 17)))))
+      'replace)
+    (with-output-to-file "testfile-ex1b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex1b)
+             (export)
+             (import (chezscheme))
+             (define x 22)
+             (export x (import (testfile-ex1a))))))
+      'replace)
+    (for-each separate-compile '(ex1a ex1b))
+    #t)
+  (equal?
+    (let () (import (testfile-ex1b)) (list x q))
+    '(22 17))
+  (begin
+    (with-output-to-file "testfile-ex2a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex2a)
+             (export q)
+             (import (chezscheme))
+             (define-syntax q (identifier-syntax 17)))))
+      'replace)
+    (with-output-to-file "testfile-ex2b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex2b)
+             (export)
+             (import (chezscheme))
+             (define x 22)
+             (export (rename (x q)) (import (prefix (rename (testfile-ex2a) (q que)) pi))))))
+      'replace)
+    (for-each separate-compile '(ex2a ex2b))
+    #t)
+  (equal?
+    (let () (import (testfile-ex2b)) (list q pique))
+    '(22 17))
+  (begin
+    (with-output-to-file "testfile-ex3a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex3a)
+             (export q)
+             (import (chezscheme))
+             (implicit-exports #f)
+             (indirect-export a x)
+             (define x 17)
+             (define-syntax a (identifier-syntax (* x 2)))
+             (indirect-export q a)
+             (define-syntax q (identifier-syntax (+ a 1))))))
+      'replace)
+    (with-output-to-file "testfile-ex3b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex3b)
+             (export)
+             (import (chezscheme))
+             (define x 22)
+             (export (rename (x q)) (import (prefix (rename (testfile-ex3a) (q que)) pi))))))
+      'replace)
+    (for-each separate-compile '(ex3a ex3b))
+    #t)
+  (equal?
+    (let () (import (testfile-ex3b)) (list q pique))
+    '(22 35))
+  (begin
+    (with-output-to-file "testfile-ex4a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex4a)
+             (export q)
+             (import (chezscheme))
+             (implicit-exports #f)
+             (define x 17)
+             (define-syntax a (identifier-syntax (* x 2)))
+             (define-syntax q (identifier-syntax (+ a 1))))))
+      'replace)
+    (with-output-to-file "testfile-ex4b.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-ex4b)
+             (export)
+             (import (chezscheme))
+             (define x 22)
+             (export (rename (x q)) (import (prefix (rename (testfile-ex4a) (q que)) pi))))))
+      'replace)
+    (for-each separate-compile '(ex4a ex4b))
+    #t)
+  (error? ; attempt to reference unexported identifier a
+    (let () (import (testfile-ex4b)) (list q pique)))
+)
+
+(define eval-test
+  (lambda (expr)
+    (eval expr)
+    #t))
+(define load-test
+  (lambda (expr)
+    (with-output-to-file "testfile.ss"
+      (lambda () (pretty-print expr))
+      'replace)
+    (load "testfile.ss")
+    #t))
+(define compile-test
+  (lambda (expr)
+    (with-output-to-file "testfile.ss"
+      (lambda () (pretty-print expr))
+      'replace)
+    (compile-file "testfile.ss")
+    (load "testfile.so")
+    #t))
+
+(define-syntax errmat
+  (lambda (x)
+    (syntax-case x ()
+      [(_ name expr ...)
+       (let ([make-name (lambda (x) (datum->syntax #'name (string->symbol (format "~s-~s" x (datum name)))))])
+         #`(begin
+             (mat #,(make-name 'eval) (error? (eval-test 'expr)) ...)
+             (mat #,(make-name 'load) (error? (load-test 'expr)) ...)
+             (mat #,(make-name 'compile) (error? (compile-test 'expr)) ...)))])))
+
+(errmat export-errors
+ ; attempt to export multiple bindings for x
+  (module A ()
+    (define x 5)
+    (define y 6)
+    (export (rename (y x)) x))
+ ; attempt to export multiple bindings for x
+  (module ()
+    (module A ()
+      (define x 5)
+      (define y 6)
+      (export (rename (y x)) x)))
+ ; attempt to export multiple bindings for x
+  (let ()
+    (module A ()
+      (define x 5)
+      (define y 6)
+      (export (rename (y x)) x))
+    0)
+ ; attempt to export multiple bindings for x
+  (library (A) (export) (import (chezscheme))
+    (define x 5)
+    (define y 6)
+    (export (rename (y x)) x))
+ ; attempt to export multiple bindings for x
+  (module A ()
+    (define x 5)
+    (define y 6)
+    (export x (rename (y x))))
+ ; attempt to export multiple bindings for x
+  (module ()
+    (module A ()
+      (define x 5)
+      (define y 6)
+      (export x (rename (y x)))))
+ ; attempt to export multiple bindings for x
+  (let ()
+    (module A ()
+      (define x 5)
+      (define y 6)
+      (export x (rename (y x))))
+    0)
+ ; attempt to export multiple bindings for x
+  (library (A) (export) (import (chezscheme))
+    (define x 5)
+    (define y 6)
+    (export x (rename (y x))))
+ ; attempt to export multiple bindings for x
+  (module A ()
+    (define x 5)
+    (module B (x) (define x 6))
+    (export x (import B)))
+ ; attempt to export multiple bindings for x
+  (module ()
+    (module A ()
+      (define x 5)
+      (module B (x) (define x 6))
+      (export x (import B))))
+ ; attempt to export multiple bindings for x
+  (let ()
+    (module A ()
+      (define x 5)
+      (module B (x) (define x 6))
+      (export x (import B)))
+    0)
+ ; attempt to export multiple bindings for x
+  (library (A) (export) (import (chezscheme))
+    (define x 5)
+    (module B (x) (define x 6))
+    (export x (import B)))
+ ; attempt to export multiple bindings for x
+  (module A ()
+    (define x 5)
+    (module B (x) (define x 6))
+    (export (import B) x))
+ ; attempt to export multiple bindings for x
+  (module ()
+    (module A ()
+      (define x 5)
+      (module B (x) (define x 6))
+      (export (import B) x)))
+ ; attempt to export multiple bindings for x
+  (let ()
+    (module A ()
+      (define x 5)
+      (module B (x) (define x 6))
+      (export (import B) x))
+    0)
+ ; attempt to export multiple bindings for x
+  (library (A) (export) (import (chezscheme))
+    (define x 5)
+    (module B (x) (define x 6))
+    (export (import B) x))
+ ; attempt to export multiple bindings for x
+  (module A ()
+    (module B (x) (define x 6))
+    (module C (x) (define x 7))
+    (export (import C) (import B)))
+ ; attempt to export multiple bindings for x
+  (module ()
+    (module A ()
+      (module B (x) (define x 6))
+      (module C (x) (define x 7))
+      (export (import C) (import B))))
+ ; attempt to export multiple bindings for x
+  (let ()
+    (module A ()
+      (module B (x) (define x 6))
+      (module C (x) (define x 7))
+      (export (import C) (import B)))
+    0)
+ ; attempt to export multiple bindings for x
+  (library (A) (export) (import (chezscheme))
+    (module B (x) (define x 6))
+    (module C (x) (define x 7))
+    (export (import C) (import B)))
+ ; missing import y
+  (module A ()
+    (module B (x) (define x 6))
+    (export (import (only B y))))
+ ; missing import y
+  (module ()
+    (module A ()
+      (module B (x) (define x 6))
+      (export (import (only B y)))))
+ ; missing import y
+  (let ()
+    (module A ()
+      (module B (x) (define x 6))
+      (export (import (only B y))))
+    0)
+ ; missing import y
+  (library (A) (export) (import (chezscheme))
+    (module B (x) (define x 6))
+    (export (import (only B y))))
+ ; missing import y
+  (module A ()
+    (module B (x) (define x 6))
+    (export (import (rename B (y z)))))
+ ; missing import y
+  (module ()
+    (module A ()
+      (module B (x) (define x 6))
+      (export (import (rename B (y z))))))
+ ; missing import y
+  (let ()
+    (module A ()
+      (module B (x) (define x 6))
+      (export (import (rename B (y z)))))
+    0)
+ ; missing import y
+  (library (A) (export) (import (chezscheme))
+    (module B (x) (define x 6))
+    (export (import (rename B (y z)))))
+ ; library (rename B y z) not found
+  (module A ()
+    (module B (x) (define x 6))
+    (export (import (rename B y z))))
+ ; library (rename B y z) not found
+  (module ()
+    (module A ()
+      (module B (x) (define x 6))
+      (export (import (rename B y z)))))
+ ; library (rename B y z) not found
+  (let ()
+    (module A ()
+      (module B (x) (define x 6))
+      (export (import (rename B y z))))
+    0)
+ ; library (rename B y z) not found
+  (library (A) (export) (import (chezscheme))
+    (module B (x) (define x 6))
+    (export (import (rename B y z))))
+ ; missing expected prefix foo: x
+  (module A ()
+    (module B (x) (define foo:y 5) (define x 6))
+    (export (import (drop-prefix B foo:))))
+ ; missing expected prefix foo: x
+  (module ()
+    (module A ()
+      (module B (x) (define foo:y 5) (define x 6))
+      (export (import (drop-prefix B foo:)))))
+ ; missing expected prefix foo: x
+  (let ()
+    (module A ()
+      (module B (x) (define foo:y 5) (define x 6))
+      (export (import (drop-prefix B foo:))))
+    0)
+ ; missing expected prefix foo: x
+  (library (A) (export) (import (chezscheme))
+    (module B (x) (define foo:y 5) (define x 6))
+    (export (import (drop-prefix B foo:))))
+)
+
+(mat indirect-export ; test stand-alone indirect-export form
+  (error? ; invalid indirect-export syntax
+    (module $ie-f (($ie-a x))
+      (import (chezscheme))
+      (define x '$ie-x)
+      (indirect-export ($ie-a y z))
+      (define y '$ie-y)
+      (define-syntax $ie-a (identifier-syntax (list x y z)))
+      (define z '$ie-z)))
+  (error? ; export z undefined
+    (module $ie-f (($ie-a x))
+      (import (chezscheme))
+      (define x '$ie-x)
+      (indirect-export $ie-a y z)
+      (define y '$ie-y)
+      (define-syntax $ie-a (identifier-syntax (list x y z)))))
+  (begin
+    (module $ie-f ($ie-a)
+      (import (chezscheme))
+      (define-syntax $ie-a (identifier-syntax (list z)))
+      (define z '$ie-z))
+    #t)
+  (error? ; attempt to reference unexported identifier z
+    (let () (import $ie-f) $ie-a))
+  (begin
+    (module $ie-f (($ie-a z))
+      (import (chezscheme))
+      (define-syntax $ie-a (identifier-syntax (list z)))
+      (define z '$ie-z))
+    #t)
+  (equal?
+    (let () (import $ie-f) $ie-a)
+    '($ie-z))
+  (begin
+    (module $ie-f ($ie-a)
+      (import (chezscheme))
+      (indirect-export $ie-a z)
+      (define-syntax $ie-a (identifier-syntax (list z)))
+      (define z '$ie-z))
+    #t)
+  (equal?
+    (let () (import $ie-f) $ie-a)
+    '($ie-z))
+  (begin
+    (module $ie-f ()
+      (import (chezscheme))
+      (export $ie-a)
+      (indirect-export $ie-a z)
+      (define-syntax $ie-a (identifier-syntax (list z)))
+      (define z '$ie-z))
+    #t)
+  (equal?
+    (let () (import $ie-f) $ie-a)
+    '($ie-z))
+  (begin
+    (module $ie-f ()
+      (import (chezscheme))
+      (indirect-export $ie-a z)
+      (export $ie-a)
+      (define-syntax $ie-a (identifier-syntax (list z)))
+      (define z '$ie-z))
+    #t)
+  (equal?
+    (let () (import $ie-f) $ie-a)
+    '($ie-z))
+  (begin
+    (module $ie-f (($ie-a x))
+      (import (chezscheme))
+      (define x '$ie-x)
+      (indirect-export $ie-a z)
+      (define y '$ie-y)
+      (define-syntax $ie-a (identifier-syntax (list x y z)))
+      (define z '$ie-z)
+      (indirect-export $ie-a y))
+    #t)
+  (equal?
+    (let () (import $ie-f) $ie-a)
+    '($ie-x $ie-y $ie-z))
+  (begin
+    (module $ie-g ()
+      (define x 3)
+      (define y 4)
+      (define-syntax a (identifier-syntax (list x y)))
+      (alias b a)
+      (export a b)
+      (indirect-export a x)
+      (indirect-export b y))
+    #t)
+  (equal?
+    (let () (import $ie-g) a)
+    '(3 4))
+  (begin
+    (module $ie-h ((cons x))
+      (define-property cons car #'x)
+      (define x 3))
+    #t)
+  (eqv?
+    (let ()
+      (define-syntax ref-prop
+        (lambda (x)
+          (lambda (r)
+            (syntax-case x ()
+              [(_ id key) (r #'id #'key)]))))
+      (import $ie-h)
+      (ref-prop cons car))
+    3)
+  (begin
+    (module $ie-h (cons)
+      (define-property cons car #'x)
+      (define x 3))
+    #t)
+  (error? ; unexported identifier x
+    (let ()
+      (define-syntax ref-prop
+        (lambda (x)
+          (lambda (r)
+            (syntax-case x ()
+              [(_ id key) (r #'id #'key)]))))
+      (import $ie-h)
+      (ref-prop cons car)))
+  (begin
+    (module $ie-h (cons)
+      (implicit-exports #t)
+      (define-property cons car #'x)
+      (define x 3))
+    #t)
+  (eqv?
+    (let ()
+      (define-syntax ref-prop
+        (lambda (x)
+          (lambda (r)
+            (syntax-case x ()
+              [(_ id key) (r #'id #'key)]))))
+      (import $ie-h)
+      (ref-prop cons car))
+    3)
+  (error? ; undefine export x
+    (library ($ie-i)
+      (export a)
+      (import (chezscheme))
+      (define-syntax a (identifier-syntax x))
+      (indirect-export a x)))
+)
+
+(mat implicit-exports ; test stand-alone implicit-exports form
+  (error? ; invalid syntax
+    (implicit-exports))
+  (error? ; invalid syntax
+    (+ (implicit-exports) 3))
+  (error? ; invalid syntax
+    (+ (implicit-exports yes!) 3))
+  (error? ; invalid syntax
+    (+ (implicit-exports no way!) 3))
+  (error? ; outside of module or library
+    (implicit-exports #t))
+  (error? ; invalid context for definition
+    (+ (implicit-exports #f) 3))
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (define-syntax a (identifier-syntax x))
+      (define x 3))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-A) a))
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (implicit-exports #t)
+      (define-syntax a (identifier-syntax x))
+      (define x 3))
+    #t)
+  (eqv?
+    (let () (import $ie-A) a)
+    3)
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (implicit-exports #f)
+      (define-syntax a (identifier-syntax x))
+      (define x 3))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-A) a))
+  (begin
+    (library ($ie-A) (export a) (import (chezscheme))
+      (define-syntax a (identifier-syntax x))
+      (define x 3))
+    #t)
+  (eqv?
+    (let () (import ($ie-A)) a)
+    3)
+  (begin
+    (library ($ie-A) (export a) (import (chezscheme))
+      (implicit-exports #f)
+      (define-syntax a (identifier-syntax x))
+      (define x 3))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import ($ie-A)) a))
+  (begin
+    (library ($ie-A) (export a) (import (chezscheme))
+      (implicit-exports #t)
+      (define-syntax a (identifier-syntax x))
+      (define x 3))
+    #t)
+  (eqv?
+    (let () (import ($ie-A)) a)
+    3)
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (module (a)
+        (define-syntax a (identifier-syntax x))
+        (define x 3)))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-A) a))
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (module ((a x))
+        (define-syntax a (identifier-syntax x))
+        (define x 3)))
+    #t)
+  (eqv?
+    (let () (import $ie-A) a)
+    3)
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (module (a)
+        (implicit-exports #f)
+        (define-syntax a (identifier-syntax x))
+        (define x 3)))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-A) a))
+  (begin
+    (module $ie-A (a) (import (chezscheme))
+      (module (a)
+        (implicit-exports #t)
+        (define-syntax a (identifier-syntax x))
+        (define x 3)))
+    #t)
+  (eqv?
+    (let () (import $ie-A) a)
+    3)
+  (begin
+    (module $ie-B (a) (import (chezscheme))
+      (define-syntax a (identifier-syntax x))
+      (module (x) (module (x (a x)) (define a 4) (define x 3))))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-B) a))
+  (begin
+    (module $ie-B (a) (import (chezscheme))
+      (define-syntax a (identifier-syntax x))
+      (indirect-export a x)
+      (module (x) (module (x (a x)) (define a 4) (define x 3))))
+    #t)
+  (eqv?
+    (let () (import $ie-B) a)
+    3)
+  (begin
+    (module $ie-C (a) (import (chezscheme))
+      (module ((b x))
+        (define-syntax b (identifier-syntax x))
+        (define x 3))
+      (alias a b))
+    #t)
+  (eqv?
+    (let () (import $ie-C) a)
+    3)
+  (begin
+    (module $ie-C (a) (import (chezscheme))
+      (module (b)
+        (define-syntax b (identifier-syntax x))
+        (define x 3))
+      (alias a b))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-C) a))
+  (begin
+    (module $ie-C (a) (import (chezscheme))
+      (module (b)
+        (indirect-export b x)
+        (define-syntax b (identifier-syntax x))
+        (define x 3))
+      (alias a b))
+    #t)
+  (eqv?
+    (let () (import $ie-C) a)
+    3)
+  (begin
+    (module $ie-D (a)
+      (module (a (b x))
+        (define-syntax b (identifier-syntax (list x)))
+        (module (a x)
+          (module (b x)
+            (define-syntax b (identifier-syntax x))
+            (define x 3))
+          (alias a b))))
+    #t)
+  (error? ; unexported identifier x
+    (let () (import $ie-D) a))
+  (begin
+    (module $ie-E (a)
+      (import (chezscheme))
+      (define-syntax a (identifier-syntax x))
+      (alias b a)
+      (indirect-export b x)
+      (define x 77))
+    #t)
+ ; this works because the indirect export of x for b
+ ; counts as an indirect export of x for a.  perhaps it
+ ; shouldn't work.
+  (eqv?
+    (let () (import $ie-E) a)
+    77)
+ ; perhaps this shouldn't work either:
+  (eqv?
+    (let ()
+      (define b 3)
+      (alias a b)
+      (fluid-let-syntax ([b (identifier-syntax 4)])
+        a))
+    4)
+  (begin
+    (module $ie-F (a)
+      (import (chezscheme))
+      (module (a)
+        (implicit-exports #f)
+        (define-syntax a (identifier-syntax x)))
+      (implicit-exports #t)
+      (define x 77))
+    #t)
+  (eqv?
+    (let () (import $ie-F) a)
+    77)
+  (begin
+    (module $ie-G (a)
+      (implicit-exports #t)
+      (module M1 (x)
+        (define x 5))
+      (module M2 ((a x))
+        (implicit-exports #t)
+        (import M1)
+        (define-syntax a (identifier-syntax x)))
+      (import M2))
+    #t)
+  (eqv?
+    (let () (import $ie-G) a)
+    5)
+  (begin
+    (module $ie-H (a)
+      (implicit-exports #t)
+      (module M1 (x)
+        (define x 5))
+      (module M2 (a)
+        (implicit-exports #t)
+        (define-syntax a (let () (import M1) (identifier-syntax x))))
+      (import M2))
+    #t)
+  (eqv?
+    (let () (import $ie-H) a)
+    5)
+  (begin
+    (module $ie-I (a)
+      (define x 5)
+      (indirect-export a x)
+      (module M2 (a)
+        (define-syntax a (identifier-syntax x)))
+      (import M2))
+    #t)
+  (eqv?
+    (let () (import $ie-I) a)
+    5)
+  (begin
+    (module $ie-J (m)
+      (implicit-exports #t)
+      (module m (e)
+        (define f 44)
+        (define-syntax e (identifier-syntax f))))
+    #t)
+  (error? ; unexported identifier f
+    (let ()
+      (import $ie-J)
+      (import m)
+      e))
+)
+
+(mat marked-top-level-ids
+  (begin
+    (define-syntax $a
+      (syntax-rules ()
+        ((_ x e)
+         (begin
+           (module ($y-marked) (define $y-marked e))
+           (define x (lambda () $y-marked))))))
+    ($a $one 1)
+    ($a $two 2)
+    (equal? (list ($one) ($two)) '(1 2)))
+  (not (top-level-bound? '$y-marked))
+  (begin
+    (define-syntax $a
+      (syntax-rules ()
+        ((_ x e)
+         (begin
+           (define $y-marked e)
+           (define x (lambda () $y-marked))))))
+    ($a $one 1)
+    ($a $two 2)
+    ($a $three 3)
+    (equal? (list ($one) ($two) ($three)) '(1 2 3)))
+  (not (top-level-bound? '$y-marked))
+  (not (top-level-bound? '$y-marked))
+  (begin
+    (define-syntax $a
+      (syntax-rules ()
+        ((_ x e)
+         (begin
+           (define $y-marked e)
+           (define-syntax x (identifier-syntax $y-marked))))))
+    ($a $one 1)
+    ($a $two 2)
+    ($a $three 3)
+    ($a $four 4)
+    (equal? (list $one $two $three $four) '(1 2 3 4)))
+  (begin ; once more, with feeling
+    (define-syntax $a
+      (syntax-rules ()
+        ((_ x e)
+         (begin
+           (define $y-marked e)
+           (define-syntax x (identifier-syntax $y-marked))))))
+    ($a $one 1)
+    ($a $two 2)
+    ($a $three 3)
+    ($a $four 4)
+    (equal? (list $one $two $three $four) '(1 2 3 4)))
+  (begin
+    (module $foo ($a) (define-syntax $a (identifier-syntax 3)))
+    (import $foo)
+    (eq? $a 3))
+  (begin ; keep with preceding mat
+    (define-syntax $a (identifier-syntax 4))
+    (eq? $a 4))
+ )
+
+(mat top-level-begin
+ ; mats to test change to body-like semantics for begin
+  (begin
+    (define ($foofrah expr ans)
+      (with-output-to-file "testfile.ss"
+        (lambda () (pretty-print expr))
+        'replace)
+      (let* ([ss.out (with-output-to-string (lambda () (load "testfile.ss")))]
+             [cf.out (with-output-to-string (lambda () (compile-file "testfile.ss")))]
+             [so.out (with-output-to-string (lambda () (load "testfile.so")))])
+        (let ([actual 
+               (list
+                 ss.out
+                 (substring cf.out
+                   (string-length "compiling testfile.ss with output to testfile.so\n")
+                   (string-length cf.out))
+                 so.out)])
+          (unless (equal? actual ans)
+            (pretty-print actual)
+            (errorf #f "unexpected actual value ~s instead of ~s" actual ans))))
+      #t)
+    #t)
+  ($foofrah
+    '(begin
+       (define-record-type (a make-a a?) (fields type mapper))
+       (define-syntax define-descendant
+         (lambda (x)
+           (syntax-case x ()
+             [(_ parent-id maker type name pred arg ...)
+              (with-syntax ([(getter ...) (generate-temporaries #'(arg ...))])
+                #'(define-record-type (name maker pred)
+                    (parent parent-id)
+                    (fields (immutable arg getter) ...)
+                    (protocol
+                      (lambda (n)
+                        (lambda (arg ...)
+                          (letrec ([rec ((n 'type (lambda (receiver) (receiver (getter rec) ...))) arg ...)])
+                            rec))))))])))
+       (define-descendant a make-a subname x x? y z)
+       (write ((a-mapper (make-a 3 4)) list)))
+    '("(3 4)" "" "(3 4)"))
+  ($foofrah
+    '(begin
+       (eval-when (compile load eval) (write 1))
+       (eval-when (compile load eval) (write 2) (write 3))
+       (newline))
+    '("123\n" "123" "123\n"))
+  ($foofrah
+    '(begin
+       (define (f) (import foo) x1)
+       (module foo (x1) (define x1 'x1))
+       (pretty-print (f)))
+    '("x1\n" "" "x1\n"))
+  ($foofrah
+    '(begin
+       (define x2 'x2)
+       (module (y2) (define y2 x2))
+       (pretty-print y2)) ;=> x2
+    '("x2\n" "" "x2\n"))
+  ($foofrah
+    '(begin
+       (define x3 'x3)
+       (module foo (y2) (define y2 x3))
+       (import foo)
+       (pretty-print y2)) ;=> x3
+    '("x3\n" "" "x3\n"))
+  ($foofrah
+    '(eval-when (compile load)
+       (eval-when (compile load eval) (define x4 "x4"))
+       (define-syntax a4 (lambda (q) x4))
+       (display a4))
+    '("" "x4" "x4"))
+  ($foofrah
+    '(eval-when (compile load eval)
+       (define x5 "x5")
+       (display x5))
+    '("x5" "x5" "x5"))
+  (begin
+    (define x5 "x5")
+    ($foofrah ; keep with preceding test
+      '(begin
+         (define x5 "x5new")
+         (define-syntax a5 (lambda (q) x5))
+         (printf "~a ~a\n" a5 x5))
+      '("x5 x5new\n" "" "x5new x5new\n")))
+  ($foofrah
+    '(begin
+       (define x6 a6)
+       (define-syntax a6 (identifier-syntax 'cool))
+       (pretty-print x6))
+    '("cool\n" "" "cool\n"))
+  (error? ; variable a7 is not bound
+    (eval '(begin
+             (define x7 a7)
+             (define-syntax a7 (identifier-syntax 'cool))
+             (define a7 'the-real-deal))))
+  ($foofrah
+    '(begin
+       (define x8 'not-cool)
+       (define (f8) x8)
+       (define x8 'just-right)
+       (pretty-print (f8))) ;=> just-right
+    '("just-right\n" "" "just-right\n"))
+  ($foofrah
+    '(begin
+       (define x9 'not-cool)
+       (define-syntax a9 (identifier-syntax x9))
+       (define x9 'just-right)
+       (pretty-print a9)) ;=> just-right
+    '("just-right\n" "" "just-right\n"))
+  ($foofrah
+    '(begin
+       (define x10 a10)
+       (module m10 (x y)
+         (define-syntax x (identifier-syntax 'm10-x))
+         (define y a10)
+         (define-syntax a10 (identifier-syntax 'm10-y)))
+       (library (l10) (export x y) (import (rnrs))
+         (define-syntax x (identifier-syntax 'l10-x))
+         (define y a10)
+         (define-syntax a10 (identifier-syntax 'l10-y)))
+       (define-syntax a10 (identifier-syntax 'outer-x10))
+       (import (rename m10 (y yy)) (rename (l10) (x xx)))
+       (pretty-print (list x y xx yy)))
+    '("(m10-x l10-y l10-x m10-y)\n" "" "(m10-x l10-y l10-x m10-y)\n"))
+  ($foofrah
+    '(begin
+       (define-syntax a
+         (syntax-rules ()
+           [(a q) (begin (define (q) x) (define x 4))]))
+       (a zz)
+       (pretty-print (zz)))
+    '("4\n" "" "4\n"))
+  ($foofrah
+    '(begin
+       (eval-when (compile load eval)
+         (module const (get put) 
+           (define ht (make-eq-hashtable))
+           (define get (lambda (name) (hashtable-ref ht name 0)))
+           (define put (lambda (name value) (hashtable-set! ht name value)))))
+       (define-syntax dc
+         (syntax-rules ()
+           [(_ id e) (let () (import const) (put 'id e))]))
+       (define-syntax con
+         (syntax-rules ()
+           [(_ id) (let () (import const) (get 'id))]))
+       (dc spam 13)
+       (dc b (list (con spam) 's))
+       (pretty-print (list (con spam) (con b) (con c))))
+    '("(13 (13 s) 0)\n" "" "(13 (13 s) 0)\n"))
+  (begin (define const) (define dc) (define con) #t)
+  ($foofrah
+    '(begin
+       (eval-when (compile load eval)
+         (module const (get put) 
+           (define ht (make-eq-hashtable))
+           (define get (lambda (name) (hashtable-ref ht name 0)))
+           (define put (lambda (name value) (hashtable-set! ht name value)))))
+       (define-syntax dc
+         (syntax-rules ()
+           [(_ id e) (let () (import const) (put 'id e))]))
+       (define-syntax con
+         (syntax-rules ()
+           [(_ id) (let () (import const) (get 'id))]))
+       (eval-when (compile load eval)
+         (dc spam 13)
+         (dc b (list (con spam) 's)))
+       (eval-when (compile load eval)
+         (pretty-print (list (con spam) (con b) (con c)))))
+    '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" "(13 (13 s) 0)\n"))
+  (begin (define const) (define dc) (define con) #t)
+  ($foofrah
+    '(begin
+       (eval-when (compile load eval)
+         (module const (get put) 
+           (define ht (make-eq-hashtable))
+           (define get (lambda (name) (hashtable-ref ht name 0)))
+           (define put (lambda (name value) (hashtable-set! ht name value)))))
+       (define-syntax dc
+         (syntax-rules ()
+           [(_ id e) (eval-when (compile load eval) (let () (import const) (put 'id e)))]))
+       (define-syntax con
+         (syntax-rules ()
+           [(_ id) (eval-when (compile load eval) (let () (import const) (get 'id)))]))
+       (dc spam 13)
+       (dc b (list (con spam) 's))
+       (eval-when (compile load eval)
+         (pretty-print (list (con spam) (con b) (con c)))))
+    '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" "(13 (13 s) 0)\n"))
+  (begin (define const) (define dc) (define con) #t)
+  ($foofrah
+    '(begin
+       (eval-when (compile eval)
+         (module const (get put) 
+           (define ht (make-eq-hashtable))
+           (define get (lambda (name) (hashtable-ref ht name 0)))
+           (define put (lambda (name value) (hashtable-set! ht name value)))))
+       (define-syntax dc
+         (syntax-rules ()
+           [(_ id e) (eval-when (compile eval) (let () (import const) (put 'id e)))]))
+       (define-syntax con
+         (syntax-rules ()
+           [(_ id) (eval-when (compile eval) (let () (import const) (get 'id)))]))
+       (dc spam 13)
+       (dc b (list (con spam) 's))
+       (eval-when (compile eval)
+         (pretty-print (list (con spam) (con b) (con c)))))
+    '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" ""))
+  (begin (define const) (define dc) (define con) #t)
+  ($foofrah
+    '(begin
+       (define-syntax a
+         (identifier-syntax
+           (begin
+             (eval-when (compile eval)
+               (module const (get put) 
+                 (define ht (make-eq-hashtable))
+                 (define get (lambda (name) (hashtable-ref ht name 0)))
+                 (define put (lambda (name value) (hashtable-set! ht name value)))))
+             (define-syntax dc
+               (syntax-rules ()
+                 [(_ id e) (eval-when (compile eval) (let () (import const) (put 'id e)))]))
+             (define-syntax con
+               (syntax-rules ()
+                 [(_ id) (eval-when (compile eval) (let () (import const) (get 'id)))]))
+             (dc spam 13)
+             (dc b (list (con spam) 's))
+             (eval-when (compile eval)
+               (pretty-print (list (con spam) (con b) (con c)))))))
+       a)
+    '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" ""))
+  (begin (define const) (define dc) (define con) #t)
+  (begin
+    (with-output-to-file "testfile-lib-c.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-lib-c)
+             (export y)
+             (import (chezscheme) (testfile-lib-a))
+             (define y (lambda () x))
+             (printf "invoke c\n"))))
+      'replace)
+    (with-output-to-file "testfile-test-ac.ss"
+      (lambda ()
+        (pretty-print 
+          '(begin
+             (library (testfile-lib-a)
+               (export x)
+               (import (chezscheme))
+               (define x (lambda () 1))
+               (printf "invoke a\n"))
+             (import (testfile-lib-c) (chezscheme))
+             (pretty-print (eq? (y) y)))))
+      'replace)
+    #t)
+  (let ([cf '(lambda (x)
+               (parameterize ([compile-imported-libraries #t])
+                 (compile-file x)))])
+    (separate-compile cf 'test-ac)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-test-ac.so"))
+    "invoke a\ninvoke c\n#f\n")
+ ; make sure no local-label bindings make it into compiled wraps
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print 
+          '(let-syntax ([a (lambda (x) 0)])
+             (define-syntax $foo (lambda (x) #'cons)))))
+      'replace)
+    (compile-file "testfile")
+    (load "testfile.so")
+    #t)
+  (equal? $foo cons)
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print 
+          '(begin
+             (define-syntax $foo-a (lambda (x) 0))
+             (define-syntax $foo (lambda (x) #'cons)))))
+      'replace)
+    (compile-file "testfile")
+    (load "testfile.so")
+    #t)
+  (equal? $foo cons)
+)
+
+#;
+(mat top-level-begin-NOT
+ ; these mats test a behavior we have at this point decided against,
+ ; in which a syntax object for an identifier imported from a library
+ ; via an import is inserted outside the scope of the local import
+ ; in a compiled file, thus forcing an implicit import of the library
+ ; when the compiled file is loaded.  possibly, the library should be
+ ; imported when a reference is actually attempted, but we shouldn't
+ ; import eagerly on the off chance that a syntax object will be used
+ ; in this manner, because the import will usually be unnecessary.
+  (begin
+    (with-output-to-file "testfile-tlb-a1.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-tlb-a1)
+             (export tlb-a1-rats)
+             (import (rnrs))
+             (define-syntax tlb-a1-rats (identifier-syntax 17)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a2.ss"
+      (lambda ()
+        (pretty-print 
+          '(define-syntax tlb-a2-foo
+             (let ()
+               (import (testfile-tlb-a1))
+               (lambda (x) #'(cons tlb-a1-rats 2))))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a3.ss"
+      (lambda ()
+        (pretty-print 
+          '(let-syntax ([silly (lambda (x)
+                                 (import (testfile-tlb-a1))
+                                 (syntax-case x ()
+                                   [(_ id) #'(define-syntax id (identifier-syntax (cons tlb-a1-rats 3)))]))])
+             (silly tlb-a3-fluffy))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a4.ss"
+      (lambda ()
+        (pretty-print 
+          '(module (tlb-a4-pie)
+             (import (testfile-tlb-a1))
+             (define-syntax tlb-a4-pie
+               (lambda (x) #'(cons tlb-a1-rats 4))))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a5.ss"
+      (lambda ()
+        (pretty-print 
+          '(meta define tlb-a5-spam
+             (let () (import (testfile-tlb-a1)) #'(cons tlb-a1-rats 5)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a6a.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-tlb-a6a)
+             (export tlb-a6-fop)
+             (import (rnrs) (testfile-tlb-a1))
+             (define tlb-a6-fop #'(cons tlb-a1-rats 6)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a6b.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-tlb-a6b)
+             (export tlb-a6-alpha)
+             (import (rnrs) (testfile-tlb-a6a))
+             (define-syntax tlb-a6-alpha (lambda (x) tlb-a6-fop)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a6c.ss"
+      (lambda ()
+        (pretty-print '(import (rnrs) (testfile-tlb-a6b)))
+        (pretty-print '(write tlb-a6-alpha)))
+      'replace)
+    (with-output-to-file "testfile-tlb-a7.ss"
+      (lambda ()
+        (pretty-print 
+          '(define-property spam spam (let () (import (testfile-tlb-a1)) #'(cons tlb-a1-rats 7)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a8.ss"
+      (lambda ()
+        (pretty-print 
+          '(define tlb-a8-spam (let () (import (testfile-tlb-a1)) #'(cons tlb-a1-rats 8)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a9.ss"
+      (lambda ()
+        (pretty-print 
+          '(let ()
+             (import (testfile-tlb-a1))
+             (set! tlb-a9-spam #'(cons tlb-a1-rats 9)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-a10.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-tlb-a1)))
+        (pretty-print '(define-top-level-value 'tlb-a10-spam #'(cons tlb-a1-rats 10))))
+      'replace)
+    (let ([cf (lambda (what)
+                `(lambda (x)
+                   (parameterize ([compile-imported-libraries #t])
+                     (,what x))))])
+      (separate-compile (cf 'compile-file) 'tlb-a2)
+      (separate-compile (cf 'compile-file) 'tlb-a3)
+      (separate-compile (cf 'compile-file) 'tlb-a4)
+      (separate-compile (cf 'compile-file) 'tlb-a5)
+      (separate-compile (cf 'compile-library) 'tlb-a6b)
+      (separate-compile (cf 'compile-program) 'tlb-a6c)
+      (separate-compile (cf 'compile-file) 'tlb-a7)
+      (separate-compile (cf 'compile-file) 'tlb-a8)
+      (separate-compile (cf 'compile-file) 'tlb-a9)
+      (separate-compile (cf 'compile-program) 'tlb-a10))
+    #t)
+  (equal?
+    (separate-eval '(visit "testfile-tlb-a2.so") '(pretty-print tlb-a2-foo))
+    "(17 . 2)\n")
+  (equal?
+    (separate-eval '(visit "testfile-tlb-a3.so") '(pretty-print tlb-a3-fluffy))
+    "(17 . 3)\n")
+  (equal?
+    (separate-eval '(visit "testfile-tlb-a4.so") '(pretty-print tlb-a4-pie))
+    "(17 . 4)\n")
+  (equal?
+    (separate-eval '(visit "testfile-tlb-a5.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a5-spam)]) a)))
+    "(17 . 5)\n")
+  (equal?
+    (separate-eval '(revisit "testfile-tlb-a6c.so"))
+    "(17 . 6)")
+  (equal?
+    (separate-eval '(visit "testfile-tlb-a7.so") '(pretty-print (let-syntax ([a (lambda (x) (lambda (r) (r #'spam #'spam)))]) a)))
+    "(17 . 7)\n")
+  (equal?
+    (separate-eval '(revisit "testfile-tlb-a8.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a8-spam)]) a)))
+    "(17 . 8)\n")
+  (equal?
+    (separate-eval '(revisit "testfile-tlb-a9.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a9-spam)]) a)))
+    "(17 . 9)\n")
+ ; don't really want to fix this one:
+  (equal?
+    (separate-eval '(load-program "testfile-tlb-a10.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a10-spam)]) a)))
+    "(17 . 10)\n")
+  (begin
+    (with-output-to-file "testfile-tlb-bQ.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-tlb-bQ)
+             (export tlb-bq)
+             (import (rnrs))
+             (define-syntax tlb-bq (identifier-syntax 17)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-bA.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-tlb-bA)
+             (export tlb-bset-a! tlb-bget-a)
+             (import (rnrs))
+             (define a #f)
+             (define tlb-bset-a! (lambda (x) (set! a x)))
+             (define tlb-bget-a (lambda () a)))))
+      'replace)
+    (with-output-to-file "testfile-tlb-bP.ss"
+      (lambda ()
+        (pretty-print '(import (rnrs) (rnrs eval) (testfile-tlb-bQ) (testfile-tlb-bA)))
+        (pretty-print '(tlb-bset-a! #'tlb-bq))
+        (pretty-print
+          '(eval
+             '(let ()
+                (define-syntax alpha (lambda (x) (tlb-bget-a)))
+                (write (cons alpha 'B)))
+             (environment '(rnrs) '(testfile-tlb-bA) '(testfile-tlb-bQ)))))
+      'replace)
+    (let ([cf (lambda (what)
+                `(lambda (x)
+                   (parameterize ([compile-imported-libraries #t])
+                     (,what x))))])
+      (separate-compile (cf 'compile-program) 'tlb-bP))
+    #t)
+  (equal?
+    (separate-eval '(load-program "testfile-tlb-bP.so"))
+    "(17 . B)")
+)
+
+(mat deferred-transformer
+ ; don't get caught being lazy on transformer evaluation
+  (begin
+    (define $ratfink
+      (let ([state 0])
+        (lambda () (set! state (+ state 1)) (lambda (x) state))))
+    (procedure? $ratfink))
+  (eqv? (let-syntax ((f ($ratfink)))
+          (let-syntax ((g ($ratfink))) g))
+        2)
+ )
+
+(mat copy-environment
+ ; dummy test to set up nondescript record-writer for environments
+ ; so that error messages involving environments don't include generated
+ ; names that may change from run to run.  the record-writer is reset at
+ ; end of this mat.
+  (equal?
+    (let ([env-rtd (record-rtd (scheme-environment))])
+      (set! *saved-record-writer* (record-writer env-rtd))
+      (record-writer env-rtd (lambda (x p wr) (display "#" p)))
+      (format "~s" (scheme-environment)))
+    "#")
+  (equal?
+    (let ([e (copy-environment (scheme-environment))])
+      (eval '(define x 17) e)
+      (eval '(define-syntax a
+               (syntax-rules ()
+                 [(_ b c)
+                  (begin
+                    (define x c)
+                    (define-syntax b (identifier-syntax x)))]))
+            e)
+      (eval '(a foo 33) e)
+      (list (eval 'foo e)
+            (eval 'x e)
+            (top-level-value 'x e)))
+    '(33 17 17))
+  (equal?
+    (let ([e (copy-environment (scheme-environment) #t)])
+      (eval '(define x 17) e)
+      (eval '(define-syntax a
+               (syntax-rules ()
+                 [(_ b c)
+                  (begin
+                    (define x c)
+                    (define-syntax b (identifier-syntax x)))]))
+            e)
+      (eval '(a foo 33) e)
+      (list (eval 'foo e)
+            (eval 'x e)
+            (top-level-value 'x e)))
+    '(33 17 17))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (eval '(define x 17) e)
+      (eval '(define-syntax a
+               (syntax-rules ()
+                 [(_ b c)
+                  (begin
+                    (define x c)
+                    (define-syntax b (identifier-syntax x)))]))
+            e)
+      (eval '(a foo 33) e)
+      (list (eval 'foo e)
+            (eval 'x e)
+            (top-level-value 'x e))))
+  (equal?
+    (let* ([e1 (copy-environment (scheme-environment))]
+           [e2 (copy-environment e1)])
+      (define-top-level-value 'list list* e1)
+      (list
+        (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e1))
+        (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e2))))
+    '((1 2 . 3) (1 2 3)))
+  (equal?
+    (let* ([e1 (copy-environment (scheme-environment))]
+           [e2 (copy-environment e1)])
+      (define-top-level-value 'list list* e1)
+      (list
+        (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e1))
+        (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e2))))
+    '((1 2 . 3) (1 2 3)))
+  (error?
+    (let* ([e1 (copy-environment (scheme-environment))]
+           [e2 (copy-environment e1)])
+      (set-top-level-value! 'list list* e1)
+      (list
+        (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e1))
+        (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e2)))))
+  (equal?
+    (let ([e1 (copy-environment (scheme-environment))])
+      (define-top-level-value 'curly (lambda (x) (+ x 15)) e1)
+      (let ([e2 (copy-environment e1)])
+        (define-top-level-value 'curly (lambda (x) (- x 15)) e2)
+        (list (eval '(curly 5) e1) (eval '(curly 5) e2))))
+    '(20 -10))
+  (equal?
+    (let ([e1 (copy-environment (scheme-environment))])
+      (set-top-level-value! 'curly (lambda (x) (+ x 15)) e1)
+      (let ([e2 (copy-environment e1)])
+        (set-top-level-value! 'curly (lambda (x) (- x 15)) e2)
+        (list (eval '(curly 5) e1) (eval '(curly 5) e2))))
+    '(20 -10))
+  (equal?
+    (let ([e1 (copy-environment (scheme-environment))])
+      (define-top-level-value 'curly (lambda (x) (+ x 15)) e1)
+      (let ([e2 (copy-environment e1)])
+        (define-top-level-value 'curly (lambda (x) (- x 15)) e1)
+        (list (eval '(curly 5) e1) (eval '(curly 5) e2))))
+    '(-10 20))
+  (equal?
+    (let ([e1 (copy-environment (scheme-environment))])
+      (set-top-level-value! 'curly (lambda (x) (+ x 15)) e1)
+      (let ([e2 (copy-environment e1)])
+        (set-top-level-value! 'curly (lambda (x) (- x 15)) e1)
+        (list (eval '(curly 5) e1) (eval '(curly 5) e2))))
+    '(-10 20))
+  (equal?
+    (let ([e (copy-environment (scheme-environment))])
+      (eval '(define let 4) e)
+      (define-top-level-value 'let* 6 e)
+      (list (top-level-value 'let e)
+            (eval '(list let*) e)))
+    '(4 (6)))
+  (error?
+    (let ([e (copy-environment (scheme-environment))])
+      (set-top-level-value! letrec 3 e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment))])
+      (set-top-level-value! 'letrec 3 e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment))])
+      (eval '(set! lambda 55) e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (eval '(define cons 55) e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (eval '(set! cons 55) e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (define-top-level-value 'cons 3 e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (set-top-level-value! 'cons 3 e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (define-top-level-value 'frappule 3 e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (set-top-level-value! 'irascible 3 e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment))])
+      (eval 'nonstandard-identifier e)))
+  (equal?
+    (let ([env-rtd (record-rtd (scheme-environment))])
+      (record-writer env-rtd *saved-record-writer*)
+      (format "~s" (scheme-environment)))
+    "#")
+  (equal?
+    (let ([e (copy-environment (scheme-environment) #t '())])
+      (define-top-level-value 'cons list e)
+      (list (eval '(cons 3 4) e) (top-level-bound? 'list e)))
+    '((3 4) #f))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #t '())])
+      (eval '(quote 3) e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #t '(scheme))])
+      (eval '(import scheme) e)
+      (eval '(let ((x 3)) x) e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #t '(import))])
+      (eval '(import scheme) e)
+      (eval '(let ((x 3)) x) e)))
+  (eqv?
+    (let ([e (copy-environment (scheme-environment) #t '(import scheme))])
+      (eval '(import scheme) e)
+      (eval '(let ((x 3)) x) e))
+    3)
+  (error?
+    (let ([e (copy-environment (scheme-environment) #t '(import scheme))])
+      (eval '(import scheme) e)
+      (set-top-level-value! 'cons 72 e)))
+  (begin
+    (define $copy-env-tmp1 723)
+    (define $copy-env-tmp2 -327)
+    (define $copy-env-env
+      (copy-environment
+        (interaction-environment)
+        #t
+        (remq 'let*
+              (remq 'cons
+                    (remq '$copy-env-tmp1
+                          (environment-symbols (interaction-environment)))))))
+    (environment? $copy-env-env))
+  (equal?
+    (eval '(let ((x (list 1 2))) (list x x $copy-env-tmp2)) $copy-env-env)
+    '(#0=(1 2) #0# -327))
+  (error? (eval 'cons $copy-env-env))
+  (error? (eval 'let* $copy-env-env))
+  (error? (eval '$copy-env-tmp1 $copy-env-env))
+  (begin
+    (eval '(define + -) $copy-env-env)
+    (begin
+      (equal? (top-level-value '+ $copy-env-env) -)
+      (equal? (eval '+ $copy-env-env) -)
+      (equal? (eval '#2%+ $copy-env-env) +)))
+  (equal?
+    (begin
+      (eval '(set! cons 52) $copy-env-env)
+      (top-level-value 'cons $copy-env-env))
+    52)
+
+ ; verify new (as of csv7.5) copy-environment semantics
+  (begin
+    (define $ce-e1 (copy-environment (scheme-environment) #t))
+    (eval '(module foo (eek) (define eek -7)) $ce-e1)
+    (eval '(import foo) $ce-e1)
+    (eval '(define-syntax ez (identifier-syntax 'tuary)) $ce-e1)
+    (define-top-level-value 'whence 'now $ce-e1)
+    #t)
+  (equal?
+    (eval '(list cons eek whence ez) $ce-e1)
+    `(,cons -7 now tuary))
+  (begin
+    (define $ce-e2 (copy-environment $ce-e1 #t))
+    #t)
+  (equal?
+    (eval '(list cons eek whence ez) $ce-e2)
+    `(,cons -7 now tuary))
+  (equal?
+    (begin
+      (eval '(set! eek (* eek 3)) $ce-e1)
+      (list (eval '(let () (import foo) eek) $ce-e1)
+            (eval '(let () (import foo) eek) $ce-e2)
+            (eval 'eek $ce-e1)
+            (top-level-value 'eek $ce-e2)))
+    '(-21 -21 -21 -21))
+  (equal?
+    (begin
+      (eval '(set! eek (* eek 3)) $ce-e2)
+      (list (eval '(let () (import foo) eek) $ce-e1)
+            (eval '(let () (import foo) eek) $ce-e2)
+            (eval 'eek $ce-e1)
+            (top-level-value 'eek $ce-e2)))
+    '(-63 -63 -63 -63))
+  (equal?
+    (begin
+      (set-top-level-value! 'eek 99 $ce-e1)
+      (list (eval '(let () (import foo) eek) $ce-e1)
+            (eval '(let () (import foo) eek) $ce-e2)
+            (eval 'eek $ce-e1)
+            (top-level-value 'eek $ce-e2)))
+    '(99 99 99 99))
+  (equal?
+    (begin
+      (set-top-level-value! 'eek 'ack $ce-e2)
+      (list (eval '(let () (import foo) eek) $ce-e1)
+            (eval '(let () (import foo) eek) $ce-e2)
+            (eval 'eek $ce-e1)
+            (top-level-value 'eek $ce-e2)))
+    '(ack ack ack ack))
+  (equal?
+    (begin
+      (eval '(set! whence 'later) $ce-e1)
+      (list (eval 'whence $ce-e1)
+            (top-level-value 'whence $ce-e2)))
+    '(later now))
+  (equal?
+    (begin
+      (set-top-level-value! 'whence 'never $ce-e2)
+      (list (eval 'whence $ce-e1)
+            (top-level-value 'whence $ce-e2)))
+    '(later never))
+  (error? ; cannot assign immutable variable
+    (eval '(set! cons 4) $ce-e1))
+  (error? ; cannot assign immutable variable
+    (eval '(set! cons 4) $ce-e2))
+  (error? ; cannot assign immutable variable
+    (set-top-level-value! 'cons 4 $ce-e1))
+  (error? ; cannot assign immutable variable
+    (set-top-level-value! 'cons 4 $ce-e2))
+  (error? ; invalid syntax
+    (eval '(set! foo 4) $ce-e1))
+  (error? ; invalid syntax
+    (eval '(set! foo 4) $ce-e2))
+  (error? ; not a variable
+    (set-top-level-value! 'foo 4 $ce-e1))
+  (error? ; not a variable
+    (set-top-level-value! 'foo 4 $ce-e2))
+  (error? ; invalid syntax
+    (eval '(set! ez 4) $ce-e1))
+  (error? ; invalid syntax
+    (eval '(set! ez 4) $ce-e2))
+  (error? ; not a variable
+    (set-top-level-value! 'ez 4 $ce-e1))
+  (error? ; not a variable
+    (set-top-level-value! 'ez 4 $ce-e2))
+  (error? ; invalid syntax
+    (eval '(begin (alias ard ez) (set! ard 45)) $ce-e1))
+  (equal?
+    (let ()
+      (define $ce-f1 (eval '(lambda () (list cons eek whence ez)) $ce-e1))
+      (define $ce-f2 (eval '(lambda () (list cons eek whence ez)) $ce-e2))
+      (define $ce-f3 (eval '(lambda () (list cons (let () (import foo) eek))) $ce-e1))
+      (define $ce-f4 (eval '(lambda () (list cons (let () (import foo) eek))) $ce-e2))
+      (eval '(define cons 3) $ce-e1)
+      (define-top-level-value 'eek 4 $ce-e1)
+      (eval '(define whence 5) $ce-e1)
+      (define-top-level-value 'ez 6 $ce-e1)
+      (define-top-level-value 'cons 'a $ce-e2)
+      (eval '(define eek 'b) $ce-e2)
+      (define-top-level-value 'whence 'c $ce-e2)
+      (eval '(define ez 'd) $ce-e2)
+      (list
+        ($ce-f1)
+        ($ce-f2)
+        ($ce-f3)
+        ($ce-f4)
+        (eval '(list cons eek whence ez) $ce-e1)
+        (eval '(list cons eek whence ez) $ce-e2)
+        (list cons (eval '(let () (import foo) eek) $ce-e1))
+        (list cons (eval '(let () (import foo) eek) $ce-e2))))
+    `((,cons ack 5 tuary)
+      (,cons ack c tuary)
+      (,cons ack)
+      (,cons ack)
+      (3 4 5 6)
+      (a b c d)
+      (,cons ack)
+      (,cons ack)))
+  (equal?
+    (let ()
+      (eval '(define foo 'not-a-module) $ce-e1)
+      (list (eval 'foo $ce-e1)
+            (eval '(let () (import foo) eek) $ce-e2)))
+    '(not-a-module ack))
+  (equal?
+    (let ([e (copy-environment (interaction-environment) #f '(cons $ce-e1))])
+      (list (eval 'cons e) (eval '$ce-e1 e)))
+    (list cons $ce-e1))
+  (let ([e1 (copy-environment (scheme-environment) #t '())])
+    (define-top-level-value 'darth 'vader e1)
+    (let ([e2 (copy-environment e1 #f)])
+      (let ([e3 (copy-environment e2 #t)])
+        (define (f) (map (lambda (e) (top-level-value 'darth e)) (list e1 e2 e3)))
+        (and (equal? (environment-symbols e1) '(darth))
+             (equal? (environment-symbols e2) '(darth))
+             (equal? (environment-symbols e3) '(darth))
+             (equal? (f) '(vader vader vader))
+             (eq? (set-top-level-value! 'darth 'maul e1) (void))
+             (equal? (f) '(maul vader vader))
+             (eq? (set-top-level-value! 'darth 'poodle e3) (void))
+             (equal? (f) '(maul vader poodle))))))
+ )
+
+(mat environment-mutable?
+  (not (environment-mutable? (scheme-environment)))
+  (environment-mutable? (interaction-environment))
+  (environment-mutable? (copy-environment (scheme-environment)))
+ )
+
+(mat trace-define-syntax
+  (equivalent-expansion?
+    (parameterize ([trace-output-port (open-output-string)]
+                   [print-gensym #f])
+      (let ([x (expand
+                 '(let ()
+                    (trace-define-syntax frob
+                      (syntax-rules ()
+                       [(_ rot gut) (gut rot)]))
+                    (frob 17 $tds-foo)))])
+        (list x (get-output-string (trace-output-port)))))
+    '(($tds-foo 17) "|(frob (frob 17 $tds-foo))\n|($tds-foo 17)\n"))
+)
+
+(mat meta
+  (error? ; x out of context
+    (let () (meta define x 3) x))
+  (error? ; x out of context
+    (module () (meta define x 3) x))
+  (begin
+    (module ($meta-z)
+      (meta define x #'"jolly")
+      (define-syntax y (lambda (z) x))
+      (define $meta-z y))
+    (equal? $meta-z "jolly"))
+  (begin
+    (module (mat-meta-bar)
+      (module foo (macro-helper a b)
+        (meta define table
+         ; pretend this is a "big computation":
+          (map cons '(#\a #\b #\c) '(1 2 3)))
+        (meta define lookup
+          (lambda (c)
+            (cond [(assq c table) => cdr] [else #f])))
+        (meta define macro-helper
+          (lambda (x)
+            (syntax-case x ()
+              [(k c)
+               (with-syntax ([n (lookup (datum c))])
+                 #'(list '(k c) a n))])))
+        (define a 'is)
+        (define-syntax b
+          (lambda (x) (macro-helper x))))
+      (define mat-meta-bar
+        (lambda ()
+          (import foo)
+          (define-syntax d
+            (lambda (x) (macro-helper x)))
+          (list a (b #\b) (d #\c)))))
+      (equal? (mat-meta-bar) '(is ((b #\b) is 2) ((d #\c) is 3))))
+  (error? ; lookup out-of-context (in definition of c)
+    (begin
+      (module (mat-meta-bar)
+        (module foo (macro-helper a b c)
+          (meta define table
+           ; pretend this is a "big computation":
+            (map cons '(#\a #\b #\c) '(1 2 3)))
+          (meta define lookup
+            (lambda (c)
+              (cond [(assq c table) => cdr] [else #f])))
+          (meta define macro-helper
+            (lambda (x)
+              (syntax-case x ()
+                [(k c)
+                 (with-syntax ([n (lookup (datum c))])
+                   #'(list '(k c) a n))])))
+          (define a 'is)
+          (define-syntax b
+            (lambda (x) (macro-helper x)))
+          (define c
+            (lambda (s)
+              (map lookup (string->list s)))))
+        (define mat-meta-bar
+          (lambda ()
+            (import foo)
+            (define-syntax d
+              (lambda (x) (macro-helper x)))
+            (list a (b #\b) (c "aq") (d #\c)))))
+        (equal? (mat-meta-bar) '(is ((b #\b) is 2) (1 #f) ((d #\c) is 3)))))
+  (begin
+    (module mat-meta-foo (macro-helper a b)
+      (meta define table
+       ; pretend this is a "big computation":
+        (map cons '(#\a #\b #\c) '(1 2 3)))
+      (meta define lookup
+        (lambda (c)
+          (cond [(assq c table) => cdr] [else #f])))
+      (meta define macro-helper
+        (lambda (x)
+          (syntax-case x ()
+            [(k c)
+             (with-syntax ([n (lookup (datum c))])
+               #'(list '(k c) a n))])))
+      (define a 'is)
+      (define-syntax b
+        (lambda (x) (macro-helper x))))
+    #t)
+  (equal?
+    (let ()
+      (define mat-meta-bar1
+        (lambda ()
+          (import mat-meta-foo)
+          (define-syntax d
+            (lambda (x) (macro-helper x)))
+          (list a (b #\b) (d #\c))))
+      (mat-meta-bar1))
+    '(is ((b #\b) is 2) ((d #\c) is 3)))
+  (begin
+    (define mat-meta-bar2
+      (lambda ()
+        (import mat-meta-foo)
+        (define-syntax d
+          (lambda (x) (macro-helper x)))
+        (list a (b #\b) (d #\c))))
+    (procedure? mat-meta-bar2))
+  (equal? (mat-meta-bar2) '(is ((b #\b) is 2) ((d #\c) is 3)))
+  (error? ; out-of-context (run-time reference to meta variable)
+    (let ()
+      (module foo (macro-helper a b c)
+        (meta define table
+         ; pretend this is a "big computation":
+          (map cons '(#\a #\b #\c) '(1 2 3)))
+        (meta define lookup
+          (lambda (c)
+            (cond [(assq c table) => cdr] [else #f])))
+        (meta define macro-helper
+          (lambda (x)
+            (syntax-case x ()
+              [(k c)
+               (with-syntax ([n (lookup (datum c))])
+                 #'(list '(k c) a n))])))
+        (define a 'is)
+        (define-syntax b
+          (lambda (x) (macro-helper x)))
+        (define c
+          (lambda (s)
+            (map lookup (string->list s)))))
+      (define bar
+        (lambda ()
+          (import foo)
+          (define-syntax d
+            (lambda (x) (macro-helper x)))
+          (list a (b #\b) (c "aq") (d #\c))))
+      (bar)))
+  (begin
+    (module (mat-meta-q mat-meta-a)
+      (meta define mat-meta-q 13)
+      (define-syntax mat-meta-a
+        (lambda (x)
+          (set! mat-meta-q (* mat-meta-q 2))
+          (with-syntax ((n mat-meta-q))
+            #'(list n (- mat-meta-q 6))))))
+    (meta define mat-meta-x (begin (set! mat-meta-q (+ mat-meta-q 4)) mat-meta-q))
+    (meta module () (set! mat-meta-q (+ mat-meta-q 10)))
+    (define-syntax ans
+      (lambda (x)
+        (with-syntax ([d (cons (quotient (+ mat-meta-q mat-meta-x) 2) mat-meta-a)])
+          #''d)))
+    (equal? ans '(35 54 48)))
+  (equal?
+    (let ()
+      (module (mat-meta-q mat-meta-a)
+        (meta define mat-meta-q 13)
+        (define-syntax mat-meta-a
+          (lambda (x)
+            (set! mat-meta-q (* mat-meta-q 2))
+            (with-syntax ((n mat-meta-q))
+              #'(list n (- mat-meta-q 6))))))
+      (meta define mat-meta-x (begin (set! mat-meta-q (+ mat-meta-q 4)) mat-meta-q))
+      (meta module () (set! mat-meta-q (+ mat-meta-q 10)))
+      (define-syntax ans
+        (lambda (x)
+          (with-syntax ([d (cons (quotient (+ mat-meta-q mat-meta-x) 2) mat-meta-a)])
+            #''d)))
+      ans)
+    '(35 54 48))
+  (begin
+    (module (mat-meta-zeta) 
+      (meta module frobrat (boz) (define boz 3))
+      (define-syntax rot (lambda (x) (import frobrat) boz))
+      (define mat-meta-zeta rot))
+    (eq? mat-meta-zeta 3))
+  (begin
+    (module (mat-meta-gorp)
+      (meta define f (lambda (x) (if (= x 0) '() (cons x (f (- x 1))))))
+      (define-syntax mat-meta-gorp
+        (lambda (x)
+          (syntax-case x ()
+            [(_ n)
+             (with-syntax ([(num ...) (f (datum n))])
+               #'(list num ...))]))))
+    (equal? (mat-meta-gorp 5) '(5 4 3 2 1)))
+  (error? ; f not bound (referenced in alpha before definition complete)
+    (module (mat-meta-gorp)
+      (meta define f
+        (lambda (x)
+          (define-syntax alpha
+            (lambda (x)
+              (f x) ; f not bound (yet)
+              #'()))
+          (if (= x 0)
+              alpha
+              (cons x (f (- x 1))))))
+      (define-syntax mat-meta-gorp
+        (lambda (x)
+          (syntax-case x ()
+            [(_ n)
+             (with-syntax ([(num ...) (f (datum n))])
+               #'(list num ...))])))))
+  (begin
+    (define-syntax $cftest
+      (syntax-rules ()
+        [(_ e0 e1 e2)
+         (begin
+           (collect (collect-maximum-generation)) ; close ports left open by load/compile-file w/mat's error handler
+           (let ((op (open-output-file "testfile.ss" 'replace)))
+             (pretty-print 'e0 op)
+             (close-output-port op))
+           (compile-file "testfile.ss")
+           (and e1 (begin (load "testfile.ss") e2)))]))
+    #t)
+  ($cftest
+    (begin
+      (meta define meta-$bun 3)
+      (define meta-$burger 4))
+    (equal? meta-$bun 3)
+    (equal? meta-$burger 4))
+  (error?
+    ($cftest
+      (meta define meta-$lettuce 3)
+      (equal? meta-$bun 3)
+      (equal? meta-$burger 4)))
+ ; check to make sure meta still works if we change interaction environment
+  (eqv?
+    (parameterize ([interaction-environment (copy-environment (interaction-environment))])
+      (eval '
+        (let ()
+          (meta define foo 3)
+          (meta define bar (* 3 7))
+          (define-syntax a (lambda (x) (+ foo bar)))
+          a)))
+    24)
+)
+
+(mat meta2
+  (error? ; x out-of-context
+    (begin
+      (meta define x 3)
+      x))
+  (begin
+    (meta define x 3)
+    (define-syntax y (lambda (z) x))
+    (eq? y 3))
+
+ ; top-level module tests
+  (error? ; x out-of-context
+    (module m (x) (meta define x 3) (pretty-print x)))
+  (error? ; x out-of-context
+    (begin
+      (module m (x) (meta define x 3))
+      (let () (import m) x)))
+  (begin
+    (module m (x) (meta define x 3))
+    (eq? (let () (import m) (define-syntax y (lambda (z) x)) y) 3))
+  (error? ; x out-of-context
+    (begin
+      (module m (x) (meta define x 3))
+      (import m)
+      x))
+  (begin
+    (module mm-m (mm-x) (meta define mm-x 3))
+    (import mm-m)
+    (define-syntax mm-y (lambda (z) mm-x))
+    (eq? mm-y 3))
+  (begin
+    (module ($meta-z)
+      (meta define x #'"jolly")
+      (define-syntax y (lambda (z) x))
+      (define $meta-z y))
+    (equal? $meta-z "jolly"))
+  
+ ; local tests
+  (error? ;=> out-of-context or unbound error
+    (let ()
+      (module m (x) (meta define x 3) (pretty-print x))
+      4))
+  (error? ;=> out-of-context or unbound error
+    (let ()
+      (module m (x) (meta define x 3))
+      (let () (import m) x)))
+  (eq?
+    (let ()
+      (module m (x) (meta define x 3))
+      (let () (import m) (define-syntax y (lambda (z) x)) y))
+    3)
+  (let ()
+    (module ($meta-z)
+      (meta define x #'"jolly")
+      (define-syntax y (lambda (z) x))
+      (define $meta-z y))
+    (equal? $meta-z "jolly"))
+  (error? ;=> q out-of-context
+    (let ()
+      (meta define p 3)
+      (define-syntax a
+        (lambda (x)
+          (meta define q 4)
+          `(,#'quote (,p ,q))))
+      a))
+  (equal?
+    (let ()
+      (meta define p 3)
+      (define-syntax a
+        (lambda (x)
+          (meta define q 4)
+          (define-syntax b (lambda (x) q))
+          `(,#'quote (,p ,b))))
+      a)
+    '(3 4))
+  
+  (begin
+    (define $mm-p "p")
+    (define $mm-q "q")
+    (define $mm-r "r")
+    (meta module
+      ($mm-a $mm-b $mm-c)
+      (define t '())
+      (define $mm-a (lambda (k v) (set! t (cons (cons k v) t)) #'(void)))
+      (define $mm-b (lambda (k) (cdr (assq k t))))
+      (define-syntax $mm-c
+        (lambda (x)
+          (syntax-case x (get put)
+            [(_ get n) ($mm-b (datum n))]
+            [(_ put n v) ($mm-a (datum n) #'v)])))
+      (set! t `((1 . ,#'$mm-q) (2 . ,#'$mm-r))))
+    ($mm-c put 7 $mm-p)
+    (equal?
+      (list ($mm-c get 1) ($mm-c get 2) ($mm-c get 7))
+      '("q" "r" "p")))
+  (equal?
+    (let ([p "p!"] [q "q!"] [r "r!"])
+      (meta module (a b c)
+        (define t '())
+        (define a (lambda (k v) (set! t (cons (cons k v) t)) #'(void)))
+        (define b (lambda (k) (cdr (assq k t))))
+        (define-syntax c
+          (lambda (x)
+            (syntax-case x (get put)
+              [(_ get n) (b (datum n))]
+              [(_ put n v) (a (datum n) #'v)])))
+        (set! t `((1 . ,#'q) (2 . ,#'r))))
+      (c put 7 p)
+      (list (c get 1) (c get 2) (c get 7)))
+    '("q!" "r!" "p!"))
+  
+ ; assuming internal-defines-as-letrec* defaults to #t
+  (internal-defines-as-letrec*)
+ ; following tests assume it's set to #f
+  (begin (internal-defines-as-letrec* #f) (not (internal-defines-as-letrec*)))
+ ; top-level module tests
+  (error? ; undefined variable merry
+    (module sam (frodo)
+      (define merry 'merry)
+      (define frodo (cons merry merry))))
+  (error? ; undefined variable frodo
+    (module sam (frodo)
+      (define merry 'merry)
+      (define frodo 'frodo)
+      (define pippin (cons frodo frodo))))
+  (begin (internal-defines-as-letrec* #t) (internal-defines-as-letrec*))
+  (eq? (let ()
+         (module (x !y ?y) (define x (call/cc values))
+           (define y 0)
+           (define !y (lambda (v) (set! y v)))
+           (define ?y (lambda () y)))
+         (!y (+ (?y) 1))
+         (x values)
+         (?y))
+       1)
+  (begin
+    (module (x !y ?y)
+      (define x (call/cc values))
+      (define y 0)
+      (define !y (lambda (v) (set! y v)))
+      (define ?y (lambda () y)))
+    (!y (+ (?y) 1))
+    (x values)
+    (eq? (?y) 1))
+  (begin
+    (meta define hobbits '())
+    (module ()
+      (meta module ()
+        (set! hobbits (cons 'merry hobbits)))
+      (meta module ()
+        (set! hobbits (cons 'lobelia hobbits))
+        (set! hobbits (cons 'frodo hobbits))
+        (set! hobbits (cons 'bilbo hobbits)))
+      (meta begin
+        (set! hobbits (cons 'pippin hobbits))))
+    (define-syntax hobbit-report
+      (lambda (x) `(,#'quote ,(datum->syntax #'* hobbits))))
+    (equal? hobbit-report '(pippin bilbo frodo lobelia merry)))
+  (let ()
+    (meta define hobbits '())
+    (module ()
+      (meta module ()
+        (set! hobbits (cons 'merry hobbits)))
+      (meta module ()
+        (set! hobbits (cons 'lobelia hobbits))
+        (set! hobbits (cons 'frodo hobbits))
+        (set! hobbits (cons 'bilbo hobbits)))
+      (meta begin
+        (set! hobbits (cons 'pippin hobbits))))
+    (define-syntax hobbit-report
+      (lambda (x) `(,#'quote ,(datum->syntax #'* hobbits))))
+    (equal? hobbit-report '(pippin bilbo frodo lobelia merry)))
+  (begin
+    (meta define $whatsit)
+    (meta begin (set! $whatsit #xc7c7c7c7))
+    (define-syntax $mm-a (lambda (x) $whatsit))
+    (eqv? $mm-a #xc7c7c7c7))
+  (error? ; no expr in body
+    (let () (meta begin (void))))
+  (error? ; invalid meta definition ((void))
+    (meta (void)))
+  (error? ; invalid meta definition ((void))
+    (module () (meta (void))))
+  (error? ; invalid meta definition ((void))
+    (let () (meta (void))))
+  (begin
+    (define hobbits '())
+    (module ()
+      (module ()
+        (set! hobbits (cons 'merry hobbits)))
+      (module ()
+        (set! hobbits (cons 'lobelia hobbits))
+        (set! hobbits (cons 'frodo hobbits))
+        (set! hobbits (cons 'bilbo hobbits)))
+      (set! hobbits (cons 'pippin hobbits)))
+    (equal? hobbits '(pippin bilbo frodo lobelia merry)))
+  (let ()
+    (define hobbits '())
+    (module ()
+      (module ()
+        (set! hobbits (cons 'merry hobbits)))
+      (module ()
+        (set! hobbits (cons 'lobelia hobbits))
+        (set! hobbits (cons 'frodo hobbits))
+        (set! hobbits (cons 'bilbo hobbits)))
+      (set! hobbits (cons 'pippin hobbits)))
+    (equal? hobbits '(pippin bilbo frodo lobelia merry)))
+  
+ ; assuming internal-defines-as-letrec* true
+  (internal-defines-as-letrec*)
+  (begin
+    (define hobbits '())
+    (module sam (frodo)
+      (define merry (set! hobbits (cons 'merry hobbits)))
+      (define frodo (set! hobbits (cons 'frodo hobbits)))
+      (define pippin (set! hobbits (cons 'pippin hobbits))))
+    (equal? hobbits '(pippin frodo merry)))
+  (let ()
+    (define hobbits '())
+    (module sam (frodo)
+      (define merry (set! hobbits (cons 'merry hobbits)))
+      (define frodo (set! hobbits (cons 'frodo hobbits)))
+      (define pippin (set! hobbits (cons 'pippin hobbits))))
+    (equal? hobbits '(pippin frodo merry)))
+  (begin
+    (define hobbits '())
+    (module sam (frodo)
+      (define merry (set! hobbits (cons 'merry hobbits)))
+      (module (frodo)
+        (define lobelia (set! hobbits (cons 'lobelia hobbits)))
+        (define frodo (set! hobbits (cons 'frodo hobbits)))
+        (define bilbo (set! hobbits (cons 'bilbo hobbits))))
+      (define pippin (set! hobbits (cons 'pippin hobbits))))
+    (equal? hobbits '(pippin bilbo frodo lobelia merry)))
+  (let ()
+    (define hobbits '())
+    (module sam (frodo)
+      (define merry (set! hobbits (cons 'merry hobbits)))
+      (module (frodo)
+        (define lobelia (set! hobbits (cons 'lobelia hobbits)))
+        (define frodo (set! hobbits (cons 'frodo hobbits)))
+        (define bilbo (set! hobbits (cons 'bilbo hobbits))))
+      (define pippin (set! hobbits (cons 'pippin hobbits))))
+    (equal? hobbits '(pippin bilbo frodo lobelia merry)))
+  (begin
+    (module sam (frodo)
+      (define merry 'merry)
+      (define frodo (cons merry merry)))
+    (equal? (let () (import sam) frodo) '(merry . merry)))
+  (error? ; undefined variable merry
+    (module sam (frodo)
+      (define frodo (cons merry merry))
+      (define merry 'merry)))
+  (error? ; undefined variable frodo
+    (module sam (frodo)
+      (define merry 'merry)
+      (define pippin (cons frodo frodo))
+      (define frodo 'frodo)))
+  (begin
+    (module sam (frodo)
+      (define merry 'merry)
+      (define frodo (lambda () pippin))
+      (define pippin (cons frodo frodo)))
+    (let () (import sam) (eq? (car (frodo)) frodo)))
+  (let ()
+    (module (x !y ?y)
+      (define x (call/cc values))
+      (define y 0)
+      (define !y (lambda (v) (set! y v)))
+      (define ?y (lambda () y)))
+    (!y (+ (?y) 1))
+    (x values)
+    (eq? (?y) 1))
+  (begin
+    (module (x !y ?y)
+      (define x (call/cc values))
+      (define y 0)
+      (define !y (lambda (v) (set! y v)))
+      (define ?y (lambda () y)))
+    (!y (+ (?y) 1))
+    (x values)
+    (eq? (?y) 1))
+  
+ ; test for proper evaluation of meta defines and inits at compile-file time,
+ ; visit time, revisit time, and load time
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(meta module $mm-m (a)
+             (define q 3)
+             (define-syntax qinc! (identifier-syntax (set! q (+ q 1))))
+             (define-syntax (a x) qinc! q)
+             qinc!
+             (set! q (* q q)))))
+      'replace)
+    (compile-file "testfile")
+    #t)
+  (eq? (let () (import $mm-m) a) 17)
+  (eq? (let () (import $mm-m) a) 18)
+  (begin (visit "testfile.so") #t)
+  (eq? (let () (import $mm-m) a) 17)
+  (eq? (let () (import $mm-m) a) 18)
+  (begin (load "testfile.so") #t)
+  (eq? (let () (import $mm-m) a) 17)
+  (eq? (let () (import $mm-m) a) 18)
+  (begin (revisit "testfile.so") #t)
+  (eq? (let () (import $mm-m) a) 19)
+)
+
+(mat quasisyntax
+  (error? ; invalid syntax
+    quasisyntax)
+  (error? ; invalid syntax
+    (quasisyntax))
+  (error? ; invalid syntax
+    (quasisyntax . a))
+  (error? ; invalid syntax
+    (quasisyntax a b c))
+  (error? ; misplaced
+    (unsyntax x))
+  (error? ; misplaced
+    (unsyntax-splicing x))
+  (error? ; misplaced
+    (unsyntax x y))
+  (error? ; misplaced
+    (unsyntax-splicing x y))
+  (error? ; misplaced
+    (unsyntax))
+  (error? ; misplaced
+    (unsyntax-splicing))
+  (error? ; misplaced
+    unsyntax)
+  (error? ; misplaced
+    unsyntax-splicing)
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`(list #,(length #'(x ...)) 'x ...)])))
+         #t)
+  (equal? (qs-foo 3 2 1) '(3 3 2 1))
+  (equal? (qs-foo 3 2 1) '(3 3 2 1))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                (quasisyntax (list (unsyntax (length #'(x ...))) 'x ...))])))
+         #t)
+  (equal? (qs-foo 3 2 1) '(3 3 2 1))
+  (equal? (qs-foo 3 2 1) '(3 3 2 1))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'#`(a #,a b #,@b #,#(#,@#'(x ...)) #,@#(#,#'(x ...)))])))
+         #t)
+  (equal?
+    (qs-foo 3 2 1)
+    '(quasisyntax
+       (a (unsyntax a) b (unsyntax-splicing b)
+          (unsyntax #3(3 2 1)) (unsyntax-splicing #1((3 2 1))))))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'(a #(#,#'(x ...) #,@#'(x ...) unsyntax unsyntax-splicing ,a ,@b) (a . #,#'(x ...)) . c)])))
+         #t)
+  (equal?
+    (qs-foo 3 2 1)
+    '(a #8((3 2 1) 3 2 1 unsyntax unsyntax-splicing ,a ,@b)
+        (a 3 2 1)
+        .
+        c))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'#(a (#,#'(x ...) #,@#'(x ...) unsyntax unsyntax-splicing ,a ,@b) (a . #,#'(x ...)))])))
+         #t)
+  (equal?
+    (qs-foo 3 2 1)
+    '#3(a ((3 2 1) 3 2 1 unsyntax unsyntax-splicing ,a ,@b)
+        (a 3 2 1)))
+ ; test zero and two+ unsyntax-splicing subforms
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'((unsyntax) 0 (unsyntax #'(a x ... b) #'(x ...)) c)])))
+         #t)
+  (equal? (qs-foo 3 2 1) '(0 (a 3 2 1 b) (3 2 1) c))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'#((unsyntax) 0 (unsyntax #'(a x ... b) #'(x ...)) c)])))
+         #t)
+  (equal? (qs-foo 3 2 1) '#(0 (a 3 2 1 b) (3 2 1) c))
+ ; test zero and two+ unsyntax-splicing subforms
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'((unsyntax-splicing) 0 (unsyntax-splicing #'(a x ... b) #'(x ...)) c)])))
+         #t)
+  (equal? (qs-foo 3 2 1) '(0 a 3 2 1 b 3 2 1 c))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'#((unsyntax-splicing) 0 (unsyntax-splicing #'(a x ... b) #'(x ...)) c)])))
+         #t)
+  (equal? (qs-foo 3 2 1) '#(0 a 3 2 1 b 3 2 1 c))
+ ; make sure out-of-place unsyntax/unsyntax-splicing keywords are left alone
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...) #`'unsyntax])))
+         #t)
+  (equal? (qs-foo 3 2 1) 'unsyntax)
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...) #`'unsyntax-splicing])))
+         #t)
+  (equal? (qs-foo 3 2 1) 'unsyntax-splicing)
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'(a . (unsyntax #'(x ...) #'(x ...)))])))
+         #t)
+  (equal? (qs-foo 3 2 1) '(a . (unsyntax (syntax (3 2 1)) (syntax (3 2 1)))))
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x ...)
+                #`'(a . (unsyntax-splicing #'(x ...)))])))
+         #t)
+  (equal? (qs-foo 3 2 1) '(a . (unsyntax-splicing (syntax (3 2 1)))))
+ ; test noninterference with quasiquote
+  (begin (define-syntax qs-foo
+           (lambda (x)
+             (syntax-case x ()
+               [(_ x1 x2 ...)
+                #``(a ,@(reverse (list #,@#'(x2 ...))) ,#,#'x1)])))
+         #t)
+  (equal?
+    (qs-foo 3 2 1)
+    '(a 1 2 3))
+ ; tests adapted from Andre van Tonder posts to srfi 93 discussion
+  (equal?
+    (let ()
+      (define-syntax swap!
+        (lambda (e)
+          (syntax-case e ()
+            [(_ a b)
+             (let ([a #'a] [b #'b])
+               (quasisyntax
+                 (let ([temp (unsyntax a)])
+                   (set! (unsyntax a) (unsyntax b))
+                   (set! (unsyntax b) temp))))])))
+      (let ([temp 1] [set! 2])
+        (swap! set! temp)
+        (cons temp set!)))
+    '(2 . 1))
+  (eq?
+    (let ()
+      (define-syntax case
+        (lambda (x)
+          (syntax-case x ()
+            [(_ e c1 c2 ...)
+             (quasisyntax
+               (let ([t e])
+                 (unsyntax
+                   (let f ([c1 #'c1] [cmore #'(c2 ...)])
+                     (if (null? cmore)
+                         (syntax-case c1 (else)
+                           [(else e1 e2 ...) #'(begin e1 e2 ...)]
+                           [((k ...) e1 e2 ...)
+                            #'(if (memv t '(k ...))
+                                  (begin e1 e2 ...))])
+                         (syntax-case c1 ()
+                           [((k ...) e1 e2 ...)
+                            (quasisyntax
+                              (if (memv t '(k ...))
+                                  (begin e1 e2 ...)
+                                  (unsyntax
+                                    (f (car cmore)
+                                       (cdr cmore)))))]))))))])))
+      (case 'a [(b c) 'no] [(d a) 'yes]))
+    'yes)
+  (eqv?
+    (let ()
+      (define-syntax let-in-order
+        (lambda (form)
+          (syntax-case form ()
+            [(_ ((i e) ...) e0 e1 ...)
+             (let f ([ies #'((i e) ...)] [its #'()])
+               (syntax-case ies ()
+                 [() (quasisyntax (let (unsyntax its) e0 e1 ...))]
+                 [((i e) . ies)
+                  (with-syntax ([t (car (generate-temporaries '(t)))])
+                    (quasisyntax
+                      (let ([t e])
+                        (unsyntax
+                          (f #'ies
+                             (quasisyntax
+                               ((i t)
+                                 (unsyntax-splicing its))))))))]))])))
+      (let-in-order ((x 1) (y 2)) (+ x y)))
+    3)
+  (equal?
+    (let-syntax ([test-ellipses-over-unsyntax
+                  (lambda (e)
+                    (let ([a #'a])
+                      (with-syntax ([(b ...) #'(1 2 3)])
+                        (quasisyntax '((b #,a) ...)))))])
+      (test-ellipses-over-unsyntax))
+    '((1 a) (2 a) (3 a)))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax '(list #,(+ 1 2) 4)))])
+      (test))
+  '(list 3 4))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (let ([name #'a])
+                           (quasisyntax '(list #,name '#,name))))])
+      (test))
+    '(list a 'a))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax
+                           '(a #,(+ 1 2) #,@(map abs '(4 -5 6)) b)))])
+      (test))
+    '(a 3 4 5 6 b))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax
+                           '((foo #,(- 10 3))
+                              #,@(cdr '(5))
+                              .
+                              #,(car '(7)))))])
+      (test))
+    '((foo 7) . 7))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax
+                           '#(10 5 #,(sqrt 4) #,@(map sqrt '(16 9)) 8)))])
+      (test))
+    '#(10 5 2 4 3 8))
+  (eqv?
+    (let-syntax ([test (lambda (_) (quasisyntax #,(+ 2 3)))])
+      (test))
+    5)
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax
+                           '(a (quasisyntax
+                                 (b #,(+ 1 2) #,(foo #,(+ 1 3) d) e))
+                               f)))])
+      (test))
+    '(a (quasisyntax (b #,(+ 1 2) #,(foo 4 d) e)) f))
+
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (let ([name1 #'x] [name2 #'y])
+                           (quasisyntax
+                             '(a (quasisyntax (b #,#,name1 #,#'#,name2 d))
+                                 e))))])
+      (test))
+    '(a (quasisyntax (b #,x #,#'y d)) e))
+ ; Bawden's extensions:
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax '(a (unsyntax 1 2) b)))])
+      (test))
+    '(a 1 2 b))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (quasisyntax
+                           '(a (unsyntax-splicing '(1 2) '(3 4)) b)))])
+      (test))
+    '(a 1 2 3 4 b))
+  (equal?
+    (let-syntax ([test (lambda (_)
+                         (let ([x #'(a b c)])
+                           (quasisyntax
+                             '(quasisyntax (#,#,x #,@#,x #,#,@x #,@#,@x)))))])
+      (test))
+    '(quasisyntax
+       (#,(a b c)
+         #,@(a b c)
+         (unsyntax a b c)
+         (unsyntax-splicing a b c))))
+)
+
+(mat meta-cond
+  (begin
+    (define $meta-cond-expr
+      '(meta-cond
+         [(= (optimize-level) 3) $mc-a $mc-b $mc-c]
+         [(= (optimize-level) 2) $mc-d]
+         [else $mc-e $mc-f]))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3]) (expand $meta-cond-expr))
+    '(begin $mc-a $mc-b $mc-c))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2]) (expand $meta-cond-expr))
+    '$mc-d)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 0]) (expand $meta-cond-expr))
+    '(begin $mc-e $mc-f))
+  (equal?
+    (parameterize ([optimize-level 0]) ; should have no effect
+      (with-output-to-string
+        (lambda ()
+          (meta-cond
+            [(= (optimize-level) 3) (pretty-print 'level3)]
+            [(= (optimize-level) 2) (pretty-print 'level2)]))))
+    (case (optimize-level)
+      [(2) "level2\n"]
+      [(3) "level3\n"]
+      [else ""]))
+)
+
+(mat make-compile-time-value
+  (error? ; incorrect number of arguments
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (lambda (r)
+            (r))))
+      a))
+  (error? ; not an identifier
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (lambda (r)
+            (r #'(a)))))
+      a))
+  (error? ; not an identifier
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (lambda (r)
+            (r #'(a) #'frip))))
+      a))
+  (error? ; not an identifier
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (lambda (r)
+            (r #'a "frip"))))
+      a))
+  (error? ; incorrect number of arguments
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (lambda (r)
+            (r #'a #'frip "extra stuff"))))
+      a))
+  (error? ; not a compile-time value
+    (compile-time-value-value 17))
+  (begin
+    (with-output-to-file "testfile-mctv0.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mctv0) (export get-ctv get-property) (import (chezscheme))
+             (define-syntax get-ctv
+               (lambda (x)  
+                 (lambda (r)
+                   (syntax-case x ()
+                     [(_ q) #`'#,(datum->syntax #'* (r #'q))]))))
+             (define-syntax get-property
+               (lambda (x)  
+                 (lambda (r)
+                   (syntax-case x ()
+                     [(_ q prop) #`'#,(datum->syntax #'* (r #'q #'prop))])))))))
+      'replace)
+    (for-each separate-compile '(mctv0))
+    #t)
+  (begin
+    (import (testfile-mctv0))
+    #t)
+  (compile-time-value? (make-compile-time-value 'fred))
+  (begin
+    (define-syntax frob (make-compile-time-value 'rabf))
+    #t)
+  (eq? (get-ctv frob) 'rabf)
+  (error? ; invalid syntax
+    frob)
+  (error? ; invalid syntax
+    (frob kupe))
+  (eq?
+    (let ()
+      (define-syntax frob (make-compile-time-value 'shuddle))
+      (get-ctv frob))
+    'shuddle)
+  (eq?
+    (let-syntax ([frob (make-compile-time-value 'skupo)])
+      (get-ctv frob))
+    'skupo)
+  (equal?
+    (let ([frob "not the global frob ..."])
+      (list frob (get-ctv frob)))
+    '("not the global frob ..." #f))
+  (eq? (get-ctv frob) 'rabf)
+  (error? ; invalid syntax
+    (let ()
+      (define-syntax frob (make-compile-time-value 'shuddle))
+      frob))
+  (error? ; invalid syntax
+    (let ()
+      (define-syntax frob (make-compile-time-value 'shuddle))
+      (frob)))
+  (error? ; duplicate definition
+    (module mctv-m1 (x)
+      (define x 3)
+      (define-syntax x (make-compile-time-value 'xxx))))
+  (error? ; duplicate definition
+    (module mctv-m1 (x)
+      (define-syntax x (make-compile-time-value 'xxx))
+      (define-syntax x (make-compile-time-value 'xxx))))
+  (begin
+    (module mctv-m1 (x)
+      (define-syntax x (make-compile-time-value 'xxx)))
+    #t)
+  (eq? (let () (import mctv-m1) (get-ctv x)) 'xxx)
+  (begin
+    (library (mctv l1) (export x) (import (chezscheme) (testfile-mctv0))
+      (define-syntax x (make-compile-time-value 'xow)))
+    #t)
+  (eq? (let () (import (mctv l1)) (get-ctv x)) 'xow)
+  (eq? (compile-time-value-value (top-level-syntax 'x (environment '(mctv l1)))) 'xow)
+  (begin
+    (with-output-to-file "testfile-mctv1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mctv1) (export x) (import (chezscheme))
+             (define-syntax x (make-compile-time-value 'xuko1)))))
+      'replace)
+    (for-each separate-compile '(mctv1))
+    #t)
+  (eq? (let () (import (testfile-mctv1)) (get-ctv x)) 'xuko1)
+  (compile-time-value? (top-level-syntax 'x (environment '(testfile-mctv1))))
+  (eq? (compile-time-value-value (top-level-syntax 'x (environment '(testfile-mctv1)))) 'xuko1)
+  (begin
+    (with-output-to-file "testfile-mctv1a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-mctv1a) (export x) (import (chezscheme))
+             (define-syntax x (make-compile-time-value 'xuko1)))))
+      'replace)
+    (for-each separate-compile '(mctv1a))
+    #t)
+  (eq? (compile-time-value-value (top-level-syntax 'x (environment '(testfile-mctv1a)))) 'xuko1)
+  (eq? (let () (import (testfile-mctv1a)) (get-ctv x)) 'xuko1)
+  (begin
+    (with-output-to-file "testfile-mctv2.ss"
+      (lambda ()
+        (pretty-print
+          '(module mctv-m2 (x)
+             (define-syntax x (make-compile-time-value 'xuko2)))))
+      'replace)
+    (for-each separate-compile '(mctv2))
+    (load "testfile-mctv2.so")
+    #t)
+  (eq? (let () (import mctv-m2) (get-ctv x)) 'xuko2)
+  (begin
+    (with-output-to-file "testfile-mctv3.ss"
+      (lambda ()
+        (pretty-print
+          '(define-syntax mctv3-x (make-compile-time-value 'xuko3))))
+      'replace)
+    (for-each separate-compile '(mctv3))
+    (load "testfile-mctv3.so")
+    #t)
+  (eq? (get-ctv mctv3-x) 'xuko3)
+  (begin
+    (with-output-to-file "testfile-mctv4.ss"
+      (lambda ()
+        (printf "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (chezscheme) (testfile-mctv0)))
+        (pretty-print '(define spod))
+        (pretty-print '(define qrtz))
+        (pretty-print '(define xptz))
+        (pretty-print '(define-syntax x (make-compile-time-value 'xuko4)))
+        (pretty-print '(define-property x spod "shuff"))
+        (pretty-print '(define-property x qrtz "dmnd"))
+        (pretty-print '(printf "~s ~s ~s ~s ~s\n"
+                         (get-property get-property spod)
+                         (get-property x spod)
+                         (get-property x qrtz)
+                         (get-property x xptz)
+                         (get-ctv x))))
+      'replace)
+    (for-each (lambda (x) (separate-compile 'compile-program x)) '(mctv4))
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-program "testfile-mctv4.ss")))
+    "#f \"shuff\" \"dmnd\" #f xuko4\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-program "testfile-mctv4.so")))
+    "#f \"shuff\" \"dmnd\" #f xuko4\n")
+  (eqv?
+    (let ()
+      (define foo 3)
+      (define-syntax alpha (make-compile-time-value #'foo))
+      (define-syntax beta
+        (lambda (x)
+          (lambda (r)
+            (r #'alpha))))
+      (let ()
+        (define foo 4)
+        beta))
+    3)
+  (eqv?
+    (let ()
+      (define foo 3)
+      (define-syntax alpha
+        (lambda (x)
+          (syntax-case x ()
+            [(_ id) #'(define-syntax id (make-compile-time-value #'foo))])))
+      (let ()
+        (define foo 4)
+        (alpha beta)
+        (define-syntax gamma
+          (lambda (x)
+            (lambda (r)
+              (r #'beta))))
+        gamma)) ;=> 3
+    3)
+  #; ; decided not to have rebuild-macro-output delve into records...
+  (eqv?
+    (let ()
+      (meta define-record-type rats (fields cheese))
+      (define foo 3)
+      (define-syntax alpha
+        (lambda (x)
+          (syntax-case x ()
+            [(_ id)
+             #`(define-syntax id
+                 (make-compile-time-value '#,(make-rats #'foo)))])))
+      (let ()
+        (define foo 4)
+        (alpha beta)
+        (define-syntax gamma
+          (lambda (x)
+            (lambda (r)
+              #`(let ()
+                  (define foo 5)
+                  #,(rats-cheese (r #'beta))))))
+        gamma))
+    3)
+  #; ; decided not to have rebuild-macro-output delve into records...
+  (eqv?
+    (let ()
+      (meta define-record-type rats (fields cheese))
+      (define foo 3)
+      (define-syntax alpha
+        (lambda (x)
+          (syntax-case x ()
+            [(_ id)
+             #`(module (id)
+                 (define foo 3.5)
+                 (define-syntax id
+                   (make-compile-time-value '#,(make-rats #'foo))))])))
+      (let ()
+        (define foo 4)
+        (alpha beta)
+        (define-syntax gamma
+          (lambda (x)
+            (lambda (r)
+              #`(let ()
+                  (define foo 5)
+                  #,(rats-cheese (r #'beta))))))
+        gamma))
+    3.5)
+  (eqv?
+    (let ()
+      (meta define make-rats list)
+      (meta define rats-cheese car)
+      (define foo 3)
+      (define-syntax alpha
+        (lambda (x)
+          (syntax-case x ()
+            [(_ id)
+             #`(module (id)
+                 (define foo 3.5)
+                 (define-syntax id
+                   (make-compile-time-value #'#,(make-rats #'foo))))])))
+      (let ()
+        (define foo 4)
+        (alpha beta)
+        (define-syntax gamma
+          (lambda (x)
+            (lambda (r)
+              #`(let ()
+                  (define foo 5)
+                  #,(syntax-case (r #'beta) ()
+                      [(foo) #'foo])))))
+        gamma))
+    3.5)
+)
+
+(mat define-property
+  (begin
+    (library (dp get-property) (export get-property) (import (scheme))
+      (define-syntax get-property
+        (lambda (x)  
+          (lambda (r)
+            (syntax-case x ()
+              [(_ q prop) #`'#,(datum->syntax #'* (r #'q #'prop))])))))
+    (import (dp get-property))
+    #t)
+  (begin
+    (define-property cons frotz 'spamgle)
+    (equal?
+      (cons (get-property cons frotz) (get-property cons fratz))
+      '(spamgle . #f)))
+  (equal?
+    (cons (get-property cons frotz) (get-property cons fratz))
+    '(spamgle . #f))
+  (equal?
+    (let ()
+      (import scheme) 
+      (cons (get-property cons frotz) (get-property cons fratz)))
+    (if (free-identifier=? #'cons (let () (import scheme) #'cons))
+        '(spamgle . #f)
+        '(#f . #f)))
+  (equal?
+    (let ()
+      (define-property cons fratz 'yubah)
+      (cons (get-property cons frotz) (get-property cons fratz)))
+    '(spamgle . yubah))
+  (equal?
+    (cons (get-property cons frotz) (get-property cons fratz))
+    '(spamgle . #f))
+ ; restore
+  (begin
+    (meta-cond
+      [(free-identifier=? #'cons (let () (import scheme) #'cons))
+       (import (only scheme cons))]
+      [else (define cons (let () (import scheme) cons))])
+    #t)
+  (equal?
+    (cons (get-property cons frotz) (get-property cons fratz))
+    '(#f . #f))
+  (equal?
+    (let ()
+      (import scheme) 
+      (cons (get-property cons frotz) (get-property cons fratz)))
+    '(#f . #f))
+  (equal?
+    (let ()
+      (import scheme) 
+      (define-property list type "procedure")
+      (list (get-property list type) (get-property car type)))
+    '("procedure" #f))
+  (equal?
+    (let ()
+      (define list (lambda x x))
+      (define-property list type "procedure")
+      (list (get-property list type) (get-property car type)))
+    '("procedure" #f))
+  (error? ; multiple definitions for list
+    (let ()
+      (define-property list type "procedure")
+      (define list (lambda x x))
+      (list (get-property list type) (get-property car type))))
+  (error? ; multiple definitions for list
+    (module m (list)
+      (define-property list type "procedure")
+      (define list (lambda x x))
+      (list (get-property list type) (get-property car type))))
+  (error? ; immutable environment
+    (eval '(define-property frot rat 3) (scheme-environment)))
+  (error? ; immutable environment
+    (eval '(define-property cons rat 3) (scheme-environment)))
+  (error? ; no visible binding
+    (eval '(let () (define-property frot cons 3) 3) (scheme-environment)))
+  (error? ; no visible binding
+    (eval '(let () (define-property cons rat 3) 3) (scheme-environment)))
+  (error? ; no visible binding
+    (library (dp err1) (export x) (import (scheme))
+      (define-property x cons "frap")))
+  (error? ; no visible binding
+    (library (dp err1) (export x) (import (scheme))
+      (define-property cons frip "frap")))
+  (error? ; no visible binding
+    (module (x) (import-only (scheme))
+      (define-property x cons "frap")))
+  (error? ; no visible binding
+    (module (x) (import-only (scheme))
+      (define-property cons frip "frap")))
+  (not (get-property list type))
+  (equal?
+    (let ()
+      (define type)
+      (define-property list type "proc")
+      (list
+        (get-property list type)
+        (let () (define type) (get-property list type))))
+    '("proc" #f))
+  (equal?
+    (let ()
+      (module (type iface list)
+        (define type)
+        (define iface)
+        (define-property list type "a proc")
+        (define-property list iface -1))
+      (list
+        (get-property list type)
+        (get-property list iface)))
+    '("a proc" -1))
+  (equal?
+    (let ()
+      (module (type list)
+        (define type)
+        (define iface)
+        (define-property list type "a proc")
+        (define-property list iface -1))
+      (list
+        (get-property list type)
+        (get-property list iface)))
+    '("a proc" #f))
+  (equal?
+    (let ()
+      (module (iface list)
+        (define type)
+        (define iface)
+        (define-property list type "a proc")
+        (define-property list iface -1))
+      (list
+        (get-property list type)
+        (get-property list iface)))
+    '(#f -1))
+  (equal?
+    (let ()
+      (module (list)
+        (define type)
+        (define iface)
+        (define-property list type "a proc")
+        (define-property list iface -1))
+      (list
+        (get-property list type)
+        (get-property list iface)))
+    '(#f #f))
+  (equal?
+    (let ()
+      (module (type iface)
+        (define type)
+        (define iface)
+        (define-property list type "a proc")
+        (define-property list iface -1))
+      (list
+        (get-property list type)
+        (get-property list iface)))
+    '(#f #f))
+  (begin
+    (define dp-out (open-output-string))
+    (module dp-m1 (x)
+      (import (scheme) (dp get-property))
+      (define x 444)
+      (define-property x frob "x-frob")
+      (define-property x spam "x-spam")
+      (fprintf dp-out "~s ~s ~s ~s\n"
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)
+        x))
+    (equal?
+      (get-output-string dp-out) 
+      "\"x-spam\" \"x-frob\" #f 444\n"))
+  (equal?
+    (let ()
+      (import dp-m1) 
+      (list
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)
+        x))
+    '("x-spam" "x-frob" #f 444))
+  (begin
+    (define dp-out (open-output-string))
+    (module dp-m1 ()
+      (import (scheme) (dp get-property))
+      (define-property dp-out spam "dp-out-spam")
+      (define-property dp-out frob "dp-out-frob")
+      (fprintf dp-out "~s ~s ~s\n"
+        (get-property dp-out spam)
+        (get-property dp-out frob)
+        (get-property dp-out rats)))
+    (and
+      (equal?
+        (get-output-string dp-out) 
+        "\"dp-out-spam\" \"dp-out-frob\" #f\n")
+      (not (get-property dp-out spam))
+      (not (get-property dp-out frob))))
+  (equal?
+    (let ()
+      (import dp-m1) 
+      (list
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)))
+    '(#f #f #f))
+  (begin
+    (module dp-m1 (m2 (f x y))
+      (import (scheme) (dp get-property))
+      (define y "yval")
+      (define-property y a "y-a")
+      (module m2 (x)
+        (define x "xval")
+        (define-property x a "x-a")
+        (define-property y b "y-b"))
+      (import m2)
+      (define-property x b "x-b")
+      (define-syntax f
+        (identifier-syntax
+          (list (list x (get-property x a) (get-property x b))
+                (list y (get-property y a) (get-property y b))))))
+    #t)
+  (equal?
+    (let () (import dp-m1) f)
+    '(("xval" "x-a" "x-b") ("yval" "y-a" #f)))
+  (equal?
+    (let ()
+      (import dp-m1)
+      (import m2)
+      (list
+        (get-property x a)
+        (get-property x b)
+        (get-property x c)
+        x))
+    '("x-a" #f #f "xval"))
+  (begin
+    (library (dp l1) (export x spam frob rats) (import (scheme) (dp get-property))
+      (define spam)
+      (define frob)
+      (define rats)
+      (define x (make-parameter 444))
+      (define-property x spam "x-spam")
+      (define-property x frob "x-frob")
+      (printf "~s ~s ~s ~s\n"
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)
+        (x)))
+    #t)
+  (begin (define dp-f) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (set! dp-f
+          (eval
+            '(lambda ()
+               (import (dp l1))
+               (printf "~s ~s ~s ~s\n"
+                 (get-property x spam)
+                 (get-property x frob)
+                 (get-property x rats)
+                 (x)))))))
+    "\"x-spam\" \"x-frob\" #f 444\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (dp-f)))
+    "\"x-spam\" \"x-frob\" #f 444\n")
+  (begin
+    (library (dp l1) (export x spam frob rats) (import (scheme) (dp get-property))
+      (define spam)
+      (define frob)
+      (define rats)
+      (define-syntax x
+        (identifier-syntax
+          (list
+            (get-property x spam)
+            (get-property x frob)
+            (get-property x rats))))
+      (define-property x spam "x-spam")
+      (define-property x frob "x-frob")
+      (printf "~s ~s ~s ~s\n"
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)
+        x))
+    #t)
+  (begin (define dp-f) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (set! dp-f
+          (eval
+            '(lambda ()
+               (import (dp l1))
+               (printf "~s ~s ~s ~s\n"
+                 (get-property x spam)
+                 (get-property x frob)
+                 (get-property x rats)
+                 x))))))
+    "")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (dp-f)))
+    "\"x-spam\" \"x-frob\" #f (\"x-spam\" \"x-frob\" #f)\n")
+  (begin
+    (library (dp l1) (export x qq spam frob rats) (import (scheme) (dp get-property))
+      (define spam)
+      (define frob)
+      (define rats)
+      (define qq (make-parameter 33))
+      (define-syntax x
+        (identifier-syntax
+          (list
+            (get-property x spam)
+            (get-property x frob)
+            (get-property x rats))))
+      (define-property x spam "x-spam")
+      (define-property x frob "x-frob")
+      (printf "~s ~s ~s ~s\n"
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)
+        x))
+    #t)
+  (begin (define dp-f) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (set! dp-f
+          (eval
+            '(lambda ()
+               (import (dp l1))
+               (printf "~s ~s ~s ~s ~s\n"
+                 (get-property x spam)
+                 (get-property x frob)
+                 (get-property x rats)
+                 x (qq)))))))
+    "\"x-spam\" \"x-frob\" #f (\"x-spam\" \"x-frob\" #f)\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (dp-f)))
+    "\"x-spam\" \"x-frob\" #f (\"x-spam\" \"x-frob\" #f) 33\n")
+  (begin
+    (library (dp l1) (export qq spam frob rats) (import (scheme) (dp get-property))
+      (define spam)
+      (define frob)
+      (define rats)
+      (define qq (make-parameter 77))
+      (define x (make-parameter 444))
+      (define-property x spam "x-spam")
+      (define-property x frob "x-frob")
+      (printf "~s ~s ~s ~s\n"
+        (get-property x spam)
+        (get-property x frob)
+        (get-property x rats)
+        (x)))
+    #t)
+  (begin (define dp-f) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (set! dp-f
+          (eval
+            '(lambda (x)
+               (import (dp l1))
+               (printf "~s ~s ~s ~s\n"
+                 (get-property x spam)
+                 (get-property x frob)
+                 (get-property x rats)
+                 (qq)))))))
+    "\"x-spam\" \"x-frob\" #f 444\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (dp-f 0)))
+    "#f #f #f 77\n")
+  (begin
+    (module (dp-a)
+      (module (dp-a)
+        (define-syntax dp-a (identifier-syntax 3)))
+      (define-property dp-a spam 55))
+    (and (eqv? dp-a 3)
+         (eqv? (get-property dp-a spam) 55)))
+  (begin
+    (module (dp-b)
+      (module ((dp-b q))
+        (define q 3)
+        (define-syntax dp-b (identifier-syntax q)))
+      (define-property dp-b spam 55))
+    (and (eqv? dp-b 3)
+         (eqv? (get-property dp-b spam) 55)))
+  (let ()
+    (module (dp-c)
+      (module (dp-c)
+        (define-syntax dp-c (identifier-syntax 3)))
+      (define-property dp-c spam 55))
+    (and (eqv? dp-c 3)
+         (eqv? (get-property dp-c spam) 55)))
+  (let ()
+    (module (dp-c)
+      (module ((dp-c q))
+        (define q 3)
+        (define-syntax dp-c (identifier-syntax q)))
+      (define-property dp-c spam 55))
+    (and (eqv? dp-c 3)
+         (eqv? (get-property dp-c spam) 55)))
+  (begin
+    (library (dp l2) (export dp-d dp-e spam) (import (scheme))
+      (define spam)
+      (module (dp-d)
+        (module (dp-d)
+          (define-syntax dp-d (identifier-syntax 3)))
+        (define-property dp-d spam 55))
+      (module (dp-e)
+        (module ((dp-e q))
+          (define q 13)
+          (define-syntax dp-e (identifier-syntax q)))
+        (define-property dp-e spam 155)))
+    (let ()
+      (import (dp l2))
+      (and (eqv? dp-d 3)
+           (eqv? (get-property dp-d spam) 55)
+           (eqv? dp-e 13)
+           (eqv? (get-property dp-e spam) 155))))
+  (begin
+    (import (dp l2))
+    (and (eqv? dp-d 3)
+         (eqv? (get-property dp-d spam) 55)
+         (eqv? dp-e 13)
+         (eqv? (get-property dp-e spam) 155)))
+  (begin
+    (with-output-to-file "testfile-dp0.ss"
+      (lambda ()
+        (pretty-print '(define $dp0-x "dp0-x"))
+        (pretty-print '(define-property $dp0-x dp0 17)))
+      'replace)
+    (with-output-to-file "testfile-dp1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp1)
+             (export cons a b spud)
+             (import (scheme))
+             (define spud)
+             (define a "a")
+             (define b "b")
+             (define-property cons spud "spud-cons")
+             (define-property a spud "spud-a")
+             (define-property b spud "spud-b"))))
+      'replace)
+    (with-output-to-file "testfile-dp2.ss"
+      (lambda ()
+        (pretty-print
+          '(module dp2 (cons a b putz)
+             (import (scheme))
+             (define putz)
+             (define a "a")
+             (define b "b")
+             (define-property cons putz "putz-cons")
+             (define-property a putz "putz-a")
+             (define-property b putz "putz-b"))))
+      'replace)
+    (for-each separate-compile '(dp0 dp1 dp2))
+    #t)
+  (begin (load "testfile-dp0.so") #t)
+  (equal? $dp0-x "dp0-x")
+  (equal? (get-property $dp0-x dp0) 17)
+  (equal?
+    (let ()
+      (import (testfile-dp1))
+      (list (cons a b) (get-property cons spud) (get-property a spud) (get-property b spud)))
+    '(("a" . "b") "spud-cons" "spud-a" "spud-b"))
+  (begin (load "testfile-dp2.so") #t)
+  (equal?
+    (let ()
+      (import dp2)
+      (list (cons a b) (get-property cons putz) (get-property a putz) (get-property b putz)))
+    '(("a" . "b") "putz-cons" "putz-a" "putz-b"))
+ ; illustrate use of define-property for storing parent record info,
+ ; while still allowing the record name to be a variable whose value
+ ; is the record type descriptor
+  (equal?
+    (let ()
+      (module (drt)
+        (define drt-key)
+        (define-syntax drt
+          (lambda (x)
+            (define construct-name
+              (lambda (template-identifier . args)
+                (datum->syntax template-identifier
+                  (string->symbol
+                    (apply string-append
+                      (map (lambda (x)
+                             (if (string? x)
+                                 x
+                                 (symbol->string (syntax->datum x))))
+                           args))))))
+            (define do-drt
+              (lambda (rname fname* prtd)
+                (with-syntax ([rname rname]
+                              [rtd (make-record-type-descriptor
+                                     (syntax->datum rname) prtd #f #f #f
+                                     (list->vector (map (lambda (fname) `(immutable ,(syntax->datum fname))) fname*)))]
+                              [make-rname (construct-name rname "make-" rname)]
+                              [rname? (construct-name rname rname "?")]
+                              [(rname-fname ...)
+                               (map (lambda (fname) (construct-name fname rname "-" fname))
+                                    fname*)]
+                              [(i ...) (enumerate fname*)])
+                  #'(begin
+                      (define rname 'rtd)
+                      (define rcd (make-record-constructor-descriptor 'rtd #f #f))
+                      (define-property rname drt-key 'rtd)
+                      (define make-rname (record-constructor rcd))
+                      (define rname? (record-predicate 'rtd))
+                      (define rname-fname (record-accessor 'rtd i))
+                      ...))))
+            (syntax-case x (parent)
+              [(_ rname fname ...)
+               (for-all identifier? #'(rname fname ...))
+               (do-drt #'rname #'(fname ...) #f)]
+              [(_ rname (parent pname) fname ...)
+               (for-all identifier? #'(rname pname fname ...))
+               (lambda (r)
+                 (let ([prtd (r #'pname #'drt-key)])
+                   (unless prtd (syntax-error #'pname "unrecognized parent record typd"))
+                   (do-drt #'rname #'(fname ...) prtd)))]))))
+      (drt foo x y)
+      (drt bar (parent foo) z)
+      (let ([b (make-bar 1 2 3)])
+        (list
+          (record-type-descriptor? foo)
+          (record-type-descriptor? bar)
+          (foo? b) (bar? b)
+          (foo-x b)
+          (foo-y b)
+          (bar-z b))))
+    '(#t #t #t #t 1 2 3))
+ ; on no!
+  (equal?
+    (let ()
+      (define type-key)
+      (define-syntax declare
+        (syntax-rules ()
+          [(_ type id)
+           (identifier? #'id)
+           (define-property id type-key #'type)]))
+      (define-syntax type-of
+        (lambda (x)
+          (syntax-case x ()
+            [(_ id)
+             (identifier? #'id)
+             (lambda (r)
+               #`'#,(r #'id #'type-key))])))
+      (let ([x 3])
+        (define p (lambda (x) x))
+        (declare fixnum? x)
+        (declare procedure? p)
+        (list (type-of x) (type-of p))))
+    '(fixnum? procedure?))
+ ; make sure library is visited and invoked when needed by
+ ; top-level-xxx procedures, even when properties are defined
+  (begin
+    (with-output-to-file "testfile-dp3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp3) (export dp3-x frop) (import (chezscheme))
+             (define frop)
+             (define dp3-x 3)
+             (define-property dp3-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp3))
+    #t)
+  (begin (import (testfile-dp3)) #t)
+  (top-level-bound? 'dp3-x)
+  (equal? (get-property dp3-x frop) "blob")
+  (begin
+    (with-output-to-file "testfile-dp4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp4) (export dp4-x frop) (import (chezscheme))
+             (define frop)
+             (define dp4-x 3)
+             (define-property dp4-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp4))
+    #t)
+  (begin (import (testfile-dp4)) #t)
+  (eqv? (top-level-value 'dp4-x) 3)
+  (equal? (get-property dp4-x frop) "blob")
+  (begin
+    (with-output-to-file "testfile-dp5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp5) (export dp5-x frop) (import (chezscheme))
+             (define frop)
+             (define dp5-x 3)
+             (define-property dp5-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp5))
+    #t)
+  (begin (import (testfile-dp5)) #t)
+ ; same as last, but reverse order of checks
+  (equal? (get-property dp5-x frop) "blob")
+  (eqv? (top-level-value 'dp5-x) 3)
+  (begin
+    (with-output-to-file "testfile-dp6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp6) (export dp6-x frop) (import (chezscheme))
+             (define frop)
+             (define-syntax dp6-x (identifier-syntax 3))
+             (define-property dp6-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp6))
+    #t)
+  (begin (import (testfile-dp6)) #t)
+  (top-level-syntax? 'dp6-x)
+  (equal? (get-property dp6-x frop) "blob")
+  (begin
+    (with-output-to-file "testfile-dp7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp7) (export dp7-x frop) (import (chezscheme))
+             (define frop)
+             (define-syntax dp7-x (identifier-syntax 3))
+             (define-property dp7-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp7))
+    #t)
+  (begin (import (testfile-dp7)) #t)
+ ; same as last, but reverse order of checks
+  (equal? (get-property dp7-x frop) "blob")
+  (top-level-syntax? 'dp7-x)
+  (begin
+    (with-output-to-file "testfile-dp8.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp8) (export dp8-x frop) (import (chezscheme))
+             (define frop)
+             (define-syntax dp8-x (identifier-syntax 3))
+             (define-property dp8-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp8))
+    #t)
+  (begin (import (testfile-dp8)) #t)
+ ; same as last, but reverse order of checks
+  (procedure? (top-level-syntax 'dp8-x))
+  (equal? (get-property dp8-x frop) "blob")
+  (begin
+    (with-output-to-file "testfile-dp9.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp9) (export dp9-x frop) (import (chezscheme))
+             (define frop)
+             (define-syntax dp9-x (identifier-syntax 3))
+             (define-property dp9-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp9))
+    #t)
+  (begin (import (testfile-dp9)) #t)
+  (error? ; not a variable
+    (set-top-level-value! 'dp9-x 11))
+  (equal? (get-property dp9-x frop) "blob")
+  (begin
+    (with-output-to-file "testfile-dp10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp10) (export dp10-x frop) (import (chezscheme))
+             (define frop)
+             (define dp10-x 3)
+             (define-property dp10-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp10))
+    #t)
+  (begin (import (testfile-dp10)) #t)
+  (error? ; immutable
+    (set-top-level-value! 'dp10-x 11))
+  (equal? (get-property dp10-x frop) "blob")
+  (begin
+    (with-output-to-file "testfile-dp11.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp11) (export dp11-x frop) (import (chezscheme))
+             (define frop)
+             (define dp11-x 3)
+             (define-property dp11-x frop "blob"))))
+      'replace)
+    (for-each separate-compile '(dp11))
+    #t)
+  (begin (import (testfile-dp11)) #t)
+  (not (top-level-mutable? 'dp11-x))
+  (equal? (get-property dp11-x frop) "blob")
+  (equal?
+    (syntax-case '(a b c) ()
+      [(_ . x)
+       (let ()
+         (define-property x goofy 'stuff)
+         (define-property x amazingly 'unlikely)
+         (list (get-property x goofy)
+               (get-property x amazingly)
+               #'x))])
+    '(stuff unlikely (b c)))
+ (begin
+   (library (docstring)
+     (export define-docstring get-docstring)
+     (import (chezscheme))
+     (define check-docstring
+       (lambda (x s)
+         (unless (string? s)
+           (syntax-error x "invalid docstring definition"))
+         s))
+     (define-syntax define-docstring
+       (lambda (x)
+         (syntax-case x ()
+           [(_ id expr)
+            #`(define-property id check-docstring
+                (check-docstring #'#,x expr))])))
+     (define-syntax get-docstring
+       (lambda (x)
+         (lambda (r)
+           (syntax-case x ()
+             [(_ id)
+              (or (r #'id #'check-docstring) "no documentation available")])))))
+   #t)
+  (equal?
+    (let ()
+      (import (docstring))
+      (define-docstring cons "cons takes three arguments")
+      (get-docstring cons))
+    "cons takes three arguments")
+  (equal?
+    (let ()
+      (import (docstring))
+      (define-docstring else "else is cool")
+      (cond [else (get-docstring else)]))
+    "else is cool")
+  ((lambda (x ls) (and (member x ls) #t))
+   (parameterize ([#%$suppress-primitive-inlining #f])
+     (expand
+       '(let ()
+          (import scheme)
+          (define-property cons car 3)
+          cons)))
+   `(#%cons #2%cons #3%cons))
+  (begin
+    (define dp-x #f)
+    (define dp-y #f)
+    (define-property dp-x dp-y "xy")
+    (define-syntax a
+      (lambda (z)
+        (define-property dp-x z "xz")
+        #'(get-property dp-x dp-y)))
+    (equal? a "xy"))
+  (begin
+    (define dp-x #f)
+    (define dp-y #f)
+    (define-property dp-x dp-y "outer")
+    (define-syntax a
+      (lambda (z)
+        (define-property dp-x dp-y "inner")
+        #'(get-property dp-x dp-y)))
+    (not a))
+  (equal?
+    (let ([x #f] [y #f])
+      (define-property x y "xy")
+      (define-syntax a
+        (lambda (z)
+          (define-property x z "xz")
+          #'(get-property x y)))
+      a)
+    "xy")
+  (eq?
+    (let ([x #f] [y #f])
+      (define-property x y "outer")
+      (define-syntax a
+        (lambda (z)
+          (define-property x y "inner")
+          #'(get-property x y)))
+      a)
+    #f)
+  (eq?
+    (let ([x #f])
+      (define-syntax a
+        (syntax-rules (x)
+          [(_ x) 'yes]
+          [(_ y) 'no]))
+      (let ()
+        (define-property x q 0)
+        (a x)))
+    'yes)
+  (begin
+    (library (dp l3) (export x)
+      (import (chezscheme))
+      (define x 5)
+      (define-property x car 17))
+    (import (dp l3))
+    (and (eqv? x 5) (eqv? (let () (import (chezscheme)) (get-property x car)) 17)))
+  (begin
+    (library (dp l4) (export sort)
+      (import (chezscheme))
+      (define-property sort car 53))
+    (library (dp l5) (export sort)
+      (import (chezscheme))
+      (define-property sort cdr 87))
+    (import (dp l4))
+    (import (dp l5))
+    (and (procedure? sort)
+         (eq? sort #%sort)
+         (eqv? (let () (import (only (chezscheme) car)) (get-property sort car)) 53)
+         (eqv? (let () (import (only (chezscheme) cdr)) (get-property sort cdr)) 87)))
+  (begin
+    (with-output-to-file "testfile-dp12.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-dp12) (export dp12-dq) (import (chezscheme))
+             (define-syntax dp12-dq (identifier-syntax "dq"))
+             (define-property dp12-dq car "dqp"))))
+      'replace)
+    (for-each separate-compile '(dp12))
+    #t)
+  (begin (import (testfile-dp12)) #t)
+  (equal? (list dp12-dq (let () (import (chezscheme)) (get-property dp12-dq car))) '("dq" "dqp"))
+  (equal?
+    (let ()
+      (define x 0)
+      (module m1 (x) (define-property x car "xcar"))
+      (module m2 (x) (define-property x cdr "xcdr"))
+      (let ([q1 (let () (import m1) (list x (get-property x car) (get-property x cdr)))]
+            [q2 (let () (import m2) (list x (get-property x car) (get-property x cdr)))]
+            [q3 (let () (import m1) (import m2) (list x (get-property x car) (get-property x cdr)))]
+            [q4 (let () (import m2) (import m1) (list x (get-property x car) (get-property x cdr)))])
+        (list x q1 q2 q3 q4 (get-property x car) (get-property x cdr))))
+    '(0 (0 "xcar" #f) (0 #f "xcdr") (0 "xcar" "xcdr") (0 "xcar" "xcdr") #f #f))
+  (equal?
+    (let ()
+      (define x 0)
+      (module m1 (x) (define-property x car "xcar"))
+      (import m1)
+      (module m2 (x) (define-property x cdr "xcdr"))
+      (import m2)
+      (list x (get-property x car) (get-property x cdr)))
+    '(0 "xcar" "xcdr"))
+  (begin
+    (module $dp13 (foo)
+      (define foo 17)
+      (module ((foo bar))
+        (define-property foo cons #'bar)
+        (define bar 35)))
+    #t)
+  (eqv?
+    (let ()
+      (import $dp13)
+      (define-syntax a
+        (lambda (x)
+          (lambda (r)
+            (syntax-case x ()
+              [(_ id) (r #'id #'cons)]))))
+      (a foo))
+    35)
+  (eqv?
+    (let ()
+      (module m (x) (define x 3) (define-property x x 4))
+      (import m)
+      (get-property x x))
+    4)
+  (eqv?
+    (let ()
+      (module m (x) (define x 3) (define-property x x 4))
+      (import (alias m (x y)))
+      (get-property x x))
+    4)
+  (eqv?
+    (let ()
+      (module m (x) (define x 3) (define-property x x 4))
+      (import (alias m (x y)))
+      (get-property x y))
+    4)
+  (eqv?
+    (let ()
+      (module m (x) (define x 3) (define-property x x 4))
+      (import (alias m (x y)))
+      (get-property y x))
+    4)
+  (eqv?
+    (let ()
+      (module m (x) (define x 3) (define-property x x 4))
+      (import (alias m (x y)))
+      (get-property y y))
+    4)
+  (eqv?
+    (let ()
+      (module m (x) (define x 3) (define-property x x 4))
+      (import (rename m (x y)))
+      (get-property y y))
+    4)
+  (begin
+    (module $dp14 (x) (define x 3) (define-property x x 4))
+    #t)
+  (eqv?
+    (let ()
+      (import $dp14)
+      (get-property x x))
+    4)
+  (eqv?
+    (let ()
+      (import (alias $dp14 (x y)))
+      (get-property x x))
+    4)
+  (eqv?
+    (let ()
+      (import (alias $dp14 (x y)))
+      (get-property x y))
+    4)
+  (eqv?
+    (let ()
+      (import (alias $dp14 (x y)))
+      (get-property y x))
+    4)
+  (eqv?
+    (let ()
+      (import (alias $dp14 (x y)))
+      (get-property y y))
+    4)
+  (eqv?
+    (let ()
+      (import (rename $dp14 (x y)))
+      (get-property y y))
+    4)
+  (equal?
+    (let ([y 14])
+      (define k1)
+      (define k2)
+      (module ()
+        (export x (rename (y x)))
+        (define x 3)
+        (define-property x k1 4)
+        (define-property x k2 5)
+        (alias y x))
+      (list x y (get-property x k1) (get-property x k2) (get-property y k1) (get-property y k2)))
+    '(3 14 4 5 #f #f))
+  (error? ; attempt to export different bindings for x
+    (let ([y 14])
+      (define k1)
+      (define k2)
+      (module ()
+        (export x (rename (y x)))
+        (define x 3)
+        (define-property x k1 4)
+        (alias y x)
+        (define-property x k2 5))
+      (list x y (get-property x k1) (get-property y k2))))
+  (begin
+    (with-output-to-file "testfile-A.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-A)
+             (export $testfile-A-x $testfile-A-prop-id)
+             (import (scheme))
+             (define $testfile-A-x (cons 'a 'b))
+             (define $testfile-A-prop-id)
+             (define-property $testfile-A-x $testfile-A-prop-id (cons 'c 'd)))))
+      'replace)
+    (with-output-to-file "testfile-B.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-B)
+             (export)
+             (import (scheme) (testfile-A))
+             (export (import (testfile-A))))))
+      'replace)
+    (with-output-to-file "testfile-C.ss"
+      (lambda ()
+        (pretty-print 
+          '(library (testfile-C)
+             (export)
+             (import (scheme) (testfile-A) (testfile-B))
+             (export (import (testfile-A)) (import (testfile-B))))))
+      'replace)
+    (for-each separate-compile '(A B C))
+    #t)
+  (equal? 
+    (let ()
+      (import (testfile-C))
+      (list $testfile-A-x (get-property $testfile-A-x $testfile-A-prop-id)))
+    '((a . b) (c . d)))
+)
+
+(mat library1
+  (error? (compile-library "/file/not/there"))
+  (error? (load-library "/file/not/there"))
+  (error? ; abc is not a string
+    (load-library 'abc))
+  (error? ; xxx is not a procedure
+    (load-library "/file/not/there" 'xxx))
+  (error? ; 3 is not a string
+    (parameterize ([source-directories '("/tmp" ".")]) (load-library 3)))
+  (error? ; 3 is not a string
+    (parameterize ([source-directories '("/tmp" ".")]) (load-library 3 values)))
+  (begin
+    (library ($l1-a) (export $l1-x) (import (scheme))
+      (module $l1-x (($l1-a $l1-b) $l1-c $l1-e)
+        (define $l1-d 4)
+        (define-syntax $l1-a (identifier-syntax (cons $l1-b $l1-y)))
+        (define $l1-b 55)
+        (define $l1-c (lambda () (* $l1-d $l1-y)))
+        (define $l1-f 44)
+        (define-syntax $l1-e (identifier-syntax $l1-f)))
+      (define $l1-y 14))
+    #t)
+  (equal?
+    (let () (import ($l1-a)) (import $l1-x) (list $l1-a ($l1-c)))
+    '((55 . 14) 56))
+  (begin
+    (import ($l1-a))
+    #t)
+  (begin
+    (import $l1-x)
+    #t)
+  (equal? $l1-a '(55 . 14))
+  (equal? ($l1-c) 56)
+  (error? ; unbound variable $l1-b
+    $l1-b)
+  (error? ; unbound variable $l1-d
+    $l1-d)
+  (error? ; unbound variable $l1-y
+    $l1-y)
+  (error? ; unexported identifier $l1-f
+    $l1-e)
+  (error? ; unbound variable $l1-f
+    $l1-f)
+  (equal?
+    (let () (import ($l1-a)) (import $l1-x) (list $l1-a ($l1-c)))
+    '((55 . 14) 56))
+  (begin
+    (library ($l1-b) (export $l1-x) (import (scheme))
+      (module $l1-x ($l1-a $l1-c $l1-e)
+        (define $l1-d 4)
+        (define $l1-a (lambda () (cons $l1-b $l1-y)))
+        (define $l1-b 55)
+        (define $l1-c (lambda () (* $l1-d $l1-y)))
+        (define $l1-f 44)
+        (define $l1-e (lambda () $l1-f)))
+      (define $l1-y 14))
+    #t)
+  (equal?
+    (let () (import ($l1-b)) (import $l1-x) (vector ($l1-a) ($l1-c) ($l1-e)))
+    '#((55 . 14) 56 44))
+  (begin
+    (import ($l1-b))
+    #t)
+  (begin
+    (import $l1-x)
+    #t)
+  (equal? ($l1-a) '(55 . 14))
+  (equal? ($l1-c) 56)
+  (equal? ($l1-e) 44)
+  (error? ; unbound variable $l1-b
+    $l1-b)
+  (error? ; unbound variable $l1-d
+    $l1-d)
+  (error? ; unbound variable $l1-y
+    $l1-y)
+  (error? ; unbound variable $l1-f
+    $l1-f)
+  (equal?
+    (let () (import ($l1-b)) (import $l1-x) (vector ($l1-a) ($l1-c) ($l1-e)))
+    '#((55 . 14) 56 44))
+  (begin
+    (library ($l1-c) (export (rename (q $l1-q) (a:x $l1-x)) $l1-p)
+      (import (scheme) (rename ($l1-a) ($l1-x a:x)) (rename ($l1-b) ($l1-x b:x)))
+      (import (drop-prefix a:x $l1-) (prefix (drop-prefix b:x $l1-) b:))
+      (define-syntax q (identifier-syntax (list a (c) (b:a) (b:c) ($l1-p) (r))))
+      (define $l1-p (lambda () (vector a (c) (b:a) (b:c))))
+      (define r (lambda () (cons* a (c) (b:a) (b:c)))))
+    #t)
+  (equal?
+    (let () (import ($l1-c)) $l1-q)
+    '((55 . 14) 56 (55 . 14) 56
+      #4((55 . 14) 56 (55 . 14) 56)
+      ((55 . 14) 56 (55 . 14) . 56)))
+  (equal?
+    (let () (import ($l1-c) ($l1-a)) (import $l1-x) (list $l1-a $l1-q))
+    '((55 . 14)
+      ((55 . 14) 56 (55 . 14) 56
+       #4((55 . 14) 56 (55 . 14) 56)
+       ((55 . 14) 56 (55 . 14) . 56))))
+
+  (begin
+    (library ($l1-d) (export $l1-x $l1-getx $l1-setx!) (import (scheme))
+      (define x 0)
+      (define-syntax $l1-x (identifier-syntax x))
+      (define $l1-getx (lambda () x))
+      (define $l1-setx! (lambda (v) (set! x v))))
+    #t)
+  (eqv?
+    (let () (import ($l1-d)) ($l1-setx! 'hello) ($l1-getx))
+    'hello)
+  (error? ; unexported identifier x
+    (let () (import ($l1-d)) $l1-x))
+  (error? ; unexported identifier x
+    (expand '(let () (import ($l1-d)) $l1-x)))
+  (error? ; immutable variable $l1-x
+    (let () (import ($l1-d)) (set! $l1-getx void)))
+  (error? ; immutable variable $l1-x
+    (expand '(let () (import ($l1-d)) (set! $l1-getx void))))
+  (begin
+    (import ($l1-d))
+    #t)
+  (eqv?
+    (begin ($l1-setx! 'hello) ($l1-getx))
+    'hello)
+  (error? ; unexported identifier x
+    $l1-x)
+  (error? ; unexported identifier x
+    (expand '$l1-x))
+  (error? ; immutable variable $l1-x
+    (set! $l1-getx void))
+  (error? ; immutable variable $l1-x
+    (expand '(set! $l1-getx void)))
+
+  (error?
+    (library ($l1-e) (export $l1-x) (import (scheme))
+      (define $l1-x 0)
+      (set! $l1-x 1)))
+  (error?
+    (expand
+      '(library ($l1-e) (export $l1-x) (import (scheme))
+         (define $l1-x 0)
+         (set! $l1-x 1))))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(library ($l1-f) (export $l1-x $l1-y) (import (scheme))
+             (define-syntax $l1-x (identifier-syntax q))
+             (define-syntax q
+               (begin
+                 (printf "An expand-time greeting from $l1-f\n")
+                 (lambda (x) 77)))
+             (define $l1-y (lambda () (* q 2)))
+             (printf "A run-time greeting from $l1-f\n")))
+        (pretty-print
+          '(library ($l1-g) (export $l1-x $l1-z $l1-w) (import (scheme) ($l1-f))
+             (define-syntax $l1-z
+               (begin
+                 (printf "An expand-time greeting from $l1-g\n")
+                 (lambda (x) ($l1-y))))
+             (define $l1-w
+               (begin
+                 (printf "A run-time greeting from $l1-g\n")
+                 (lambda (x) (cons* x $l1-x ($l1-y)))))))
+        (pretty-print
+          '(library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme) ($l1-f) ($l1-g))
+             (define $l1-v (list $l1-x ($l1-y) $l1-z ($l1-w 13)))
+             (printf "A run-time greeting from $l1-h\n"))))
+      'replace)
+    (compile-file "testfile")
+    #t)
+ ; look, ma, no need to load...
+  (equal?
+    (let () (import ($l1-h)) $l1-v)
+    '(77 154 154 (13 77 . 154)))
+  (begin
+    (library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme))
+      (define $l1-x "these aren't")
+      (define $l1-y "the exports")
+      (define $l1-v "you're looking for"))
+    #t)
+  (begin (load "testfile.so") #t)
+  (equal?
+    (let () (import ($l1-h)) $l1-v)
+    '(77 154 154 (13 77 . 154)))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(library ($l1-f) (export $l1-x $l1-y) (import (scheme))
+             (define-syntax $l1-x (identifier-syntax q))
+             (define-syntax q
+               (begin
+                 (printf "An expand-time greeting from $l1-f\n")
+                 (lambda (x) 77)))
+             (define $l1-y (lambda () (* q 2)))
+             (printf "A run-time greeting from $l1-f\n")))
+        (pretty-print
+          '(library ($l1-g) (export $l1-x $l1-z $l1-w) (import (scheme) ($l1-f))
+             (define-syntax $l1-z
+               (begin
+                 (printf "An expand-time greeting from $l1-g\n")
+                 (lambda (x) ($l1-y))))
+             (define $l1-w
+               (begin
+                 (printf "A run-time greeting from $l1-g\n")
+                 (lambda (x) (cons* x $l1-z $l1-x ($l1-y)))))))
+        (pretty-print
+          '(library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme) ($l1-f) ($l1-g))
+             (define $l1-v (list $l1-x ($l1-y) $l1-z ($l1-w 13)))
+             (printf "A run-time greeting from $l1-h\n"))))
+      'replace)
+    (compile-file "testfile")
+    #t)
+ ; look, ma, no need to load...
+  (equal?
+    (let () (import ($l1-h)) $l1-v)
+    '(77 154 154 (13 154 77 . 154)))
+  (begin
+    (library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme))
+      (define $l1-x "these aren't")
+      (define $l1-y "the exports")
+      (define $l1-v "you're looking for"))
+    #t)
+  (begin (load "testfile.so") #t)
+  (equal?
+    (let () (import ($l1-h)) $l1-v)
+    '(77 154 154 (13 154 77 . 154)))
+
+  (error? ; unknown library ($l1-ham)
+    (begin
+      (library ($l1-spam) (export) (import ($l1-ham)))
+      (library ($l1-ham) (export) (import ($l1-spam)))))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(library ($l1-i) (export $l1-x $l1-y) (import (scheme))
+             (define $l1-x 'i-am-x)
+             (define-syntax $l1-y (identifier-syntax 'i-am-y))))
+        (pretty-print
+          '(library ($l1-j) (export $l1-x $l1-y)
+             (import ($l1-i) (only (scheme) errorf))
+             (errorf #f "this error shouldn't happen")))
+        (pretty-print
+          '(library ($l1-k) (export $l1-z) (import (scheme) ($l1-j))
+             (define $l1-z (list 'i-am-z $l1-x $l1-y)))))
+      'replace)
+    (compile-file "testfile")
+    #t)
+  (equal?
+    (let () (import ($l1-k)) $l1-z)
+    '(i-am-z i-am-x i-am-y))
+  (begin (load "testfile.so") #t)
+  (equal?
+    (let () (import ($l1-k)) $l1-z)
+    '(i-am-z i-am-x i-am-y))
+
+  (begin
+    (library ($l1-l) (export $l1-x) (import (scheme))
+      (define $l1-x 'i-am-$l1-l.$l1-x))
+    #t)
+  (eq?
+    (let ()
+      (import ($l1-l))
+      (define-syntax a (lambda (x) #`'#,(datum->syntax #'* $l1-x)))
+      a)
+    'i-am-$l1-l.$l1-x)
+
+  (begin
+    (with-output-to-file "testfile-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a1)
+             (export $l1-a)
+             (import (scheme))
+             (define $l1-a 'a1))))
+      'replace)
+    (with-output-to-file "testfile-b1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b1)
+             (export $l1-a $l1-b)
+             (import (scheme) (testfile-a1))
+             (define $l1-b 'b1))))
+      'replace)
+    (with-output-to-file "testfile-c1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-c1)
+             (export $l1-a $l1-b $l1-c)
+             (import (scheme) (testfile-b1))
+             (define ($l1-c) (list $l1-a $l1-b 'c1)))))
+      'replace)
+    (with-output-to-file "testfile-d1.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-b1)))
+        (pretty-print '(define ($l1-d) (list $l1-a $l1-b 'd1))))
+      'replace)
+    (with-output-to-file "testfile-e1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-e1)
+             (export $l1-e)
+             (import (scheme) (testfile-b1))
+             (alias $l1-e $l1-a))))
+      'replace)
+    (with-output-to-file "testfile-f1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-f1)
+             (export $l1-f)
+             (import (scheme))
+             (define-syntax $l1-f (identifier-syntax "macro-f")))))
+      'replace)
+    (with-output-to-file "testfile-g1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-g1)
+             (export $l1-f)
+             (import (scheme) (testfile-f1)))))
+      'replace)
+    (with-output-to-file "testfile-h1.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-g1)))
+        (pretty-print '(define ($l1-h) (list $l1-f))))
+      'replace)
+    (for-each separate-compile '(a1 b1 c1 d1 e1 f1 g1 h1))
+    #t)
+  (equal? (begin (load "testfile-d1.so") ($l1-d)) '(a1 b1 d1))
+  (begin (import (testfile-c1)) #t)
+  (equal? ($l1-c) '(a1 b1 c1))
+  (begin (import (testfile-e1)) #t)
+  (equal? $l1-e 'a1)
+  (equal? (begin (load "testfile-h1.so") ($l1-h)) '("macro-f"))
+
+  (begin
+    (with-output-to-file "testfile-a2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a2)
+             (export $l1-a)
+             (import (scheme))
+             (define $l1-a 'a2))))
+      'replace)
+    (with-output-to-file "testfile-b2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b2)
+             (export $l1-a $l1-b)
+             (import (scheme) (testfile-a2))
+             (define $l1-b 'b2))))
+      'replace)
+    (with-output-to-file "testfile-c2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-c2)
+             (export $l1-a $l1-b $l1-c)
+             (import (scheme) (testfile-b2))
+             (define ($l1-c) (list $l1-a $l1-b 'c2)))))
+      'replace)
+    (with-output-to-file "testfile-d2.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-b2)))
+        (pretty-print '(define ($l1-d) (list $l1-a $l1-b 'd2))))
+      'replace)
+    (for-each separate-compile '(a2 b2 c2 d2 a2))
+    #t)
+  (error? ; expected different compilation instance
+          ; program complains about b2 rather than b2 about a2
+          ;   now that load-library reloads source when dependency changes
+          ;   would be nice if program were reloaded from source as well
+    (load "testfile-d2.so"))
+  ; no longer fails now that load-library reloads source when dependency changes
+  #;(error? ; expected different compilation instance
+    (import (testfile-c2)))
+  (begin
+    (library ($l1-m) (export $l1-x) (import (scheme)) (define $l1-x 333))
+    (library ($l1-n) (export $l1-x) (import (scheme)) (import ($l1-m)))
+    #t)
+  (eqv?
+    (let () (import ($l1-n)) $l1-x)
+    333)
+  (begin
+    (define-syntax $from1
+      (syntax-rules ()
+        ((_ m id)
+         (let () (import-only m) id))))
+    (define-syntax $from2
+      (syntax-rules ()
+        ((_ m id)
+         (let () (module (id) (import m)) id))))
+    (define-syntax $from3
+      (syntax-rules ()
+        [(_ m id)
+         (let ([z (cons 1 2)])
+           (let ([id z])
+             (import m)
+             (let ([t id])
+               (if (eq? t z) (errorf 'from "~s undefined" 'id) t))))]))
+    (library ($frappe) (export wire whip) (import (scheme))
+      (define wire 3)
+      (define-syntax whip (identifier-syntax egg))
+      (define egg 'whites))
+    (equal?
+      (list (cons ($from1 ($frappe) wire) ($from1 ($frappe) whip))
+            (cons ($from2 ($frappe) wire) ($from2 ($frappe) whip))
+            (cons ($from3 ($frappe) wire) ($from3 ($frappe) whip)))
+      '((3 . whites) (3 . whites) (3 . whites))))
+  (begin
+    (library ($q) (export m from) (import (scheme))
+      (module m (f) (define f "this is f"))
+      (define-syntax from
+        (syntax-rules () [(_ m id) (let () (import-only m) id)])))
+    (equal? (let () (import-only ($q)) (from m f)) "this is f"))
+  (begin
+    (library ($p) (export d f) (import (scheme))
+      (define-syntax d
+        (syntax-rules ()
+          ((_ e) (m (lambda () e)))))
+      (define m (lambda (x) x))
+      (define f (lambda (th) (th))))
+    (eqv? (let () (import-only ($p)) (f (d 2))) 2))
+ ; this works for libraries because m is implicitly exported
+  (eqv? (let () (import-only ($p)) (f (d 1/3))) 1/3)
+  (error? ; cons undefined
+    (let () (import-only ($p)) (f (d cons))))
+  (error? ; invalid syntax
+    (library (a) (export x:eval) (import (add-prefix (rnrs eval) x))))
+  (error? ; invalid syntax
+    (library (a) (export val) (import (drop-prefix (rnrs eval) x))))
+  (error? ; invalid syntax
+    (library (a) (export meaning) (import (alias (rnrs eval) [eval meaning]))))
+  (begin
+    (define $l1-q1)
+    (define $l1-q2)
+    (define-syntax $l1-qlib
+      (syntax-rules ()
+        [(_ name (export ex ...) (import im ...) body ...)
+         (begin
+           (library name (export ex ... q)
+             (import im ... (rename (only (rnrs) cons) (cons list)))
+             (define q list) body ...)
+           (let () (import name) (set! $l1-q1 q)))]))
+    ($l1-qlib ($l1-libfoo) (export q) (import (rnrs)) (define q list))
+    (let () (import ($l1-libfoo)) (set! $l1-q2 q))
+    (equal? (list $l1-q1 $l1-q2) (list cons list)))
+ ; check for existence of chezscheme library
+  (begin
+    (library ($l1-r1) (export $l1-x) (import (chezscheme))
+      (define $l1-x (sort < '(1 3 2 0 5))))
+    (library ($l1-r2) (export $l1-y) (import (chezscheme) ($l1-r1))
+      (define $l1-y (cons $l1-x (void))))
+    (equal? (let () (import ($l1-r2)) $l1-y) `((0 1 2 3 5) . ,(void))))
+  (error? ; invalid context for library form
+    (module (a) (library (a) (export) (import))))
+  (error? ; invalid syntax for library form
+    (module (a) (library a (import) (export x) (define x 3)) (import a) x))
+  (error? ; invalid context for top-level-program form
+    (module (a) (top-level-program (import))))
+  (error? ; invalid syntax for top-level-program form
+    (module (a) (top-level-program (display "hello"))))
+  (error? ; invalid context for library form
+    (lambda () (library (a) (export) (import))))
+  (error? ; invalid syntax for library form
+    (lambda () (library a (import) (export x) (define x 3)) (import a) x))
+  (error? ; invalid context for top-level-program form
+    (lambda () (top-level-program (import))))
+  (error? ; invalid syntax for top-level-program form
+    (lambda () (top-level-program (display "hello"))))
+  (error? ; defnie not defined
+    (library ($l1-s) (export y) (import (rnrs)) (defnie x 3) (define y 4)))
+
+  (begin
+    (library ($l1-s)
+      (export m)
+      (import (chezscheme))
+      (module m (x set-x!)
+        (define x 0)
+        (define set-x! (lambda () (set! x 1)))))
+    #t)
+  (error? ; attempt to reference assigned hence unexported
+    (let () (import ($l1-s)) (import m) x))
+  (error? ; attempt to reference assigned hence unexported
+    (let () (import ($l1-s)) (import m) (set! x 2)))
+  (error? ; invalid version
+    (let () (import-only (chezscheme csv7 (6))) record-field-mutator))
+  (equal?
+    (let () (import-only (chezscheme csv7)) record-field-mutator)
+    csv7:record-field-mutator)
+
+ ; test macros generating libraries
+  (begin
+    (let-syntax ([make-A (syntax-rules ()
+                           [(_) (library (A)
+                                  (export $library-x)
+                                  (import (chezscheme))
+                                  (define $library-x 3))])])
+      (make-A))
+    #t)
+  (error? ; out-of-context library reference (A)
+    (equal? (let () (import (A)) $library-x) 3))
+  (begin
+    (let-syntax ([make-A (lambda (x)
+                           (syntax-case x ()
+                             [(k) (with-implicit (k A)
+                                    #'(library (A)
+                                        (export $library-x)
+                                        (import (chezscheme))
+                                        (define $library-x 3)))]))])
+      (make-A))
+    #t)
+  (error? ; unbound $library-x
+    (equal? (let () (import (A)) $library-x) 3))
+  (begin
+    (let-syntax ([make-A (lambda (x)
+                           (syntax-case x ()
+                             [(k id ...)
+                              (with-implicit (k A)
+                                #'(library (A)
+                                    (export id ...)
+                                    (import (chezscheme))
+                                    (define id 3)
+                                    ...))]))])
+      (make-A $library-x))
+    #t)
+  (eqv? (let () (import (A)) $library-x) 3)
+  (let-syntax ([make-A (syntax-rules ()
+                         [(_) (begin
+                                (library (A)
+                                  (export x)
+                                  (import (chezscheme))
+                                  (define x 3))
+                                (let () (import (A))
+                                  (eqv? x 3)))])])
+    (make-A))
+  (let-syntax ([make-A (syntax-rules ()
+                         [(_) (begin
+                                (library (A)
+                                  (export x)
+                                  (import (chezscheme))
+                                  (define x 3))
+                                (define-syntax q
+                                  (syntax-rules ()
+                                    [(_) (let ()
+                                           (import (A))
+                                           x)]))
+                                (eqv? (q) 3))])])
+    (make-A))
+
+  (begin
+    (with-output-to-file "testfile-a14.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a14) (export f) (import (chezscheme))
+             (define f (lambda (n) (if (fx= n 0) 1 (fx* n (f (fx- n 1))))))
+             (printf "invoked a\n"))))
+      'replace)
+    (with-output-to-file "testfile-b14.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b14) (export g) (import (chezscheme) (testfile-a14))
+             (define g (lambda (n) (f n)))
+             (printf "invoked b\n"))))
+      'replace)
+    (with-output-to-file "testfile-c14.ss"
+      (lambda ()
+        (pretty-print '(import (chezscheme) (testfile-b14)))
+        (pretty-print '(pretty-print (g 10))))
+      'replace)
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile-c14.ss")))
+    "invoked a\ninvoked b\n3628800\n")
+  ; test for proper propagation and non-propagation of constants across library boundaries
+  (begin
+    (with-output-to-file "testfile-a15.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a15) (export a b c d e f g fa fb fc fd fe ff fg)
+             (import (chezscheme))
+             (define-record-type foo (nongenerative) (fields x))
+             (define a '())
+             (define b 'sym)
+             (define c 3/4)
+             (define d '(x . y))
+             (define e (record-type-descriptor foo))
+             (define f (make-foo 3))
+             (define g "hello!")
+             (define fa (lambda () a))
+             (define fb (lambda () b))
+             (define fc (lambda () c))
+             (define fd (lambda () d))
+             (define fe (lambda () e))
+             (define ff (lambda () f))
+             (define fg (lambda () g)))))
+      'replace)
+    (with-output-to-file "testfile-b15.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b15) (export a b c d e f g fa fb fc fd fe ff fg)
+             (import (chezscheme) (prefix (testfile-a15) %))
+             (define a %a)
+             (define b %b)
+             (define c %c)
+             (define d %d)
+             (define e %e)
+             (define f %f)
+             (define g %g)
+             (define fa (lambda () (%fa)))
+             (define fb (lambda () (%fb)))
+             (define fc (lambda () (%fc)))
+             (define fd (lambda () (%fd)))
+             (define fe (lambda () (%fe)))
+             (define ff (lambda () (%ff)))
+             (define fg (lambda () (%fg))))))
+      'replace)
+    (with-output-to-file "testfile-c15.ss"
+      (lambda ()
+        (pretty-print '(define $c15-ls1
+                         (let ()
+                           (import (testfile-a15))
+                           (list a b c d e f g (fa) (fb) (fc) (fd) (fe) (ff) (fg)))))
+        (pretty-print '(define $c15-ls2
+                         (let ()
+                           (import (testfile-b15))
+                           (list a b c d e f g (fa) (fb) (fc) (fd) (fe) (ff) (fg)))))
+        (pretty-print '(pretty-print (map eq? $c15-ls1 $c15-ls2)))
+        (pretty-print '(pretty-print (map eqv? $c15-ls1 $c15-ls2)))
+        (pretty-print '(pretty-print (map equal? $c15-ls1 $c15-ls2))))
+      'replace)
+    (for-each separate-compile '(a15 b15 c15))
+    #t)
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda () (load "testfile-c15.so")))
+    '("(#t #t #f #t #t #t #t #t #t #f #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n"
+      "(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n"))
+  (begin
+    (library ($l3) (export f) (import (chezscheme)) (define (f x) x))
+    #t)
+  (equal?
+    (let () (import ($l3)) (f (f 3)))
+    3)
+  (begin
+    ;; (export import-spec ...) empty case
+    (library ($empty) (export) (import (chezscheme)) (export (import)))
+    #t)
+  (begin
+    (library ($l4-A) (export a) (import (chezscheme)) (define a 1))
+    (library ($l4-B) (export b) (import (chezscheme)) (define b 2))
+    #t)
+  (equal? '(1 2) (let () (import ($l4-A) ($l4-B)) (list a b)))
+  (begin
+    ;; (export import-spec ...) multiple imports case
+    (library ($l4-C) (export) (import (chezscheme)) (export (import ($l4-A) ($l4-B))))
+    (equal? '(1 2) (let () (import ($l4-C)) (list a b))))
+ )
+
+(mat library2
+  ; test to make sure that libraries needed by the transformers of local
+  ; macros are invoked immediately and not required as run-time requirements.
+  (begin
+    (with-output-to-file "testfile-a3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a3) (export q) (import (rnrs) (only (scheme) putprop)) (define q 3) (putprop 'testfile-a3 'invoke #t))))
+      'replace)
+    (with-output-to-file "testfile-b3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b3) (export x) (import (testfile-a3) (rnrs) (only (scheme) putprop))
+             (define x (let () (define-syntax p (lambda (x) (putprop 'testfile-b3 'visit #t) q)) p)))))
+      'replace)
+    (for-each separate-compile '(a3 b3))
+    #t)
+  (equal?
+    (let ()
+      (import (testfile-b3))
+      (list x (getprop 'testfile-a3 'invoke #f) (getprop 'testfile-b3 'visit #f)))
+    '(3 #f #f))
+  (begin
+    (with-output-to-file "testfile-a4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a4) (export q) (import (rnrs) (only (scheme) putprop))
+             (define q (lambda (x) (if (= x 0) 1 (* x (q (- x 1))))))
+             (putprop 'testfile-a4 'invoke #t))))
+      'replace)
+    (with-output-to-file "testfile-b4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b4) (export x) (import (testfile-a4) (rnrs) (only (scheme) putprop))
+             (define x (let () (define-syntax p (lambda (x) (putprop 'testfile-b4 'visit #t) (q 3))) (list p (q 4)))))))
+      'replace)
+    (for-each separate-compile '(a4 b4))
+    #t)
+  (equal?
+    (let ()
+      (import (testfile-b4))
+      (list x (getprop 'testfile-a4 'invoke #f) (getprop 'testfile-b4 'visit #f)))
+    '((6 24) #t #f))
+  (begin
+    (with-output-to-file "testfile-a5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a5) (export q) (import (rnrs) (only (scheme) putprop)) (define q 3) (putprop 'testfile-a5 'invoke #t))))
+      'replace)
+    (with-output-to-file "testfile-b5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b5) (export x) (import (testfile-a5) (rnrs) (only (scheme) putprop))
+             (define x (let-syntax ([p (lambda (x) (putprop 'testfile-b5 'visit #t) q)]) p)))))
+      'replace)
+    (for-each separate-compile '(a5 b5))
+    #t)
+  (equal?
+    (let ()
+      (import (testfile-b5))
+      (list x (getprop 'testfile-a5 'invoke #f) (getprop 'testfile-b5 'visit #f)))
+    '(3 #f #f))
+  (begin
+    (with-output-to-file "testfile-a6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a6) (export q) (import (rnrs) (only (scheme) putprop)) (define q 3) (putprop 'testfile-a6 'invoke #t))))
+      'replace)
+    (with-output-to-file "testfile-b6.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b6) (export x) (import (testfile-a6) (rnrs) (only (scheme) putprop))
+             (let-syntax ([p (lambda (x) (putprop 'testfile-b6 'visit #t) q)]) (define x p)))))
+      'replace)
+    (for-each separate-compile '(a6 b6))
+    #t)
+  (equal?
+    (let ()
+      (import (testfile-b6))
+      (list x (getprop 'testfile-a6 'invoke #f) (getprop 'testfile-b6 'visit #f)))
+    '(3 #f #f))
+
+ ; test cyclic dependency check
+ ; this mat and next four are connected
+  (begin
+    (with-output-to-file "testfile-a7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a7) (export x) (import (rnrs) (testfile-b7)) (define x y))))
+      'replace)
+    (with-output-to-file "testfile-b7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b7) (export y) (import (rnrs) (testfile-a7)) (define y x))))
+      'replace)
+    #t)
+  (error? ; possible cyclic dependency
+    (let () (import (testfile-a7) (testfile-b7)) (list x y)))
+  (error? ; possible cyclic dependency
+    (let () (import (testfile-b7) (testfile-a7)) (list x y)))
+ ; make sure errors didn't leave libraries in a state where they can't be redefined
+  (begin
+    (with-output-to-file "testfile-a7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a7) (export x) (import (rnrs) (testfile-b7)) (define x y))))
+      'replace)
+    (with-output-to-file "testfile-b7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b7) (export y) (import (rnrs)) (define y 17))))
+      'replace)
+    #t)
+  (equal?
+    (let () (import (testfile-a7) (testfile-b7)) (list x y))
+    '(17 17))
+
+ ; import cycles
+  (error? ; cyclic dependency on import
+    (library ($l2-lib1) (export) (import ($l2-lib1))))
+  (begin ; make sure we can redefine after cyclic import error
+    (library ($l2-lib1) (export a) (import (rnrs)) (define a "a"))
+    #t)
+  (equal? (let () (import ($l2-lib1)) a) "a")
+
+  (begin
+    (delete-file "testfile-a8.so")
+    (with-output-to-file "testfile-a8.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a8) (export a) (import (testfile-a8)))))
+      'replace)
+     #t)
+  (error? ; cyclic dependency on import
+    (import (testfile-a8)))
+  (begin ; make sure we can redefine after cyclic import error
+    (with-output-to-file "testfile-a8.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a8) (export cons) (import (rnrs)))))
+      'replace)
+    #t)
+  (equal? (let () (import (testfile-a8)) cons) (let () (import (rnrs)) cons))
+
+  (begin
+    (delete-file "testfile.a9.so")
+    (with-output-to-file "testfile-a9.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a9) (export a) (import (testfile-a9)))))
+      'replace)
+    #t)
+  (error? ; cyclic dependency on import
+    (compile-file "testfile-a9"))
+  (begin ; make sure we can redefine after cyclic import error
+    (with-output-to-file "testfile-a9.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a9) (export cons) (import (rnrs)))))
+      'replace)
+    (compile-file "testfile-a9")
+    (load "testfile-a9.so")
+    #t)
+  (equal? (let () (import (testfile-a9)) cons) (let () (import (rnrs)) cons))
+
+  (begin
+    (delete-file "testfile-a10.so")
+    (delete-file "testfile-b10.so")
+    (with-output-to-file "testfile-a10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a10) (export a) (import (testfile-b10)))))
+      'replace)
+    (with-output-to-file "testfile-b10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b10) (export a) (import (testfile-a10)))))
+      'replace)
+    #t)
+  (error? ; cyclic dependency on import (indirect)
+    (import (testfile-a10)))
+  (begin ; make sure we can redefine after cyclic import error
+    (with-output-to-file "testfile-a10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a10) (export a) (import (testfile-b10)))))
+      'replace)
+    (with-output-to-file "testfile-b10.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b10) (export a) (import (rnrs)) (define a "eh?"))))
+      'replace)
+    #t)
+  (equal? (let () (import (testfile-a10)) a) "eh?")
+
+ ; invoke cycles
+  (begin
+    (library ($l2-lib2) (export a)
+      (import (rnrs) (rnrs eval))
+      (define a (eval 'a (environment '($l2-lib2)))))
+    #t)
+  (error? ; cyclic dependency on invoke
+    (let () (import ($l2-lib2)) a))
+
+  (begin
+    (delete-file "testfile-a11.so")
+    (delete-file "testfile-b11.so")
+    (with-output-to-file "testfile-a11.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a11) (export a) (import (testfile-b11)))))
+      'replace)
+    (with-output-to-file "testfile-b11.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-b11) (export a)
+             (import (rnrs) (rnrs eval))
+             (define a (eval 'a (environment '(testfile-a11)))))))
+      'replace)
+    #t)
+  (error? ; cyclic dependency on invoke (indirect)
+    (let () (import (testfile-a11)) a))
+
+ ; visit cycles
+  (begin
+    (delete-file "testfile-a12.so")
+    (remprop 'chewie 'ratface)
+    (with-output-to-file "testfile-a12.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a12) (export a)
+             (import (rnrs) (rnrs eval) (only (scheme) getprop))
+             (define-syntax a
+               (if (getprop 'chewie 'ratface #f)
+                   (eval 'a (environment '(testfile-a12)))
+                   (lambda (x) 3))))))
+      'replace)
+    (separate-compile 'a12)
+    (putprop 'chewie 'ratface #t)
+    #t)
+  (error? ; cyclic dependency on visit
+    (let () (import (testfile-a12)) a))
+  (begin
+    (with-output-to-file "testfile-a13.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a13) (export a)
+             (import (rename (rnrs) (cons a))))))
+      'replace)
+    (separate-compile 'a13)
+    #t)
+  (equal? (let () (import (testfile-a13)) (a 3 4)) '(3 . 4))
+  (error? (library (foo) (export a (rename b a)) (import (rnrs)) (define a 3) (define b 4)))
+  (error? (library (foo) (export a (rename (b a))) (import (rnrs)) (define a 3) (define b 4)))
+  (error? (library (foo) (exports a) (import (rnrs)) (define a 3)))
+  (error? (library (foo) (export a) (imports (rnrs)) (define a 3)))
+
+  (error? ; misplaced library form
+    (let ()
+      (library (foo)
+        (export)
+        (import (scheme))
+        (library (bar) (export) (import)))))
+  (error? ; misplaced library form
+    (let () (library (foo) (export) (import))))
+  (error? ; misplaced library form
+    (+ (library (bar) (export) (import)) 3))
+
+ ; make sure library is visited when needed
+  (begin
+    (with-output-to-file "testfile-f2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-f2) (export f2-x) (import (rnrs) (rnrs mutable-pairs))
+             (define-syntax define-mutable
+               (syntax-rules ()
+                 [(_ x e)
+                  (begin
+                    (define t (list e))
+                    (define-syntax x
+                      (identifier-syntax
+                        [_ (car t)]
+                        [(set! _ new) (set-car! t new)])))]))
+             (define-mutable f2-x 772))))
+      'replace)
+    (for-each separate-compile '(f2))
+    #t)
+  (begin
+    (define (f2-x-whack! v)
+      (import (testfile-f2))
+      (set! f2-x v))
+    (f2-x-whack! 29)
+    #t)
+  (eqv? (let () (import (testfile-f2)) f2-x) 29)
+  (not (top-level-bound? 'f2-x))
+ ; make sure #'x doesn't force library to be visited if x is an exported
+ ; keyword or invoked if x is an exported variable
+  (begin
+    (with-output-to-file "testfile-g2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-g2) (export hit-a hit-x) (import (chezscheme))
+             (define hit-a (make-parameter #f))
+             (define hit-x (make-parameter #f)))))
+      'replace)
+    (with-output-to-file "testfile-h2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-h2) (export x a) (import (rnrs) (testfile-g2))
+             (define-syntax a (begin (hit-a #t) (lambda (x) 73)))
+             (define x (begin (hit-x #t) (list (hit-x) 97))))))
+      'replace)
+    (for-each separate-compile '(g2 h2))
+    #t)
+  (let () (import (testfile-g2)) (and (not (hit-a)) (not (hit-x))))
+  (let () (import (testfile-g2) (testfile-h2)) (let ([q #'a]) (and (identifier? q) (not (hit-a)) (not (hit-x)))))
+  (let () (import (testfile-g2) (testfile-h2)) (let ([q #'x]) (and (identifier? q) (not (hit-a)) (not (hit-x)))))
+  (let () (import (testfile-g2) (testfile-h2)) (and (eqv? a 73) (hit-a) (not (hit-x))))
+  (let () (import (testfile-g2) (testfile-h2)) (and (equal? x '(#t 97)) (hit-a) (hit-x)))
+)
+
+(mat library3
+ ; test several-deep invoke-dependency chain
+  (begin
+    (with-output-to-file "testfile-a3-0.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a3-0)
+             (export x0)
+             (import (rnrs))
+             (define x0 7))))
+      'replace)
+    (with-output-to-file "testfile-a3-1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a3-1)
+             (export x1)
+             (import (rnrs) (testfile-a3-0))
+             (define x1 (+ x0 1)))))
+      'replace)
+    (with-output-to-file "testfile-a3-2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a3-2)
+             (export x2)
+             (import (rnrs) (testfile-a3-1))
+             (define x2 (+ x1 2)))))
+      'replace)
+    (with-output-to-file "testfile-a3-3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a3-3)
+             (export x3)
+             (import (rnrs) (testfile-a3-2))
+             (define x3 (+ x2 3)))))
+      'replace)
+    (with-output-to-file "testfile-a3-4.ss"
+      (lambda ()
+        (pretty-print '(import (rnrs) (testfile-a3-3)))
+        (pretty-print '(write (+ x3 4))))
+      'replace)
+    (separate-compile 'compile-library 'a3-0)
+    (separate-compile 'compile-library 'a3-1)
+    (separate-compile 'compile-library 'a3-2)
+    (separate-compile 'compile-library 'a3-3)
+    (separate-compile 'compile-program 'a3-4)
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (load-program "testfile-a3-4.so")))
+    "17")
+  (eqv? (let () (import (testfile-a3-3)) x3) 13)
+ ; try begin containing library and top-level program
+  (begin
+    (with-output-to-file "testfile-a3-5.ss"
+      (lambda ()
+        (pretty-print
+          '(begin
+             (library (a3-5 foo)
+               (export x)
+               (import (rnrs))
+               (define x "hello"))
+             (top-level-program
+               (import (rnrs) (a3-5 foo))
+               (display x)))))
+      'replace)
+    (separate-compile 'a3-5)
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile-a3-5.so")))
+    "hello")
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile-a3-5.ss")))
+    "hello")
+ ; try begin containing two libraries
+  (begin
+    (with-output-to-file "testfile-a3-6.ss"
+      (lambda ()
+        (pretty-print
+          '(begin
+             (library (a3-6 foo)
+               (export a x)
+               (import (rnrs))
+               (define-syntax a (identifier-syntax "boo"))
+               (define x "hello"))
+             (library (a3-6 bar)
+               (export y)
+               (import (rnrs) (a3-6 foo))
+               (define y (cons a x)))
+             (let () (import (a3-6 bar)) (write y)))))
+      'replace)
+    (separate-compile 'a3-6)
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile-a3-6.so")))
+    "(\"boo\" . \"hello\")")
+  (equal?
+    (let ()
+      (import (a3-6 bar))
+      y)
+    '("boo" . "hello"))
+  (equal?
+    (let ()
+      (import (a3-6 foo))
+      (cons x a))
+    '("hello" . "boo"))
+ ; import a library in subset-mode system, then outside of subset-mode system
+  (begin
+    (with-output-to-file "testfile-a3-7.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a3-7)
+             (export x)
+             (import (rnrs))
+             (define x "hello"))))
+      'replace)
+    #t)
+  (equal?
+    (parameterize ([subset-mode 'system]) (eval '(let () (import (testfile-a3-7)) x)))
+    "hello")
+  (equal?
+    (let () (import (testfile-a3-7)) x)
+    "hello")
+
+  (begin
+    (with-output-to-file "testfile-a3-8.ss"
+      (lambda ()
+        (pretty-print '(printf "outside (testfile-a3-8)\n"))
+        (pretty-print
+          '(library (testfile-a3-8)
+             (export a3-8-x)
+             (import (rnrs))
+             (define a3-8-x 5)
+             (error #f "library should not be invoked"))))
+      'replace)
+    (with-output-to-file "testfile-a3-9.ss"
+      (lambda ()
+        (pretty-print 
+          '(let ()
+             (import (scheme) (testfile-a3-8))
+             (printf "inside testfile-a3-9\n"))))
+      'replace)
+    (with-output-to-file "testfile-a3-10.ss"
+      (lambda ()
+        (pretty-print '(import (scheme) (testfile-a3-8)))
+        (pretty-print '(printf "inside testfile-a3-10\n")))
+      'replace)
+    (separate-compile 'a3-8)
+    (separate-compile 'a3-9)
+    (separate-compile 'a3-10)
+    #t)
+  (equal?
+    (with-output-to-string (lambda () (load "testfile-a3-9.so")))
+    "inside testfile-a3-9\n")
+  (equal?
+    (with-output-to-string (lambda () (load "testfile-a3-10.so")))
+    "inside testfile-a3-10\n")
+)
+
+(mat library4
+  ; test reloading of libraries if dependencies have changed
+  ; when compile-imported-libraries is true.
+  ; first test with compile-imported-libraries true:
+  (begin
+    (define ($reset-l4-1)
+      (for-each delete-file '("testfile-l4-a1.so" "testfile-l4-b1.so" "testfile-l4-c1.so"))
+      (with-output-to-file "testfile-l4-a1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-a1) (export x) (import (chezscheme) (testfile-l4-b1) (testfile-l4-c1))
+               (include "testfile-l4-d1.ss")
+               (define a 'a-object)
+               (define x (list a b c d)))))
+        'replace)
+      (with-output-to-file "testfile-l4-b1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-b1) (export b) (import (chezscheme))
+               (define b (list 'b-object)))))
+        'replace)
+      (with-output-to-file "testfile-l4-c1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-c1) (export c) (import (chezscheme))
+               (define-syntax c (lambda (x) #''c-object)))))
+        'replace)
+      (with-output-to-file "testfile-l4-d1.ss"
+        (lambda ()
+          (pretty-print
+            '(define-syntax d (lambda (x) #''d-object))))
+        'replace)
+      (with-output-to-file "testfile-l4-p1.ss"
+        (lambda ()
+          (pretty-print
+            '(import (testfile-l4-a1) (chezscheme)))
+          (pretty-print
+            '(pretty-print x)))
+        'replace)
+      (let ([s (separate-eval
+                 '(compile-imported-libraries #t)
+                 '(compile-file-message #f)
+                 '(load-program "testfile-l4-p1.ss"))])
+        (unless (equal? s "(a-object (b-object) c-object d-object)\n")
+          (errorf #f "unexpected separate-eval return value ~s" s)))
+      ; ensure different file times for followup updates
+      (sleep (make-time 'time-duration 0 (if (embedded?) 3 1)))
+      #t)
+    #t)
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-a1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-a1) (export x) (import (chezscheme) (testfile-l4-b1) (testfile-l4-c1))
+               (include "testfile-l4-d1.ss")
+               (define a 'newa-object)
+               (define x (list a b c d)))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #t)
+        '(compile-file-message #f)
+        '(load-program "testfile-l4-p1.ss")))
+    "(newa-object (b-object) c-object d-object)\n")
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-b1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-b1) (export b) (import (chezscheme))
+               (define b (list 'newb-object)))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #t)
+        '(compile-file-message #f)
+        '(load-program "testfile-l4-p1.ss")))
+    "(a-object (newb-object) c-object d-object)\n")
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-c1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-c1) (export c) (import (chezscheme))
+               (define-syntax c (lambda (x) #''newc-object)))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #t)
+        '(compile-file-message #f)
+        '(load-program "testfile-l4-p1.ss")))
+    "(a-object (b-object) newc-object d-object)\n")
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-d1.ss"
+        (lambda ()
+          (pretty-print
+            '(define-syntax d (lambda (x) #''newd-object))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #t)
+        '(compile-file-message #f)
+        '(load-program "testfile-l4-p1.ss")))
+    "(a-object (b-object) c-object newd-object)\n")
+  ; now with compile-imported-libraries false
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-a1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-a1) (export x) (import (chezscheme) (testfile-l4-b1) (testfile-l4-c1))
+               (include "testfile-l4-d1.ss")
+               (define a 'newera-object)
+               (define x (list a b c d)))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #f)
+        '(compile-file-message #t)
+        '(load-program "testfile-l4-p1.ss")))
+    "(newera-object (b-object) c-object d-object)\n")
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-b1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-b1) (export b) (import (chezscheme))
+               (define b (list 'newerb-object)))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #f)
+        '(compile-file-message #t)
+        '(load-program "testfile-l4-p1.ss")))
+    "(a-object (newerb-object) c-object d-object)\n")
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-c1.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-l4-c1) (export c) (import (chezscheme))
+               (define-syntax c (lambda (x) #''newerc-object)))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #f)
+        '(compile-file-message #t)
+        '(load-program "testfile-l4-p1.ss")))
+    "(a-object (b-object) newerc-object d-object)\n")
+  ($reset-l4-1)
+  (equal?
+    (begin
+      (with-output-to-file "testfile-l4-d1.ss"
+        (lambda ()
+          (pretty-print
+            '(define-syntax d (lambda (x) #''newerd-object))))
+        'replace)
+      (separate-eval
+        '(compile-imported-libraries #f)
+        '(compile-file-message #t)
+        '(load-program "testfile-l4-p1.ss")))
+    "(a-object (b-object) c-object newerd-object)\n")
+)
+
+(mat library5
+  ; test for proper runtime library dependencies
+  (begin
+    (with-output-to-file "testfile-l5-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-l5-a1) (export a) (import (chezscheme))
+             (define a (cons 3 4)))))
+      'replace)
+    (with-output-to-file "testfile-l5-b1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-l5-b1) (export a b c) (import (chezscheme) (testfile-l5-a1))
+             (define-syntax b (identifier-syntax (vector a)))
+             (define c (cons 5 6)))))
+      'replace)
+    (with-output-to-file "testfile-l5-c1.ss"
+      (lambda ()
+        (for-each pretty-print
+          `((import (chezscheme) (testfile-l5-b1))
+            (set-car! a 55)
+            (pretty-print (list a b)))))
+      'replace)
+    (equal?
+      (parameterize ([compile-imported-libraries #t])
+        (compile-program "testfile-l5-c1"))
+      '((testfile-l5-a1))))
+  ; delete testfile-l5-b1.{ss,so} to make sure they aren't surreptitiously loaded
+  (begin
+    (delete-file "testfile-l5-b1.ss")
+    (delete-file "testfile-l5-b1.so")
+    (and (not (file-exists? "testfile-l5-b1.ss"))
+         (not (file-exists? "testfile-l5-b1.so"))))
+  (equal?
+    (separate-eval '(load-program "testfile-l5-c1.so"))
+    "((55 . 4) #((55 . 4)))\n")
+)
+
+(mat library6
+  ; test for proper handling of visit library dependencies
+  (begin
+    (with-output-to-file "testfile-l6-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-l6-a1) (export a) (import (chezscheme))
+             (define a (cons 3 4)))))
+      'replace)
+    (with-output-to-file "testfile-l6-b1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-l6-b1) (export b-x b-y) (import (chezscheme) (testfile-l6-a1))
+             (define-syntax b-x (lambda (x) (car a)))
+             (define b-y (cons 5 6)))))
+      'replace)
+    (with-output-to-file "testfile-l6-c1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-l6-c1) (export c) (import (chezscheme) (testfile-l6-b1))
+             (meta define c
+               (lambda (x)
+                 #`(cons (* #,x #,(car b-y)) (* #,x #,(cdr b-y))))))))
+      'replace)
+    (with-output-to-file "testfile-l6-prog1.ss"
+      (lambda ()
+        (pretty-print '(eval-when (visit) (printf "visiting testfile-l6-prog1\n")))
+        (pretty-print '(define-syntax M
+                         (lambda (x)
+                           (import (testfile-l6-c1))
+                           (syntax-case x ()
+                             [(_ f d) #`(f #,(c (datum d)))]))))
+        (pretty-print '(eval-when (revisit) (printf "revisiting testfile-l6-prog1\n")))
+        (pretty-print '(pretty-print (M vector 2))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (compile-file x)))
+      "testfile-l6-prog1")
+    #t)
+
+  (begin
+    (delete-file "testfile-l6-a1.so")
+    (delete-file "testfile-l6-a1.ss")
+    (and (not (file-exists? "testfile-l6-a1.so"))
+         (not (file-exists? "testfile-l6-a1.ss"))))
+
+  (equal?
+    (separate-eval '(revisit "testfile-l6-prog1.so"))
+    "revisiting testfile-l6-prog1\n#((10 . 12))\n")
+)
+
+(mat library7
+  (begin
+    (mkfile "testfile-l7-a1.ss"
+      '(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa)) (define (a x) (+ x (* x x)))))
+    (mkfile "testfile-l7-b1.ss"
+      '(library (testfile-l7-b1) (export b) (import (chezscheme) (testfile-l7-a1)) (define (b x) (cons 'b a-macro))))
+    (mkfile "testfile-l7-c1.ss"
+      '(library (testfile-l7-c1) (export c) (import (chezscheme) (testfile-l7-a1)) (define (c x) (cons 'c (a x)))))
+    (mkfile "testfile-l7-d1.ss"
+      '(library (testfile-l7-d1) (export d) (import (chezscheme) (testfile-l7-a1)) (define (d x) (list 'd a-macro (a x)))))
+    (separate-compile
+      '(lambda (x) (for-each compile-library x))
+      '(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1" "testfile-l7-d1"))
+    #t)
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-l7-b1)) (b 7))
+      '(let () (import (testfile-l7-c1)) (c 7))
+      '(let () (import (testfile-l7-d1)) (d 7)))
+    "(b . aaa)\n(c . 56)\n(d aaa 56)\n")
+  (begin
+    (separate-compile
+      '(lambda (x) (for-each compile-library x))
+      '(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1"))
+    #t)
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-l7-b1)) (b 7))
+      '(let () (import (testfile-l7-c1)) (c 7))
+      ; this should reload from source, since dependency is out-of-date
+      '(let () (import (testfile-l7-d1)) (d 7)))
+    "(b . aaa)\n(c . 56)\n(d aaa 56)\n")
+  (equal?
+    (separate-eval
+      ; this should reload from source, since dependency is out-of-date
+      '(let () (import (testfile-l7-d1)) (d 7))
+      '(let () (import (testfile-l7-c1)) (c 7))
+      '(let () (import (testfile-l7-b1)) (b 7)))
+    "(d aaa 56)\n(c . 56)\n(b . aaa)\n")
+  (error? ; expected different compilation instance
+    (separate-eval
+      '(let () (import (testfile-l7-b1)) (b 7))
+      '(let () (import (testfile-l7-c1)) (c 7))
+      '(load-library "testfile-l7-d1.so")
+      '(let () (import (testfile-l7-d1)) (d 7))))
+  (error? ; expected different compilation instance
+    (separate-eval
+      '(load-library "testfile-l7-d1.so")
+      '(let () (import (testfile-l7-d1)) (d 7))))
+  (equal?
+    (separate-eval
+      '(load-library "testfile-l7-b1.ss")
+      '(let () (import (testfile-l7-b1)) (b 7))
+      ; this should reload from source, since dependency is out-of-date
+      '(let () (import (testfile-l7-c1)) (c 7))
+      ; this should reload from source, since dependency is out-of-date
+      '(let () (import (testfile-l7-d1)) (d 7)))
+    "(b . aaa)\n(c . 56)\n(d aaa 56)\n")
+  (error? ; expected different compilation instance
+    (separate-eval
+      '(load-library "testfile-l7-b1.ss")
+      '(load-library "testfile-l7-c1.ss")
+      '(load-library "testfile-l7-d1.so")
+      '(let () (import (testfile-l7-d1)) (d 7))))
+  (begin
+    (delete-file "testfile-l7-a1.so")
+    #t)
+  (equal?
+    (separate-eval
+      '(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss"))
+      '(let () (import (testfile-l7-b1)) (b 7))
+      ; this should reload from source, since dependency is out-of-date
+      '(let () (import (testfile-l7-c1)) (c 7))
+      '(let () (import (testfile-l7-d1)) (d 7)))
+    "compiling testfile-l7-b1.ss with output to testfile-l7-b1.so\ncompiling testfile-l7-a1.ss with output to testfile-l7-a1.so\n(b . aaa)\n(c . 56)\n(d aaa 56)\n")
+  (begin
+    (delete-file "testfile-l7-a1.so")
+    #t)
+  (error? ; expected different compilation instance
+    (separate-eval
+      '(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss"))
+      '(load-library "testfile-l7-c1.so")
+      '(let () (import (testfile-l7-c1)) (c 7))))
+  (equal?
+    (separate-eval
+      '(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11)))
+      '(let () (import (testfile-l7-b1)) (b 7))
+      '(let () (import (testfile-l7-c1)) (c 7))
+      '(let () (import (testfile-l7-d1)) (d 7)))
+    "(b . aaa2)\n(c . 77)\n(d aaa2 77)\n")
+  (error? ; expected different compilation instance
+    (separate-eval
+      '(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11)))
+      '(let () (import (testfile-l7-b1)) (b 7))
+      '(let () (import (testfile-l7-c1)) (c 7))
+      '(load-library "testfile-l7-d1.so")
+      '(let () (import (testfile-l7-d1)) (d 7))))
+)
+
+(mat library-regression
+  ; test that failing invoke code does not result in cyclic dependency problem on re-run
+  (equal?
+    (separate-eval
+      '(begin
+         (library (invoke-fail)
+           (export x)
+           (import (chezscheme))
+           (define x #f)
+           (error #f "failed to load library (invoke-fail)"))
+         (guard (e [else
+                     (guard (e2 [else 
+                                  (display-condition e) (newline)
+                                  (display-condition e2) (newline)])
+                       (eval 'x (environment '(chezscheme) '(invoke-fail))))])
+           (eval 'x (environment '(chezscheme) '(invoke-fail))))))
+    "Exception: failed to load library (invoke-fail)\nException: failed to load library (invoke-fail)\n")
+
+  ; test that true cyclic dependency will always report the same thing
+  (equal?
+    (separate-eval
+      '(begin
+         (library (invoke-cyclic)
+           (export x y)
+           (import (chezscheme))
+           (define x #f)
+           (define y (eval '(if x 5 10) (environment '(chezscheme) '(invoke-cyclic)))))
+         (guard (e [else
+                     (guard (e2 [else 
+                                  (display-condition e) (newline)
+                                  (display-condition e2) (newline)])
+                       (eval 'x (environment '(chezscheme) '(invoke-cyclic))))])
+           (eval 'x  (environment '(chezscheme) '(invoke-cyclic))))))
+    "Exception: cyclic dependency involving invocation of library (invoke-cyclic)\nException: cyclic dependency involving invocation of library (invoke-cyclic)\n")
+
+  (begin
+    ; library to help make it easier to cause a failure in the visit-code that
+    ; does not lead to failure during compilation of the file.
+    (with-output-to-file "testfile-lr-l1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-lr-l1)
+             (export make-it-fail)
+             (import (chezscheme))
+             (define make-it-fail (make-parameter #f (lambda (x) (and x #t)))))))
+      'replace)
+    ; simple test to define one macro and potentially to raise an error when
+    ; defining the second one.
+    (with-output-to-file "testfile-lr-l2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-lr-l2)
+             (export M1 M2)
+             (import (chezscheme) (testfile-lr-l1))
+             (define-syntax M1
+               (identifier-syntax #f))
+
+             (define-syntax M2
+               (if (make-it-fail)
+                   (error 'M2 "user requested failure with (make-it-fail) parameter")
+                   (lambda (x)
+                     (syntax-case x ()
+                       [(_ expr) #'expr])))))))
+      'replace)
+    ; more complete test that attempts to create the various types of things
+    ; that can be defined in visit code so that we can verify things are being
+    ; properly reset.
+    (with-output-to-file "testfile-lr-l3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-lr-l3)
+             (export a b c d e f g h)
+             (import (chezscheme) (testfile-lr-l1))
+
+             (module a (x) (define x 5))
+             (alias b cons)
+             (define-syntax c (make-compile-time-value 5))
+             (define d 5)
+             (meta define e 5)
+             (define-syntax f (identifier-syntax #f))
+             (define $g (make-parameter #f))
+             (define-syntax g
+               (make-variable-transformer
+                 (lambda (x)
+                   (syntax-case x ()
+                     [(set! _ v) #'($g v)]
+                     [_ #'($g)]
+                     [(_ e* ...) #'(($g) e* ...)]))))
+             (define-property f g 10)
+             (define-syntax h
+               (if (make-it-fail)
+                   (error 'h "user requested failure with (make-it-fail) parameter")
+                   (lambda (x)
+                     (syntax-case x ()
+                       [(_ expr) #'expr])))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (for-each compile-library x)))
+      '(list "testfile-lr-l1" "testfile-lr-l2" "testfile-lr-l3"))
+    #t)
+
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l2) (testfile-lr-l1))
+         (make-it-fail #t)
+         (guard (e [else
+                     (guard (e2
+                              [else
+                                (display-condition e) (newline)
+                                (display-condition e2) (newline)])
+                       (eval 'M1 (environment '(testfile-lr-l2))))])
+           (eval 'M1 (environment '(testfile-lr-l2))))))
+    "Exception in M2: user requested failure with (make-it-fail) parameter\nException in M2: user requested failure with (make-it-fail) parameter\n")
+
+  ; module is defined as part of import code, run time bindings are setup as part of invoke code
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (import a)
+         x))
+    "5\n")
+
+  ; alias is part of module binding ribcage, set up by import code
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (b 'a 'b)))
+    "(a . b)\n")
+
+  ; compile-time-value is set in visit code, should show same error each time it is referenced
+  (equal?
+    (separate-eval
+      '(begin
+         (library (lookup)
+           (export lookup)
+           (import (chezscheme))
+           (define-syntax lookup
+             (lambda (x)
+               (syntax-case x ()
+                 [(_ id) (lambda (rho) #`'#,(rho #'id))]
+                 [(_ id key) (lambda (rho) #`'#,(rho #'id #'key))]))))
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (guard (e [else
+                     (guard (e2
+                              [else
+                                (display-condition e) (newline)
+                                (display-condition e2) (newline)])
+                       (eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))])
+           (eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))))
+    "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
+
+  ; defines are set up as part of invoke code
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         d))
+    "5\n")
+
+  ; meta defines are set up as part of visit code
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (guard (e [else
+                     (guard (e2
+                              [else
+                                (display-condition e) (newline)
+                                (display-condition e2) (newline)])
+                       (eval '(let ()
+                                (define-syntax get-e
+                                  (lambda (x)
+                                    (syntax-case x ()
+                                      [(_) #`'#,e])))
+                                (get-e))
+                         (environment '(chezscheme) '(testfile-lr-l3))))])
+           (eval '(let ()
+                    (define-syntax get-e
+                      (lambda (x)
+                        (syntax-case x ()
+                          [(_) #`'#,e])))
+                    (get-e))
+             (environment '(chezscheme) '(testfile-lr-l3))))))
+    "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
+
+  ; macros are set up as part of visit code
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (guard (e [else
+                     (guard (e2
+                              [else
+                                (display-condition e) (newline)
+                                (display-condition e2) (newline)])
+                       (eval 'f (environment '(testfile-lr-l3))))])
+           (eval 'f (environment '(testfile-lr-l3))))))
+    "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
+
+  ; variable transformer macros are set up as part of visit code
+  (equal?
+    (separate-eval
+      '(begin
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (guard (e [else
+                     (guard (e2
+                              [else
+                                (display-condition e) (newline)
+                                (display-condition e2) (newline)])
+                       (eval 'g (environment '(testfile-lr-l3))))])
+           (eval 'g (environment '(testfile-lr-l3))))))
+    "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
+
+  ; properties are setup as part of visit code.
+  (equal?
+    (separate-eval
+      '(begin
+         (library (lookup)
+           (export lookup)
+           (import (chezscheme))
+           (define-syntax lookup
+             (lambda (x)
+               (syntax-case x ()
+                 [(_ id) (lambda (rho) #`'#,(rho #'id))]
+                 [(_ id key) (lambda (rho) #`'#,(rho #'id #'key))]))))
+         (import (testfile-lr-l3) (testfile-lr-l1))
+         (make-it-fail #t)
+         (guard (e [else
+                     (guard (e2
+                              [else
+                                (display-condition e) (newline)
+                                (display-condition e2) (newline)])
+                       (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))])
+           (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))))
+    "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
+
+  ;; re-arm import code if it complains about a library that is not visible
+  (begin
+    (with-output-to-file "testfile-lr-l4.ss"
+      (lambda ()
+        (pretty-print
+         '(library (testfile-lr-l4)
+            (export x)
+            (import (chezscheme))
+            (define x 123))))
+      'replace)
+    (with-output-to-file "testfile-lr-p4.ss"
+      (lambda ()
+        (for-each pretty-print
+         '((import (testfile-lr-l4) (scheme))
+           (define (run args)
+             (guard (c [#t (display-condition c) (newline)])
+               (pretty-print (top-level-value (car args) (environment (cdr args))))))
+           (when (> x 0) ;; reference export
+             (let ([args (map string->symbol (command-line-arguments))])
+               (if (= (length args) 2)
+                   (begin
+                     (run args)
+                     (run args))
+                   (error #f "expected 2 args")))))))
+      'replace)
+    (separate-eval
+     '(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
+        (compile-program "testfile-lr-p4.ss")
+        (compile-whole-program "testfile-lr-p4.wpo" "testfile-lr-p4-visible" #t)
+        (compile-whole-program "testfile-lr-p4.wpo" "testfile-lr-p4-not-visible" #f)))
+    (equal?
+     (separate-eval
+      '(parameterize ([command-line-arguments '("x" "testfile-lr-l4")])
+         (load-program "testfile-lr-p4-visible")
+         (load-program "testfile-lr-p4-not-visible")))
+     (string-append
+      "123\n"
+      "123\n"
+      "Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"
+      "Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"))))
+
+(mat invoke-library
+  (error? ; invalid library reference
+     (invoke-library '(testfile-il1 (<= 3))))
+  (error? ; invalid library reference
+     (invoke-library '(testfile-il1 (what?))))
+  (error? ; invalid library reference
+     (invoke-library '()))
+  (error? ; invalid library reference
+     (invoke-library 'hello))
+  (error? ; invalid library reference
+     (invoke-library '(3 2 1)))
+  (begin
+    (mkfile "testfile-il1.ss"
+      '(library (testfile-il1 (2)) (export a) (import (chezscheme)) (define a 3) (printf "invoked (testfile-il1)\n")))
+    #t)
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\n3\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1))
+      '(printf "hello\n")
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\nhello\n3\n")
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a)
+      '(printf "hello\n")
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n3\nhello\n")
+  (begin
+    (separate-eval '(compile-library "testfile-il1"))
+    #t)
+  (delete-file "testfile-il1.ss")
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\n3\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1))
+      '(printf "hello\n")
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\nhello\n3\n")
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a)
+      '(printf "hello\n")
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n3\nhello\n")
+  (error? ; version mismatch
+    (separate-eval '(invoke-library '(testfile-il1 (3)))))
+  (error? ; version mismatch
+    (separate-eval
+      '(invoke-library '(testfile-il1 ((>= 3))))))
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1 ((>= 2)))))
+    "invoked (testfile-il1)\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1 (2))))
+    "invoked (testfile-il1)\n")
+)
+
+(mat cross-library-optimization
+  (begin
+    (with-output-to-file "testfile-clo-1a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-clo-1a)
+             (export f)
+             (import (chezscheme))
+             (define f (lambda (s) (format "~s!\n" s))))))
+      'replace)
+    (with-output-to-file "testfile-clo-1b.ss"
+      (lambda ()
+        (pretty-print
+          '(import (chezscheme) (testfile-clo-1a)))
+        (pretty-print
+          '(display-string (f 'hello))))
+      'replace)
+    #t)
+  (eqv? (compile-library "testfile-clo-1a") (void))
+  ; in this case, can't propage f because of the embedded string constant,
+  ; so program depends on library at run time
+  (equal? (compile-program "testfile-clo-1b") '((testfile-clo-1a)))
+  (equal?
+    (with-output-to-string
+      (lambda () (load-program "testfile-clo-1b.so")))
+    "hello!\n")
+  (begin
+    (with-output-to-file "testfile-clo-2a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-clo-2a)
+             (export f)
+             (import (chezscheme))
+             (define f (lambda (s) (symbol->string s))))))
+      'replace)
+    (with-output-to-file "testfile-clo-2b.ss"
+      (lambda ()
+        (pretty-print
+          '(import (chezscheme) (testfile-clo-2a)))
+        (pretty-print
+          '(display-string (f 'hello))))
+      'replace)
+    #t)
+  (eqv? (compile-library "testfile-clo-2a") (void))
+  ; in this case, nothing stopping propagation of f,
+  ; so program doesn't necessarily depend on library at run time
+  (and (member
+         (compile-program "testfile-clo-2b")
+         '(() ((testfile-clo-2a))))
+       #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (load-program "testfile-clo-2b.so")))
+    "hello")
+  ; testing internal consistency for library w/externally visible side effect, which we don't guarantee
+  ; will happen if all runtime references are optimized away
+  (begin
+    (with-output-to-file "testfile-clo-3a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-clo-3a)
+             (export g h)
+             (import (chezscheme))
+             (define (f) (putprop 'spam 'canned #t))
+             (define (g) (getprop 'spam 'canned #f))
+             (define (h) (remprop 'spam 'canned))
+             (f))))
+      'replace)
+    (with-output-to-file "testfile-clo-3b.ss"
+      (lambda ()
+        (pretty-print
+          '(import (chezscheme) (testfile-clo-3a)))
+        (pretty-print
+          '(write (g))))
+      'replace)
+    #t)
+  (equal?
+    (let ([libs (parameterize ([compile-imported-libraries #t]) (compile-program "testfile-clo-3b"))])
+      (cond
+        ; if compiled program depends on the library, the externally visible side effect (putprop) will be done
+        [(equal? libs '((testfile-clo-3a)))
+         (cons
+           (equal? (with-output-to-string (lambda () (load-program "testfile-clo-3b.so"))) "#t")
+           (let () (import (testfile-clo-3a)) (g)))]
+        ; otherwise not
+        [(equal? libs '())
+         (cons
+           (equal? (with-output-to-string (lambda () (load-program "testfile-clo-3b.so"))) "#f")
+           (not (let () (import (testfile-clo-3a)) (g))))]
+        [else 'oops]))
+    '(#t . #t))
+  (equal? (let () (import (testfile-clo-3a)) (h)) (void))
+  (not (let () (import (testfile-clo-3a)) (g)))
+)
+
+(mat lots-of-libraries
+  (begin
+    (define (lol-mklibname n) (string->symbol (format "testfile-lol-~d" n)))
+    (define (lol-mkvarname n) (string->symbol (format "n~d" n)))
+    (define lol-fiblib
+      (lambda (n)
+        (let fiblib ([n n])
+          (if (fx= n 1)
+              `((library (testfile-lol-1) (export n1) (import (chezscheme)) (define n1 1))
+                (library (testfile-lol-0) (export n0) (import (chezscheme)) (define n0 0)))
+              (cons
+                `(library (,(lol-mklibname n))
+                   (export ,(lol-mkvarname n))
+                   (import (chezscheme) (,(lol-mklibname (fx- n 1))) (,(lol-mklibname (fx- n 2))))
+                   (define ,(lol-mkvarname n) (+ ,(lol-mkvarname (fx- n 1)) ,(lol-mkvarname (fx- n 2)))))
+                (fiblib (fx- n 1)))))))
+    #t)
+  (eqv?
+    (let ([n 10])
+      (eval `(begin ,@(reverse (lol-fiblib n)) (let () (import (,(lol-mklibname n))) ,(lol-mkvarname n)))))
+    55)
+  (begin
+    (define lol-n 100)
+    (do ([lib* (lol-fiblib lol-n) (cdr lib*)] [n lol-n (fx- n 1)])
+        ((null? lib*))
+      (with-output-to-file (format "~s.ss" (lol-mklibname n))
+        (lambda () (pretty-print (car lib*)))
+        'replace))
+    (with-output-to-file "testfile-lol-prog.ss"
+      (lambda ()
+        (for-each pretty-print
+          `((import (chezscheme) (,(lol-mklibname lol-n)))
+            (pretty-print ,(lol-mkvarname lol-n)))))
+      'replace)
+    (define $lol-watchdog
+      (let ([t (current-time 'time-utc)])
+        (let ([time-n 3])
+          (separate-eval
+            `(parameterize ([compile-imported-libraries #t])
+               (compile-library ,(format "~a.ss" (lol-mklibname time-n)))))
+          (do ([n 0 (+ n 1)]) ((> n time-n)) (delete-file (format "~a.so" (lol-mklibname n)))))
+        (let ([t (time-difference (current-time 'time-utc) t)])
+          (let ([t-reasonable
+                  (let ([ns (* (+ (* (time-second t) (expt 10 9)) (time-nanosecond t)) lol-n)])
+                    (make-time 'time-duration (remainder ns (expt 10 9)) (quotient ns (expt 10 9))))])
+            `(let ([t (current-time 'time-utc)])
+               (timer-interrupt-handler
+                 (let ([t-reasonable (make-time 'time-duration ,(time-nanosecond t-reasonable) ,(time-second t-reasonable))])
+                   (lambda ()
+                     (unless (time<=? (time-difference (current-time 'time-utc) t) t-reasonable)
+                       (errorf #f "unreasonable time elapsed"))
+                     (set-timer 10000))))
+               ((timer-interrupt-handler)))))))
+    #t)
+  (string?
+    (separate-compile
+      `(lambda (x)
+         ,$lol-watchdog
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      'lol-prog))
+  (equal?
+    (separate-eval `(begin ,$lol-watchdog (load-program "testfile-lol-prog.so")))
+    (format "~d\n"
+      (let fib ([i 1] [n1 1] [n0 0])
+        (if (fx= i lol-n)
+            n1
+            (fib (+ i 1) (+ n1 n0) n1)))))
+  ; test rebuild
+  (string?
+    (separate-compile
+      `(lambda (x)
+         ,$lol-watchdog
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      'lol-prog))
+  ; test maybe rebuild
+  (string?
+    (separate-compile
+      `(lambda (x)
+         ,$lol-watchdog
+         (parameterize ([compile-imported-libraries #t])
+           (maybe-compile-program x)))
+      'lol-prog))
+)
+
+(mat import-dependencies
+  (begin
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 3)))
+             (define x (begin (printf "rt\n") 4)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    #t)
+  (begin
+    (with-output-to-file "testfile-m1.ss"
+      (lambda ()
+        (pretty-print
+          '(module (q1)
+             (import (testfile-a))
+             (define-syntax q1 (identifier-syntax a)))))
+      'replace)
+    (separate-compile 'compile-file 'm1)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m1.so") 'q1)
+    "ct\n3\n")
+  (begin
+    (with-output-to-file "testfile-m2.ss"
+      (lambda ()
+        (pretty-print
+          '(module (q2)
+             (import (testfile-a))
+             (define-syntax q2 (identifier-syntax x)))))
+      'replace)
+    (separate-compile 'compile-file 'm2)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m2.so") 'q2)
+    "rt\n4\n")
+  (begin
+    (sleep (make-time 'time-duration 1000000 1))
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 33)))
+             (define x (begin (printf "rt\n") 44)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    (separate-compile 'maybe-compile-file 'm1)
+    (separate-compile 'maybe-compile-file 'm2)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m1.so") 'q1)
+    "ct\n33\n")
+  (equal?
+    (separate-eval '(load "testfile-m2.so") 'q2)
+    "rt\n44\n")
+  ; --------
+  (begin
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 3)))
+             (define x (begin (printf "rt\n") 4)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    #t)
+  (begin
+    (with-output-to-file "testfile-m3.ss"
+      (lambda ()
+        (pretty-print
+          '(define-syntax q3 (let () (import (testfile-a)) (identifier-syntax a)))))
+      'replace)
+    (separate-compile 'compile-file 'm3)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m3.so") 'q3)
+    "ct\n3\n")
+  (begin
+    (with-output-to-file "testfile-m4.ss"
+      (lambda ()
+        (pretty-print
+          '(define-syntax q4 (let () (import (testfile-a)) (identifier-syntax x)))))
+      'replace)
+    (separate-compile 'compile-file 'm4)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m4.so") 'q4)
+    "rt\n4\n")
+  (begin
+    (sleep (make-time 'time-duration 1000000 1))
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 33)))
+             (define x (begin (printf "rt\n") 44)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    (separate-compile 'maybe-compile-file 'm3)
+    (separate-compile 'maybe-compile-file 'm4)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m3.so") 'q3)
+    "ct\n33\n")
+  (equal?
+    (separate-eval '(load "testfile-m4.so") 'q4)
+    "rt\n44\n")
+  ; --------
+  (begin
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 3)))
+             (define x (begin (printf "rt\n") 4)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    #t)
+  (begin
+    (with-output-to-file "testfile-m5.ss"
+      (lambda ()
+        (pretty-print
+          '(define-property q5 q5 (let () (import (testfile-a)) #'a))))
+      'replace)
+    (separate-compile 'compile-file 'm5)
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-m5.so")
+      '(let ()
+         (define-syntax ref-prop
+           (lambda (x)
+             (lambda (r)
+               (syntax-case x ()
+                 [(_ id key) (r #'id #'key)]))))
+         (ref-prop q5 q5)))
+    "ct\n3\n")
+  (begin
+    (with-output-to-file "testfile-m6.ss"
+      (lambda ()
+        (pretty-print
+          '(define-property q6 q6 (let () (import (testfile-a)) #'x))))
+      'replace)
+    (separate-compile 'compile-file 'm6)
+    #t)
+  (equal?
+    (separate-eval '(load "testfile-m6.so")
+      '(let ()
+         (define-syntax ref-prop
+           (lambda (x)
+             (lambda (r)
+               (syntax-case x ()
+                 [(_ id key) (r #'id #'key)]))))
+         (ref-prop q6 q6)))
+    "rt\n4\n")
+  (begin
+    (sleep (make-time 'time-duration 1000000 1))
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 33)))
+             (define x (begin (printf "rt\n") 44)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    (separate-compile 'maybe-compile-file 'm5)
+    (separate-compile 'maybe-compile-file 'm6)
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-m5.so")
+      '(let ()
+         (define-syntax ref-prop
+           (lambda (x)
+             (lambda (r)
+               (syntax-case x ()
+                 [(_ id key) (r #'id #'key)]))))
+         (ref-prop q5 q5)))
+    "ct\n33\n")
+  (equal?
+    (separate-eval '(load "testfile-m6.so")
+      '(let ()
+         (define-syntax ref-prop
+           (lambda (x)
+             (lambda (r)
+               (syntax-case x ()
+                 [(_ id key) (r #'id #'key)]))))
+         (ref-prop q6 q6)))
+    "rt\n44\n")
+  ; --------
+  (begin
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 3)))
+             (define x (begin (printf "rt\n") 4)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    #t)
+  (begin
+    (with-output-to-file "testfile-m7.ss"
+      (lambda ()
+        (pretty-print
+          '(meta define q7 (let () (import (testfile-a)) #'a))))
+      'replace)
+    (separate-compile 'compile-file 'm7)
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-m7.so")
+      '(let ()
+         (define-syntax qq (lambda (x) q7))
+         qq))
+    "ct\n3\n")
+  (begin
+    (with-output-to-file "testfile-m8.ss"
+      (lambda ()
+        (pretty-print
+          '(meta define q8 (let () (import (testfile-a)) #'x))))
+      'replace)
+    (separate-compile 'compile-file 'm8)
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-m8.so")
+      '(let ()
+         (define-syntax qq (lambda (x) q8))
+         qq))
+    "rt\n4\n")
+  (begin
+    (sleep (make-time 'time-duration 1000000 1))
+    (with-output-to-file "testfile-a.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-a) (export a x) (import (chezscheme))
+             (define-syntax a (begin (printf "ct\n") (identifier-syntax 33)))
+             (define x (begin (printf "rt\n") 44)))))
+      'replace)
+    (separate-compile 'compile-library 'a)
+    (separate-compile 'maybe-compile-file 'm7)
+    (separate-compile 'maybe-compile-file 'm8)
+    #t)
+  (equal?
+    (separate-eval
+      '(load "testfile-m7.so")
+      '(let ()
+         (define-syntax qq (lambda (x) q7))
+         qq))
+    "ct\n33\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-m8.so")
+      '(let ()
+         (define-syntax qq (lambda (x) q8))
+         qq))
+    "rt\n44\n")
+)
+
+(mat eval-when-library
+  (begin
+    (with-output-to-file "testfile-ewl1.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when ()
+             (library (testfile-ewl1)
+               (export x)
+               (import (rnrs))
+               (define-syntax x (identifier-syntax 23))))))
+      'replace)
+    (with-output-to-file "testfile-ewl2.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when (eval)
+             (library (testfile-ewl2)
+               (export x)
+               (import (rnrs))
+               (define-syntax x (identifier-syntax 23))))))
+      'replace)
+    (with-output-to-file "testfile-ewl3.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when (load)
+             (library (testfile-ewl3)
+               (export x)
+               (import (rnrs))
+               (define-syntax x (identifier-syntax 23))))))
+      'replace)
+    (with-output-to-file "testfile-ewl4.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when (visit)
+             (library (testfile-ewl4)
+               (export x)
+               (import (rnrs))
+               (define-syntax x (identifier-syntax 23))))))
+      'replace)
+    (with-output-to-file "testfile-ewl5.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when (revisit)
+             (library (testfile-ewl5)
+               (export x)
+               (import (rnrs))
+               (define-syntax x (identifier-syntax 23))))))
+      'replace)
+    (with-output-to-file "testfile-ewl6.ss"
+      (lambda ()
+        (pretty-print
+          '(eval-when (compile)
+             (library (testfile-ewl6)
+               (export x)
+               (import (rnrs))
+               (define-syntax x (identifier-syntax 23))))))
+      'replace)
+    (for-each
+      delete-file
+      '("testfile-ewl1.so" "testfile-ewl2.so" "testfile-ewl3.so" "testfile-ewl4.so"
+         "testfile-ewl5.so" "testfile-ewl6.so"))
+    #t)
+ ; loading testfile-ewlx.ss did not define library (testfile-ewlx)
+  (error? (let ([x 55]) (import (testfile-ewl1)) x))
+  (error? (let ([x 55]) (import (testfile-ewl3)) x))
+  (error? (let ([x 55]) (import (testfile-ewl4)) x))
+  (error? (let ([x 55]) (import (testfile-ewl5)) x))
+  (error? (let ([x 55]) (import (testfile-ewl6)) x))
+  (begin
+    (for-each separate-compile '(ewl1 ewl2 ewl3 ewl4 ewl5 ewl6))
+    (for-each load-library
+      '("testfile-ewl1.so" "testfile-ewl2.so" "testfile-ewl3.so" "testfile-ewl4.so"
+         "testfile-ewl5.so" "testfile-ewl6.so"))
+    #t)
+ ; loading testfile-ewlx.so did not define library (testfile-ewlx)
+ ; actually "testfile-ewlx.ss did not ..." (ss rather than so)
+ ;   now that load-library reloads source when dependency changes
+  (error? (let ([x 55]) (import (testfile-ewl1)) x))
+  (error? (let ([x 55]) (import (testfile-ewl2)) x))
+  (error? (let ([x 55]) (import (testfile-ewl6)) x))
+  (begin
+    (load-library "testfile-ewl2.ss")
+    (compile-library "testfile-ewl6")
+    #t)
+  (eqv? (let ([x 55]) (import (testfile-ewl2)) x) 23)
+  (eqv? (let ([x 55]) (import (testfile-ewl3)) x) 23)
+  (eqv? (let ([x 55]) (import (testfile-ewl4)) x) 23)
+  (eqv? (let ([x 55]) (import (testfile-ewl5)) x) 23)
+  (eqv? (let ([x 55]) (import (testfile-ewl6)) x) 23)
+)
+
+(mat library-directories
+  (error? ; invalid argument
+    (library-directories '("a" . hello)))
+  (error? ; invalid argument
+    (library-directories '("a" . ("src" . "obj"))))
+  (error? ; invalid argument
+    (library-directories '("a" . (("src")))))
+  (error? ; invalid argument
+    (library-directories '("a" . (("src" "obj")))))
+  (error? ; invalid argument
+    (library-directories '("a" . ((("src" "obj"))))))
+  (let ([x (library-directories)])
+    (and (list? x)
+         (andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x)))
+  (if (windows?)
+      (parameterize ([library-directories "a1;boo;c:/;dxxy"])
+        (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo") ("c:/" . "c:/") ("dxxy" . "dxxy"))))
+      (parameterize ([library-directories "a1:boo:c;/:dxxy"])
+        (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo") ("c;/" . "c;/") ("dxxy" . "dxxy")))))
+  (if (windows?)
+      (parameterize ([library-directories "a1;boo;;boo-obj;c:/;;dxxy"])
+        (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo-obj") ("c:/" . "dxxy"))))
+      (parameterize ([library-directories "a1:boo::boo-obj:c;/::dxxy"])
+        (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo-obj") ("c;/" . "dxxy")))))
+  (let ([default (library-directories)])
+    (if (windows?)
+        (parameterize ([library-directories "a1;boo;c:/;dxxy;"])
+          (equal? (library-directories) `(,@'(("a1" . "a1") ("boo" . "boo") ("c:/" . "c:/") ("dxxy" . "dxxy")) ,@default)))
+        (parameterize ([library-directories "a1:boo:c;/:dxxy:"])
+          (equal? (library-directories) `(,@'(("a1" . "a1") ("boo" . "boo") ("c;/" . "c;/") ("dxxy" . "dxxy")) ,@default)))))
+  (begin
+    (with-output-to-file "testfile-ld1.ss"
+      (lambda ()
+        (pretty-print
+          `(library (,(string->symbol (cd)) testfile-ld1)
+             (export x)
+             (import (rnrs))
+             (define-syntax x (identifier-syntax 23)))))
+      'replace)
+    #t)
+  (error? ; library not found
+    (parameterize ([library-directories '()])
+      (eval `(lambda () (import (testfile-ld1)) x))))
+  (eqv?
+    ((parameterize ([library-directories '()])
+       (eval `(lambda () (import (,(string->symbol (cd)) testfile-ld1)) x))))
+    23)
+)
+
+(mat library-extensions
+  (error? ; invalid argument
+    (library-extensions '.a1.sls))
+  (error? ; invalid argument
+    (library-extensions '((".foo"))))
+  (error? ; invalid argument
+    (library-extensions '((".foo" ".bar"))))
+  (error? ; invalid argument
+    (library-extensions '(((".junk")))))
+  (let ([x (library-extensions)])
+    (and (list? x)
+         (andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x)))
+  (if (windows?)
+      (parameterize ([library-extensions ".a1.sls;.boo;.crud;.junk"])
+        (equal? (library-extensions) '((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so"))))
+      (parameterize ([library-extensions ".a1.sls:.boo:.crud:.junk"])
+        (equal? (library-extensions) '((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so")))))
+  (let ([default (library-extensions)])
+    (if (windows?)
+        (parameterize ([library-extensions ".a1.sls;.boo;.crud;.junk;"])
+          (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so")) ,@default)))
+        (parameterize ([library-extensions ".a1.sls:.boo:.crud:.junk:"])
+          (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so")) ,@default)))))
+  (let ([default (library-extensions)])
+    (if (windows?)
+        (parameterize ([library-extensions ".a1.sls;.boo;;.booso;.crud;;.junk;"])
+          (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".booso") (".crud" . ".junk")) ,@default)))
+        (parameterize ([library-extensions ".a1.sls:.boo::.booso:.crud::.junk:"])
+          (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".booso") (".crud" . ".junk")) ,@default)))))
+)
+
+(mat library-search-handler
+  (procedure? (library-search-handler))
+  (eq? (library-search-handler) default-library-search-handler)
+  (error? (default-library-search-handler "not-symbol" '(lib) '() '()))
+  (error? (default-library-search-handler 'import 'bad-library-name '() '()))
+  (error? (default-library-search-handler 'import '(lib) '(("invalid" "path" "list")) '()))
+  (error? (default-library-search-handler 'import '(lib) '(("foo" . "bar")) '(("bad") ("extensions"))))
+  (error?
+   (parameterize ([library-search-handler
+                   (lambda (who path dir* all-ext*)
+                     (values '(bad source path) #f #f))])
+     (eval '(import (foo)))))
+  (error?
+   (parameterize ([library-search-handler
+                   (lambda (who path dir* all-ext*)
+                     (values #f '(bad object path) #f))])
+     (eval '(import (foo)))))
+  (error?
+   (parameterize ([library-search-handler
+                   (lambda (who path dir* all-ext*)
+                     (values #f #f #t))])
+     (eval '(import (foo)))))
+  (begin
+    (mkdir "lsh-testdir")
+    (mkdir "lsh-testdir/src1")
+    (mkdir "lsh-testdir/src2")
+    (mkdir "lsh-testdir/obj")
+    #t)
+  (begin
+    (with-output-to-file "lsh-testdir/src1/lib.ss"
+      (lambda ()
+        (pretty-print
+         '(library (lib) (export a) (import (scheme))
+            (define a "src1 provided this a"))))
+      'replace)
+    (with-output-to-file "lsh-testdir/src2/lib.ss"
+      (lambda ()
+        (pretty-print
+         '(library (lib) (export a) (import (scheme))
+            (define a "a from src2"))))
+      'replace)
+    (with-output-to-file "lsh-testdir/src2/foo.ss"
+      (lambda ()
+        (pretty-print
+         '(library (foo) (export a) (import (scheme) (lib)))))
+      'replace)
+    (parameterize ([generate-wpo-files #t]
+                   [compile-imported-libraries #t]
+                   [library-directories '(("src2" . "obj"))])
+      (compile-file "lsh-testdir/src2/lib.ss" "lsh-testdir/obj/lib.so")
+      (compile-file "lsh-testdir/src2/foo.ss" "lsh-testdir/obj/foo.so"))
+    #t)
+  (equal?
+   "a from src2\n"
+   (separate-eval
+    '(cd "lsh-testdir")
+    '(library-extensions '((".ss" . ".so")))
+    '(library-directories '(("src2" . "obj") ("src1" . "obj")))
+    '(library-search-handler
+      (lambda (who path dir* all-ext*)
+        (let-values ([(src-path obj-path obj-exists?)
+                      (default-library-search-handler who path dir* all-ext*)])
+          (assert (equal? src-path "src2/lib.ss"))
+          (assert (equal? obj-path "obj/lib.so"))
+          (assert obj-exists?)
+          (values src-path obj-path obj-exists?))))
+    '(printf "~a\n" (let () (import (lib)) a))))
+  (equal?
+   "src1 provided this a\n"
+   (separate-eval
+    '(cd "lsh-testdir")
+    '(library-extensions '((".ss" . ".so")))
+    '(library-directories '(("src2" . "obj") ("src1" . "obj")))
+    '(library-search-handler
+      (lambda (who path dir* all-ext*)
+        (assert (eq? who 'import))
+        (assert (equal? path '(lib)))
+        (assert (equal? dir* (library-directories)))
+        (assert (equal? all-ext* (library-extensions)))
+        ;; switcheroo
+        (values "src1/lib.ss" #f #f)))
+    '(printf "~a\n" (let () (import (lib)) a))))
+  (equal?
+   (string-append
+    "compiling src1/lib.ss with output to obj/lib-compiled.so\n"
+    "src1 provided this a\n")
+   (separate-eval
+    '(cd "lsh-testdir")
+    '(compile-imported-libraries #t)
+    '(library-search-handler
+      (lambda (who path dir* all-ext*)
+        (values "src1/lib.ss" "obj/lib-compiled.so" #f)))
+    '(printf "~a\n" (let () (import (lib)) a))))
+  ;; the default library-search-handler finds obj/lib.wpo
+  ;; so no libraries are needed at run time
+  (equal?
+    "()\n"
+   (separate-eval
+    '(cd "lsh-testdir")
+    '(library-extensions '((".ss" . ".so")))
+    '(library-directories '(("src1" . "obj") ("src2" . "obj")))
+    '(compile-whole-library "obj/foo.wpo" "foo.library")))
+  (equal?
+   "((lib))\n"
+   (separate-eval
+    '(cd "lsh-testdir")
+    '(library-extensions '((".ss" . ".so")))
+    '(library-directories '(("src1" . "obj") ("src2" . "obj")))
+    '(define (check who path dir*)
+       (assert (eq? who 'compile-whole-library))
+       (assert (equal? path '(lib)))
+       (assert (equal? dir* (library-directories))))
+    '(library-search-handler
+      (lambda (who path dir* all-ext*)
+        (check who path dir*)
+        (assert (equal? all-ext* '((".ss" . ".wpo"))))
+        ;; default search finds the wpo file, but ...
+        (let-values ([(src-path obj-path obj-exists?)
+                      (default-library-search-handler who path dir* all-ext*)])
+          ;; user reordered library-directories since compiling the wpo file
+          (assert (equal? src-path "src1/lib.ss"))
+          (assert (equal? obj-path "obj/lib.wpo"))
+          (assert obj-exists?))
+        ;; ... we install a new handler that returns the object file instead
+        (library-search-handler
+         (lambda (who path dir* all-ext*)
+           (check who path dir*)
+           (assert (equal? all-ext* (library-extensions)))
+           (values #f "obj/lib.so" #t)))
+        ;; ... and report no .wpo file found so we fall back to the
+        ;; library-search-handler just installed
+        (values #f #f #f)))
+    '(compile-whole-library "obj/foo.wpo" "foo.library")))
+  (begin
+    (rm-rf "lsh-testdir")
+    #t)
+)
+
+(mat compile-imported-libraries
+  (not (compile-imported-libraries))
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (define $cil '())
+    (with-output-to-file "testdir/cil1.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil1 $cil))))
+        (pretty-print
+          '(library (testdir cil1) (export a) (import (rnrs))
+             (define x 57388321)
+             (define-syntax a (lambda (q) #'x)))))
+      'replace)
+    (with-output-to-file "testdir/cil2.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil2 $cil))))
+        (pretty-print
+          '(library (testdir cil2) (export a b f get-y) (import (rnrs) (testdir cil1))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil2)))
+        (pretty-print '(f (cons (b) a))))
+      'replace)
+    #t)
+  (equal?
+    (parameterize ([compile-imported-libraries #t]
+                   [compile-file-message #f]
+                   [compile-library-handler
+                    (lambda args
+                      (printf "hello!\n")
+                      (flush-output-port)
+                      (apply compile-library args)
+                      (printf "goodbye.\n")
+                      (flush-output-port))])
+      (with-output-to-string
+        (lambda ()
+          (load-program "testdir/cil"))))
+    "hello!\nhello!\ngoodbye.\ngoodbye.\n")
+  (file-exists? "testdir/cil1.so")
+  (file-exists? "testdir/cil2.so")
+  (equal? $cil '(cil1 cil2))
+  (equal? (let () (import (testdir cil2)) (get-y)) '((57388321) . 57388321)) 
+  (equal? (let () (import (testdir cil2)) (f 772) (get-y)) 772)
+  (eq?
+    (parameterize ([compile-imported-libraries #t])
+      (load-program "testdir/cil"))
+    (void))
+  (equal? (let () (import (testdir cil2)) (get-y)) '((57388321) . 57388321)) 
+  (equal? $cil '(cil1 cil2))
+  (begin
+    (rm-rf "testdir")
+    #t)
+ ; once again with extension .ss, to see if position in library-extensions list matters
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (define $cil '())
+    (with-output-to-file "testdir/cil3.ss"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil3 $cil))))
+        (pretty-print
+          '(library (testdir cil3) (export a) (import (rnrs))
+             (define x 57388321)
+             (define-syntax a (lambda (q) #'x)))))
+      'replace)
+    (with-output-to-file "testdir/cil4.ss"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil4 $cil))))
+        (pretty-print
+          '(library (testdir cil4) (export a b f get-y) (import (rnrs) (testdir cil3))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil4)))
+        (pretty-print '(f (cons (b) a))))
+      'replace)
+    #t)
+  (eq?
+    (parameterize ([compile-imported-libraries #t])
+      (load-program "testdir/cil"))
+    (void))
+  (file-exists? "testdir/cil3.so")
+  (file-exists? "testdir/cil4.so")
+  (equal? $cil '(cil3 cil4))
+  (equal? (let () (import (testdir cil4)) (get-y)) '((57388321) . 57388321)) 
+  (equal? (let () (import (testdir cil4)) (f 772) (get-y)) 772)
+  (eq?
+    (parameterize ([compile-imported-libraries #t])
+      (load-program "testdir/cil"))
+    (void))
+  (equal? (let () (import (testdir cil4)) (get-y)) '((57388321) . 57388321)) 
+  (equal? $cil '(cil3 cil4))
+  (begin
+    (rm-rf "testdir")
+    (rm-rf "objdir")
+    #t)
+ ; try again with different library-directories and library-extensions
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (define $cil '())
+    (with-output-to-file "testdir/cil5.ss"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil5 $cil))))
+        (pretty-print
+          '(library (testdir cil5) (export a) (import (rnrs))
+             (define x 57388321)
+             (define-syntax a (lambda (q) #'x)))))
+      'replace)
+    (with-output-to-file "testdir/cil6.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil6 $cil))))
+        (pretty-print
+          '(library (testdir cil6) (export a b f get-y) (import (rnrs) (testdir cil5))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil6)))
+        (pretty-print '(f (cons (b) a))))
+      'replace)
+    #t)
+  (eq?
+    (parameterize ([compile-imported-libraries #t]
+                   [library-directories '(("." . "objdir"))]
+                   [library-extensions '((".sls" . ".bar") (".ss" . ".foo"))])
+      (load-program "testdir/cil"))
+    (void))
+  (file-exists? "objdir/testdir/cil5.foo")
+  (file-exists? "objdir/testdir/cil6.bar")
+  (equal? $cil '(cil5 cil6))
+  (equal? (let () (import (testdir cil6)) (get-y)) '((57388321) . 57388321)) 
+  (equal? (let () (import (testdir cil6)) (f 772) (get-y)) 772)
+  (eq?
+    (parameterize ([compile-imported-libraries #t]
+                   [library-directories '(("." . "objdir"))]
+                   [library-extensions '((".sls" . ".bar") (".ss" . ".foo"))])
+      (load-program "testdir/cil"))
+    (void))
+  (equal? (let () (import (testdir cil6)) (get-y)) '((57388321) . 57388321)) 
+  (equal? $cil '(cil5 cil6))
+  (begin
+    (rm-rf "testdir")
+    (rm-rf "objdir")
+    #t)
+ ; what if we compile explicitly first?
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (define $cil '())
+    (with-output-to-file "testdir/cil7.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil7 $cil))))
+        (pretty-print
+          '(library (testdir cil7) (export a) (import (rnrs))
+             (define x 57388321)
+             (define-syntax a (lambda (q) #'x)))))
+      'replace)
+    (with-output-to-file "testdir/cil8.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil8 $cil))))
+        (pretty-print
+          '(library (testdir cil8) (export a b f get-y) (import (rnrs) (testdir cil7))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil8)))
+        (pretty-print '(f (cons (b) a))))
+      'replace)
+    (compile-library "testdir/cil7.sls")
+    (compile-library "testdir/cil8.sls")
+    #t)
+  (file-exists? "testdir/cil7.so")
+  (file-exists? "testdir/cil8.so")
+  (equal? $cil '(cil8 cil7))
+  (eq?
+    (parameterize ([compile-imported-libraries #t])
+      (load-program "testdir/cil"))
+    (void))
+  (equal? $cil '(cil8 cil7))
+  (equal? (let () (import (testdir cil8)) (get-y)) '((57388321) . 57388321)) 
+  (begin
+    (rm-rf "testdir")
+    #t)
+ ; what if we compile ahead of time, and put .so in library extensions?
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (define $cil '())
+    (with-output-to-file "testdir/cil9.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil9 $cil))))
+        (pretty-print
+          '(library (testdir cil9) (export a) (import (rnrs))
+             (define x 57388321)
+             (define-syntax a (lambda (q) #'x)))))
+      'replace)
+    (with-output-to-file "testdir/cil10.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil10 $cil))))
+        (pretty-print
+          '(library (testdir cil10) (export a b f get-y) (import (rnrs) (testdir cil9))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil10)))
+        (pretty-print '(f (cons (b) a))))
+      'replace)
+    (compile-library "testdir/cil9.sls")
+    (compile-library "testdir/cil10.sls")
+    #t)
+  (file-exists? "testdir/cil9.so")
+  (file-exists? "testdir/cil10.so")
+  (equal? $cil '(cil10 cil9))
+  (eq?
+    (parameterize ([compile-imported-libraries #t]
+                   [library-extensions (cons ".so" (library-extensions))])
+      (load-program "testdir/cil"))
+    (void))
+  (equal? $cil '(cil10 cil9))
+  (equal? (let () (import (testdir cil10)) (get-y)) '((57388321) . 57388321)) 
+  (begin
+    (rm-rf "testdir")
+    #t)
+ ; separate compilation
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (define $cil '())
+    (with-output-to-file "testdir/cil11.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil11 $cil))))
+        (pretty-print
+          '(library (testdir cil11) (export a) (import (rnrs))
+             (define x 57388321)
+             (define-syntax a (lambda (q) #'x)))))
+      'replace)
+    (with-output-to-file "testdir/cil12.sls"
+      (lambda ()
+        (pretty-print '(eval-when (compile) (set! $cil (cons 'cil12 $cil))))
+        (pretty-print
+          '(library (testdir cil12) (export a b f get-y) (import (rnrs) (testdir cil11))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil.ss"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil12)))
+        (pretty-print '(f (cons (b) a))))
+      'replace)
+    #t)
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (set! $cil '())
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      "testdir/cil")
+    #t)
+  (file-exists? "testdir/cil.so")
+  (file-exists? "testdir/cil11.so")
+  (file-exists? "testdir/cil12.so")
+  (equal? $cil '())
+  (equal? (let () (import (testdir cil11)) a) 57388321)
+  (eq?
+    (parameterize ([compile-imported-libraries #t])
+      (load-program "testdir/cil.so"))
+    (void))
+  (equal? (let () (import (testdir cil12)) (get-y)) '((57388321) . 57388321)) 
+  (equal? $cil '())
+  (begin
+    (rm-rf "testdir")
+    #t)
+ ; test auto recompilation if dependency is recompiled
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (with-output-to-file "testdir/cil13.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil13) (export a x) (import (rnrs))
+             (define x 73)
+             (define-syntax a (lambda (q) #'(+ x 6))))))
+      'replace)
+    (with-output-to-file "testdir/cil14.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil14) (export a b f get-y) (import (rnrs) (testdir cil13))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a x)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil-a.ss"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil14)))
+        (pretty-print '(f (cons (b) a)))
+        (pretty-print '(display (get-y))))
+      'replace)
+    (with-output-to-file "testdir/cil15.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil15) (export a x) (import (rnrs))
+             (define x 73)
+             (define-syntax a (lambda (q) #'(+ x 6))))))
+      'replace)
+    (with-output-to-file "testdir/cil16.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil16) (export a b f get-y) (import (rnrs) (testdir cil15))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a x)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil-b.ss"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil16)))
+        (pretty-print '(f (cons (b) a)))
+        (pretty-print '(display (get-y))))
+      'replace)
+    (with-output-to-file "testdir/cil17.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil17) (export a x) (import (rnrs))
+             (define x 73)
+             (define-syntax a (lambda (q) #'(+ x 6))))))
+      'replace)
+    (with-output-to-file "testdir/cil18.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil18) (export a b f get-y) (import (rnrs) (testdir cil17))
+             (define y #f)
+             (define get-y (lambda () y))
+             (define b (lambda () (list a x)))
+             (define f (lambda (v) (set! y v))))))
+      'replace)
+    (with-output-to-file "testdir/cil-c.ss"
+      (lambda ()
+        (display "#! /usr/bin/env scheme-script\n")
+        (pretty-print '(import (rnrs) (testdir cil18)))
+        (pretty-print '(f (cons (b) a)))
+        (pretty-print '(display (get-y))))
+      'replace)
+    #t)
+ ; compile 'em all in a separate process
+  (begin
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      "testdir/cil-a")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      "testdir/cil-b")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      "testdir/cil-c")
+    #t)
+  (file-exists? "testdir/cil-a.so")
+  (file-exists? "testdir/cil13.so")
+  (file-exists? "testdir/cil14.so")
+  (file-exists? "testdir/cil-b.so")
+  (file-exists? "testdir/cil15.so")
+  (file-exists? "testdir/cil16.so")
+  (file-exists? "testdir/cil-c.so")
+  (file-exists? "testdir/cil13.so")
+  (file-exists? "testdir/cil14.so")
+ ; can't test programs' output here, since we don't want
+ ; to load the libraries until after the next step
+ ; now delete object file or modify source file and recompile
+  (begin
+   ; ensure a different time stamp
+    (delete-file "testdir/cil13.so")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      "testdir/cil-a")
+    (sleep (make-time 'time-duration 0 1))
+    (with-output-to-file "testdir/cil15.sls"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil15) (export a x) (import (rnrs))
+             (define x -73)
+             (define-syntax a (lambda (q) #'(+ x 6))))))
+      'replace)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #t])
+           (compile-program x)))
+      "testdir/cil-b")
+    (delete-file "testdir/cil17.so")
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-imported-libraries #f]) ; #f here rather than #t should cause failure
+           (compile-program x)))
+      "testdir/cil-c")
+    #t)
+  (file-exists? "testdir/cil-a.so")
+  (file-exists? "testdir/cil13.so")
+  (file-exists? "testdir/cil14.so")
+  (file-exists? "testdir/cil-b.so")
+  (file-exists? "testdir/cil15.so")
+  (file-exists? "testdir/cil16.so")
+  ; testdir/cil-c.so exists now that load-library reloads source when dependency changes
+  (file-exists? "testdir/cil-c.so")
+  (file-exists? "testdir/cil13.so")
+  (file-exists? "testdir/cil14.so")
+  (file-exists? "testdir/cil-a.so")
+  (file-exists? "testdir/cil13.so")
+  (file-exists? "testdir/cil14.so")
+ ; now test programs' output
+  (equal?
+    (with-output-to-string
+      (lambda () (load-program "testdir/cil-a.so")))
+    "((79 73) . 79)")
+  (equal?
+    (with-output-to-string
+      (lambda () (load-program "testdir/cil-b.so")))
+    "((-67 -73) . -67)")
+  (begin
+    (rm-rf "testdir")
+    #t)
+  ; ---------------------------------------------------------------
+  (begin
+    (mkdir "testdir")
+    #t)
+  (begin
+    (with-output-to-file "testdir/cil19A.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil19A)
+             (export x)
+             (import (chezscheme))
+             (define x (make-parameter 13)))))
+      'replace)
+    (with-output-to-file "testdir/cil19B.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil19B)
+             (export y)
+             (import (chezscheme))
+            ; importing from within RHS to make sure RHS imports are tracked
+             (define y (make-parameter (let () (import (testdir cil19A)) (+ (x) 5)))))))
+      'replace)
+    (with-output-to-file "testdir/cil19C.ss"
+      (lambda ()
+        (pretty-print
+          '(import (chezscheme) (testdir cil19B)))
+        (pretty-print
+          '(pretty-print (y))))
+      'replace)
+    #t)
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "compiling testdir/cil19B.ss with output to testdir/cil19B.so\ncompiling testdir/cil19A.ss with output to testdir/cil19A.so\n18\n")
+  (file-exists? "testdir/cil19A.so")
+  (file-exists? "testdir/cil19B.so")
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "18\n")
+ ; now add an include file
+  (begin
+    (sleep (make-time 'time-duration 0 1))
+    (with-output-to-file "testdir/cil19A1.ss"
+      (lambda ()
+        (pretty-print
+          '(define x (make-parameter 19))))
+      'replace)
+    (with-output-to-file "testdir/cil19A.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testdir cil19A)
+             (export x)
+             (import (chezscheme))
+             (include "cil19A1.ss"))))
+      'replace)
+    #t)
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "compiling testdir/cil19A.ss with output to testdir/cil19A.so\ncompiling testdir/cil19B.ss with output to testdir/cil19B.so\n24\n")
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "24\n")
+ ; now change first include file to include a second
+  (begin
+    (sleep (make-time 'time-duration 0 1))
+    (with-output-to-file "testdir/cil19A2.ss"
+      (lambda ()
+        (pretty-print
+          '(define x (make-parameter 23))))
+      'replace)
+    (with-output-to-file "testdir/cil19A1.ss"
+      (lambda ()
+        (pretty-print
+          '(include "cil19A2.ss")))
+      'replace)
+    #t)
+  ; load w/compile-imported-libraries #f---should get old result
+  ; not longer now that load-library reloads source when dependency changes
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #f)
+      '(load-program "testdir/cil19C.ss"))
+    "28\n"
+    #;"24\n")
+  ; should get new result with compile-imported-libraries #t
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "compiling testdir/cil19A.ss with output to testdir/cil19A.so\ncompiling testdir/cil19B.ss with output to testdir/cil19B.so\n28\n")
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "28\n")
+ ; now change second include file
+  (begin
+    (sleep (make-time 'time-duration 0 1))
+    (with-output-to-file "testdir/cil19A2.ss"
+      (lambda ()
+        (pretty-print
+          '(define x (make-parameter 31))))
+      'replace)
+    #t)
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "compiling testdir/cil19A.ss with output to testdir/cil19A.so\ncompiling testdir/cil19B.ss with output to testdir/cil19B.so\n36\n")
+  (equal?
+    (separate-eval
+      '(compile-imported-libraries #t)
+      '(load-program "testdir/cil19C.ss"))
+    "36\n")
+  (begin
+    (rm-rf "testdir")
+    #t)
+)
+
+(mat import-notify
+  (eq? (import-notify 'yes) (void))
+  (eq? (import-notify) #t)
+  (begin
+    (with-output-to-file "testfile-imno1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-imno1) (export x) (import (rnrs))
+             (define x -73))))
+      'replace)
+    (with-output-to-file "testfile-imno2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-imno2) (export y) (import (rnrs) (testfile-imno1))
+             (define y (+ x x)))))
+      'replace)
+    (separate-compile 'imno1)
+    #t)
+  (equal?
+    (parameterize ([source-directories '(".")]
+                   [library-directories '(".")]
+                   [console-output-port (open-output-string)])
+      (eval '(lambda () (import (testfile-imno2)) y))
+      (get-output-string (console-output-port)))
+    "import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: visiting object file \"testfile-imno1.so\"\nattempting to 'revisit' previously 'visited' \"testfile-imno1.so\" for library (testfile-imno1) run-time info\n")
+  (eq? (import-notify #f) (void))
+)
+
+(mat rnrs-libraries
+  (equal?
+    (let ([cons void])
+      (let () (import (rnrs base)) (cons 3 4)))
+    '(3 . 4))
+)
+
+(mat top-level-program
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (eval '(top-level-program (import (scheme))
+                 (define-syntax a (identifier-syntax (cons x y)))
+                 (define x 55)
+                 (printf "x = ~s\n" x)
+                 (define y 'yyy)
+                 (printf "(a x y) = ~s\n" (list a x y))))))
+    "x = 55\n(a x y) = ((55 . yyy) 55 yyy)\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (with-output-to-file "testfile-tlp1.ss"
+          (lambda ()
+            (pretty-print
+              '(library (testfile-tlp1) (export $tlp-x $tlp-y) (import (scheme))
+                 (define-syntax $tlp-y
+                   (begin
+                     (printf "visiting tlp1\n")
+                     (identifier-syntax (cons ($tlp-x) (z)))))
+                 (define z (make-parameter 'zzz))
+                 (define $tlp-x (make-parameter 'xxx))
+                 (printf "invoking tlp1\n"))))
+          'replace)
+        (with-output-to-file "testfile-tlp.ss"
+          (lambda ()
+            (pretty-print
+              '(top-level-program (import (testfile-tlp1) (rnrs) (only (scheme) list printf))
+                 (define-syntax a (identifier-syntax (cons x y)))
+                 (define x ($tlp-x))
+                 (printf "x = ~s\n" x)
+                 (define y $tlp-y)
+                 (printf "(a x y) = ~s\n" (list a x y)))))
+          'replace)
+       ; compile in same Scheme process
+        (compile-file "testfile-tlp1")
+        (compile-file "testfile-tlp")))
+    "compiling testfile-tlp1.ss with output to testfile-tlp1.so\nvisiting tlp1\ncompiling testfile-tlp.ss with output to testfile-tlp.so\n")
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile-tlp.so")))
+    "invoking tlp1\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n")
+  (begin
+    (with-output-to-file "testfile-tlp2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-tlp2) (export $tlp-x $tlp-y) (import (scheme))
+             (define-syntax $tlp-y
+               (begin
+                 (printf "visiting tlp2\n")
+                 (identifier-syntax (cons ($tlp-x) z))))
+             (define z 'zzz)
+             (define $tlp-x (make-parameter 'xxx))
+             (printf "invoking tlp2\n"))))
+      'replace)
+    (with-output-to-file "testfile-tlp.ss"
+      (lambda ()
+        (pretty-print
+          '(top-level-program (import (testfile-tlp2) (rnrs) (only (scheme) list printf))
+             (define-syntax a (identifier-syntax (cons x y)))
+             (define x ($tlp-x))
+             (printf "x = ~s\n" x)
+             (define y $tlp-y)
+             (printf "(a x y) = ~s\n" (list a x y)))))
+      'replace)
+    (for-each separate-compile '(tlp2 tlp))
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda () (load "testfile-tlp.so")))
+    "invoking tlp2\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n")
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (rnrs))
+            (define x 0)
+            (define (inc v) (set! x (+ x v)) x)
+            (if (inc 3)))))
+      'replace)
+    #t)
+  (error? ; invalid syntax (if (inc 3)) at [not near] line 4, char 1
+    (load-program "testfile.ss"))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (with-output-to-file "testfile-tlp1.ss"
+          (lambda ()
+            (pretty-print
+              '(library (testfile-tlp1) (export $tlp-x $tlp-y) (import (scheme))
+                 (define-syntax $tlp-y
+                   (begin
+                     (printf "visiting tlp1\n")
+                     (identifier-syntax (cons ($tlp-x) (z)))))
+                 (define z (make-parameter 'zzz))
+                 (define $tlp-x (make-parameter 'xxx))
+                 (printf "invoking tlp1\n"))))
+          'replace)
+        (with-output-to-file "testfile-tlp.ss"
+          (lambda ()
+            (for-each pretty-print
+              '((import (testfile-tlp1) (rnrs) (only (scheme) list printf))
+                (define-syntax a (identifier-syntax (cons x y)))
+                (define x ($tlp-x))
+                (printf "x = ~s\n" x)
+                (define y $tlp-y)
+                (printf "(a x y) = ~s\n" (list a x y)))))
+          'replace)
+       ; compile in same Scheme process
+        (compile-library "testfile-tlp1")
+        (compile-program "testfile-tlp")))
+    "compiling testfile-tlp1.ss with output to testfile-tlp1.so\nvisiting tlp1\ncompiling testfile-tlp.ss with output to testfile-tlp.so\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-library "testfile-tlp1.so")))
+    "")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-program "testfile-tlp.so")))
+    "invoking tlp1\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n")
+ ; load again from source
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-library "testfile-tlp1.ss")))
+    "visiting tlp1\n")
+  (error? ; wrong version of testfile-tlp1
+    (load-program "testfile-tlp.so"))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-program "testfile-tlp.ss")))
+    "invoking tlp1\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n")
+  (begin
+    (delete-file "testfile-tlp1.so")
+    (delete-file "testfile-tlp.so")
+    #t)
+  (begin
+    (with-output-to-file "testfile-tlp1.ss"
+      (lambda ()
+        (parameterize ([print-vector-length #t])
+          (pretty-print
+            '(library (testfile-tlp1) (export $tlp-z) (import (chezscheme))
+               (define $tlp-z '#3(1 2))))))
+      'replace)
+    (with-output-to-file "testfile-tlp.ss"
+      (lambda ()
+        (parameterize ([print-vector-length #t])
+          (for-each pretty-print
+            '((import (testfile-tlp1) (chezscheme))
+              (pretty-print (equal? $tlp-z '#3(1 2)))))))
+      'replace)
+    #t)
+  (error? ; nonstandard vector-length syntax
+    (compile-library "testfile-tlp1"))
+  (error? ; nonstandard vector-length syntax
+    (compile-program "testfile-tlp"))
+  (error? ; nonstandard vector-length syntax
+    (load-library "testfile-tlp1.ss"))
+  (error? ; nonstandard vector-length syntax
+    (load-program "testfile-tlp.ss"))
+  (begin
+    (with-output-to-file "testfile-tlp1.ss"
+      (lambda ()
+        (display "#!chezscheme\n")
+        (parameterize ([print-vector-length #t])
+          (pretty-print
+            '(library (testfile-tlp1) (export $tlp-z) (import (chezscheme))
+               (define $tlp-z '#3(1 2))))))
+      'replace)
+    (with-output-to-file "testfile-tlp.ss"
+      (lambda ()
+        (display "#!chezscheme\n")
+        (parameterize ([print-vector-length #t])
+          (for-each pretty-print
+            '((import (testfile-tlp1) (chezscheme))
+              (pretty-print (equal? $tlp-z '#3(1 2)))))))
+      'replace)
+    #t)
+  (equal?
+    (begin
+      (compile-library "testfile-tlp1")
+      (compile-program "testfile-tlp")
+      (with-output-to-string
+        (lambda ()
+          (load-library "testfile-tlp1.so")
+          (load-program "testfile-tlp.so"))))
+    "#t\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (load-library "testfile-tlp1.ss")
+        (load-program "testfile-tlp.ss")))
+    "#t\n")
+ ; test to make sure compiled top-level-program doesn't try to
+ ; load libraries upon which it should not depend
+  (equal?
+    (begin
+      (with-output-to-file "testfile-tlp3.ss"
+        (lambda ()
+          (pretty-print 
+            '(library (testfile-tlp3)
+               (export t1-x)
+               (import (chezscheme))
+               (define t1-x 332211))))
+        'replace)
+      (with-output-to-file "testfile-tlp4.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-tlp4)
+               (export t2-q)
+               (import (chezscheme) (testfile-tlp3))
+               (define-syntax t2-q (lambda (x) t1-x)))))
+        'replace)
+      (with-output-to-file "testfile-tlp5.ss"
+        (lambda ()
+          (pretty-print '(import (chezscheme) (testfile-tlp4)))
+          (pretty-print '(pretty-print t2-q)))
+        'replace)
+      (separate-compile 'compile-library 'tlp3)
+      (separate-compile 'compile-library 'tlp4)
+      (separate-compile 'compile-program 'tlp5)
+      (delete-file "testfile-tlp3.ss")
+      (delete-file "testfile-tlp4.ss")
+      (delete-file "testfile-tlp3.so")
+      (delete-file "testfile-tlp4.so")
+      (printf "loading testfile-tlp5.so\n")
+      (with-output-to-string
+        (lambda ()
+          (load-program "testfile-tlp5.so"))))
+    "332211\n")
+ ; check dependencies returned by compile-program
+  (equal?
+    (let ()
+      (define dep8)
+      (with-output-to-file "testfile-tlp6.ss"
+        (lambda ()
+          (pretty-print 
+            '(library (testfile-tlp6)
+               (export t1-x)
+               (import (chezscheme))
+               (define t1-x 332211))))
+        'replace)
+      (with-output-to-file "testfile-tlp7.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-tlp7)
+               (export t2-q)
+               (import (chezscheme) (testfile-tlp6))
+               (define-syntax t2-q (lambda (x) t1-x)))))
+        'replace)
+      (with-output-to-file "testfile-tlp8.ss"
+        (lambda ()
+          (pretty-print '(import (chezscheme) (testfile-tlp7)))
+          (pretty-print '(pretty-print t2-q)))
+        'replace)
+      (compile-library "testfile-tlp6")
+      (compile-library "testfile-tlp7")
+      (set! dep8 (compile-program "testfile-tlp8"))
+      (printf "loading testfile-tlp8.so\n")
+      (list
+        (with-output-to-string
+          (lambda ()
+            (load-program "testfile-tlp8.so")))
+        dep8))
+    '("332211\n" ()))
+ ; version of the above where program does depend on something
+  (equal?
+    (let ()
+      (define dep8)
+      (with-output-to-file "testfile-tlp9.ss"
+        (lambda ()
+          (pretty-print 
+            '(library (testfile-tlp9)
+               (export t1-x)
+               (import (chezscheme))
+               (define t1-x (make-parameter 332211)))))
+        'replace)
+      (with-output-to-file "testfile-tlp10.ss"
+        (lambda ()
+          (pretty-print
+            '(library (testfile-tlp10)
+               (export t2-q)
+               (import (chezscheme) (testfile-tlp9))
+               (define-syntax t2-q (identifier-syntax (t1-x))))))
+        'replace)
+      (with-output-to-file "testfile-tlp11.ss"
+        (lambda ()
+          (pretty-print '(import (chezscheme) (testfile-tlp10)))
+          (pretty-print '(pretty-print t2-q)))
+        'replace)
+     ; if we don't let the compilation happen implicitly, the filename
+     ; for (testfile-tlp9) doesn't get set
+      (parameterize ([compile-imported-libraries #t])
+        (set! dep8 (compile-program "testfile-tlp11")))
+      (printf "loading testfile-tlp11.so\n")
+      (list
+        (with-output-to-string
+          (lambda ()
+            (load-program "testfile-tlp11.so")))
+        dep8))
+    '("332211\n" ((testfile-tlp9))))
+  (equal? (library-object-filename '(testfile-tlp9)) "testfile-tlp9.so")
+ ; make sure internal module bindings are properly set up before
+ ; the body forms are processed
+  (begin
+    (top-level-program
+      (import (chezscheme))
+      (module ((a x))
+        (define x 3)
+        (define-syntax a (identifier-syntax x))
+        (putprop 'tlp-spam 'tlp 7))
+      a
+      (putprop 'tlp-spam 'spam a))
+    (and (eqv? (getprop 'tlp-spam 'spam) 3)
+         (eqv? (getprop 'tlp-spam 'tlp) 7)
+         (remprop 'tlp-spam 'spam)
+         (remprop 'tlp-spam 'tlp)
+         #t))
+  ; make sure we ignore return value(s) of interleaved init expressions
+  (equal?
+   (with-output-to-string
+     (lambda ()
+       ; prevent cp0 from fixing the problem
+       (parameterize ([run-cp0 (lambda (f x) x)])
+         (eval '(top-level-program (import (scheme))
+                  (define (f) (printf "hello\n") (values 1 2 3))
+                  (f)
+                  (define x 'world)
+                  (pretty-print x))))))
+   "hello\nworld\n")
+)
+
+(mat library-meta
+  (begin
+    (with-output-to-file "testfile-lm-a1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-lm-a1)
+             (export a)
+             (import (chezscheme))
+             (meta define a #'17))))
+      'replace)
+    (with-output-to-file "testfile-lm-a2.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-lm-a2)
+             (export b)
+             (import (chezscheme) (testfile-lm-a1))
+             (define-syntax b (lambda (q) a)))))
+      'replace)
+    (for-each separate-compile '(lm-a1 lm-a2))
+    #t)
+  (equal?
+    (let ()
+      (import (testfile-lm-a2))
+      b)
+    17)
+  (error? ; attempt to assign unbound variable
+    (let ()
+      (import (testfile-lm-a1))
+      (define-syntax b (lambda (q) (set! a (+ a 1)) a))))
+  ; test $visit-library
+  (begin
+    (with-output-to-file "testfile-lm-b1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-lm-b1)
+             (export a)
+             (import (chezscheme))
+             (meta define a #'17))))
+      'replace)
+    (with-output-to-file "testfile-lm-b2.ss"
+      (lambda ()
+        (pretty-print '(import (testfile-lm-b1)))
+        (pretty-print '(define-syntax b (lambda (q) a))))
+      'replace)
+    (for-each separate-compile '(lm-b1 lm-b2))
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (parameterize ([trace-output-port (current-output-port)])
+          (load "testfile-lm-b2.so"))))
+    "")
+  (eqv? b 17)
+)
+
+(mat library-introspection
+  (error? (library-exports 'foo))
+  (error? (library-exports '(1 2 3)))
+  (error? (library-exports '(probably not a valid loaded library)))
+  (error? (library-exports '(probably not a valid loaded library (2 3))))
+  (error? (library-exports '(rnrs (six))))
+  (error? (library-exports '(rnrs (1))))
+  (error? (library-version 'foo))
+  (error? (library-version '(1 2 3)))
+  (error? (library-version '(probably not a valid loaded library)))
+  (error? (library-version '(probably not a valid loaded library ((>= 0)))))
+  (error? (library-version '(rnrs (3 . 4))))
+  (error? (library-version '(rnrs (1))))
+  (error? (library-requirements 'foo))
+  (error? (library-requirements '(1 2 3)))
+  (error? (library-requirements '(probably not a valid loaded library)))
+  (error? (library-requirements '(probably not a valid loaded library (1))))
+  (error? (library-requirements '(rnrs (3.0))))
+  (error? (library-requirements '(rnrs (1))))
+  (error? (library-object-filename 'foo))
+  (error? (library-object-filename '(1 2 3)))
+  (error? (library-object-filename '(probably not a valid loaded library)))
+  (error? (library-object-filename '(probably not a valid loaded library (2 3))))
+  (error? (library-object-filename '(rnrs (six))))
+  (error? (library-object-filename '(rnrs (1))))
+
+  (error? (library-requirements 'foo (library-requirements-options)))
+  (error? (library-requirements '(1 2 3) (library-requirements-options)))
+  (error? (library-requirements '(probably not a valid loaded library) (library-requirements-options)))
+  (error? (library-requirements '(probably not a valid loaded library (1)) (library-requirements-options)))
+  (error? (library-requirements '(rnrs (3.0)) (library-requirements-options)))
+  (error? (library-requirements '(rnrs (1)) (library-requirements-options)))
+
+  (enum-set? (library-requirements-options))
+  (error? (library-requirements-options . a))
+  (error? (library-requirements-options spam))
+  (error? (library-requirements-options import spam))
+
+  (error? (library-requirements '(chezscheme) 'import))
+  (error? (library-requirements '(chezscheme) '(import)))
+  (error? (library-requirements '(chezscheme) '()))
+
+  (begin
+    (define set-equal?
+      (lambda (s1 s2)
+        (and (= (length s1) (length s2))
+             (andmap (lambda (x) (member x s2)) s1)
+             #t)))
+    #t)
+  (list? (library-list))
+  (andmap list? (library-list))
+  (andmap (lambda (x) (andmap symbol? x)) (library-list))
+  (begin
+    (library (null) (export) (import))
+    #t)
+  (let ([ls (library-list)])
+    (and
+      (member '(rnrs) ls)
+      (member '(rnrs strings) ls)
+      (member '(rnrs io ports) ls)
+      (member '(chezscheme) ls)
+      (member '(scheme) ls)
+      (member '(null) ls))
+      #t)
+  (null? (library-exports '(null)))
+  (set-equal?
+    (library-exports '(rnrs mutable-pairs))
+    '(set-car! set-cdr!))
+  (equal? (sort stringstring (library-exports '(scheme))))
+          (sort stringstring (library-exports '(chezscheme)))))
+  (equal? (library-version '(rnrs)) '(6))
+  (equal? (library-version '(rnrs (6))) '(6))
+  (equal? (library-version '(rnrs (or (6) (7)))) '(6))
+  (equal? (library-version '(rnrs (or (6) (7)))) '(6))
+  (equal? (library-version '(scheme)) '())
+  (equal? (library-requirements '(scheme)) '())
+  (equal? (library-requirements '(scheme) (library-requirements-options)) '())
+  (equal? (library-requirements '(scheme) (library-requirements-options import)) '())
+  (equal? (library-requirements '(scheme ())) '())
+  (equal? (library-requirements '(rnrs)) '())
+  (equal? (library-requirements '(null)) '())
+  (not (library-object-filename '(rnrs)))
+  (not (library-object-filename '(rnrs (6))))
+  (not (library-object-filename '(rnrs (or (6) (7)))))
+  (not (library-object-filename '(rnrs (or (6) (7)))))
+  (not (library-object-filename '(scheme)))
+  (begin
+    (library (li1 (3 4 5))
+      (export x y)
+      (import (chezscheme))
+      (define-syntax x (lambda (x) 3))
+      (define y (+ x 1)))
+    (library (li2 (7 2))
+      (export x z w)
+      (import (rnrs) (li1 (3)))
+      (define z (+ x y))
+      (define-syntax w (lambda (q) (* y 2))))
+    (library (li2a (7 2))
+      (export x z w)
+      (import (rnrs) (li1 (3)))
+      (define z (+ x x))
+      (define-syntax w (lambda (q) (* y 2))))
+    #t)
+  (and (member '(li1) (library-list))
+       (member '(li2) (library-list))
+       (member '(li2a) (library-list))
+       #t)
+  (equal? (library-version '(li1)) '(3 4 5))
+  (equal? (library-version '(li2)) '(7 2))
+  (equal? (library-version '(li2 ((>= 5)))) '(7 2))
+  (equal? (library-version '(li2 (7 (>= 1)))) '(7 2))
+  (error? (library-version '(li2 (6))))
+  (set-equal? (library-exports '(li1)) '(x y))
+  (set-equal? (library-exports '(li2)) '(x z w))
+  (set-equal? (library-exports '(li2 ((>= 5)))) '(x z w))
+  (set-equal? (library-exports '(li2 (7 (>= 1)))) '(x z w))
+  (error? (library-exports '(li2 (6))))
+  (not (library-object-filename '(li1)))
+  (not (library-object-filename '(li2)))
+  (not (library-object-filename '(li2 ((>= 5)))))
+  (not (library-object-filename '(li2 (7 (>= 1)))))
+  (error? (library-exports '(li2 (6))))
+  (set-equal?
+    (library-requirements '(li1))
+    '((chezscheme)))
+  (set-equal?
+    (library-requirements '(li2 ((>= 7))))
+    '((rnrs (6)) (li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2))
+    '((rnrs (6)) (li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2) (library-requirements-options import))
+    '((rnrs (6)) (li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2) (library-requirements-options visit@visit))
+    '())
+  (set-equal?
+    (library-requirements '(li2) (library-requirements-options invoke@visit))
+    '((li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2) (library-requirements-options invoke))
+    '((li1 (3 4 5))))
+  (error? (library-requirements '(li2 (6))))
+  (set-equal?
+    (library-requirements '(li2a))
+    '((rnrs (6)) (li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2a) (library-requirements-options import))
+    '((rnrs (6)) (li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2a) (library-requirements-options visit@visit))
+    '())
+  (set-equal?
+    (library-requirements '(li2a) (library-requirements-options invoke@visit))
+    '((li1 (3 4 5))))
+  (set-equal?
+    (library-requirements '(li2a) (library-requirements-options invoke))
+    '())
+  (equal?
+    (let ()
+      (import (li1) (li2))
+      (list x y z w))
+    '(3 4 7 8))
+ ; make sure requirements haven't changed just because we used the exports
+  (set-equal?
+    (library-requirements '(li1))
+    '((chezscheme)))
+  (set-equal?
+    (library-requirements '(li2))
+    '((rnrs (6)) (li1 (3 4 5))))
+  (begin
+    (define-syntax $li-a
+      (syntax-rules ()
+        [(_ name a p)
+         (begin
+           (library name (export a y) (import (rnrs))
+             (define-syntax a (identifier-syntax (cons y 1)))
+             (define y 'hello))
+           (define p (lambda () (import name) y)))]))
+    ($li-a ($li-spam) q $li-get-y)
+    #t)
+  (eq? ($li-get-y) 'hello)
+  (equal? (let () (import ($li-spam)) q) '(hello . 1))
+  (eqv? (let ([y 75]) (import ($li-spam)) y) 75)
+  (begin
+    (with-output-to-file "testfile-li3.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-li3)
+             (export x)
+             (import (rnrs))
+             (define x 3))))
+      'replace)
+    (with-output-to-file "testfile-li4.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-li4)
+             (export x)
+             (import (rnrs))
+             (define x 3))))
+      'replace)
+    (with-output-to-file "testfile-li5.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-li5)
+             (export x)
+             (import (rnrs))
+             (define x 3))))
+      'replace)
+    (separate-compile 'li5)
+    #t)
+  (equal?
+    (parameterize ([compile-imported-libraries #t])
+      (eval '(let () (import (testfile-li3)) x))
+      (library-object-filename '(testfile-li3)))
+    "testfile-li3.so")
+  (equal?
+    (parameterize ([compile-imported-libraries #f])
+      (eval '(let () (import (testfile-li4)) x))
+      (library-object-filename '(testfile-li4)))
+    #f)
+  (equal?
+    (begin
+      (eval '(let () (import (testfile-li5)) x))
+      (library-object-filename '(testfile-li5)))
+    "testfile-li5.so")
+  (equal?
+    (begin
+      (load-library "testfile-li3.ss")
+      (library-object-filename '(testfile-li3)))
+    #f)
+  (equal?
+    (begin
+      (load-library "testfile-li3.so")
+      (library-object-filename '(testfile-li3)))
+    "testfile-li3.so")
+)
+
+(mat rnrs-eval
+  (begin
+    (define $eval-e1 (environment '(rnrs)))
+    (environment? $eval-e1))
+  (error? ; variable environment not bound
+    (r6rs:eval 'environment $eval-e1))
+  (error? ; variable eval not bound
+    (r6rs:eval 'eval $eval-e1))
+  (eq? (r6rs:eval 'cons $eval-e1) cons)
+  (error? ; invalid context for definition
+    (r6rs:eval '(define x 4) $eval-e1))
+  (error? ; invalid context for definition
+    (r6rs:eval '(define foo 4) $eval-e1))
+  (error? ; cannot assign cons
+    (r6rs:eval '(set! cons 4) $eval-e1))
+  (error? ; cannot assign foo
+    (r6rs:eval '(set! foo 4) $eval-e1))
+  (begin
+    (with-output-to-file "testfile-eval1.ss"
+      (lambda ()
+        (pretty-print
+          '(library (testfile-eval1)
+             (export canned spam list define quote set!)
+             (import (rnrs))
+             (define-syntax canned
+               (begin
+                 (display "testfile-eval1 visit")
+                 (newline)
+                 (identifier-syntax tuna)))
+             (define spam (lambda () (cons 'not canned)))
+             (define tuna 'yummy)
+             (display "testfile-eval1 invoke")
+             (newline))))
+      'replace)
+    #t)
+  (equal?
+    (r6rs:eval
+      '(list canned (spam))
+      (environment '(testfile-eval1)))
+    '(yummy (not . yummy)))
+  (error? ; cons is not bound
+    (r6rs:eval
+      '(cons canned (spam))
+      (environment '(testfile-eval1))))
+  (error? ; invalid context for definition
+    (r6rs:eval
+      '(define foo 3)
+      (environment '(testfile-eval1))))
+  (error? ; cannot assign
+    (r6rs:eval
+      '(set! spam 3)
+      (environment '(testfile-eval1))))
+  (error? ; cannot assign
+    (r6rs:eval
+      '(set! foo 3)
+      (environment '(testfile-eval1))))
+  (error? ; invalid definition in immutable environment
+    (let ([env (environment '(testfile-eval1))])
+      (eval `(define cons ',vector) env)))
+  (equal?
+    (let ([env (copy-environment (environment '(testfile-eval1)))])
+      (eval `(define cons ',vector) env)
+      (r6rs:eval '(cons canned (spam)) env))
+    '#(yummy (not . yummy)))
+  (eq?
+    (r6rs:eval '(let () (import (scheme)) compile)
+      (environment '(only (scheme) let import)))
+    compile)
+)
+
+(mat top-level-syntax-functions
+  (error? (top-level-syntax "hello"))
+  (error? (top-level-syntax))
+  (error? (top-level-syntax 'hello 'hello))
+  (error? (top-level-syntax (scheme-environment) (scheme-environment)))
+  (error? (top-level-syntax? "hello"))
+  (error? (top-level-syntax?))
+  (error? (top-level-syntax? 'hello 'hello))
+  (error? (top-level-syntax? (scheme-environment) (scheme-environment)))
+  (error? (define-top-level-syntax "hello" "hello"))
+  (error? (define-top-level-syntax))
+  (error? (define-top-level-syntax 15))
+  (error? (define-top-level-syntax 'hello 'hello 'hello))
+  (error? (define-top-level-syntax (scheme-environment) (scheme-environment) (scheme-environment)))
+  (error?
+    (let ([e (scheme-environment)])
+      (define-top-level-syntax 'p (lambda (x) "hello") e)))
+  (error?
+    (let ([e (copy-environment (scheme-environment) #f)])
+      (define-top-level-syntax 'p void e)))
+  (error?
+    (let ([e (scheme-environment)])
+      (top-level-syntax 'p e)))
+  (and (top-level-syntax 'hopenotdefined) #t)
+  (and (top-level-syntax 'cons) #t)
+  (and (top-level-syntax 'scheme) #t)
+  (error? (top-level-syntax 'cond (environment)))
+  (top-level-syntax? 'hopenotdefined)
+  (top-level-syntax? 'cons)
+  (top-level-syntax? 'scheme)
+  (not (top-level-syntax? 'cond (environment)))
+
+  (top-level-syntax? 'cond)
+  (procedure? (top-level-syntax 'cond))
+
+  (begin
+    (define-top-level-syntax '$tls-foo (syntax-rules () [(_ x) (x x)]))
+    #t)
+  (equal? ($tls-foo list) `(,list))
+
+  (equal?
+    (parameterize ([interaction-environment
+                    (copy-environment (scheme-environment) #t)])
+      (let ([t (syntax-rules () [(_ x y) (* x y)])])
+        (eval `(define-syntax cons ',t))
+        (eval '(cons 3 4))))
+    12)
+  (equal?
+    (let ([e (environment '(only (scheme) cond))])
+      (list
+        (top-level-syntax? 'cond e)
+        (eq? (top-level-syntax 'cond e) (top-level-syntax 'cond (scheme-environment)))
+        (top-level-syntax? 'cdr e)))
+    '(#t #t #f))
+  (equal?
+    (let ([e (copy-environment (environment) #t)])
+      (let ([t1 (lambda (x) 17)] [t2 (syntax-rules () [(_ x y) (list y x)])])
+        (define-top-level-syntax 'p t1 e)
+        (define-top-level-syntax 'q t2 e)
+        (list
+          (top-level-syntax? 'p e)
+          (top-level-syntax? 'q e)
+          (top-level-syntax? 'r e)
+          (eq? (top-level-syntax 'p e) t1)
+          (eq? (top-level-syntax 'q e) t2)
+          ((top-level-syntax 'p e) 'p)
+          (eval '(q 3 4) e)
+          (eval 'p e))))
+    '(#t #t #t #t #t 17 (4 3) 17))
+ )
+
+(mat annotations
+  (error? ; #f is not a string
+    (make-source-file-descriptor #f
+      (open-bytevector-input-port (string->utf8 "hello"))))
+  (error? ; 17 is not a binary-input port
+    (make-source-file-descriptor "foo" 17))
+  (error? ; # is not a binary-input port
+    (make-source-file-descriptor "foo" (open-string-input-port "oops")))
+  (error? ; # does not support port-position and set-port-position!
+    (make-source-file-descriptor "foo"
+      (make-custom-binary-input-port "foo" (lambda (bv s c) 0) #f #f #f)
+      #t))
+  (begin
+    (define str "(ugh (if \x3b2;))")
+    (define bv (string->utf8 str))
+    (define ip (open-bytevector-input-port bv))
+    (define sfd (make-source-file-descriptor "foo" ip #t))
+    #t)
+  (not (= (bytevector-length bv) (string-length str)))
+  (error? ; sfd is not an sfd
+    (make-source-object 'sfd 2 3))
+  (error? ; two is not an exact integer
+    (make-source-object sfd 'two 3))
+  (error? ; three is not an exact integer
+    (make-source-object sfd 2 'three))
+  (error? ; bfp 3 is not between 0 and efp 2
+    (make-source-object sfd 3 2))
+  (error? ; bfp -7 not between 0 and efp -3
+    (make-source-object sfd -7 -3))
+  (error? ; bfp -7 is not between 0 and efp 3
+    (make-source-object sfd -7 3))
+  (error? ; bfp -7 is not between 0 and efp 3
+    (make-source-object sfd -7 3 2 1))
+  (error? ; one is not an exact integer
+    (make-source-object sfd 1 2 'one 1))
+  (error? ; one is not an exact integer
+    (make-source-object sfd 1 2 1 'one))
+  (error? ; zero is not an exact positive integer
+    (make-source-object sfd 1 2 0 1))
+  (error? ; zero is not an exact positive integer
+    (make-source-object sfd 1 2 1 0))
+  (error? ; bfp 3 is not between 0 and efp 2
+    (make-source-object sfd 3 2 1 1))
+  (begin
+    (define source (make-source-object sfd 2 3))
+    (define source-at-line-two (make-source-object sfd 3 5 2 1))
+    #t)
+  (error? ; source is not a source object
+    (make-annotation #f 'source #f))
+  (begin
+    (define a (make-annotation '(if 3) source '(if I were a rich man)))
+    (define a-at-line-two (make-annotation '(if 3) source-at-line-two '(if I were a rich man)))
+    (define x (datum->syntax #'* a))
+    #t)
+  (source-file-descriptor? sfd)
+  (not (source-file-descriptor? source))
+  (source-object? source)
+  (source-object? source-at-line-two)
+  (not (source-object? sfd))
+  (not (source-object? a))
+  (annotation? a)
+  (not (annotation? source))
+  (error? ; # is not an sfd
+    (source-file-descriptor-path source))
+  (error? ; # is not an sfd
+    (source-file-descriptor-checksum a))
+  (error? ; # is not a source object
+    (source-object-sfd sfd))
+  (error? ; # is not a source object
+    (source-object-bfp a))
+  (error? ; 3 is not a source object
+    (source-object-efp 3))
+  (error? ; 3 is not a source object
+    (source-object-line 3))
+  (error? ; 3 is not a source object
+    (source-object-column 3))
+  (error? ; 3 is not an annotation
+    (annotation-expression 3))
+  (error? ; # is not an annotation
+    (annotation-stripped source))
+  (error? ; # is not an annotation
+    (annotation-source sfd))
+  (error? ; # is not an annotation
+    (annotation-option-set source))
+  (error? ; invalid syntax
+    (annotation-options . debug))
+  (error? ; invalid syntax
+    (annotation-options 3 profile))
+  (error? ; invalid option
+    (annotation-options fig))
+  (error? ; invalid option
+    (annotation-options debug fig))
+  (error? ; invalid option
+    (annotation-options fig profile))
+  (equal?
+    (source-file-descriptor-path sfd)
+    "foo")
+  (number? (source-file-descriptor-checksum sfd))
+  (eq? (source-object-sfd source) sfd)
+  (eq? (source-object-bfp source) 2)
+  (eq? (source-object-efp source) 3)
+  (eq? (source-object-line source) #f)
+  (eq? (source-object-column source) #f)
+  (eq? (source-object-sfd source) sfd)
+  (eq? (source-object-bfp source-at-line-two) 3)
+  (eq? (source-object-efp source-at-line-two) 5)
+  (eq? (source-object-line source-at-line-two) 2)
+  (eq? (source-object-column source-at-line-two) 1)
+  (equal? (annotation-expression a) '(if 3))
+  (eq? (annotation-source a) source)
+  (equal? (annotation-stripped a) '(if I were a rich man))
+  (enum-set=? (annotation-option-set a) (annotation-options debug profile))
+  (enum-set=?
+    (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options)))
+    (annotation-options))
+  (enum-set=?
+    (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug)))
+    (annotation-options debug))
+  (enum-set=?
+    (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options profile)))
+    (annotation-options profile))
+  (enum-set=?
+    (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug profile)))
+    (annotation-options debug profile))
+  (enum-set=?
+    (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options profile debug)))
+    (annotation-options debug profile))
+  (eq? (syntax->annotation x) a)
+  (not (syntax->annotation #'(a b c)))
+  (not (syntax->annotation '(a b c)))
+  (not (syntax->annotation #f))
+  (error? ; invalid syntax (if I were a rich man) at char 2 of foo
+    (expand a))
+  (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo
+    (expand a-at-line-two))
+  (error? ; invalid syntax (if I were a rich man) at char 2 of foo
+    (eval a))
+  (error? ; invalid syntax (if I were a rich man) at char 2, char 1 of foo
+    (eval a-at-line-two))
+  (error? ; invalid syntax (if I were a rich man) at char 2 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* a))) foo)))
+  (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* a-at-line-two))) foo)))
+  (error? ; invalid syntax (if I were a rich man) at char 2 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug profile))))) foo)))
+  (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source-at-line-two '(if I were a rich man) (annotation-options debug profile))))) foo)))
+  (error? ; invalid syntax (if I were a rich man) at char 2 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug))))) foo)))
+  (error? ; invalid syntax (if I were a rich man)
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options profile))))) foo)))
+  (error? ; invalid syntax (if I were a rich man)
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options))))) foo)))
+  (error? ; invalid argument count in call (f) at char 2 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options debug profile)))))) foo)))
+  (error? ; invalid argument count in call (f) at line 2, char 1 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source-at-line-two '(f) (annotation-options debug profile)))))) foo)))
+  (error? ; invalid argument count in call (f) at char 2 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options debug)))))) foo)))
+  (error? ; invalid argument count in call (f)
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options profile)))))) foo)))
+  (error? ; invalid argument count in call (f)
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options)))))) foo)))
+  (begin
+    (profile-clear)
+    #t)
+  (begin
+    (define foo
+      (parameterize ([compile-profile #t] [current-eval compile])
+        (eval '(lambda ()
+                 (define-syntax foo
+                   (lambda (z)
+                     (datum->syntax #'*
+                       (make-annotation
+                         `(,(make-annotation '+ (make-source-object sfd 2 3) '+ (annotation-options debug profile))
+                            ,(make-annotation '3 (make-source-object sfd 4 5) '3 (annotation-options))
+                            ,(make-annotation '44 (make-source-object sfd 8 10) '44 (annotation-options debug)))
+                         (make-source-object sfd 1 11)
+                         '(+ 3 44)
+                         (annotation-options profile)))))
+                 foo))))
+    #t)
+  (equal? (foo) 47)
+  (equal?
+    (let ([ls (profile-dump-list)])
+      (vector
+        (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 1 11))) ls)
+        (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 2 3))) ls)
+        (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 4 5))) ls)
+        (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 8 10))) ls)))
+    '#((1 "foo" 1 11 #f #f)
+       (1 "foo" 2 3 #f #f)
+       #f
+       #f))
+  (begin
+    (profile-clear)
+    #t)
+  (begin
+    (define ip (transcoded-port ip (native-transcoder)))
+    (define-values (x fp) (get-datum/annotations ip sfd 0))
+    #t)
+  (error? ; # is not a textual input port
+    (get-datum/annotations sfd sfd 0))
+  (error? ; # is not an sfd
+    (get-datum/annotations ip ip 0))
+  (error? ; # is not a valid file position
+    (get-datum/annotations ip sfd sfd))
+  (error? ; -5 is not a valid file position
+    (get-datum/annotations ip sfd -5))
+  (error? ; 5.0 is not a valid file position
+    (get-datum/annotations ip sfd 5.0))
+  (eqv? fp (string-length str))
+  (annotation? x)
+  (equal? (annotation-stripped x) (with-input-from-string str read))
+  (equal?
+    (let f ([x x])
+      (and (annotation? x)
+           (let ([x (annotation-expression x)])
+             (if (list? x)
+                 (map f x)
+                 x))))
+    (with-input-from-string str read))
+  (begin
+    (define source (annotation-source x))
+    #t)
+  (source-object? source)
+  (eq? (source-object-sfd source) sfd)
+  (eqv? (source-object-bfp source) 0)
+  (eqv? (source-object-efp source) (string-length str))
+  (error? ; not a string
+    (source-file-descriptor 'spam 0))
+  (error? ; not an exact nonnegative integer
+    (source-file-descriptor "spam" -1))
+  (error? ; not an exact nonnegative integer
+    (source-file-descriptor "spam" 1.0))
+  (source-file-descriptor? (source-file-descriptor "spam" #x34534a5))
+  (source-file-descriptor? (source-file-descriptor "spam" #x20333333333339999999997834443333337))
+  (equal?
+    (source-file-descriptor-path (source-file-descriptor "spam" #x20333333333339999999997834443333337))
+    "spam")
+  (equal?
+    (source-file-descriptor-checksum (source-file-descriptor "spam" #x20333333333339999999997834443333337))
+    #x20333333333339999999997834443333337)
+  (error? ; not an sfd
+    (locate-source "spam" 17))
+  (error? ; not an exact nonnegative integer
+    (locate-source sfd -1))
+  (error? ; not an exact nonnegative integer
+    (locate-source sfd 'a))
+  (let-values ([() (locate-source sfd 7)]) #t)
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (printf "; bogus exports\n")
+        (printf "(module (a 3)\n")
+        (printf "  (define a 3))\n"))
+      'replace)
+    #t)
+  (equal?
+    (guard (c [(syntax-violation? c)
+               (let* ([form (syntax-violation-form c)]
+                      [annotation (syntax->annotation form)]
+                      [source (annotation-source annotation)])
+                 (cons
+                   (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-bfp source))) vector)
+                   (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-efp source))) vector)))])
+      (load "testfile.ss"))
+    '(#("testfile.ss" 2 12) . #("testfile.ss" 2 13)))
+  (equal?
+    (let ([sfd (source-file-descriptor (source-file-descriptor-path sfd) (source-file-descriptor-checksum sfd) )])
+      (let ([source (make-source-object sfd 2 3)])
+        (guard (c [(syntax-violation? c)
+                   (let* ([form (syntax-violation-form c)]
+                          [annotation (syntax->annotation form)]
+                          [source (annotation-source annotation)])
+                     (cons
+                       (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-bfp source))) vector)
+                       (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-efp source))) vector)))])
+          (load "testfile.ss"))))
+    '(#("testfile.ss" 2 12) . #("testfile.ss" 2 13)))
+
+  (error? ; not a source object
+   (locate-source-object-source "spam" #t #t))
+  (error?
+   (current-locate-source-object-source 7))
+  (error?
+   (current-locate-source-object-source "string"))
+  (error? ; not a source object
+   ((current-locate-source-object-source) "spam" #t #t))
+  (error? ; invalid syntax (if I were a rich man) at line 200, char 17 of foo
+   (parameterize ([current-locate-source-object-source
+                   (lambda (src start? cache?)
+                     (values (source-file-descriptor-path (source-object-sfd src)) 200 17))])
+     (expand a)))
+ )
+
+(mat annotations-via-recorded-lines
+  (error?
+   (current-make-source-object 7))
+  (error?
+   (current-make-source-object "string"))
+  (begin
+    (define sfd-with-lines
+      (let ((op (open-output-file "testfile.ss" 'replace)))
+        (display "apple\n  banana\ncoconut" op)
+        (close-port op)
+        (let* ([ip (open-file-input-port "testfile.ss")]
+               [sfd (make-source-file-descriptor "testfile.ss" ip)])
+          (close-port ip)
+          sfd)))
+    (define input-string-with-lines "Apple\n  Banana\nCoconut\nMore")
+    (define input-port-with-lines (open-string-input-port input-string-with-lines))
+    (define input-port-with-line-pos 0)
+    (define (make-make-source-object/get-lines expected-sfd)
+      (lambda (sfd bfp efp)
+        (if (eq? sfd expected-sfd)
+            ;; Gather line and column now:
+            (let-values ([(path line col) (locate-source sfd bfp #t)])
+              (make-source-object sfd bfp efp line col))
+            (error 'recording-make-source-object "reading some other file?"))))
+    (define (read-with-lines)
+      (parameterize ([current-make-source-object (make-make-source-object/get-lines sfd-with-lines)])
+        (let-values ([(v pos) (get-datum/annotations input-port-with-lines sfd-with-lines input-port-with-line-pos)])
+          (set! input-port-with-line-pos pos)
+          v)))
+    #t)
+  (begin
+    (define line-one (read-with-lines))
+    (annotation? line-one))
+  (equal? (annotation-stripped line-one) 'Apple)
+  (equal? (source-object-bfp (annotation-source line-one)) 0)
+  (equal? (source-object-line (annotation-source line-one)) 1)
+  (equal? (source-object-column (annotation-source line-one)) 1)
+  (begin
+    (define line-two (read-with-lines))
+    (annotation? line-two))
+  (equal? (source-object-bfp (annotation-source line-two)) 8)
+  (equal? (source-object-line (annotation-source line-two)) 2)
+  (equal? (source-object-column (annotation-source line-two)) 3)
+  (begin
+    (define line-three (read-with-lines))
+    (annotation? line-three))
+  (equal? (source-object-bfp (annotation-source line-three)) 15)
+  (equal? (source-object-line (annotation-source line-three)) 3)
+  (equal? (source-object-column (annotation-source line-three)) 1)
+  (annotation? (read-with-lines)) ; 'More
+  (eof-object? (read-with-lines))
+
+  ;; Make sure lines are calculated right with input that is longer than
+  ;; the file buffer size:
+  (begin
+    (define input-string-with-lines (string-append
+                                     "\""
+                                     (make-string (* 2 (file-buffer-size)) #\a)
+                                     "\""
+                                     "\nend"))
+    
+    (define input-port-with-lines (open-string-input-port input-string-with-lines))
+    (define sfd-with-lines
+      (let ((op (open-output-file "testfile.ss" 'replace)))
+        (display input-string-with-lines op)
+        (close-port op)
+        (let* ([ip (open-file-input-port "testfile.ss")]
+               [sfd (make-source-file-descriptor "testfile.ss" ip)])
+          (close-port ip)
+          sfd)))
+    (define input-port-with-line-pos 0)
+    (define (read-with-lines)
+      (parameterize ([current-make-source-object (make-make-source-object/get-lines sfd-with-lines)])
+        (let-values ([(v pos) (get-datum/annotations input-port-with-lines sfd-with-lines input-port-with-line-pos)])
+          (set! input-port-with-line-pos pos)
+          v)))
+    (define line-one (read-with-lines))
+    (annotation? line-one))
+  (string? (annotation-stripped line-one))
+  (begin
+    (define line-two (read-with-lines))
+    (annotation? line-two))
+  (equal? (source-object-line (annotation-source line-two)) 2)
+  (equal? (source-object-column (annotation-source line-two)) 1)
+  )
+
+(mat locate-source-caching
+  (begin
+   (define (make-expr n)
+     `(let ()
+        ,@(let loop ([i n])
+            (if (zero? i)
+                '(#t)
+                (cons
+                 `(let-values ([(x y z) (values 1 2 3)]) x)
+                 (loop (sub1 i)))))))
+
+   (define (time-expr n)
+     (with-output-to-file "testfile.ss"
+       (lambda ()
+         (pretty-print (make-expr n)))
+       'truncate)
+     (collect)
+     (parameterize ([collect-request-handler void])
+       (let ([start (current-time)])
+         (load "testfile.ss" expand)
+         (let ([delta (time-difference (current-time) start)])
+           (+ (* #e1e9 (time-second delta))
+              (time-nanosecond delta))))))
+
+   (let loop ([tries 3])
+     (when (zero? tries)
+       (error 'source-cache-test "loading lots of `let-values` forms seems to take too long"))
+     (let ([t1000 (time-expr 1000)] [t10000 (time-expr 10000)])
+       (or (> (* 20 t1000) t10000)
+         (begin
+           (printf "t1000 = ~s, t10000 = ~s, t10000 / t1000 = ~s\n" t1000 t10000 (inexact (/ t10000 t1000)))
+           (loop (sub1 tries)))))))
+
+  (begin
+    (define sfd-to-cache
+      (let ((op (open-output-file "testfile.ss" 'replace)))
+        (display "apple\n  banana\ncoconut" op)
+        (close-port op)
+        (let* ([ip (open-file-input-port "testfile.ss")]
+               [sfd (make-source-file-descriptor "testfile.ss" ip)])
+          (close-port ip)
+          sfd)))
+
+    (equal? (call-with-values
+             (lambda () (locate-source sfd-to-cache 8 #t))
+             (case-lambda
+              [(name line col) (list line col)]))
+            '(2 3)))
+
+  (begin
+    (let ((op (open-output-file "testfile.ss" 'replace)))
+      (display "1\n2\n3\n4\n5\n6789" op)
+      (close-port op))
+    ;; Cache may report the old source line,
+    ;; or uncached should report no line:
+    (equal? (call-with-values
+             (lambda () (locate-source sfd-to-cache 8 #t))
+             (case-lambda
+              [() '(2 3)] ; report no line same as expected cache
+              [(name line col) (list line col)]))
+            '(2 3)))
+
+  ;; An uncached lookup defniitely reports no line:
+  (equal? (call-with-values
+            (lambda () (locate-source sfd-to-cache 8 #f))
+            (lambda () 'none))
+          'none)
+
+  (begin
+    (collect (collect-maximum-generation))
+    ;; After collecting the maximum generation, the
+    ;; cached information should definitely be gone:
+    (equal? (call-with-values
+             (lambda () (locate-source sfd-to-cache 8 #t))
+             (lambda () 'gone))
+            'gone))
+  )
+
+(mat include
+  (error? ; invalid syntax
+    (expand '(include spam)))
+  (error? ; invalid syntax
+    (parameterize ([source-directories '("../s" "../c")])
+      (expand '(include spam))))
+ )
+
+(mat extend-syntax
+   (begin (extend-syntax (foo)
+             [(foo a b) (list a b)])
+          #t)
+   (equal? (foo 3 4) '(3 4))
+   (begin (extend-syntax (foo bar)
+             [(foo) '()]
+             [(foo (bar x)) x]
+             [(foo x) (cons x '())]
+             [(foo x y ...) (cons x (foo y ...))])
+          #t)
+   (equal? (foo 'a 'b 'c 'd) '(a b c d))
+   (equal? (foo 'a 'b 'c (bar 'd)) '(a b c . d))
+   (begin (extend-syntax (foo)
+             [(foo ((x v) ...) e1 e2 ...)
+              (andmap symbol? '(x ...))
+              ((lambda (x ...) e1 e2 ...) v ...)]
+             [(foo ((lambda (x ...) e1 e2 ...) v ...))
+              (= (length '(x ...)) (length '(v ...)))
+               (foo ((x v) ...) e1 e2 ...)])
+          #t)
+   (equal? (foo ((a 3) (b 4)) (cons a b)) '(3 . 4))
+   (error? (extend-syntax (foo ...) [(foo ...) 0]))
+   (error? (extend-syntax (foo) [(foo x ... y) 0]))
+   (error? (extend-syntax (foo) [(foo x . ...) 0]))
+   (error? (extend-syntax (foo) [(foo (...)) 0]))
+   (error? (extend-syntax (foo) [(foo x x) 0]))
+   (begin (extend-syntax (foo) [(foo foo) 0]) #t)
+   (begin (extend-syntax (foo) [(foo keys) (with ([x `,'keys]) 'x)])
+          (equal? (foo (a b c)) '(a b c)))
+   (begin (extend-syntax (foo) [(foo x y) '`(x ,@y)])
+          (equal? (foo a b) '`(a ,@b)))
+   (begin (extend-syntax (foo) ; test exponential "with" time problem
+             [(foo)
+              (with ([a1 1] [b1 2] [c1 3] [d1 4] [e1 5] [f1 6] [g1 7] [h1 8]
+                     [a2 1] [b2 2] [c2 3] [d2 4] [e2 5] [f2 6] [g2 7] [h2 8]
+                     [a3 1] [b3 2] [c3 3] [d3 4] [e3 5] [f3 6] [g3 7] [h3 8]
+                     [a4 1] [b4 2] [c4 3] [d4 4] [e4 5] [f4 6] [g4 7] [h4 8]
+                     [a5 1] [b5 2] [c5 3] [d5 4] [e5 5] [f5 6] [g5 7] [h5 8]
+                     [a6 1] [b6 2] [c6 3] [d6 4] [e6 5] [f6 6] [g6 7] [h6 8]
+                     [a7 1] [b7 2] [c7 3] [d7 4] [e7 5] [f7 6] [g7 7] [h7 8]
+                     [a8 1] [b8 2] [c8 3] [d8 4] [e8 5] [f8 6] [g8 7] [h8 8])
+                 '(a1 b2 c3 d4 e5 f6 g7 h8))])
+      (equal? (foo) '(1 2 3 4 5 6 7 8)))
+   (equal? (letrec* ((x 3) (y (+ x 2))) (list x y)) '(3 5))
+ )
+
+(mat with
+   (begin (extend-syntax (foo)
+             [(foo x ...)
+              (with ([n (length '(x ...))])
+                 (list n 'x ...))])
+          #t)
+   (equal? (foo 3 2 1) '(3 3 2 1))
+   (begin (extend-syntax (foo)
+             [(foo (x ...) ...)
+              (list (with ([(y ...)
+                            '(x ... (with ([n (length '(x ...))]) n))])
+                       (with ([(z ...) (reverse '(y ...))])
+                          (list 'z ...)))
+                    ...)])
+          #t)
+   (equal? (foo) '())
+   (equal? (foo (a b) (c d e)) '((2 b a) (3 e d c)))
+   (begin (extend-syntax (foo)
+             [(foo x ...)
+              (with ([(y1 y2 ...) '(x ...)])
+                 (with ([(z1 z2) 'y1])
+                    '(z2 z1)))])
+          #t)
+   (equal? (foo (a b) (c d) (e f)) '(b a))
+ )
diff --git a/mats/Mf-a6fb b/mats/Mf-a6fb
new file mode 100644
index 0000000..ff9e687
--- /dev/null
+++ b/mats/Mf-a6fb
@@ -0,0 +1,27 @@
+# Mf-a6fb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6fb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-a6le b/mats/Mf-a6le
new file mode 100644
index 0000000..891724f
--- /dev/null
+++ b/mats/Mf-a6le
@@ -0,0 +1,27 @@
+# Mf-a6le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m64 -fPIC -shared -O2 -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-a6nb b/mats/Mf-a6nb
new file mode 100644
index 0000000..0f7ac17
--- /dev/null
+++ b/mats/Mf-a6nb
@@ -0,0 +1,27 @@
+# Mf-a6nb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6nb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-a6nt b/mats/Mf-a6nt
new file mode 100644
index 0000000..5e522c3
--- /dev/null
+++ b/mats/Mf-a6nt
@@ -0,0 +1,31 @@
+# Mf-a6nt
+# Copyright 1984-2021 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6nt
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj foreign4.obj
+
+include Mf-base
+
+export MSYS_NO_PATHCONV=1
+export MSYS2_ARG_CONV_EXCL=*
+
+foreign1.so: $(fsrc)
+	cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv959.lib $(fsrc)"
+
+cat_flush.exe: cat_flush.c
+	cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<"
diff --git a/mats/Mf-a6ob b/mats/Mf-a6ob
new file mode 100644
index 0000000..0ffcccc
--- /dev/null
+++ b/mats/Mf-a6ob
@@ -0,0 +1,27 @@
+# Mf-a6ob
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6ob
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-a6osx b/mats/Mf-a6osx
new file mode 100644
index 0000000..a464227
--- /dev/null
+++ b/mats/Mf-a6osx
@@ -0,0 +1,27 @@
+# Mf-a6osx
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6osx
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m64 -dynamiclib -undefined dynamic_lookup -O2 -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-a6s2 b/mats/Mf-a6s2
new file mode 100644
index 0000000..eccb7d8
--- /dev/null
+++ b/mats/Mf-a6s2
@@ -0,0 +1,27 @@
+# Mf-a6s2
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = a6s2
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	gcc -o cat_flush cat_flush.c
diff --git a/mats/Mf-arm32le b/mats/Mf-arm32le
new file mode 100644
index 0000000..d90958c
--- /dev/null
+++ b/mats/Mf-arm32le
@@ -0,0 +1,27 @@
+# Mf-arm32le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = arm32le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) ${CFLAGS} -fPIC -fomit-frame-pointer -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) ${CFLAGS} -o cat_flush cat_flush.c
diff --git a/mats/Mf-base b/mats/Mf-base
new file mode 100644
index 0000000..e072c4c
--- /dev/null
+++ b/mats/Mf-base
@@ -0,0 +1,545 @@
+# Mf-base
+# Copyright 1984-2021 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# Assumes recursive makes inherit command-line settings as in GNU make
+
+# Running "make" or "make all" in this directory runs the mats (test
+# programs) and produces a report of bugs and errors.  Unless you make
+# changes to the mats or to the system, the report file report-$(conf)
+# (where $(conf) is set below) will be output in the $(outdir) directory.
+
+# If an error or bug report occurs, refer to the offending ".mo" file
+# produced by the mats and mentioned in the bug or error report to
+# determine what failed.
+
+# Running "make allx" runs a set of mats with various settings.  "make
+# bullyx" runs a different, more stressful set.  These targets allow make
+# to run the various configurations in parallel (if so configured, e.g.
+# with the -j flag).  Most output from each parallel execution is directed
+# to (separate) files, with status printed to stdout when testing of each
+# different configuration begins and ends.  In addition, each target
+# concatenates the summary file from all configurations run into "summary"
+# in the current directory.
+
+# Running make with the argument "clean" removes the .so files, .mo
+# files, report files, and temporary files generated by the mats.
+
+# The variables below may be changed to affect how the mats are run.
+# For example, "make o=2 cp0=t ctb=8192" causes the mats to be run at
+# optimize level 2 with cp0 enabled and collect-trip-bytes set to 8192.
+
+MatsDir = $(abspath .)
+
+ifeq (${OS},Windows_NT)
+  dirsep = ;
+else
+  dirsep = :
+endif
+
+# Explicit ".exe" needed for WSL
+ifeq ($(OS),Windows_NT)
+  ExeSuffix = .exe
+else
+  ExeSuffix =
+endif
+
+include ../c/Mf-config
+
+# Scheme is the scheme executable to test, SCHEMEHEAPDIRS tells
+# it where to find its boot files, and CHEZSCHEMELIBDIRS tells
+# it where to find libraries.
+Scheme = $(abspath ../bin/$m/scheme${ExeSuffix})
+export SCHEMEHEAPDIRS=.${dirsep}$(abspath ../boot)/%m
+export CHEZSCHEMELIBDIRS=.
+
+# Include is the directory holding scheme.h.
+Include = ../boot/$m
+
+# patchfile is the name of a patch to be loaded while running the mats.
+patchfile =
+
+# o is the optimize level at which the mats should be run.
+o = 0
+
+# p determines whether profiling is enabled: f for false, t for true.
+defaultp = f
+p = $(defaultp)
+
+# pdhtml determines whether profile-dump-html is called at end of a run: f for false, t for true.
+# NB: beware of lost profile information due to mats that call profile-clear
+defaultpdhtml = f
+pdhtml = $(defaultpdhtml)
+
+# cp0 determines whether cp0 is run: f for no, t for yes
+defaultcp0 = f
+cp0 = $(defaultcp0)
+
+# eval is the evaluator to use.
+defaulteval = compile
+eval = $(defaulteval)
+
+# ctb is the value to which collect-trip-bytes is set.
+defaultctb = (collect-trip-bytes)
+ctb = $(defaultctb)
+
+# cn defines the value to which collect-notify is set: f for #f, t for #t
+defaultcn = f
+cn = $(defaultcn)
+
+# cgr is the value to which collect-generation-radix is set.
+defaultcgr = (collect-generation-radix)
+cgr = $(defaultcgr)
+
+# cmg is the value to which collect-maximum-generation is set.
+defaultcmg = (collect-maximum-generation)
+cmg = $(defaultcmg)
+
+# rmg is the value to which release-minimum-generation is set.
+defaultrmg = (release-minimum-generation)
+rmg = $(defaultrmg)
+
+# cis defines the value to which compile-interpret-simple is set: f for
+# #f, t for #t
+defaultcis = f
+cis = $(defaultcis)
+
+# spi defines the value to which suppress-primitive-inlining is set:
+# f for #f, t for #t
+defaultspi = f
+spi = $(defaultspi)
+
+# hci defines the value to which heap-check-interval (mat.ss) is set:
+# 0 to disable, > 0 to enable
+defaulthci = 0
+hci = $(defaulthci)
+
+# eoc determines whether object counts are enabled
+defaulteoc = t
+eoc = $(defaulteoc)
+
+# cl determines the commonization level
+defaultcl = (commonization-level)
+cl = $(defaultcl)
+
+# ecpf determines whether the compiler checks prelex flags
+defaultecpf = t
+ecpf = $(defaultecpf)
+
+# c determines whether mat coverage (.covout) files are created
+defaultc = f
+c = $(defaultc)
+
+# set of coverage files to load
+coverage-files = $(abspath ../boot/$m/petite.covin ../boot/$m/scheme.covin)
+
+# set of mats to run
+mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread profile\
+ misc cp0 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
+ ftype unix windows examples ieee date exceptions oop
+
+Examples = $(abspath ../examples)
+
+MAKEFLAGS += --no-print-directory
+
+# directory where (most) output for this run will be written
+outdir=output
+
+conf = $(eval)-$o-$(spi)-$(cp0)-$(cis)
+objdir=output-$(conf)
+objname = $(mats:%=%.mo)
+obj = $(objname:%=$(objdir)/%)
+src = $(mats:%=%.ms)
+
+# prettysrc is src to use for pretty-print test; we leave out mat files
+# with cycles, e.g., primvars.ms, misc.ms, 4.ms, 5_1.ms, hash.ms
+prettysrc = 3.ms 5_3.ms 5_4.ms 5_5.ms bytevector.ms thread.ms profile.ms\
+ 5_6.ms 5_7.ms 5_8.ms 6.ms io.ms format.ms 7.ms record.ms enum.ms 8.ms\
+ fx.ms fl.ms cfl.ms foreign.ms unix.ms windows.ms examples.ms ieee.ms date.ms\
+ exceptions.ms
+
+define conf-scheme-code
+  '(optimize-level $o)'\
+  '(#%$$suppress-primitive-inlining #${spi})'\
+  '(heap-check-interval ${hci})'\
+  '(#%$$enable-check-prelex-flags #${ecpf})'\
+  '(compile-profile #$p)'\
+  '(collect-notify #${cn})'\
+  '(collect-trip-bytes ${ctb})'\
+  '(collect-generation-radix ${cgr})'\
+  '(collect-maximum-generation ${cmg})'\
+  '(enable-object-counts #${eoc})'\
+  '(commonization-level ${cl})'\
+  '(release-minimum-generation ${rmg})'\
+  '(compile-interpret-simple #${cis})'\
+  '(set! *examples-directory* "${Examples}")'\
+  '(enable-cp0 #${cp0})'\
+  '(set! *scheme* "${Scheme}")'\
+  '(set! *mats-dir* "${MatsDir}")'\
+  '(set! $$cat_flush "${MatsDir}/cat_flush${ExeSuffix}")'\
+  '(current-eval ${eval})'\
+  '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'
+endef
+
+$(objdir)/%.mo : %.ms mat.so
+	echo $(conf-scheme-code)\
+             '(time ((mat-file "$(objdir)") "$*"))'\
+             '(unless (= (#%$$check-heap-errors) 0)'\
+             '  (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
+             '  (abort))'\
+           | ${Scheme} -q mat.so ${patchfile}
+
+# same as above except puts the .mo file in .
+%.mo : %.ms mat.so
+	echo $(conf-scheme-code)\
+             '(time ((mat-file ".") "$*"))'\
+             '(parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\
+             '(unless (= (#%$$check-heap-errors) 0)'\
+             '  (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
+             '  (abort))'\
+           | ${Scheme} -q mat.so ${patchfile}
+
+%.so : %.ss
+	echo '(reset-handler abort) (time (compile-file "$*"))' | ${Scheme} -q ${patchfile}
+
+report: $(outdir)/report-$(conf)
+
+experr: experr-$(conf)
+
+$(outdir)/report-$(conf): $(outdir)/errors-$(conf)
+	$(MAKE) doreport
+
+doreport: experr-$(conf)
+	rm -f $(outdir)/report-$(conf)
+	-diff experr-$(conf) $(outdir)/errors-$(conf) > $(outdir)/report-$(conf) 2>&1
+
+maybe-doreport:
+	-if [ -f $(outdir)/errors-$(conf) ] ; then\
+          $(MAKE) doreport ;\
+         fi
+
+$(outdir)/errors-$(conf): ${obj}
+	$(MAKE) doerrors
+
+doerrors: $(outdir)
+	rm -f $(outdir)/errors-$(conf)
+	-(cd $(objdir); grep '^Error' $(objname)) > $(outdir)/errors-$(conf)
+	-(cd $(objdir); grep '^Bug' $(objname)) >> $(outdir)/errors-$(conf)
+	-(cd $(objdir); grep '^Warning' $(objname)) >> $(outdir)/errors-$(conf)
+	-(cd $(objdir); grep '^Expected' $(objname))\
+         >> $(outdir)/errors-$(conf)
+
+fastreport:
+	$(MAKE) doerrors
+	$(MAKE) doreport
+
+docoverage: mat.so
+	if [ "$c" = "t" ] ; then\
+          echo '(reset-handler abort) (combine-coverage-files "$(objdir)/all.covout" (quote ($(mats:%="$(objdir)/%.covout"))))' | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "$(objdir)/all.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "$(objdir)/run.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+        fi
+
+doallcoverage: mat.so
+	if [ "$c" = "t" ] ; then\
+          echo '(reset-handler abort) (combine-coverage-files "all.covout" (map symbol->string (quote ($(shell echo */all.covout)))))' | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "all.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (combine-coverage-files "run.covout" (map symbol->string (quote ($(shell echo */run.covout)))))' | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "run.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+        fi
+
+define parallel-config-template
+parallel$(1)-0:
+	-@$$(MAKE) allxphelp outdir=output-$(1)-0 objdir=output-$(1)-0 o=0 $(2)
+parallel$(1)-3:
+	-@$$(MAKE) allxphelp outdir=output-$(1)-3 objdir=output-$(1)-3 o=3 $(2)
+endef
+
+#configs from partialx and allx
+$(eval $(call parallel-config-template,1,))
+$(eval $(call parallel-config-template,2,cp0=t))
+$(eval $(call parallel-config-template,3,cp0=t cl=3))
+$(eval $(call parallel-config-template,4,spi=t rmg=2 p=t))
+$(eval $(call parallel-config-template,5,eval=interpret cl=6))
+$(eval $(call parallel-config-template,6,eval=interpret cp0=t rmg=2))
+$(eval $(call parallel-config-template,7,eoc=f hci=101 cl=9))
+$(eval $(call parallel-config-template,8,eval=interpret hci=101 rmg=2))
+
+#configs from bullyx
+$(eval $(call parallel-config-template,b1,allxphelp-target=allxhelpnotall spi=t cp0=f))
+$(eval $(call parallel-config-template,b2,spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' hci=503))
+$(eval $(call parallel-config-template,b3,spi=t cp0=f cis=t cmg=1))
+$(eval $(call parallel-config-template,b4,spi=f cp0=f cis=t cmg=6 hci=101))
+$(eval $(call parallel-config-template,b5,spi=t cp0=t ctb='(/ (collect-trip-bytes) 64)' cgr=6))
+$(eval $(call parallel-config-template,b6,spi=t cp0=f p=t eoc=f hci=101))
+$(eval $(call parallel-config-template,b7,spi=f cp0=t cl=9 p=t hci=101))
+$(eval $(call parallel-config-template,b8,eval=interpret spi=f cp0=f))
+$(eval $(call parallel-config-template,b9,eval=interpret spi=f cp0=t))
+$(eval $(call parallel-config-template,b10,eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' hci=503))
+$(eval $(call parallel-config-template,b11,eval=interpret spi=t cp0=t cgr=2 hci=101 p=t))
+
+
+partialx-confs = 1-0 1-3 2-3 6-3
+
+allx-confs = 1-0 1-3 3-0 3-3 4-0 4-3 5-0 5-3 6-0 6-3 7-0 8-3
+
+bullyx-confs = $(foreach n,1 2 3 4 5 6 7 8 9 10 11,b$(n)-0 b$(n)-3)
+
+define parallel-target-template
+$(1)-targets: $($(1)-confs:%=parallel%)
+$(1): prettyclean
+	@echo building prereqs with output to Make.out
+	@$$(MAKE) parallel-prereqs > Make.out 2>&1
+	@$$(MAKE) $(1)-targets
+	$(if $(2),@$$(MAKE) $(2))
+	cat $($(1)-confs:%=output-%/summary) > summary && cat summary
+endef
+
+$(eval $(call parallel-target-template,partialx))
+$(eval $(call parallel-target-template,allx,doallcoverage))
+$(eval $(call parallel-target-template,bullyx,doallcoverage))
+
+
+just-reports:
+	for EVAL in compile interpret ; do\
+          for O in 0 2 3 ; do\
+            for SPI in f t ; do\
+              for CP0 in f t ; do\
+                for CIS in f t ; do\
+                  $(MAKE) maybe-doreport eval=$$EVAL o=$$O spi=$$SPI cp0=$$CP0 cis=$$CIS ;\
+                done\
+              done\
+            done\
+          done\
+        done
+
+
+allxhelp:
+	$(MAKE) doheader
+	-$(MAKE) all
+	$(MAKE) dosummary
+
+config-vars = spi hci ecpf cp0 cis p eval ctb cgr cmg eoc cl rmg
+full-config-str = $(strip o=$(o) $(foreach var, $(config-vars),$(if $(filter-out $($(var:%=default%)),$($(var))),$(var)=$($(var)))) $(hdrmsg))
+
+allxphelp-target = allxhelp
+allxphelp: $(outdir)
+	@echo "matting configuration ($(full-config-str)) with output to $(outdir)/Make.out"
+	@$(MAKE) $(allxphelp-target) > "$(outdir)/Make.out" 2>&1
+	@echo "finished matting configuration $(full-config-str)"
+
+summary-file=$(outdir)/summary
+
+$(outdir):
+	@mkdir -p "$(outdir)"
+
+doheader: $(outdir)
+	printf "%s" "-------- o=$o" >> $(summary-file)
+	if [ "$(spi)" != "$(defaultspi)" ] ; then printf " spi=$(spi)" >> $(summary-file) ; fi
+	if [ "$(hci)" != "$(defaulthci)" ] ; then printf " hci=$(hci)" >> $(summary-file) ; fi
+	if [ "$(ecpf)" != "$(defaultecpf)" ] ; then printf " ecpf(ecpf)" >> $(summary-file) ; fi
+	if [ "$(cp0)" != "$(defaultcp0)" ] ; then printf " cp0=$(cp0)" >> $(summary-file) ; fi
+	if [ "$(cis)" != "$(defaultcis)" ] ; then printf " cis=$(cis)" >> $(summary-file) ; fi
+	if [ "$p" != "$(defaultp)" ] ; then printf " p=$p" >> $(summary-file) ; fi
+	if [ "$(eval)" != "$(defaulteval)" ] ; then printf " eval=$(eval)" >> $(summary-file) ; fi
+	if [ "$(ctb)" != "$(defaultctb)" ] ; then printf " ctb=$(ctb)" >> $(summary-file) ; fi
+	if [ "$(cgr)" != "$(defaultcgr)" ] ; then printf " cgr=$(cgr)" >> $(summary-file) ; fi
+	if [ "$(cmg)" != "$(defaultcmg)" ] ; then printf " cmg=$(cmg)" >> $(summary-file) ; fi
+	if [ "$(eoc)" != "$(defaulteoc)" ] ; then printf " eoc=$(eoc)" >> $(summary-file) ; fi
+	if [ "$(cl)" != "$(defaultcl)" ] ; then printf " cl=$(cl)" >> $(summary-file) ; fi
+	if [ "$(rmg)" != "$(defaultrmg)" ] ; then printf " rmg=$(rmg)" >> $(summary-file) ; fi
+	if [ "$(hdrmsg)" != "" ] ; then printf " $(hdrmsg)" >> $(summary-file) ; fi
+
+dosummary:
+	printf " --------\n" >> $(summary-file)
+	if [ -f $(outdir)/report-$(conf) ] ; then\
+          cat $(outdir)/report-$(conf) >> $(summary-file) ;\
+        else \
+          printf 'NO REPORT\n' >> $(summary-file) ;\
+        fi
+
+allxhelpnotall:
+	rm -f mat.so
+	$(MAKE) doheader hdrmsg="not all"
+	-$(MAKE)
+	$(MAKE) dosummary
+	$(MAKE) docoverage
+
+all0: ; $(MAKE) all o=0
+all1: ; $(MAKE) all o=1
+all2: ; $(MAKE) all o=2
+all3: ; $(MAKE) all o=3
+
+parallel-prereqs: $(src) oop.ss ht.ss mat.so cat_flush${ExeSuffix} ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} build-examples
+
+all: $(outdir) $(outdir)/script.all $(src) oop.ss ht.ss mat.so cat_flush${ExeSuffix} ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} build-examples
+	${Scheme} --verbose -q mat.so ${patchfile} < $(outdir)/script.all
+	$(MAKE) doerrors
+	$(MAKE) doreport
+	$(MAKE) docoverage
+
+$(outdir)/script.all: Mf-base $(outdir)
+
+$(outdir)/script.all makescript$o:
+	echo $(conf-scheme-code)\
+             '(record-run-coverage "$(objdir)/run.covout"'\
+             '  (lambda ()'\
+             '    (time (for-each (lambda (x) (time ((mat-file "$(objdir)") x)))'\
+             '            (quote ($(mats:%="%")))))'\
+             '    (parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\
+             '    (unless (= (#%$$check-heap-errors) 0)'\
+             '      (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
+             '      (abort))))'\
+          > $(outdir)/script.all
+
+source:
+	$(MAKE) source0 o=0
+	$(MAKE) source2 o=2
+	$(MAKE) source3 o=3
+
+source$o: ${src} mat.ss oop.ss ht.ss cat_flush.c ${fsrc} freq.in freq.out m4test.in m4test.out $(outdir)/script.all prettytest.ss ftype.h
+
+rootsrc = $(shell cd ../../mats; echo *)
+${rootsrc}:
+ifeq ($(OS),Windows_NT)
+	cp -p ../../mats/$@ $@
+else
+	ln -s ../../mats/$@ $@
+endif
+
+prettytest.ss:
+	rm -f prettytest.ss
+	$(MAKE) ${prettysrc}
+	cat ${prettysrc} > prettytest.ss
+
+bullyprettytest.ss: ${src}
+	(cd ../s; make source)
+	cat ${src} ../s/*.ss > prettytest.ss
+
+mat.so: ${patchfile}
+foreign.mo ${objdir}/foreign.mo: ${fobj}
+thread.mo ${objdir}/thread.mo: ${fobj}
+examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out build-examples
+6.mo ${objdir}/6.mo: prettytest.ss
+bytevector.mo ${objdir}/bytevector.mo: prettytest.ss
+io.mo ${objdir}/io.mo: prettytest.ss
+unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush${ExeSuffix}
+oop.mo ${objdir}/oop.mo: oop.ss
+ftype.mo ${objdir}/ftype.mo: ftype.h
+hash.mo ${objdir}/hash.mo: ht.ss
+
+build-examples:
+	( cd ../examples && ${MAKE} Scheme=${Scheme} )
+	touch build-examples
+
+prettyclean:
+	rm -f *.o ${mdclean} *.so *.mo *.covout experr* errors* report* summary testfile* testscript\
+ ${fobj} prettytest.ss cat_flush${ExeSuffix} so_locations\
+ build-examples script.all? *.html experr*.rej experr*.orig
+	rm -rf testdir*
+	rm -rf output output-* patches-work-dir
+	( cd ../examples && ${MAKE} Scheme=${Scheme} clean )
+
+clean: prettyclean
+	rm -f Make.out
+
+
+### rules for generating various experr files
+
+# everything starts with the root experr files with default
+# settings for the various parameters
+experr-compile-$o-f-f-f: root-experr-compile-$o-f-f-f
+	cp root-experr-compile-$o-f-f-f experr-compile-$o-f-f-f
+
+root-experr: # don't list dependencies!
+	rm -f root-experr-compile-$o-f-f-f
+	# use the shell glob mechanism to find the file in any output* dir
+	err_file=(output*/errors-compile-$o-f-f-f); cp $${err_file[0]} root-experr-compile-$o-f-f-f
+
+root-experrs: # don't list dependencies!
+	$(MAKE) root-experr o=0
+	$(MAKE) root-experr o=3
+
+# derive spi=t experr files by patching spi=f experr files
+# cp first in case patch is empty, since patch produces an empty output
+# file rather than a copy of the input file if the patch file is empty
+experr-compile-$o-t-f-f: experr-compile-$o-f-f-f patch-compile-$o-t-f-f
+	cp experr-compile-$o-f-f-f experr-compile-$o-t-f-f
+	-patch experr-compile-$o-t-f-f patch-compile-$o-t-f-f
+
+# derive cp0=t experr files by patching cp0=f experr files
+experr-compile-$o-$(spi)-t-f: experr-compile-$o-$(spi)-f-f patch-compile-$o-$(spi)-t-f
+	cp experr-compile-$o-$(spi)-f-f experr-compile-$o-$(spi)-t-f
+	-patch experr-compile-$o-$(spi)-t-f patch-compile-$o-$(spi)-t-f
+
+# derive cis=t experr files by patching cis=f experr files
+experr-compile-$o-$(spi)-$(cp0)-t: experr-compile-$o-$(spi)-$(cp0)-f patch-compile-$o-$(spi)-$(cp0)-t
+	cp experr-compile-$o-$(spi)-$(cp0)-f experr-compile-$o-$(spi)-$(cp0)-t
+	-patch experr-compile-$o-$(spi)-$(cp0)-t patch-compile-$o-$(spi)-$(cp0)-t
+
+# derive eval=interpret experr files by patching eval=compile experr files
+# (with cis=f, since compile-interpret-simple does not affect interpret)
+experr-interpret-$o-$(spi)-$(cp0)-$(cis): experr-compile-$o-$(spi)-$(cp0)-f patch-interpret-$o-$(spi)-$(cp0)-f
+	cp experr-compile-$o-$(spi)-$(cp0)-f experr-interpret-$o-$(spi)-$(cp0)-$(cis)
+	-patch experr-interpret-$o-$(spi)-$(cp0)-$(cis) patch-interpret-$o-$(spi)-$(cp0)-f
+
+
+### rebuilding patch files
+
+patches:
+	rm -rf patches-work-dir
+	mkdir patches-work-dir
+	shopt -s nullglob; cp output*/errors-compile* output*/errors-interpret* patches-work-dir
+	for O in 0 2 3 ; do\
+	  if [ -f patches-work-dir/errors-compile-$$O-f-f-f -a -e patches-work-dir/errors-compile-$$O-t-f-f ] ; then \
+            $(MAKE) xpatch-compile-$$O-t-f-f o=$$O spi=t ; \
+          fi ;\
+          for SPI in f t ; do\
+	    if [ -f patches-work-dir/errors-compile-$$O-$$SPI-f-f -a -e patches-work-dir/errors-compile-$$O-$$SPI-t-f ] ; then \
+              $(MAKE) xpatch-compile-$$O-$$SPI-t-f o=$$O spi=$$SPI cp0=t ;\
+            fi ;\
+            for CP0 in f t ; do\
+	      if [ -f patches-work-dir/errors-compile-$$O-$$SPI-$$CP0-f -a -e patches-work-dir/errors-compile-$$O-$$SPI-$$CP0-t ] ; then \
+                $(MAKE) xpatch-compile-$$O-$$SPI-$$CP0-t o=$$O spi=$$SPI cp0=$$CP0 cis=t ;\
+              fi ;\
+	      if [ -f patches-work-dir/errors-compile-$$O-$$SPI-$$CP0-f -a -e patches-work-dir/errors-interpret-$$O-$$SPI-$$CP0-f ] ; then \
+                $(MAKE) xpatch-interpret-$$O-$$SPI-$$CP0-f o=$$O spi=$$SPI cp0=$$CP0 ;\
+              fi\
+            done\
+          done\
+        done
+
+xpatch-compile-$o-t-f-f: # don't list dependencies!
+	rm -f patch-compile-$o-t-f-f
+	-diff --context patches-work-dir/errors-compile-$o-f-f-f\
+                        patches-work-dir/errors-compile-$o-t-f-f\
+                        > patch-compile-$o-t-f-f
+
+xpatch-compile-$o-$(spi)-t-f: # don't list dependencies!
+	rm -f patch-compile-$o-$(spi)-t-f
+	-diff --context patches-work-dir/errors-compile-$o-$(spi)-f-f\
+                        patches-work-dir/errors-compile-$o-$(spi)-t-f\
+                        > patch-compile-$o-$(spi)-t-f
+
+xpatch-compile-$o-$(spi)-$(cp0)-t: # don't list dependencies!
+	rm -f patch-compile-$o-$(spi)-$(cp0)-t
+	-diff --context patches-work-dir/errors-compile-$o-$(spi)-$(cp0)-f\
+                        patches-work-dir/errors-compile-$o-$(spi)-$(cp0)-t\
+                        > patch-compile-$o-$(spi)-$(cp0)-t
+
+xpatch-interpret-$o-$(spi)-$(cp0)-f: # don't list dependencies!
+	rm -f patch-interpret-$o-$(spi)-$(cp0)-f
+	-diff --context patches-work-dir/errors-compile-$o-$(spi)-$(cp0)-f\
+                        patches-work-dir/errors-interpret-$o-$(spi)-$(cp0)-f\
+                        > patch-interpret-$o-$(spi)-$(cp0)-f
diff --git a/mats/Mf-i3fb b/mats/Mf-i3fb
new file mode 100644
index 0000000..1e4e8fc
--- /dev/null
+++ b/mats/Mf-i3fb
@@ -0,0 +1,27 @@
+# Mf-i3fb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3fb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-i3le b/mats/Mf-i3le
new file mode 100644
index 0000000..b248620
--- /dev/null
+++ b/mats/Mf-i3le
@@ -0,0 +1,27 @@
+# Mf-i3le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-i3nb b/mats/Mf-i3nb
new file mode 100644
index 0000000..8afeb5c
--- /dev/null
+++ b/mats/Mf-i3nb
@@ -0,0 +1,27 @@
+# Mf-i3nb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3nb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-i3nt b/mats/Mf-i3nt
new file mode 100644
index 0000000..9396c9a
--- /dev/null
+++ b/mats/Mf-i3nt
@@ -0,0 +1,31 @@
+# Mf-i3nt
+# Copyright 1984-2021 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3nt
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj
+
+include Mf-base
+
+export MSYS_NO_PATHCONV=1
+export MSYS2_ARG_CONV_EXCL=*
+
+foreign1.so: $(fsrc)
+	cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv959.lib $(fsrc)"
+
+cat_flush.exe: cat_flush.c
+	cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<"
diff --git a/mats/Mf-i3ob b/mats/Mf-i3ob
new file mode 100644
index 0000000..fcd4dee
--- /dev/null
+++ b/mats/Mf-i3ob
@@ -0,0 +1,27 @@
+# Mf-i3ob
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3ob
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-i3osx b/mats/Mf-i3osx
new file mode 100644
index 0000000..a55f6ee
--- /dev/null
+++ b/mats/Mf-i3osx
@@ -0,0 +1,27 @@
+# Mf-i3osx
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3osx
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-i3qnx b/mats/Mf-i3qnx
new file mode 100644
index 0000000..3e1437a
--- /dev/null
+++ b/mats/Mf-i3qnx
@@ -0,0 +1,27 @@
+# Mf-i3qnx
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3qnx
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-i3s2 b/mats/Mf-i3s2
new file mode 100644
index 0000000..c39fffe
--- /dev/null
+++ b/mats/Mf-i3s2
@@ -0,0 +1,27 @@
+# Mf-i3s2
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = i3s2
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	gcc -o cat_flush cat_flush.c
diff --git a/mats/Mf-ppc32le b/mats/Mf-ppc32le
new file mode 100644
index 0000000..547ca00
--- /dev/null
+++ b/mats/Mf-ppc32le
@@ -0,0 +1,27 @@
+# Mf-ppc32le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ppc32le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ta6fb b/mats/Mf-ta6fb
new file mode 100644
index 0000000..5ed233e
--- /dev/null
+++ b/mats/Mf-ta6fb
@@ -0,0 +1,27 @@
+# Mf-ta6fb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6fb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ta6le b/mats/Mf-ta6le
new file mode 100644
index 0000000..0353150
--- /dev/null
+++ b/mats/Mf-ta6le
@@ -0,0 +1,27 @@
+# Mf-ta6le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m64 -pthread -fPIC -shared -O2 -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ta6nb b/mats/Mf-ta6nb
new file mode 100644
index 0000000..9b9b898
--- /dev/null
+++ b/mats/Mf-ta6nb
@@ -0,0 +1,27 @@
+# Mf-ta6nb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6nb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ta6nt b/mats/Mf-ta6nt
new file mode 100644
index 0000000..4a8b069
--- /dev/null
+++ b/mats/Mf-ta6nt
@@ -0,0 +1,31 @@
+# Mf-ta6nt
+# Copyright 1984-2021 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6nt
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj
+
+include Mf-base
+
+export MSYS_NO_PATHCONV=1
+export MSYS2_ARG_CONV_EXCL=*
+
+foreign1.so: $(fsrc)
+	cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv959.lib $(fsrc)"
+
+cat_flush.exe: cat_flush.c
+	cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<"
diff --git a/mats/Mf-ta6ob b/mats/Mf-ta6ob
new file mode 100644
index 0000000..8f25aed
--- /dev/null
+++ b/mats/Mf-ta6ob
@@ -0,0 +1,27 @@
+# Mf-ta6ob
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6ob
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ta6osx b/mats/Mf-ta6osx
new file mode 100644
index 0000000..becbbcd
--- /dev/null
+++ b/mats/Mf-ta6osx
@@ -0,0 +1,27 @@
+# Mf-ta6osx
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6osx
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m64 -pthread -dynamiclib -undefined dynamic_lookup -O2 -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ta6s2 b/mats/Mf-ta6s2
new file mode 100644
index 0000000..c5f0b0e
--- /dev/null
+++ b/mats/Mf-ta6s2
@@ -0,0 +1,27 @@
+# Mf-ta6s2
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6s2
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	gcc -m64 -D_REENTRANT -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	gcc -o cat_flush cat_flush.c
diff --git a/mats/Mf-ti3fb b/mats/Mf-ti3fb
new file mode 100644
index 0000000..56bf7d3
--- /dev/null
+++ b/mats/Mf-ti3fb
@@ -0,0 +1,27 @@
+# Mf-ti3fb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3fb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ti3le b/mats/Mf-ti3le
new file mode 100644
index 0000000..22b4148
--- /dev/null
+++ b/mats/Mf-ti3le
@@ -0,0 +1,27 @@
+# Mf-ti3le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ti3nb b/mats/Mf-ti3nb
new file mode 100644
index 0000000..573946e
--- /dev/null
+++ b/mats/Mf-ti3nb
@@ -0,0 +1,27 @@
+# Mf-ti3nb
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3nb
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ti3nt b/mats/Mf-ti3nt
new file mode 100644
index 0000000..355e279
--- /dev/null
+++ b/mats/Mf-ti3nt
@@ -0,0 +1,32 @@
+# Mf-ti3nt
+# Copyright 1984-2021 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3nt
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj
+
+include Mf-base
+
+export MSYS_NO_PATHCONV=1
+export MSYS2_ARG_CONV_EXCL=*
+
+foreign1.so: $(fsrc)
+	cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv959.lib $(fsrc)"
+
+cat_flush.exe: cat_flush.c
+	cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<"
+
diff --git a/mats/Mf-ti3ob b/mats/Mf-ti3ob
new file mode 100644
index 0000000..4472b60
--- /dev/null
+++ b/mats/Mf-ti3ob
@@ -0,0 +1,27 @@
+# Mf-ti3ob
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3ob
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ti3osx b/mats/Mf-ti3osx
new file mode 100644
index 0000000..9273b44
--- /dev/null
+++ b/mats/Mf-ti3osx
@@ -0,0 +1,27 @@
+# Mf-ti3osx
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3osx
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -pthread -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/Mf-ti3s2 b/mats/Mf-ti3s2
new file mode 100644
index 0000000..bb3b360
--- /dev/null
+++ b/mats/Mf-ti3s2
@@ -0,0 +1,27 @@
+# Mf-ti3s2
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ti3s2
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	gcc -m32 -D_REENTRANT -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	gcc -o cat_flush cat_flush.c
diff --git a/mats/Mf-tppc32le b/mats/Mf-tppc32le
new file mode 100644
index 0000000..8b9d9f0
--- /dev/null
+++ b/mats/Mf-tppc32le
@@ -0,0 +1,27 @@
+# Mf-tppc32le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tppc32le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	$(CC) -m32 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	$(CC) -o cat_flush cat_flush.c
diff --git a/mats/bytevector.ms b/mats/bytevector.ms
new file mode 100644
index 0000000..bfcbd81
--- /dev/null
+++ b/mats/bytevector.ms
@@ -0,0 +1,11308 @@
+;;; bytevector.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat native-endianness
+ ; wrong argument count
+  (error? (native-endianness 'big))
+
+  (and (memq (native-endianness) '(big little)) #t)
+  (eq? (native-endianness)
+       (case (machine-type)
+         [(i3le ti3le i3nt ti3nt a6nt ta6nt i3ob ti3ob i3fb ti3fb i3nb ti3nb i3osx ti3osx a6le ta6le a6nb ta6nb a6osx ta6osx a6fb ta6fb a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx arm32le tarm32le) 'little]
+         [(ppc32le tppc32le) 'big]
+         [else (errorf #f "unrecognized machine type")]))
+)
+
+(mat endianness
+ ; invalid endianness
+  (error? (endianness spam))
+  (error? (endianness 'big))
+  (error? (endianness "little"))
+
+ ; invalid syntax
+  (error? (endianness))
+  (error? (endianness . big))
+  (error? (endianness big little))
+
+  (eq? (endianness big) 'big)
+  (eq? (endianness little) 'little)
+  (eq? (let ([big 'large]) (endianness big)) 'big)
+  (eq? (let ([little 'small]) (endianness little)) 'little)
+)
+
+(mat make-bytevector
+ ; wrong argument count
+  (error? (make-bytevector))
+  (error? (make-bytevector 0 0 0))
+
+ ; invalid size
+  (error? (make-bytevector -1))
+  (error? (make-bytevector -1 0))
+  (error? (make-bytevector (+ (most-positive-fixnum) 1)))
+  (error? (make-bytevector (+ (most-positive-fixnum) 1) -1))
+  (error? (begin (make-bytevector 'a -1) #f))
+
+ ; invalid fill
+  (error? (make-bytevector 3 'a))
+  (error? (make-bytevector 10 256))
+  (error? (make-bytevector 10 -129))
+  (error? (make-bytevector 10 (+ (most-positive-fixnum) 1)))
+  (error? (begin (make-bytevector 10 (- (most-negative-fixnum) 1)) #f))
+
+  (eqv? (bytevector-length (make-bytevector 10)) 10)
+  (eqv? (let ([n 11]) (bytevector-length (make-bytevector n))) 11)
+  (eqv? (bytevector-length (make-bytevector 100)) 100)
+  (eqv? (bytevector-length (make-bytevector (+ 100 17))) 117)
+  (eq? (make-bytevector 0) #vu8())
+  (let ([x (make-bytevector 10)])
+    (and (= (bytevector-length x) 10)
+         (andmap fixnum? (bytevector->s8-list x))))
+  (do ([n -128 (fx+ n 1)])
+      ((fx= n 128) #t)
+    (let ([v (make-bytevector 3)])
+      (unless (and (fixnum? (bytevector-s8-ref v 0))
+                   (fixnum? (bytevector-s8-ref v 1))
+                   (fixnum? (bytevector-s8-ref v 2)))
+        (errorf #f "wrong value for ~s" n))))
+  (do ([q 10000 (fx- q 1)])
+      ((fx= q 0) #t)
+    (do ([n -128 (fx+ n 1)])
+        ((fx= n 128) #t)
+      (let ([v (make-bytevector 3 n)])
+        (unless (and (eqv? (bytevector-s8-ref v 0) n)
+                     (eqv? (bytevector-s8-ref v 1) n)
+                     (eqv? (bytevector-s8-ref v 2) n))
+          (errorf #f "wrong value for ~s" n)))))
+  (do ([q 10000 (fx- q 1)])
+      ((fx= q 0) #t)
+    (do ([n 0 (fx+ n 1)])
+        ((fx= n 255) #t)
+      (let ([v (make-bytevector 3 n)])
+        (unless (and (eqv? (bytevector-u8-ref v 0) n)
+                     (eqv? (bytevector-u8-ref v 1) n)
+                     (eqv? (bytevector-u8-ref v 2) n))
+          (errorf #f "wrong value for ~s" n)))))
+)
+
+(mat bytevector
+ ; invalid value
+  (error? (bytevector 3 4 256))
+  (error? (bytevector 3 4 -129))
+  (error? (bytevector 3 4 500))
+  (error? (bytevector 3 4 -500))
+  (error? (bytevector 3 4 1e100))
+  (error? (begin (bytevector 3 4 #e1e100) #f))
+
+  (eqv? (bytevector) #vu8())
+  (equal? (bytevector 7 7 7 7 7 7 7 7 7 7) (make-bytevector 10 7))
+  (equal? (bytevector 2 2) (make-bytevector (- 4 2) (+ 1 1)))
+  (eqv? (bytevector) (make-bytevector (- 4 4) (+ 1 1)))
+  (eqv? (bytevector) (make-bytevector (- 4 4) (+ 1 1)))
+  (equal? (bytevector 1) #vu8(1))
+  (equal? (bytevector -1) #vu8(255))
+  (equal? (bytevector -1 2) #vu8(255 2))
+  (equal? (bytevector 2 -1) #vu8(2 255))
+  (equal?
+    (letrec-syntax ([z (syntax-rules ()
+                         [(_) (list (bytevector))]
+                         [(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
+      (z 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))
+    '(#vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11 12 13)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11 12)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11)
+      #vu8(1 2 3 4 5 6 7 8 9 10)
+      #vu8(1 2 3 4 5 6 7 8 9)
+      #vu8(1 2 3 4 5 6 7 8)
+      #vu8(1 2 3 4 5 6 7)
+      #vu8(1 2 3 4 5 6)
+      #vu8(1 2 3 4 5)
+      #vu8(1 2 3 4)
+      #vu8(1 2 3)
+      #vu8(1 2)
+      #vu8(1)
+      #vu8()))
+  (equal?
+    (letrec-syntax ([z (syntax-rules ()
+                         [(_) (list (bytevector))]
+                         [(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
+      (z -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17))
+    '(#vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242 241 240 239)
+      #vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242 241 240)
+      #vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242 241)
+      #vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242)
+      #vu8(255 254 253 252 251 250 249 248 247 246 245 244 243)
+      #vu8(255 254 253 252 251 250 249 248 247 246 245 244)
+      #vu8(255 254 253 252 251 250 249 248 247 246 245)
+      #vu8(255 254 253 252 251 250 249 248 247 246)
+      #vu8(255 254 253 252 251 250 249 248 247)
+      #vu8(255 254 253 252 251 250 249 248)
+      #vu8(255 254 253 252 251 250 249)
+      #vu8(255 254 253 252 251 250)
+      #vu8(255 254 253 252 251)
+      #vu8(255 254 253 252)
+      #vu8(255 254 253)
+      #vu8(255 254)
+      #vu8(255)
+      #vu8()))
+  (equal?
+    (let ([a 1] [c -3] [d -4] [e 5] [f 6] [h -8] [k 11] [l -12] [p -16] [q 17])
+      (letrec-syntax ([z (syntax-rules ()
+                           [(_) (list (bytevector))]
+                           [(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
+        (z a 2 c d e f -7 h 9 -10 k l -13 -14 15 p q)))
+    '(#vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242 15 240 17)
+      #vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242 15 240)
+      #vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242 15)
+      #vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242)
+      #vu8(1 2 253 252 5 6 249 248 9 246 11 244 243)
+      #vu8(1 2 253 252 5 6 249 248 9 246 11 244)
+      #vu8(1 2 253 252 5 6 249 248 9 246 11)
+      #vu8(1 2 253 252 5 6 249 248 9 246)
+      #vu8(1 2 253 252 5 6 249 248 9)
+      #vu8(1 2 253 252 5 6 249 248)
+      #vu8(1 2 253 252 5 6 249)
+      #vu8(1 2 253 252 5 6)
+      #vu8(1 2 253 252 5)
+      #vu8(1 2 253 252)
+      #vu8(1 2 253)
+      #vu8(1 2)
+      #vu8(1)
+      #vu8()))
+  (equal?
+    (let ([a -1] [c 3] [d 4] [e -5] [f -6] [h 8] [k -11] [l 12] [p 16] [q -17])
+      (letrec-syntax ([z (syntax-rules ()
+                           [(_) (list (bytevector))]
+                           [(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
+        (z a -2 c d e f 7 h -9 10 k l 13 14 -15 p q)))
+    '(#vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14 241 16 239)
+      #vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14 241 16)
+      #vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14 241)
+      #vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14)
+      #vu8(255 254 3 4 251 250 7 8 247 10 245 12 13)
+      #vu8(255 254 3 4 251 250 7 8 247 10 245 12)
+      #vu8(255 254 3 4 251 250 7 8 247 10 245)
+      #vu8(255 254 3 4 251 250 7 8 247 10)
+      #vu8(255 254 3 4 251 250 7 8 247)
+      #vu8(255 254 3 4 251 250 7 8)
+      #vu8(255 254 3 4 251 250 7)
+      #vu8(255 254 3 4 251 250)
+      #vu8(255 254 3 4 251)
+      #vu8(255 254 3 4)
+      #vu8(255 254 3)
+      #vu8(255 254)
+      #vu8(255)
+      #vu8()))
+  (equal? (apply bytevector (make-list 20000 #xc7))
+          (u8-list->bytevector (make-list 20000 #xc7)))
+  (let ([n0 1] [n1 -2] [n4 5])
+    (let ([x (bytevector n0 n1 3 -4 n4)])
+      (and (bytevector? x)
+           (equal? (bytevector->s8-list x) '(1 -2 3 -4 5))
+           (equal? (bytevector->u8-list x) '(1 254 3 252 5))
+           (eqv? (bytevector-s8-ref x 0) 1)
+           (eqv? (bytevector-u8-ref x 0) 1)
+           (eqv? (bytevector-s8-ref x 1) -2)
+           (eqv? (bytevector-u8-ref x 1) 254)
+           (eqv? (bytevector-s8-ref x 2) 3)
+           (eqv? (bytevector-u8-ref x 2) 3)
+           (eqv? (bytevector-s8-ref x 3) -4)
+           (eqv? (bytevector-u8-ref x 3) 252)
+           (eqv? (bytevector-s8-ref x 4) 5)
+           (eqv? (bytevector-u8-ref x 4) 5))))
+  (begin
+    (define $bv-f
+      (lambda (a b c d e f g h i j k l m n o p q r s t u v w x y z)
+        (letrec-syntax ([foo (syntax-rules ()
+                               [(_) (list (bytevector))]
+                               [(_ x ... y) (cons (bytevector x ... y) (foo x ...))])])
+          (foo a b c d e f g h i j k l m n o p q r s t u v w x y z))))
+    #t)
+  (equal?
+    ($bv-f 101 -102 103 -104 -105 106 107 -108 -109 -110 111 112 113 114 -115 -116 -117 -118 119 120 121 -122 -123 124 -125 126)
+    '(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111)
+      #vu8(101 154 103 152 151 106 107 148 147 146)
+      #vu8(101 154 103 152 151 106 107 148 147)
+      #vu8(101 154 103 152 151 106 107 148)
+      #vu8(101 154 103 152 151 106 107)
+      #vu8(101 154 103 152 151 106)
+      #vu8(101 154 103 152 151)
+      #vu8(101 154 103 152)
+      #vu8(101 154 103)
+      #vu8(101 154)
+      #vu8(101)
+      #vu8()))
+  (begin
+    (define $bv-g
+      (lambda (a c e g i k m o q s u w y)
+        (letrec-syntax ([foo (syntax-rules ()
+                               [(_) (list (bytevector))]
+                               [(_ x ... y) (cons (bytevector x ... y) (foo x ...))])])
+          (foo a -102 c -104 e 106 g -108 i -110 k 112 m 114 o -116 q -118 s 120 u -122 w 124 y 126))))
+    #t)
+  (equal?
+    ($bv-g 101 103 -105 107 -109 111 113 -115 -117 119 121 -123 -125)
+    '(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111)
+      #vu8(101 154 103 152 151 106 107 148 147 146)
+      #vu8(101 154 103 152 151 106 107 148 147)
+      #vu8(101 154 103 152 151 106 107 148)
+      #vu8(101 154 103 152 151 106 107)
+      #vu8(101 154 103 152 151 106)
+      #vu8(101 154 103 152 151)
+      #vu8(101 154 103 152)
+      #vu8(101 154 103)
+      #vu8(101 154)
+      #vu8(101)
+      #vu8()))
+  (begin
+    (define $bv-h
+      (lambda (b d f h j l n p r t v x z)
+        (letrec-syntax ([foo (syntax-rules ()
+                               [(_) (list (bytevector))]
+                               [(_ x ... y) (cons (bytevector x ... y) (foo x ...))])])
+          (foo 101 b 103 d -105 f 107 h -109 j 111 l 113 n -115 p -117 r 119 t 121 v -123 x -125 z))))
+    #t)
+  (equal?
+    ($bv-h -102 -104 106 -108 -110 112 114 -116 -118 120 -122 124 126)
+    '(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111)
+      #vu8(101 154 103 152 151 106 107 148 147 146)
+      #vu8(101 154 103 152 151 106 107 148 147)
+      #vu8(101 154 103 152 151 106 107 148)
+      #vu8(101 154 103 152 151 106 107)
+      #vu8(101 154 103 152 151 106)
+      #vu8(101 154 103 152 151)
+      #vu8(101 154 103 152)
+      #vu8(101 154 103)
+      #vu8(101 154)
+      #vu8(101)
+      #vu8()))
+  (begin
+    (define $bv-i-ls* '())
+    (define $bv-i
+      (lambda (b d f h j l n p r t v x z)
+        (define this)
+        (define (init!) (set! $bv-i-ls* (cons '() $bv-i-ls*)) (set! this 0))
+        (define (bump!) (set! this (fx+ this 1)) (set-car! $bv-i-ls* (cons this (car $bv-i-ls*))))
+        (define-syntax plink (syntax-rules () [(_ x) (begin (bump!) x)]))
+        (letrec-syntax ([foo (syntax-rules ()
+                               [(_) (list (bytevector))]
+                               [(_ x ... y) (cons (begin (init!) (bytevector (plink x) ... (plink y))) (foo x ...))])])
+          (foo 101 b 103 d -105 f 107 h -109 j 111 l 113 n -115 p -117 r 119 t 121 v -123 x -125 z))))
+    #t)
+  (equal?
+    ($bv-i -102 -104 106 -108 -110 112 114 -116 -118 120 -122 124 126)
+    '(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111 112)
+      #vu8(101 154 103 152 151 106 107 148 147 146 111)
+      #vu8(101 154 103 152 151 106 107 148 147 146)
+      #vu8(101 154 103 152 151 106 107 148 147)
+      #vu8(101 154 103 152 151 106 107 148)
+      #vu8(101 154 103 152 151 106 107)
+      #vu8(101 154 103 152 151 106)
+      #vu8(101 154 103 152 151)
+      #vu8(101 154 103 152)
+      #vu8(101 154 103)
+      #vu8(101 154)
+      #vu8(101)
+      #vu8()))
+  (equal?
+    (sort (lambda (ls1 ls2) (fx<= (length ls1) (length ls2))) $bv-i-ls*)
+    '((1)
+      (2 1)
+      (3 2 1)
+      (4 3 2 1)
+      (5 4 3 2 1)
+      (6 5 4 3 2 1)
+      (7 6 5 4 3 2 1)
+      (8 7 6 5 4 3 2 1)
+      (9 8 7 6 5 4 3 2 1)
+      (10 9 8 7 6 5 4 3 2 1)
+      (11 10 9 8 7 6 5 4 3 2 1)
+      (12 11 10 9 8 7 6 5 4 3 2 1)
+      (13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
+      (26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)))
+)
+
+(mat bytevector-syntax
+  (eq? #vu8() '#vu8())
+  (eq? '#0vu8() #vu8())
+  (equal?
+    '(#vu8(1 2 3) #3vu8(1 2 3) #6vu8(1 2 3))
+    (list (bytevector 1 2 3) (bytevector 1 2 3) (bytevector 1 2 3 3 3 3)))
+  (let ([x (with-input-from-string "#10vu8()" read)])
+    (and (= (bytevector-length x) 10)
+         (andmap fixnum? (bytevector->u8-list x))))
+)
+
+(mat bytevector-length
+ ; wrong argument count
+  (error? (bytevector-length))
+  (error? (begin (bytevector-length #vu8() '#vu8()) #f))
+
+ ; not a bytevector
+  (error? (bytevector-length '(a b c)))
+  (error? (begin (bytevector-length '(a b c)) #f))
+
+  (eqv? (bytevector-length #vu8(3 252 5)) 3)
+  (eqv? (bytevector-length '#100vu8(5 4 3)) 100)
+  (eqv? (bytevector-length #vu8()) 0)
+)
+
+(mat $bytevector-ref-check?
+  (let ([bv (make-bytevector 3)] [imm-bv (bytevector->immutable-bytevector (make-bytevector 3))] [not-bv (make-fxvector 3)])
+    (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
+      (and
+        (not (#%$bytevector-ref-check? 8 not-bv i0))
+        (not (#%$bytevector-ref-check? 8 bv ifalse))
+        (not (#%$bytevector-ref-check? 8 bv i-1))
+        (not (#%$bytevector-ref-check? 8 imm-bv i-1))
+        (#%$bytevector-ref-check? 8 bv 0)
+        (#%$bytevector-ref-check? 8 bv 1)
+        (#%$bytevector-ref-check? 8 bv 2)
+        (#%$bytevector-ref-check? 8 imm-bv 0)
+        (#%$bytevector-ref-check? 8 imm-bv 1)
+        (#%$bytevector-ref-check? 8 imm-bv 2)
+        (#%$bytevector-ref-check? 8 bv i0)
+        (#%$bytevector-ref-check? 8 bv i1)
+        (#%$bytevector-ref-check? 8 bv i2)
+        (#%$bytevector-ref-check? 8 imm-bv i0)
+        (#%$bytevector-ref-check? 8 imm-bv i1)
+        (#%$bytevector-ref-check? 8 imm-bv i2)
+        (not (#%$bytevector-ref-check? 8 bv 3))
+        (not (#%$bytevector-ref-check? 8 bv i3))
+        (not (#%$bytevector-ref-check? 8 bv ibig))
+        (not (#%$bytevector-ref-check? 8 imm-bv 3))
+        (not (#%$bytevector-ref-check? 8 imm-bv i3))
+        (not (#%$bytevector-ref-check? 8 imm-bv ibig)))))
+  (let ([n 128])
+    (let ([bv (make-bytevector n)] [imm-bv (bytevector->immutable-bytevector (make-bytevector n))] [not-bv (make-fxvector n)])
+      (and
+        (let ([i 0])
+          (and (not (#%$bytevector-ref-check? 8 not-bv i))
+               (not (#%$bytevector-ref-check? 16 not-bv i))
+               (not (#%$bytevector-ref-check? 32 not-bv i))
+               (not (#%$bytevector-ref-check? 64 not-bv i))))
+        (let f ([i -1])
+          (or (fx< i -8)
+              (and (not (#%$bytevector-ref-check? 8 bv i))
+                   (not (#%$bytevector-ref-check? 16 bv i))
+                   (not (#%$bytevector-ref-check? 32 bv i))
+                   (not (#%$bytevector-ref-check? 64 bv i))
+                   (not (#%$bytevector-ref-check? 8 imm-bv i))
+                   (not (#%$bytevector-ref-check? 16 imm-bv i))
+                   (not (#%$bytevector-ref-check? 32 imm-bv i))
+                   (not (#%$bytevector-ref-check? 64 imm-bv i))
+                   (f (fx* i 2)))))
+        (let f ([i 0])
+          (or (fx= i n)
+              (and (#%$bytevector-ref-check? 8 bv i)
+                   (if (and (fx= (modulo i 2) 0) (fx<= (fx+ i 2) n))
+                       (and (#%$bytevector-ref-check? 16 bv i)
+                            (#%$bytevector-ref-check? 16 imm-bv i))
+                       (not (or (#%$bytevector-ref-check? 16 bv i)
+                                (#%$bytevector-ref-check? 16 imm-bv i))))
+                   (if (and (fx= (modulo i 4) 0) (fx<= (fx+ i 4) n))
+                       (and (#%$bytevector-ref-check? 32 bv i)
+                            (#%$bytevector-ref-check? 32 imm-bv i))
+                       (not (or (#%$bytevector-ref-check? 32 bv i)
+                                (#%$bytevector-ref-check? 32 imm-bv i))))
+                   (if (and (fx= (modulo i 8) 0) (fx<= (fx+ i 8) n))
+                       (and (#%$bytevector-ref-check? 64 bv i)
+                            (#%$bytevector-ref-check? 64 imm-bv i))
+                       (not (or (#%$bytevector-ref-check? 64 bv i)
+                                (#%$bytevector-ref-check? 64 imm-bv i))))
+                   (f (fx+ i 1)))))
+        (let ([i n])
+          (and (not (#%$bytevector-ref-check? 8 bv i))
+               (not (#%$bytevector-ref-check? 16 bv i))
+               (not (#%$bytevector-ref-check? 32 bv i))
+               (not (#%$bytevector-ref-check? 64 bv i))
+               (not (#%$bytevector-ref-check? 8 imm-bv i))
+               (not (#%$bytevector-ref-check? 16 imm-bv i))
+               (not (#%$bytevector-ref-check? 32 imm-bv i))
+               (not (#%$bytevector-ref-check? 64 imm-bv i))))
+        (let ([i (+ (most-positive-fixnum) 1)])
+          (and (not (#%$bytevector-ref-check? 8 bv i))
+               (not (#%$bytevector-ref-check? 16 bv i))
+               (not (#%$bytevector-ref-check? 32 bv i))
+               (not (#%$bytevector-ref-check? 64 bv i))
+               (not (#%$bytevector-ref-check? 8 imm-bv i))
+               (not (#%$bytevector-ref-check? 16 imm-bv i))
+               (not (#%$bytevector-ref-check? 32 imm-bv i))
+               (not (#%$bytevector-ref-check? 64 imm-bv i)))))))
+)
+
+(mat bytevector-s8-ref
+ ; wrong argument count
+  (error? (bytevector-s8-ref))
+  (error? (bytevector-s8-ref #vu8(3 252 5)))
+  (error? (begin (bytevector-s8-ref #vu8(3 252 5) 0 5) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s8-ref '#(3 -4 5) 2))
+  (error? (begin (bytevector-s8-ref '(3 -4 5) 2) #f))
+
+ ; invalid index
+  (error? (bytevector-s8-ref #vu8(3 252 5) 3))
+  (error? (bytevector-s8-ref #vu8(3 252 5) -1))
+  (error? (begin (bytevector-s8-ref #vu8(3 252 5) 'a) #f))
+
+  (eqv? (bytevector-s8-ref #vu8(3 252 5) 0) 3)
+  (eqv? (bytevector-s8-ref #vu8(3 252 5) 1) -4)
+  (eqv? (bytevector-s8-ref #vu8(3 252 5) 2) 5)
+  (do ([n -128 (fx+ n 1)])
+      ((fx= n 128) #t)
+    (unless (eqv? (bytevector-s8-ref (bytevector 15 n 35) 1) n)
+      (errorf #f "wrong value for ~s" n)))
+  (do ([n 128 (fx+ n 1)])
+      ((fx= n 256) #t)
+    (unless (eqv? (bytevector-s8-ref (bytevector 15 n 35) 1) (- n 256))
+      (errorf #f "wrong value for ~s" n)))
+)
+
+(mat bytevector-u8-ref
+ ; wrong argument count
+  (error? (bytevector-u8-ref))
+  (error? (bytevector-u8-ref #vu8(3 252 5)))
+  (error? (begin (bytevector-u8-ref #vu8(3 252 5) 0 5) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u8-ref '#(3 -4 5) 2))
+  (error? (begin (bytevector-u8-ref '(3 -4 5) 2) #f))
+
+ ; invalid index
+  (error? (bytevector-u8-ref #vu8(3 252 5) 3))
+  (error? (bytevector-u8-ref #vu8(3 252 5) -1))
+  (error? (begin (bytevector-u8-ref #vu8(3 252 5) 'a) #f))
+
+  (eqv? (bytevector-u8-ref #vu8(3 252 5) 0) 3)
+  (eqv? (bytevector-u8-ref #vu8(3 252 5) 1) 252)
+  (eqv? (bytevector-u8-ref #vu8(3 252 5) 2) 5)
+  (do ([n -128 (fx+ n 1)])
+      ((fx= n 0) #t)
+    (unless (eqv? (bytevector-u8-ref (bytevector 15 n 35) 1) (+ 256 n))
+      (errorf #f "wrong value for ~s" n)))
+  (do ([n 0 (fx+ n 1)])
+      ((fx= n 256) #t)
+    (unless (eqv? (bytevector-u8-ref (bytevector 15 n 35) 1) n)
+      (errorf #f "wrong value for ~s" n)))
+)
+
+(mat bytevector-s8-set!
+  (begin
+    (define $v1 (bytevector 3 4 5))
+    (and (bytevector? $v1) (equal? $v1 #vu8(3 4 5))))
+
+ ; wrong argument count
+  (error? (bytevector-s8-set!))
+  (error? (bytevector-s8-set! $v1))
+  (error? (bytevector-s8-set! $v1 2))
+  (error? (begin (bytevector-s8-set! $v1 2 3 4) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s8-set! (list 3 4 5) 2 3))
+  (error? (begin (bytevector-s8-set! (list 3 4 5) 2 3) #f))
+
+ ; invalid index
+  (error? (bytevector-s8-set! $v1 3 3))
+  (error? (bytevector-s8-set! $v1 -1 3))
+  (error? (begin (bytevector-s8-set! $v1 'a 3) #f))
+
+ ; invalid value
+  (error? (bytevector-s8-set! $v1 2 -129))
+  (error? (bytevector-s8-set! $v1 2 128))
+  (error? (begin (bytevector-s8-set! $v1 0 'd) #f))
+
+ ; make sure no damage done
+  (and (bytevector? $v1) (equal? $v1 #vu8(3 4 5)))
+
+  (let ((v (bytevector 3 4 5)))
+    (and (begin (bytevector-s8-set! v 0 33) (equal? v #vu8(33 4 5)))
+         (begin (bytevector-s8-set! v 1 -44) (equal? v #vu8(33 212 5)))
+         (begin (bytevector-s8-set! v 2 55) (equal? v #vu8(33 212 55)))))
+  (let ([v (bytevector 3 4 5)])
+    (do ([n -128 (fx+ n 1)])
+        ((fx= n 128) #t)
+      (bytevector-s8-set! v 1 n)
+      (unless (and (eqv? (bytevector-s8-ref v 0) 3)
+                   (eqv? (bytevector-s8-ref v 1) n)
+                   (eqv? (bytevector-s8-ref v 2) 5))
+        (errorf #f "wrong value for ~s" n))))
+)
+
+(mat bytevector-u8-set!
+  (begin
+    (define $v1 (bytevector 3 4 5))
+    (and (bytevector? $v1) (equal? $v1 #vu8(3 4 5))))
+
+ ; wrong argument count
+  (error? (bytevector-u8-set!))
+  (error? (bytevector-u8-set! $v1))
+  (error? (bytevector-u8-set! $v1 2))
+  (error? (begin (bytevector-u8-set! $v1 2 3 4) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u8-set! (list 3 4 5) 2 3))
+  (error? (begin (bytevector-u8-set! (list 3 4 5) 2 3) #f))
+
+ ; invalid index
+  (error? (bytevector-u8-set! $v1 3 3))
+  (error? (bytevector-u8-set! $v1 -1 3))
+  (error? (begin (bytevector-u8-set! $v1 'a 3) #f))
+
+ ; invalid value
+  (error? (bytevector-u8-set! $v1 2 -1))
+  (error? (bytevector-u8-set! $v1 0 256))
+  (error? (begin (bytevector-u8-set! $v1 0 'd) #f))
+
+ ; make sure no damage done
+  (and (bytevector? $v1) (equal? $v1 #vu8(3 4 5)))
+
+  (let ((v (bytevector 3 4 5)))
+    (and (begin (bytevector-u8-set! v 0 33) (equal? v #vu8(33 4 5)))
+         (begin (bytevector-u8-set! v 1 128) (equal? v #vu8(33 128 5)))
+         (begin (bytevector-u8-set! v 2 55) (equal? v #vu8(33 128 55)))))
+  (let ([v (bytevector 3 4 5)])
+    (do ([n 0 (fx+ n 1)])
+        ((fx= n 256) #t)
+      (bytevector-u8-set! v 1 n)
+      (unless (and (eqv? (bytevector-u8-ref v 0) 3)
+                   (eqv? (bytevector-u8-ref v 1) n)
+                   (eqv? (bytevector-u8-ref v 2) 5))
+        (errorf #f "wrong value for ~s" n))))
+)
+
+(module (big-endian->signed little-endian->signed native->signed
+         big-endian->unsigned little-endian->unsigned native->unsigned)
+  (define (signed n) (if (>= n 128) (- n 256) n))
+
+  (define (big-endian->signed . args)
+    (let f ([args (cdr args)] [a (signed (car args))])
+      (if (null? args)
+          a
+          (f (cdr args) (logor (ash a 8) (car args))))))
+
+  (define (little-endian->signed . args)
+    (let f ([args args])
+      (if (null? (cdr args))
+          (signed (car args))
+          (logor (ash (f (cdr args)) 8) (car args)))))
+
+  (define (native->signed . args)
+    (case (native-endianness)
+      [(big) (apply big-endian->signed args)]
+      [(little) (apply little-endian->signed args)]
+      [else
+       (errorf 'native->signed
+         "unhandled endianness ~s"
+         (native-endianness))]))
+
+  (define (big-endian->unsigned . args)
+    (let f ([args (cdr args)] [a (car args)])
+      (if (null? args)
+          a
+          (f (cdr args) (logor (ash a 8) (car args))))))
+
+  (define (little-endian->unsigned . args)
+    (let f ([args args])
+      (if (null? args)
+          0
+          (logor (ash (f (cdr args)) 8) (car args)))))
+
+  (define (native->unsigned . args)
+    (case (native-endianness)
+      [(big) (apply big-endian->unsigned args)]
+      [(little) (apply little-endian->unsigned args)]
+      [else
+       (errorf 'native->unsigned
+         "unhandled endianness ~s"
+         (native-endianness))])))
+
+(mat bytevector-s16-native-ref
+ ; wrong argument count
+  (error? (bytevector-s16-native-ref))
+  (error? (bytevector-s16-native-ref #vu8(3 252 5)))
+  (error? (begin (bytevector-s16-native-ref #vu8(3 252 5) 0 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s16-native-ref '#(3 252 5) 0))
+  (error? (begin (bytevector-s16-native-ref '#(3 252 5) 0) #f))
+
+ ; invalid index
+  (error? (bytevector-s16-native-ref #vu8(3 252 5) -1))
+  (error? (bytevector-s16-native-ref #vu8(3 252 5) 1))
+  (error? (bytevector-s16-native-ref #vu8(3 252 5) 2))
+  (error? (bytevector-s16-native-ref #vu8(3 252 5) 3))
+  (error? (begin (bytevector-s16-native-ref #vu8(3 252 5) 4.0) #f))
+
+  (eqv?
+    (bytevector-s16-native-ref #vu8(3 252 5) 0)
+    (native->signed 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-s16-native-ref v 0)
+        (bytevector-s16-native-ref v 2)
+        (bytevector-s16-native-ref v 4)
+        (bytevector-s16-native-ref v i)
+        (bytevector-s16-native-ref v 6)
+        (bytevector-s16-native-ref v 8)))
+    (list
+      (native->signed 3 252)
+      (native->signed 5 17)
+      (native->signed 23 55)
+      (native->signed 23 55)
+      (native->signed 250 89)
+      (native->signed 200 201)))
+
+  (test-cp0-expansion eqv?
+    '(bytevector-s16-native-ref #vu8(3 252 5) 0)
+    (native->signed 3 252))
+  (equal?
+    ;; list doesn't get inlined, so take if off the front of the list
+    (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+           (expand/optimize '(let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+                               (list
+                                 (bytevector-s16-native-ref v 0)
+                                 (bytevector-s16-native-ref v 2)
+                                 (bytevector-s16-native-ref v 4)
+                                 (bytevector-s16-native-ref v i)
+                                 (bytevector-s16-native-ref v 6)
+                                 (bytevector-s16-native-ref v 8))))))
+      (list
+         (native->signed 3 252)
+         (native->signed 5 17)
+         (native->signed 23 55)
+         (native->signed 23 55)
+         (native->signed 250 89)
+         (native->signed 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-s16-native-ref (bytevector i j) 0)
+                    (native->signed i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+)
+
+(mat bytevector-u16-native-ref
+ ; wrong argument count
+  (error? (bytevector-u16-native-ref))
+  (error? (bytevector-u16-native-ref #vu8(3 252 5)))
+  (error? (begin (bytevector-u16-native-ref #vu8(3 252 5) 0 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u16-native-ref '#(3 252 5) 0))
+  (error? (begin (bytevector-u16-native-ref '#(3 252 5) 0) #f))
+
+ ; invalid index
+  (error? (bytevector-u16-native-ref #vu8(3 252 5) -1))
+  (error? (bytevector-u16-native-ref #vu8(3 252 5) 1))
+  (error? (bytevector-u16-native-ref #vu8(3 252 5) 2))
+  (error? (bytevector-u16-native-ref #vu8(3 252 5) 3))
+  (error? (begin (bytevector-u16-native-ref #vu8(3 252 5) 4.0) #f))
+
+  (eqv?
+    (bytevector-u16-native-ref #vu8(3 252 5) 0)
+    (native->unsigned 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-u16-native-ref v 0)
+        (bytevector-u16-native-ref v 2)
+        (bytevector-u16-native-ref v 4)
+        (bytevector-u16-native-ref v i)
+        (bytevector-u16-native-ref v 6)
+        (bytevector-u16-native-ref v 8)))
+    (list
+      (native->unsigned 3 252)
+      (native->unsigned 5 17)
+      (native->unsigned 23 55)
+      (native->unsigned 23 55)
+      (native->unsigned 250 89)
+      (native->unsigned 200 201)))
+
+  (test-cp0-expansion eqv?
+    '(bytevector-u16-native-ref #vu8(3 252 5) 0)
+    (native->unsigned 3 252))
+  (equal?
+    ;; list doesn't get inlined, so take if off the front of the list
+    (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+           (expand/optimize '(let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+                               (list
+                                 (bytevector-u16-native-ref v 0)
+                                 (bytevector-u16-native-ref v 2)
+                                 (bytevector-u16-native-ref v 4)
+                                 (bytevector-u16-native-ref v i)
+                                 (bytevector-u16-native-ref v 6)
+                                 (bytevector-u16-native-ref v 8))))))
+      (list
+         (native->unsigned 3 252)
+         (native->unsigned 5 17)
+         (native->unsigned 23 55)
+         (native->unsigned 23 55)
+         (native->unsigned 250 89)
+         (native->unsigned 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-u16-native-ref (bytevector i j) 0)
+                    (native->unsigned i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+)
+
+(mat bytevector-s16-native-set!
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s16-native-set!))
+  (error? (bytevector-s16-native-set! $v1))
+  (error? (bytevector-s16-native-set! $v1 0))
+  (error? (begin (bytevector-s16-native-set! $v1 0 0 15) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s16-native-set! (make-vector 10) 0 0))
+  (error? (begin (bytevector-s16-native-set! (make-vector 10) 0 0) #f))
+
+ ; invalid index
+  (error? (bytevector-s16-native-set! $v1 -1 0))
+  (error? (bytevector-s16-native-set! $v1 1 0))
+  (error? (bytevector-s16-native-set! $v1 3 0))
+  (error? (bytevector-s16-native-set! $v1 5 0))
+  (error? (bytevector-s16-native-set! $v1 7 0))
+  (error? (bytevector-s16-native-set! $v1 9 0))
+  (error? (bytevector-s16-native-set! $v1 11 0))
+  (error? (begin (bytevector-s16-native-set! $v1 'q 0) #f))
+
+ ; invalid value
+  (error? (bytevector-s16-native-set! $v1 0 #x8000))
+  (error? (bytevector-s16-native-set! $v1 2 #x-8001))
+  (error? (begin (bytevector-s16-native-set! $v1 4 "hello") #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad)))
+
+  (begin
+    (bytevector-s16-native-set! $v1 0 -1)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 0 (native->signed #x80 #x00))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 0 (native->signed #x00 #x80))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 0 (native->signed #x7f #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 0 (native->signed #xff #x7f))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 0 (native->signed #xff #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 0 #x0000)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 2 (native->signed #xf3 #x45))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 4 (native->signed #x23 #xc7))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 6 (native->signed #x3a #x1c))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-s16-native-set! $v1 8 (native->signed #xe3 #xd7))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-s16-native-set! v 0 (native->signed i j))
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+)
+
+(mat bytevector-u16-native-set!
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u16-native-set!))
+  (error? (bytevector-u16-native-set! $v1))
+  (error? (bytevector-u16-native-set! $v1 0))
+  (error? (begin (bytevector-u16-native-set! $v1 0 0 15) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u16-native-set! (make-vector 10) 0 0))
+  (error? (begin (bytevector-u16-native-set! (make-vector 10) 0 0) #f))
+
+ ; invalid index
+  (error? (bytevector-u16-native-set! $v1 -1 0))
+  (error? (bytevector-u16-native-set! $v1 1 0))
+  (error? (bytevector-u16-native-set! $v1 3 0))
+  (error? (bytevector-u16-native-set! $v1 5 0))
+  (error? (bytevector-u16-native-set! $v1 7 0))
+  (error? (bytevector-u16-native-set! $v1 9 0))
+  (error? (bytevector-u16-native-set! $v1 11 0))
+  (error? (begin (bytevector-u16-native-set! $v1 'q 0) #f))
+
+ ; invalid value
+  (error? (bytevector-u16-native-set! $v1 0 #x10000))
+  (error? (bytevector-u16-native-set! $v1 2 #x-1))
+  (error? (begin (bytevector-u16-native-set! $v1 4 "hello") #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad)))
+
+  (begin
+    (bytevector-u16-native-set! $v1 0 #xffff)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 0 (native->unsigned #x80 #x00))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 0 (native->unsigned #x00 #x80))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 0 (native->unsigned #x7f #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 0 (native->unsigned #xff #x7f))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 0 (native->unsigned #xff #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 0 #x0000)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 2 (native->unsigned #xf3 #x45))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 4 (native->unsigned #x23 #xc7))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 6 (native->unsigned #x3a #x1c))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-u16-native-set! $v1 8 (native->unsigned #xe3 #xd7))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-u16-native-set! v 0 (native->unsigned i j))
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+)
+
+(mat bytevector-s16-ref
+ ; wrong argument count
+  (error? (bytevector-s16-ref))
+  (error? (bytevector-s16-ref #vu8(3 252 5)))
+  (error? (begin (bytevector-s16-ref #vu8(3 252 5) 0 0 'big) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s16-ref '#(3 252 5) 0 'big))
+  (error? (begin (bytevector-s16-ref '#(3 252 5) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s16-ref #vu8(3 252 5) -1 (native-endianness)))
+  (error? (bytevector-s16-ref #vu8(3 252 5) 2 'big))
+  (error? (bytevector-s16-ref #vu8(3 252 5) 3 'little))
+  (error? (begin (bytevector-s16-ref #vu8(3 252 5) 4.0 'big) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s16-ref #vu8(3 252 5) 0 'bigger))
+  (error? (bytevector-s16-ref #vu8(3 252 5) 0 "little"))
+  (error? (begin (bytevector-s16-ref #vu8(3 252 5) 0 #t) #f))
+
+ ; aligned accesses, endianness native
+  (eqv?
+    (bytevector-s16-ref #vu8(3 252 5) 0 (native-endianness))
+    (native->signed 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-s16-ref v 0 (native-endianness))
+        (bytevector-s16-ref v 2 (native-endianness))
+        (bytevector-s16-ref v 4 (native-endianness))
+        (bytevector-s16-ref v i (native-endianness))
+        (bytevector-s16-ref v 6 (native-endianness))
+        (bytevector-s16-ref v 8 (native-endianness))))
+    (list
+      (native->signed 3 252)
+      (native->signed 5 17)
+      (native->signed 23 55)
+      (native->signed 23 55)
+      (native->signed 250 89)
+      (native->signed 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-s16-ref (bytevector i j) 0 (native-endianness))
+                    (native->signed i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+
+ ; aligned accesses, endianness big
+  (eqv?
+    (bytevector-s16-ref #vu8(3 252 5) 0 'big)
+    (big-endian->signed 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-s16-ref v 0 'big)
+        (bytevector-s16-ref v 2 'big)
+        (bytevector-s16-ref v 4 'big)
+        (bytevector-s16-ref v i 'big)
+        (bytevector-s16-ref v 6 'big)
+        (bytevector-s16-ref v 8 'big)))
+    (list
+      (big-endian->signed 3 252)
+      (big-endian->signed 5 17)
+      (big-endian->signed 23 55)
+      (big-endian->signed 23 55)
+      (big-endian->signed 250 89)
+      (big-endian->signed 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-s16-ref (bytevector i j) 0 'big)
+                    (big-endian->signed i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+
+ ; aligned accesses, endianness little
+  (eqv?
+    (bytevector-s16-ref #vu8(3 252 5) 0 'little)
+    (little-endian->signed 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-s16-ref v 0 'little)
+        (bytevector-s16-ref v 2 'little)
+        (bytevector-s16-ref v 4 'little)
+        (bytevector-s16-ref v i 'little)
+        (bytevector-s16-ref v 6 'little)
+        (bytevector-s16-ref v 8 'little)))
+    (list
+      (little-endian->signed 3 252)
+      (little-endian->signed 5 17)
+      (little-endian->signed 23 55)
+      (little-endian->signed 23 55)
+      (little-endian->signed 250 89)
+      (little-endian->signed 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-s16-ref (bytevector i j) 0 'little)
+                    (little-endian->signed i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+
+ ; unaligned accesses, endianness mixed
+  (eqv?
+    (bytevector-s16-ref #vu8(3 252 5) 1 (native-endianness))
+    (native->signed 252 5))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 5])
+      (list
+        (bytevector-s16-ref v 1 (native-endianness))
+        (bytevector-s16-ref v 3 'little)
+        (bytevector-s16-ref v 5 'big)
+        (bytevector-s16-ref v i 'big)
+        (bytevector-s16-ref v 7 'little)
+        (bytevector-s16-ref v 9 (native-endianness))))
+    (list
+      (native->signed 252 5)
+      (little-endian->signed 17 23)
+      (big-endian->signed 55 250)
+      (big-endian->signed 55 250)
+      (little-endian->signed 89 200)
+      (native->signed 201 128)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-s16-ref (bytevector 0 i j) 1 'little)
+                    (little-endian->signed i j))
+        (errorf #f "failed for ~s and ~s (little)" i j))
+      (unless (eqv? (bytevector-s16-ref (bytevector 0 i j) 1 'big)
+                    (big-endian->signed i j))
+        (errorf #f "failed for ~s and ~s (big)" i j))
+      (unless (eqv? (bytevector-s16-ref (bytevector 0 i j) 1 (native-endianness))
+                    (native->signed i j))
+        (errorf #f "failed for ~s and ~s (native)" i j))))
+)
+
+(mat bytevector-u16-ref
+ ; wrong argument count
+  (error? (bytevector-u16-ref))
+  (error? (bytevector-u16-ref #vu8(3 252 5)))
+  (error? (begin (bytevector-u16-ref #vu8(3 252 5) 0 0 'big) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u16-ref '#(3 252 5) 0 'big))
+  (error? (begin (bytevector-u16-ref '#(3 252 5) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u16-ref #vu8(3 252 5) -1 (native-endianness)))
+  (error? (bytevector-u16-ref #vu8(3 252 5) 2 'little))
+  (error? (bytevector-u16-ref #vu8(3 252 5) 3 'big))
+  (error? (begin (bytevector-u16-ref #vu8(3 252 5) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u16-ref #vu8(3 252 5) 0 'bigger))
+  (error? (bytevector-u16-ref #vu8(3 252 5) 0 "little"))
+  (error? (begin (bytevector-u16-ref #vu8(3 252 5) 0 #t) #f))
+
+ ; aligned accesses, endianness native
+  (eqv?
+    (bytevector-u16-ref #vu8(3 252 5) 0 (native-endianness))
+    (native->unsigned 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-u16-ref v 0 (native-endianness))
+        (bytevector-u16-ref v 2 (native-endianness))
+        (bytevector-u16-ref v 4 (native-endianness))
+        (bytevector-u16-ref v i (native-endianness))
+        (bytevector-u16-ref v 6 (native-endianness))
+        (bytevector-u16-ref v 8 (native-endianness))))
+    (list
+      (native->unsigned 3 252)
+      (native->unsigned 5 17)
+      (native->unsigned 23 55)
+      (native->unsigned 23 55)
+      (native->unsigned 250 89)
+      (native->unsigned 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-u16-ref (bytevector i j) 0 (native-endianness))
+                    (native->unsigned i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+
+ ; aligned accesses, endianness big
+  (eqv?
+    (bytevector-u16-ref #vu8(3 252 5) 0 'big)
+    (big-endian->unsigned 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-u16-ref v 0 'big)
+        (bytevector-u16-ref v 2 'big)
+        (bytevector-u16-ref v 4 'big)
+        (bytevector-u16-ref v i 'big)
+        (bytevector-u16-ref v 6 'big)
+        (bytevector-u16-ref v 8 'big)))
+    (list
+      (big-endian->unsigned 3 252)
+      (big-endian->unsigned 5 17)
+      (big-endian->unsigned 23 55)
+      (big-endian->unsigned 23 55)
+      (big-endian->unsigned 250 89)
+      (big-endian->unsigned 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-u16-ref (bytevector i j) 0 'big)
+                    (big-endian->unsigned i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+
+ ; aligned accesses, endianness little
+  (eqv?
+    (bytevector-u16-ref #vu8(3 252 5) 0 'little)
+    (little-endian->unsigned 3 252))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4])
+      (list
+        (bytevector-u16-ref v 0 'little)
+        (bytevector-u16-ref v 2 'little)
+        (bytevector-u16-ref v 4 'little)
+        (bytevector-u16-ref v i 'little)
+        (bytevector-u16-ref v 6 'little)
+        (bytevector-u16-ref v 8 'little)))
+    (list
+      (little-endian->unsigned 3 252)
+      (little-endian->unsigned 5 17)
+      (little-endian->unsigned 23 55)
+      (little-endian->unsigned 23 55)
+      (little-endian->unsigned 250 89)
+      (little-endian->unsigned 200 201)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-u16-ref (bytevector i j) 0 'little)
+                    (little-endian->unsigned i j))
+        (errorf #f "failed for ~s and ~s" i j))))
+
+ ; unaligned accesses, endianness mixed
+  (eqv?
+    (bytevector-u16-ref #vu8(3 252 5) 1 (native-endianness))
+    (native->unsigned 252 5))
+  (equal?
+    (let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 5])
+      (list
+        (bytevector-u16-ref v 1 (native-endianness))
+        (bytevector-u16-ref v 3 'little)
+        (bytevector-u16-ref v 5 'big)
+        (bytevector-u16-ref v i 'big)
+        (bytevector-u16-ref v 7 'little)
+        (bytevector-u16-ref v 9 (native-endianness))))
+    (list
+      (native->unsigned 252 5)
+      (little-endian->unsigned 17 23)
+      (big-endian->unsigned 55 250)
+      (big-endian->unsigned 55 250)
+      (little-endian->unsigned 89 200)
+      (native->unsigned 201 128)))
+
+  (do ([i 0 (fx+ i 1)])
+      ((fx= i (expt 2 8)) #t)
+    (do ([j 0 (fx+ j 1)])
+        ((fx= j (expt 2 8)))
+      (unless (eqv? (bytevector-u16-ref (bytevector 0 i j) 1 'little)
+                    (little-endian->unsigned i j))
+        (errorf #f "failed for ~s and ~s (little)" i j))
+      (unless (eqv? (bytevector-u16-ref (bytevector 0 i j) 1 'big)
+                    (big-endian->unsigned i j))
+        (errorf #f "failed for ~s and ~s (big)" i j))
+      (unless (eqv? (bytevector-u16-ref (bytevector 0 i j) 1 (native-endianness))
+                    (native->unsigned i j))
+        (errorf #f "failed for ~s and ~s (native)" i j))))
+)
+
+(mat bytevector-s16-set!
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s16-set!))
+  (error? (bytevector-s16-set! $v1))
+  (error? (bytevector-s16-set! $v1 0 0))
+  (error? (begin (bytevector-s16-set! $v1 0 0 0 (native-endianness)) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s16-set! (make-vector 10) 0 0 'big))
+  (error? (begin (bytevector-s16-set! (make-vector 10) 0 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s16-set! $v1 -1 0 (native-endianness)))
+  (error? (bytevector-s16-set! $v1 10 0 (native-endianness)))
+  (error? (bytevector-s16-set! $v1 11 0 'big))
+  (error? (begin (bytevector-s16-set! $v1 'q 0 'little) #f))
+
+ ; invalid value
+  (error? (bytevector-s16-set! $v1 0 #x8000 (native-endianness)))
+  (error? (bytevector-s16-set! $v1 1 #x8000 (native-endianness)))
+  (error? (bytevector-s16-set! $v1 2 #x-8001 'big))
+  (error? (bytevector-s16-set! $v1 3 #x-8001 'big))
+  (error? (bytevector-s16-set! $v1 4 "hello" 'little))
+  (error? (begin (bytevector-s16-set! $v1 5 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s16-set! $v1 0 0 'bigger))
+  (error? (bytevector-s16-set! $v1 0 0 "little"))
+  (error? (begin (bytevector-s16-set! $v1 0 0 #t) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; aligned accesses, endianness native
+  (begin
+    (bytevector-s16-set! $v1 0 -1 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (native->signed #x80 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (native->signed #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (native->signed #x7f #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (native->signed #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (native->signed #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 #x0000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 2 (native->signed #xf3 #x45) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 4 (native->signed #x23 #xc7) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 6 (native->signed #x3a #x1c) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 8 (native->signed #xe3 #xd7) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-s16-set! v 0 (native->signed i j) (native-endianness))
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+
+ ; aligned accesses, endianness little
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s16-set! $v1 0 -1 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (little-endian->signed #x80 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (little-endian->signed #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (little-endian->signed #x7f #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (little-endian->signed #xff #x7f) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (little-endian->signed #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 #x0000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 2 (little-endian->signed #xf3 #x45) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 4 (little-endian->signed #x23 #xc7) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 6 (little-endian->signed #x3a #x1c) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 8 (little-endian->signed #xe3 #xd7) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-s16-set! v 0 (little-endian->signed i j) 'little)
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s16-set! $v1 0 -1 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (big-endian->signed #x80 #x00) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (big-endian->signed #x00 #x80) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (big-endian->signed #x7f #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (big-endian->signed #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 (big-endian->signed #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 0 #x0000 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 2 (big-endian->signed #xf3 #x45) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 4 (big-endian->signed #x23 #xc7) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 6 (big-endian->signed #x3a #x1c) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 8 (big-endian->signed #xe3 #xd7) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-s16-set! v 0 (big-endian->signed i j) 'big)
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s16-set! $v1 1 -1 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xff #xff #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 1 (native->signed #x80 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 1 (little-endian->signed #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 1 (little-endian->signed #x7f #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 1 (native->signed #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 1 (big-endian->signed #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xff #xff #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 1 #x0000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 3 (big-endian->signed #xf3 #x45) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 5 (little-endian->signed #x23 #xc7) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 7 (native->signed #x3a #x1c) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad))))
+  (begin
+    (bytevector-s16-set! $v1 9 (big-endian->signed #xe3 #xd7) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7))))
+
+  (let ([v (bytevector 0 #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-s16-set! v 1 (native->signed i j) (native-endianness))
+        (unless (equal? v (bytevector 0 i j))
+          (errorf #f "failed for ~s and ~s (native)" i j))
+        (bytevector-u8-set! v 1 #xc7)
+        (bytevector-u8-set! v 2 #xc7)
+        (bytevector-s16-set! v 1 (big-endian->signed i j) 'big)
+        (unless (equal? v (bytevector 0 i j))
+          (errorf #f "failed for ~s and ~s (big)" i j))
+        (bytevector-u8-set! v 1 #xc7)
+        (bytevector-u8-set! v 2 #xc7)
+        (bytevector-s16-set! v 1 (little-endian->signed i j) 'little)
+        (unless (equal? v (bytevector 0 i j))
+          (errorf #f "failed for ~s and ~s (little)" i j)))))
+)
+
+(mat bytevector-u16-set!
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u16-set!))
+  (error? (bytevector-u16-set! $v1))
+  (error? (bytevector-u16-set! $v1 0 0))
+  (error? (begin (bytevector-u16-set! $v1 0 0 0 (native-endianness)) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u16-set! (make-vector 10) 0 0 'big))
+  (error? (begin (bytevector-u16-set! (make-vector 10) 0 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u16-set! $v1 -1 0 (native-endianness)))
+  (error? (bytevector-u16-set! $v1 10 0 'big))
+  (error? (bytevector-u16-set! $v1 11 0 'big))
+  (error? (begin (bytevector-u16-set! $v1 'q 0 'little) #f))
+
+ ; invalid value
+  (error? (bytevector-u16-set! $v1 0 #x10000 (native-endianness)))
+  (error? (bytevector-u16-set! $v1 1 #x10000 (native-endianness)))
+  (error? (bytevector-u16-set! $v1 2 #x-1 'little))
+  (error? (bytevector-u16-set! $v1 3 #x-1 'little))
+  (error? (bytevector-u16-set! $v1 4 "hello" 'big))
+  (error? (begin (bytevector-u16-set! $v1 5 "hello" 'big) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u16-set! $v1 0 0 'bigger))
+  (error? (bytevector-u16-set! $v1 0 0 "little"))
+  (error? (begin (bytevector-u16-set! $v1 0 0 #t) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; aligned accesses, endianness native
+  (begin
+    (bytevector-u16-set! $v1 0 #xffff (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (native->unsigned #x80 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (native->unsigned #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (native->unsigned #x7f #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (native->unsigned #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (native->unsigned #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 #x0000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 2 (native->unsigned #xf3 #x45) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 4 (native->unsigned #x23 #xc7) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 6 (native->unsigned #x3a #x1c) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 8 (native->unsigned #xe3 #xd7) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-u16-set! v 0 (native->unsigned i j) (native-endianness))
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+
+ ; aligned accesses, endianness little
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u16-set! $v1 0 #xffff 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (little-endian->unsigned #x80 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (little-endian->unsigned #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (little-endian->unsigned #x7f #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (little-endian->unsigned #xff #x7f) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (little-endian->unsigned #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 #x0000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 2 (little-endian->unsigned #xf3 #x45) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 4 (little-endian->unsigned #x23 #xc7) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 6 (little-endian->unsigned #x3a #x1c) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 8 (little-endian->unsigned #xe3 #xd7) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-u16-set! v 0 (little-endian->unsigned i j) 'little)
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u16-set! $v1 0 #xffff 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (big-endian->unsigned #x80 #x00) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (big-endian->unsigned #x00 #x80) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (big-endian->unsigned #x7f #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (big-endian->unsigned #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 (big-endian->unsigned #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xff #xff #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 0 #x0000 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 2 (big-endian->unsigned #xf3 #x45) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 4 (big-endian->unsigned #x23 #xc7) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 6 (big-endian->unsigned #x3a #x1c) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 8 (big-endian->unsigned #xe3 #xd7) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(0 0 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7 #xad))))
+
+  (let ([v (bytevector #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-u16-set! v 0 (big-endian->unsigned i j) 'big)
+        (unless (equal? v (bytevector i j))
+          (errorf #f "failed for ~s and ~s" i j)))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 11 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xad #xad #xad #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u16-set! $v1 1 #xffff 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xff #xff #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 1 (native->unsigned #x80 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x80 #x00 #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 1 (little-endian->unsigned #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x80 #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 1 (little-endian->unsigned #x7f #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x7f #xff #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 1 (native->unsigned #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xff #x7f #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 1 (big-endian->unsigned #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #xff #xff #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 1 #x0000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xad #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 3 (big-endian->unsigned #xf3 #x45) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 5 (little-endian->unsigned #x23 #xc7) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #x23 #xc7 #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 7 (native->unsigned #x3a #x1c) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #x23 #xc7 #x3a #x1c #xad #xad))))
+  (begin
+    (bytevector-u16-set! $v1 9 (big-endian->unsigned #xe3 #xd7) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 #vu8(#xad #x00 #x00 #xf3 #x45 #x23 #xc7 #x3a #x1c #xe3 #xd7))))
+
+  (let ([v (bytevector 0 #xc7 #xc7)])
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i (expt 2 8)) #t)
+      (do ([j 0 (fx+ j 1)])
+          ((fx= j (expt 2 8)))
+        (bytevector-u16-set! v 1 (native->unsigned i j) (native-endianness))
+        (unless (equal? v (bytevector 0 i j))
+          (errorf #f "failed for ~s and ~s (native)" i j))
+        (bytevector-u8-set! v 1 #xc7)
+        (bytevector-u8-set! v 2 #xc7)
+        (bytevector-u16-set! v 1 (big-endian->unsigned i j) 'big)
+        (unless (equal? v (bytevector 0 i j))
+          (errorf #f "failed for ~s and ~s (big)" i j))
+        (bytevector-u8-set! v 1 #xc7)
+        (bytevector-u8-set! v 2 #xc7)
+        (bytevector-u16-set! v 1 (little-endian->unsigned i j) 'little)
+        (unless (equal? v (bytevector 0 i j))
+          (errorf #f "failed for ~s and ~s (little)" i j)))))
+)
+
+(mat bytevector-s24-ref
+ ; wrong argument count
+  (error? (bytevector-s24-ref))
+  (error? (bytevector-s24-ref #vu8(3 252 5 0)))
+  (error? (bytevector-s24-ref #vu8(3 252 5 0) 0))
+  (error? (begin (bytevector-s24-ref #vu8(3 252 5 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s24-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-s24-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) 6 'little))
+  (error? (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) 0 'bigger))
+  (error? (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) 0 "little"))
+  (error? (begin (bytevector-s24-ref #vu8(3 252 5 0 0 0 0) 0 #t) #f))
+
+ ; 32-bit aligned accesses, endianness native
+  (eqv?
+    (bytevector-s24-ref #vu8(3 252 5 32 65 87 20) 0 (native-endianness))
+    (native->signed 3 252 5))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s24-ref v 0 (native-endianness))
+        (bytevector-s24-ref v 4 (native-endianness))
+        (bytevector-s24-ref v 8 (native-endianness))
+        (bytevector-s24-ref v 12 (native-endianness))))
+    (list
+      (native->signed 30 100 200)
+      (native->signed 249 199 99)
+      (native->signed 248 189 190)
+      (native->signed 24 25 26)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+      (unless (eqv? (bytevector-s24-ref (apply bytevector ls) 0 (native-endianness))
+                    (apply native->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; 32-bit aligned accesses, endianness big
+  (eqv?
+    (bytevector-s24-ref #vu8(3 252 5 32 65 87 20) 0 'big)
+    (big-endian->signed 3 252 5))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s24-ref v 0 'big)
+        (bytevector-s24-ref v 4 'big)
+        (bytevector-s24-ref v 8 'big)
+        (bytevector-s24-ref v 12 'big)))
+    (list
+      (big-endian->signed 30 100 200)
+      (big-endian->signed 249 199 99)
+      (big-endian->signed 248 189 190)
+      (big-endian->signed 24 25 26)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+      (unless (eqv? (bytevector-s24-ref (apply bytevector ls) 0 'big)
+                    (apply big-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; 32-bit aligned accesses, endianness little
+  (eqv?
+    (bytevector-s24-ref #vu8(3 252 5 32 65 87 20) 0 'little)
+    (little-endian->signed 3 252 5))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s24-ref v 0 'little)
+        (bytevector-s24-ref v 4 'little)
+        (bytevector-s24-ref v 8 'little)
+        (bytevector-s24-ref v 12 'little)))
+    (list
+      (little-endian->signed 30 100 200)
+      (little-endian->signed 249 199 99)
+      (little-endian->signed 248 189 190)
+      (little-endian->signed 24 25 26)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+      (unless (eqv? (bytevector-s24-ref (apply bytevector ls) 0 'little)
+                    (apply little-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; not 32-bit aligned, endianness mixed
+  (eqv?
+    (bytevector-s24-ref #vu8(3 252 5 32 65 87 20) 3 (native-endianness))
+    (native->signed 32 65 87))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s24-ref v 1 'little)
+        (bytevector-s24-ref v 6 'big)
+        (bytevector-s24-ref v 11 (native-endianness))
+        (bytevector-s24-ref v 15 'little)))
+    (list
+      (little-endian->signed 100 200 250)
+      (big-endian->signed 99 29 248)
+      (native->signed 207 24 25)
+      (little-endian->signed 27 28 29)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-s24-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-s24-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-s24-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (eval `(bytevector-s24-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-s24-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-s24-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-u24-ref
+ ; wrong argument count
+  (error? (bytevector-u24-ref))
+  (error? (bytevector-u24-ref #vu8(3 252 5 0)))
+  (error? (bytevector-u24-ref #vu8(3 252 5 0) 0))
+  (error? (begin (bytevector-u24-ref #vu8(3 252 5 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u24-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-u24-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u24-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-u24-ref #vu8(3 252 5 0 0 0 0) 6 'little))
+  (error? (bytevector-u24-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-u24-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u24-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-u24-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-u24-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+ ; 32-bit aligned accesses, endianness native
+  (eqv?
+    (bytevector-u24-ref #vu8(3 252 5 32 65 87 20) 0 (native-endianness))
+    (native->unsigned 3 252 5))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u24-ref v 0 (native-endianness))
+        (bytevector-u24-ref v 4 (native-endianness))
+        (bytevector-u24-ref v 8 (native-endianness))
+        (bytevector-u24-ref v 12 (native-endianness))))
+    (list
+      (native->unsigned 30 100 200)
+      (native->unsigned 249 199 99)
+      (native->unsigned 248 189 190)
+      (native->unsigned 24 25 26)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+      (unless (eqv? (bytevector-u24-ref (apply bytevector ls) 0 (native-endianness))
+                    (apply native->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; 32-bit aligned accesses, endianness big
+  (eqv?
+    (bytevector-u24-ref #vu8(3 252 5 32 65 87 20) 0 'big)
+    (big-endian->unsigned 3 252 5))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u24-ref v 0 'big)
+        (bytevector-u24-ref v 4 'big)
+        (bytevector-u24-ref v 8 'big)
+        (bytevector-u24-ref v 12 'big)))
+    (list
+      (big-endian->unsigned 30 100 200)
+      (big-endian->unsigned 249 199 99)
+      (big-endian->unsigned 248 189 190)
+      (big-endian->unsigned 24 25 26)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+      (unless (eqv? (bytevector-u24-ref (apply bytevector ls) 0 'big)
+                    (apply big-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; 32-bit aligned accesses, endianness little
+  (eqv?
+    (bytevector-u24-ref #vu8(3 252 5 32 65 87 20) 0 'little)
+    (little-endian->unsigned 3 252 5))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u24-ref v 0 'little)
+        (bytevector-u24-ref v 4 'little)
+        (bytevector-u24-ref v 8 'little)
+        (bytevector-u24-ref v 12 'little)))
+    (list
+      (little-endian->unsigned 30 100 200)
+      (little-endian->unsigned 249 199 99)
+      (little-endian->unsigned 248 189 190)
+      (little-endian->unsigned 24 25 26)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+      (unless (eqv? (bytevector-u24-ref (apply bytevector ls) 0 'little)
+                    (apply little-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; not 32-bit aligned accesses, endianness mixed
+  (eqv?
+    (bytevector-u24-ref #vu8(3 252 5 32 65 87 20) 3 (native-endianness))
+    (native->unsigned 32 65 87))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29)])
+      (list
+        (bytevector-u24-ref v 1 'little)
+        (bytevector-u24-ref v 6 'big)
+        (bytevector-u24-ref v 11 (native-endianness))
+        (bytevector-u24-ref v 15 'little)))
+    (list
+      (little-endian->unsigned 100 200 250)
+      (big-endian->unsigned 99 29 248)
+      (native->unsigned 207 24 25)
+      (little-endian->unsigned 27 28 29)))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-u24-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-u24-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-u24-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (eval `(bytevector-u24-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-u24-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-u24-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-s24-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s24-set!))
+  (error? (bytevector-s24-set! $v1))
+  (error? (bytevector-s24-set! $v1 0))
+  (error? (bytevector-s24-set! $v1 0 0))
+  (error? (begin (bytevector-s24-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s24-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-s24-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-s24-set! $v1 -1 0 'big))
+  (error? (bytevector-s24-set! $v1 21 0 (native-endianness)))
+  (error? (bytevector-s24-set! $v1 22 0 'little))
+  (error? (bytevector-s24-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-s24-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-s24-set! $v1 0 (expt 2 23) 'big))
+  (error? (bytevector-s24-set! $v1 4 (- -1 (expt 2 23)) (native-endianness)))
+  (error? (begin (bytevector-s24-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s24-set! $v1 0 0 'huge))
+  (error? (bytevector-s24-set! $v1 4 0 "tiny"))
+  (error? (begin (bytevector-s24-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; 32-bit aligned accesses, endianness native
+  (begin
+    (bytevector-s24-set! $v1 0 -1 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (native->signed #x80 #x00 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (native->signed #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x80 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (native->signed #x7f #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (native->signed #xff #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #x7f #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (native->signed #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 #x000000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 4 (native->signed #xf3 #x45 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 8 (native->signed #x23 #xc7 #xe8) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 12 (native->signed #x3a #x1c #x59) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 16 (native->signed #xe3 #xd7 #xa9) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xe3 #xd7 #xa9 #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-s24-set! v 0 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; 32-bit aligned accesses, endianness big
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s24-set! $v1 0 -1 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (big-endian->signed #x80 #x00 #x00) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (big-endian->signed #x00 #x00 #x80) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x80 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (big-endian->signed #x7f #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (big-endian->signed #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #x7f #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (big-endian->signed #xff #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 #x000000 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 4 (big-endian->signed #xf3 #x45 #x19) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 8 (big-endian->signed #x23 #xc7 #xe8) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 12 (big-endian->signed #x3a #x1c #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 16 (big-endian->signed #xe3 #xd7 #xa9) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xe3 #xd7 #xa9 #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-s24-set! v 0 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; 32-bit aligned accesses, endianness little
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s24-set! $v1 0 -1 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (little-endian->signed #x80 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (little-endian->signed #x00 #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x80 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (little-endian->signed #x7f #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (little-endian->signed #xff #xff #x7f) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #x7f #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 (little-endian->signed #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 0 #x000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 4 (little-endian->signed #xf3 #x45 #x19) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 8 (little-endian->signed #x23 #xc7 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 12 (little-endian->signed #x3a #x1c #x59) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 16 (little-endian->signed #xe3 #xd7 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xe3 #xd7 #xa9 #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-s24-set! v 0 (apply little-endian->signed ls) 'little)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; not 32-bit aligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s24-set! $v1 1 -1 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 1 (little-endian->signed #x80 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x80 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 1 (native->signed #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 1 (native->signed #x7f #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x7f #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 1 (big-endian->signed #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 1 (little-endian->signed #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 1 #x000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 5 (native->signed #xf3 #x45 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 10 (little-endian->signed #x23 #xc7 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #x23 #xc7 #xe8 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 15 (big-endian->signed #x3a #x1c #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #x23 #xc7 #xe8 #xad #xad #x3a
+                        #x1c #x59 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s24-set! $v1 20 (little-endian->signed #xe3 #xd7 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #x23 #xc7 #xe8 #xad #xad #x3a
+                        #x1c #x59 #xad #xad #xe3 #xd7 #xa9))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-s24-set! v 1 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s24-set! v 1 (apply little-endian->signed (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s24-set! v 1 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (eval `(bytevector-s24-set! ,v 1 ,(apply big-endian->signed ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s24-set! ,v 1 ,(apply little-endian->signed (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s24-set! ,v 1 ,(apply native->signed ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u24-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u24-set!))
+  (error? (bytevector-u24-set! $v1))
+  (error? (bytevector-u24-set! $v1 0))
+  (error? (bytevector-u24-set! $v1 0 0))
+  (error? (if (bytevector-u24-set! $v1 0 0 'big 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-u24-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (if (bytevector-u24-set! (make-vector 10) 0 0 (native-endianness)) #f #t))
+
+ ; invalid index
+  (error? (bytevector-u24-set! $v1 -1 0 'big))
+  (error? (bytevector-u24-set! $v1 21 0 (native-endianness)))
+  (error? (bytevector-u24-set! $v1 22 0 'little))
+  (error? (bytevector-u24-set! $v1 23 0 (native-endianness)))
+  (error? (if (bytevector-u24-set! $v1 'q 0 'big) #f #t))
+
+ ; invalid value
+  (error? (bytevector-u24-set! $v1 0 (expt 2 24) 'big))
+  (error? (bytevector-u24-set! $v1 4 #x-1 (native-endianness)))
+  (error? (if (bytevector-u24-set! $v1 8 "hello" 'little) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-u24-set! $v1 0 0 'huge))
+  (error? (bytevector-u24-set! $v1 4 0 "tiny"))
+  (error? (if (bytevector-u24-set! $v1 8 0 $v1) #f #t))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; 32-bit aligned accesses, endianness native
+  (begin
+    (bytevector-u24-set! $v1 0 #xffffff (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (native->unsigned #x80 #x00 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (native->unsigned #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x80 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (native->unsigned #x7f #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (native->unsigned #xff #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #x7f #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (native->unsigned #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 #x000000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 4 (native->unsigned #xf3 #x45 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 8 (native->unsigned #x23 #xc7 #xe8) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 12 (native->unsigned #x3a #x1c #x59) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 16 (native->unsigned #xe3 #xd7 #xa9) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xe3 #xd7 #xa9 #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-u24-set! v 0 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; 32-bit aligned accesses, endianness big
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u24-set! $v1 0 #xffffff 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (big-endian->unsigned #x80 #x00 #x00) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (big-endian->unsigned #x00 #x00 #x80) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x80 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (big-endian->unsigned #x7f #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (big-endian->unsigned #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #x7f #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (big-endian->unsigned #xff #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 #x000000 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 4 (big-endian->unsigned #xf3 #x45 #x19) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 8 (big-endian->unsigned #x23 #xc7 #xe8) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 12 (big-endian->unsigned #x3a #x1c #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 16 (big-endian->unsigned #xe3 #xd7 #xa9) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xe3 #xd7 #xa9 #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-u24-set! v 0 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; 32-bit aligned accesses, endianness little
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u24-set! $v1 0 #xffffff 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (little-endian->unsigned #x80 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (little-endian->unsigned #x00 #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x80 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (little-endian->unsigned #x7f #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (little-endian->unsigned #xff #xff #x7f) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #x7f #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 (little-endian->unsigned #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 0 #x000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 4 (little-endian->unsigned #xf3 #x45 #x19) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 8 (little-endian->unsigned #x23 #xc7 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 12 (little-endian->unsigned #x3a #x1c #x59) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 16 (little-endian->unsigned #xe3 #xd7 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #xad #xf3 #x45 #x19 #xad
+                        #x23 #xc7 #xe8 #xad #x3a #x1c #x59 #xad
+                        #xe3 #xd7 #xa9 #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-u24-set! v 0 (apply little-endian->unsigned ls) 'little)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; not 32-bit aligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u24-set! $v1 1 #xffffff 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 1 (little-endian->unsigned #x80 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x80 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 1 (native->unsigned #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 1 (native->unsigned #x7f #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x7f #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 1 (big-endian->unsigned #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 1 (little-endian->unsigned #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 1 #x000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 5 (native->unsigned #xf3 #x45 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 10 (little-endian->unsigned #x23 #xc7 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #x23 #xc7 #xe8 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 15 (big-endian->unsigned #x3a #x1c #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #x23 #xc7 #xe8 #xad #xad #x3a
+                        #x1c #x59 #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u24-set! $v1 20 (little-endian->unsigned #xe3 #xd7 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #xad #xf3 #x45 #x19
+                        #xad #xad #x23 #xc7 #xe8 #xad #xad #x3a
+                        #x1c #x59 #xad #xad #xe3 #xd7 #xa9))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (bytevector-u24-set! v 1 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u24-set! v 1 (apply little-endian->unsigned (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u24-set! v 1 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 3))])
+        (eval `(bytevector-u24-set! ,v 1 ,(apply big-endian->unsigned ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u24-set! ,v 1 ,(apply little-endian->unsigned (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u24-set! ,v 1 ,(apply native->unsigned ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s32-native-ref
+ ; wrong argument count
+  (error? (bytevector-s32-native-ref))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0)))
+  (error? (begin (bytevector-s32-native-ref #vu8(3 252 5 0) 0 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s32-native-ref '#(3 252 5 0 0 0 0) 0))
+  (error? (begin (bytevector-s32-native-ref '#(3 252 5 0 0 0 0) 0) #f))
+
+ ; invalid index
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) -1))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 1))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 2))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 3))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 4))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 5))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 6))
+  (error? (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 7))
+  (error? (begin (bytevector-s32-native-ref #vu8(3 252 5 0 0 0 0) 4.0) #f))
+
+  (eqv?
+    (bytevector-s32-native-ref #vu8(3 252 5 32 65 87 20) 0)
+    (native->signed 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s32-native-ref v 0)
+        (bytevector-s32-native-ref v 4)
+        (bytevector-s32-native-ref v 8)
+        (bytevector-s32-native-ref v 12)))
+    (list
+      (native->signed 30 100 200 250)
+      (native->signed 249 199 99 29)
+      (native->signed 248 189 190 207)
+      (native->signed 24 25 26 27)))
+
+  (test-cp0-expansion eqv?
+    '(bytevector-s32-native-ref #vu8(3 252 5 32 65 87 20) 0)
+    (native->signed 3 252 5 32))
+  (equal?
+    (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+           (expand/optimize '(let ([v '#vu8(30 100 200 250
+                                             249 199 99 29
+                                             248 189 190 207
+                                             24 25 26 27
+                                             28 29 30)])
+                               (list
+                                 (bytevector-s32-native-ref v 0)
+                                 (bytevector-s32-native-ref v 4)
+                                 (bytevector-s32-native-ref v 8)
+                                 (bytevector-s32-native-ref v 12))))))
+    (list
+      (native->signed 30 100 200 250)
+      (native->signed 249 199 99 29)
+      (native->signed 248 189 190 207)
+      (native->signed 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-s32-native-ref (apply bytevector ls) 0)
+                    (apply native->signed ls))
+        (errorf #f "failed for ~s" ls))))
+)
+
+(mat bytevector-u32-native-ref
+ ; wrong argument count
+  (error? (bytevector-u32-native-ref))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0)))
+  (error? (begin (bytevector-u32-native-ref #vu8(3 252 5 0) 0 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u32-native-ref '#(3 252 5 0 0 0 0) 0))
+  (error? (begin (bytevector-u32-native-ref '#(3 252 5 0 0 0 0) 0) #f))
+
+ ; invalid index
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) -1))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 1))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 2))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 3))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 4))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 5))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 6))
+  (error? (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 7))
+  (error? (begin (bytevector-u32-native-ref #vu8(3 252 5 0 0 0 0) 4.0) #f))
+
+  (eqv?
+    (bytevector-u32-native-ref #vu8(3 252 5 32 65 87 20) 0)
+    (native->unsigned 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u32-native-ref v 0)
+        (bytevector-u32-native-ref v 4)
+        (bytevector-u32-native-ref v 8)
+        (bytevector-u32-native-ref v 12)))
+    (list
+      (native->unsigned 30 100 200 250)
+      (native->unsigned 249 199 99 29)
+      (native->unsigned 248 189 190 207)
+      (native->unsigned 24 25 26 27)))
+
+  (test-cp0-expansion eqv?
+    '(bytevector-u32-native-ref #vu8(3 252 5 32 65 87 20) 0)
+    (native->unsigned 3 252 5 32))
+  (equal?
+    (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+           (expand/optimize '(let ([v '#vu8(30 100 200 250
+                                             249 199 99 29
+                                             248 189 190 207
+                                             24 25 26 27
+                                             28 29 30)])
+                               (list
+                                 (bytevector-u32-native-ref v 0)
+                                 (bytevector-u32-native-ref v 4)
+                                 (bytevector-u32-native-ref v 8)
+                                 (bytevector-u32-native-ref v 12))))))
+    (list
+      (native->unsigned 30 100 200 250)
+      (native->unsigned 249 199 99 29)
+      (native->unsigned 248 189 190 207)
+      (native->unsigned 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-u32-native-ref (apply bytevector ls) 0)
+                    (apply native->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+)
+
+(mat bytevector-s32-native-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s32-native-set!))
+  (error? (bytevector-s32-native-set! $v1))
+  (error? (bytevector-s32-native-set! $v1 0))
+  (error? (begin (bytevector-s32-native-set! $v1 0 0 15) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s32-native-set! (make-vector 10) 0 0))
+  (error? (begin (bytevector-s32-native-set! (make-vector 10) 0 0) #f))
+
+ ; invalid index
+  (error? (bytevector-s32-native-set! $v1 -1 0))
+  (error? (bytevector-s32-native-set! $v1 1 0))
+  (error? (bytevector-s32-native-set! $v1 2 0))
+  (error? (bytevector-s32-native-set! $v1 3 0))
+  (error? (bytevector-s32-native-set! $v1 5 0))
+  (error? (bytevector-s32-native-set! $v1 6 0))
+  (error? (bytevector-s32-native-set! $v1 7 0))
+  (error? (bytevector-s32-native-set! $v1 9 0))
+  (error? (bytevector-s32-native-set! $v1 10 0))
+  (error? (bytevector-s32-native-set! $v1 11 0))
+  (error? (bytevector-s32-native-set! $v1 13 0))
+  (error? (bytevector-s32-native-set! $v1 14 0))
+  (error? (bytevector-s32-native-set! $v1 15 0))
+  (error? (bytevector-s32-native-set! $v1 17 0))
+  (error? (bytevector-s32-native-set! $v1 18 0))
+  (error? (bytevector-s32-native-set! $v1 19 0))
+  (error? (bytevector-s32-native-set! $v1 20 0))
+  (error? (bytevector-s32-native-set! $v1 21 0))
+  (error? (bytevector-s32-native-set! $v1 22 0))
+  (error? (bytevector-s32-native-set! $v1 23 0))
+  (error? (begin (bytevector-s32-native-set! $v1 'q 0) #f))
+
+ ; invalid value
+  (error? (bytevector-s32-native-set! $v1 0 #x80000000))
+  (error? (bytevector-s32-native-set! $v1 4 #x-80000001))
+  (error? (begin (bytevector-s32-native-set! $v1 8 "hello") #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (begin
+    (bytevector-s32-native-set! $v1 0 -1)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 0 (native->signed #x80 #x00 #x00 #x00))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 0 (native->signed #x00 #x00 #x00 #x80))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 0 (native->signed #x7f #xff #xff #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 0 (native->signed #xff #xff #xff #x7f))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 0 (native->signed #xff #xff #xff #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 0 #x00000000)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 4 (native->signed #xf3 #x45 #x23 #x19))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 8 (native->signed #x23 #xc7 #x72 #xe8))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 12 (native->signed #x3a #x1c #x22 #x59))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-native-set! $v1 16 (native->signed #xe3 #xd7 #xc2 #xa9))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-s32-native-set! v 0 (apply native->signed ls))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u32-native-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u32-native-set!))
+  (error? (bytevector-u32-native-set! $v1))
+  (error? (bytevector-u32-native-set! $v1 0))
+  (error? (begin (bytevector-u32-native-set! $v1 0 0 15) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u32-native-set! (make-vector 10) 0 0))
+  (error? (begin (bytevector-u32-native-set! (make-vector 10) 0 0) #f))
+
+ ; invalid index
+  (error? (bytevector-u32-native-set! $v1 -1 0))
+  (error? (bytevector-u32-native-set! $v1 1 0))
+  (error? (bytevector-u32-native-set! $v1 2 0))
+  (error? (bytevector-u32-native-set! $v1 3 0))
+  (error? (bytevector-u32-native-set! $v1 5 0))
+  (error? (bytevector-u32-native-set! $v1 6 0))
+  (error? (bytevector-u32-native-set! $v1 7 0))
+  (error? (bytevector-u32-native-set! $v1 9 0))
+  (error? (bytevector-u32-native-set! $v1 10 0))
+  (error? (bytevector-u32-native-set! $v1 11 0))
+  (error? (bytevector-u32-native-set! $v1 13 0))
+  (error? (bytevector-u32-native-set! $v1 14 0))
+  (error? (bytevector-u32-native-set! $v1 15 0))
+  (error? (bytevector-u32-native-set! $v1 17 0))
+  (error? (bytevector-u32-native-set! $v1 18 0))
+  (error? (bytevector-u32-native-set! $v1 19 0))
+  (error? (bytevector-u32-native-set! $v1 20 0))
+  (error? (bytevector-u32-native-set! $v1 21 0))
+  (error? (bytevector-u32-native-set! $v1 22 0))
+  (error? (bytevector-u32-native-set! $v1 23 0))
+  (error? (begin (bytevector-u32-native-set! $v1 'q 0) #f))
+
+ ; invalid value
+  (error? (bytevector-u32-native-set! $v1 0 #x100000000))
+  (error? (bytevector-u32-native-set! $v1 4 #x-1))
+  (error? (begin (bytevector-u32-native-set! $v1 8 "hello") #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (begin
+    (bytevector-u32-native-set! $v1 0 #xffffffff)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 0 (native->unsigned #x80 #x00 #x00 #x00))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 0 (native->unsigned #x00 #x00 #x00 #x80))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 0 (native->unsigned #x7f #xff #xff #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 0 (native->unsigned #xff #xff #xff #x7f))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 0 (native->unsigned #xff #xff #xff #xff))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 0 #x00000000)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 4 (native->unsigned #xf3 #x45 #x23 #x19))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 8 (native->unsigned #x23 #xc7 #x72 #xe8))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 12 (native->unsigned #x3a #x1c #x22 #x59))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-native-set! $v1 16 (native->unsigned #xe3 #xd7 #xc2 #xa9))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-u32-native-set! v 0 (apply native->unsigned ls))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s32-ref
+ ; wrong argument count
+  (error? (bytevector-s32-ref))
+  (error? (bytevector-s32-ref #vu8(3 252 5 0)))
+  (error? (bytevector-s32-ref #vu8(3 252 5 0) 0))
+  (error? (begin (bytevector-s32-ref #vu8(3 252 5 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s32-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-s32-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s32-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-s32-ref #vu8(3 252 5 0 0 0 0) 6 'little))
+  (error? (bytevector-s32-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-s32-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s32-ref $v1 0 'bigger))
+  (error? (bytevector-s32-ref $v1 0 "little"))
+  (error? (begin (bytevector-s32-ref $v1 0 #t) #f))
+
+ ; aligned accesses, endianness native
+  (eqv?
+    (bytevector-s32-ref #vu8(3 252 5 32 65 87 20) 0 (native-endianness))
+    (native->signed 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s32-ref v 0 (native-endianness))
+        (bytevector-s32-ref v 4 (native-endianness))
+        (bytevector-s32-ref v 8 (native-endianness))
+        (bytevector-s32-ref v 12 (native-endianness))))
+    (list
+      (native->signed 30 100 200 250)
+      (native->signed 249 199 99 29)
+      (native->signed 248 189 190 207)
+      (native->signed 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-s32-ref (apply bytevector ls) 0 (native-endianness))
+                    (apply native->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; aligned accesses, endianness big
+  (eqv?
+    (bytevector-s32-ref #vu8(3 252 5 32 65 87 20) 0 'big)
+    (big-endian->signed 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s32-ref v 0 'big)
+        (bytevector-s32-ref v 4 'big)
+        (bytevector-s32-ref v 8 'big)
+        (bytevector-s32-ref v 12 'big)))
+    (list
+      (big-endian->signed 30 100 200 250)
+      (big-endian->signed 249 199 99 29)
+      (big-endian->signed 248 189 190 207)
+      (big-endian->signed 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-s32-ref (apply bytevector ls) 0 'big)
+                    (apply big-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; aligned accesses, endianness little
+  (eqv?
+    (bytevector-s32-ref #vu8(3 252 5 32 65 87 20) 0 'little)
+    (little-endian->signed 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s32-ref v 0 'little)
+        (bytevector-s32-ref v 4 'little)
+        (bytevector-s32-ref v 8 'little)
+        (bytevector-s32-ref v 12 'little)))
+    (list
+      (little-endian->signed 30 100 200 250)
+      (little-endian->signed 249 199 99 29)
+      (little-endian->signed 248 189 190 207)
+      (little-endian->signed 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-s32-ref (apply bytevector ls) 0 'little)
+                    (apply little-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; unaligned accesses, endianness mixed
+  (eqv?
+    (bytevector-s32-ref #vu8(3 252 5 32 65 87 20) 3 (native-endianness))
+    (native->signed 32 65 87 20))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-s32-ref v 1 'little)
+        (bytevector-s32-ref v 6 'big)
+        (bytevector-s32-ref v 11 (native-endianness))
+        (bytevector-s32-ref v 15 'little)))
+    (list
+      (little-endian->signed 100 200 250 249)
+      (big-endian->signed 99 29 248 189)
+      (native->signed 207 24 25 26)
+      (little-endian->signed 27 28 29 30)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 5))])
+      (unless (eqv? (bytevector-s32-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-s32-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-s32-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-u32-ref
+ ; wrong argument count
+  (error? (bytevector-u32-ref))
+  (error? (bytevector-u32-ref #vu8(3 252 5 0)))
+  (error? (bytevector-u32-ref #vu8(3 252 5 0) 0))
+  (error? (begin (bytevector-u32-ref #vu8(3 252 5 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u32-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-u32-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u32-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-u32-ref #vu8(3 252 5 0 0 0 0) 6 'little))
+  (error? (bytevector-u32-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-u32-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u32-ref $v1 0 'bigger))
+  (error? (bytevector-u32-ref $v1 0 "little"))
+  (error? (begin (bytevector-u32-ref $v1 0 #t) #f))
+
+ ; aligned accesses, endianness native
+  (eqv?
+    (bytevector-u32-ref #vu8(3 252 5 32 65 87 20) 0 (native-endianness))
+    (native->unsigned 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u32-ref v 0 (native-endianness))
+        (bytevector-u32-ref v 4 (native-endianness))
+        (bytevector-u32-ref v 8 (native-endianness))
+        (bytevector-u32-ref v 12 (native-endianness))))
+    (list
+      (native->unsigned 30 100 200 250)
+      (native->unsigned 249 199 99 29)
+      (native->unsigned 248 189 190 207)
+      (native->unsigned 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-u32-ref (apply bytevector ls) 0 (native-endianness))
+                    (apply native->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; aligned accesses, endianness big
+  (eqv?
+    (bytevector-u32-ref #vu8(3 252 5 32 65 87 20) 0 'big)
+    (big-endian->unsigned 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u32-ref v 0 'big)
+        (bytevector-u32-ref v 4 'big)
+        (bytevector-u32-ref v 8 'big)
+        (bytevector-u32-ref v 12 'big)))
+    (list
+      (big-endian->unsigned 30 100 200 250)
+      (big-endian->unsigned 249 199 99 29)
+      (big-endian->unsigned 248 189 190 207)
+      (big-endian->unsigned 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-u32-ref (apply bytevector ls) 0 'big)
+                    (apply big-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; aligned accesses, endianness little
+  (eqv?
+    (bytevector-u32-ref #vu8(3 252 5 32 65 87 20) 0 'little)
+    (little-endian->unsigned 3 252 5 32))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u32-ref v 0 'little)
+        (bytevector-u32-ref v 4 'little)
+        (bytevector-u32-ref v 8 'little)
+        (bytevector-u32-ref v 12 'little)))
+    (list
+      (little-endian->unsigned 30 100 200 250)
+      (little-endian->unsigned 249 199 99 29)
+      (little-endian->unsigned 248 189 190 207)
+      (little-endian->unsigned 24 25 26 27)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+      (unless (eqv? (bytevector-u32-ref (apply bytevector ls) 0 'little)
+                    (apply little-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; unaligned accesses, endianness mixed
+  (eqv?
+    (bytevector-u32-ref #vu8(3 252 5 32 65 87 20) 3 (native-endianness))
+    (native->unsigned 32 65 87 20))
+  (equal?
+    (let ([v '#vu8(30 100 200 250
+                   249 199 99 29
+                   248 189 190 207
+                   24 25 26 27
+                   28 29 30)])
+      (list
+        (bytevector-u32-ref v 1 'little)
+        (bytevector-u32-ref v 6 'big)
+        (bytevector-u32-ref v 11 (native-endianness))
+        (bytevector-u32-ref v 15 'little)))
+    (list
+      (little-endian->unsigned 100 200 250 249)
+      (big-endian->unsigned 99 29 248 189)
+      (native->unsigned 207 24 25 26)
+      (little-endian->unsigned 27 28 29 30)))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 5))])
+      (unless (eqv? (bytevector-u32-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-u32-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-u32-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-s32-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s32-set!))
+  (error? (bytevector-s32-set! $v1))
+  (error? (bytevector-s32-set! $v1 0))
+  (error? (bytevector-s32-set! $v1 0 0))
+  (error? (begin (bytevector-s32-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s32-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-s32-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-s32-set! $v1 -1 0 'big))
+  (error? (bytevector-s32-set! $v1 20 0 'little))
+  (error? (bytevector-s32-set! $v1 21 0 (native-endianness)))
+  (error? (bytevector-s32-set! $v1 22 0 'little))
+  (error? (bytevector-s32-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-s32-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-s32-set! $v1 0 #x80000000 'big))
+  (error? (bytevector-s32-set! $v1 4 #x-80000001 (native-endianness)))
+  (error? (begin (bytevector-s32-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s32-set! $v1 0 #x7ffffff 'huge))
+  (error? (bytevector-s32-set! $v1 4 #x-80000000 "tiny"))
+  (error? (begin (bytevector-s32-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; aligned accesses, endianness native
+  (begin
+    (bytevector-s32-set! $v1 0 -1 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (native->signed #x80 #x00 #x00 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (native->signed #x00 #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (native->signed #x7f #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (native->signed #xff #xff #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (native->signed #xff #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 #x00000000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 4 (native->signed #xf3 #x45 #x23 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 8 (native->signed #x23 #xc7 #x72 #xe8) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 12 (native->signed #x3a #x1c #x22 #x59) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 16 (native->signed #xe3 #xd7 #xc2 #xa9) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-s32-set! v 0 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s32-set! $v1 0 -1 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (big-endian->signed #x80 #x00 #x00 #x00) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (big-endian->signed #x00 #x00 #x00 #x80) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (big-endian->signed #x7f #xff #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (big-endian->signed #xff #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (big-endian->signed #xff #xff #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 #x00000000 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 4 (big-endian->signed #xf3 #x45 #x23 #x19) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 8 (big-endian->signed #x23 #xc7 #x72 #xe8) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 12 (big-endian->signed #x3a #x1c #x22 #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 16 (big-endian->signed #xe3 #xd7 #xc2 #xa9) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-s32-set! v 0 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; aligned accesses, endianness little
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s32-set! $v1 0 -1 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (little-endian->signed #x80 #x00 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (little-endian->signed #x00 #x00 #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (little-endian->signed #x7f #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (little-endian->signed #xff #xff #xff #x7f) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 (little-endian->signed #xff #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 0 #x00000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 4 (little-endian->signed #xf3 #x45 #x23 #x19) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 8 (little-endian->signed #x23 #xc7 #x72 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 12 (little-endian->signed #x3a #x1c #x22 #x59) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 16 (little-endian->signed #xe3 #xd7 #xc2 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-s32-set! v 0 (apply little-endian->signed ls) 'little)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s32-set! $v1 1 -1 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xff #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 1 (little-endian->signed #x80 #x00 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x80 #x00 #x00 #x00 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 1 (native->signed #x00 #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x80 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 1 (native->signed #x7f #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x7f #xff #xff #xff #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 1 (big-endian->signed #xff #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #x7f #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 1 (little-endian->signed #xff #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xff #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 1 #x00000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 5 (native->signed #xf3 #x45 #x23 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 10 (little-endian->signed #x23 #xc7 #x72 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #x23 #xc7 #x72 #xe8 #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 15 (big-endian->signed #x3a #x1c #x22 #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #x23 #xc7 #x72 #xe8 #xad #x3a
+                        #x1c #x22 #x59 #xad #xad #xad #xad))))
+  (begin
+    (bytevector-s32-set! $v1 19 (little-endian->signed #xe3 #xd7 #xc2 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #x23 #xc7 #x72 #xe8 #xad #x3a
+                        #x1c #x22 #x59 #xe3 #xd7 #xc2 #xa9))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-s32-set! v 1 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s32-set! v 1 (apply little-endian->signed (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s32-set! v 1 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u32-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u32-set!))
+  (error? (bytevector-u32-set! $v1))
+  (error? (bytevector-u32-set! $v1 0))
+  (error? (bytevector-u32-set! $v1 0 0))
+  (error? (if (bytevector-u32-set! $v1 0 0 'big 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-u32-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (if (bytevector-u32-set! (make-vector 10) 0 0 (native-endianness)) #f #t))
+
+ ; invalid index
+  (error? (bytevector-u32-set! $v1 -1 0 'big))
+  (error? (bytevector-u32-set! $v1 20 0 'little))
+  (error? (bytevector-u32-set! $v1 21 0 (native-endianness)))
+  (error? (bytevector-u32-set! $v1 22 0 'little))
+  (error? (bytevector-u32-set! $v1 23 0 (native-endianness)))
+  (error? (if (bytevector-u32-set! $v1 'q 0 'big) #f #t))
+
+ ; invalid value
+  (error? (bytevector-u32-set! $v1 0 #x100000000 'big))
+  (error? (bytevector-u32-set! $v1 4 #x-1 (native-endianness)))
+  (error? (if (bytevector-u32-set! $v1 8 "hello" 'little) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-u32-set! $v1 0 #xfffffff 'huge))
+  (error? (bytevector-u32-set! $v1 4 0 "tiny"))
+  (error? (if (bytevector-u32-set! $v1 8 0 $v1) #f #t))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; aligned accesses, endianness native
+  (begin
+    (bytevector-u32-set! $v1 0 #xffffffff (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (native->unsigned #x80 #x00 #x00 #x00) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (native->unsigned #x00 #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (native->unsigned #x7f #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (native->unsigned #xff #xff #xff #x7f) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (native->unsigned #xff #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 #x00000000 (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 4 (native->unsigned #xf3 #x45 #x23 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 8 (native->unsigned #x23 #xc7 #x72 #xe8) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 12 (native->unsigned #x3a #x1c #x22 #x59) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 16 (native->unsigned #xe3 #xd7 #xc2 #xa9) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-u32-set! v 0 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u32-set! $v1 0 #xffffffff 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (big-endian->unsigned #x80 #x00 #x00 #x00) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (big-endian->unsigned #x00 #x00 #x00 #x80) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (big-endian->unsigned #x7f #xff #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (big-endian->unsigned #xff #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (big-endian->unsigned #xff #xff #xff #xff) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 #x00000000 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 4 (big-endian->unsigned #xf3 #x45 #x23 #x19) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 8 (big-endian->unsigned #x23 #xc7 #x72 #xe8) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 12 (big-endian->unsigned #x3a #x1c #x22 #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 16 (big-endian->unsigned #xe3 #xd7 #xc2 #xa9) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-u32-set! v 0 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; aligned accesses, endianness little
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u32-set! $v1 0 #xffffffff 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (little-endian->unsigned #x80 #x00 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (little-endian->unsigned #x00 #x00 #x00 #x80) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x80 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (little-endian->unsigned #x7f #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x7f #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (little-endian->unsigned #xff #xff #xff #x7f) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #x7f #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 (little-endian->unsigned #xff #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xff #xff #xff #xff #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 0 #x00000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 4 (little-endian->unsigned #xf3 #x45 #x23 #x19) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 8 (little-endian->unsigned #x23 #xc7 #x72 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 12 (little-endian->unsigned #x3a #x1c #x22 #x59) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 16 (little-endian->unsigned #xe3 #xd7 #xc2 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #xf3 #x45 #x23 #x19
+                        #x23 #xc7 #x72 #xe8 #x3a #x1c #x22 #x59
+                        #xe3 #xd7 #xc2 #xa9 #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-u32-set! v 0 (apply little-endian->unsigned ls) 'little)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u32-set! $v1 1 #xffffffff 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xff #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 1 (little-endian->unsigned #x80 #x00 #x00 #x00) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x80 #x00 #x00 #x00 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 1 (native->unsigned #x00 #x00 #x00 #x80) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x80 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 1 (native->unsigned #x7f #xff #xff #xff) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x7f #xff #xff #xff #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 1 (big-endian->unsigned #xff #xff #xff #x7f) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #x7f #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 1 (little-endian->unsigned #xff #xff #xff #xff) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xff #xff #xff #xff #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 1 #x00000000 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 5 (native->unsigned #xf3 #x45 #x23 #x19) (native-endianness))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 10 (little-endian->unsigned #x23 #xc7 #x72 #xe8) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #x23 #xc7 #x72 #xe8 #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 15 (big-endian->unsigned #x3a #x1c #x22 #x59) 'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #x23 #xc7 #x72 #xe8 #xad #x3a
+                        #x1c #x22 #x59 #xad #xad #xad #xad))))
+  (begin
+    (bytevector-u32-set! $v1 19 (little-endian->unsigned #xe3 #xd7 #xc2 #xa9) 'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #x00 #x00 #x00 #x00 #xf3 #x45 #x23
+                        #x19 #xad #x23 #xc7 #x72 #xe8 #xad #x3a
+                        #x1c #x22 #x59 #xe3 #xd7 #xc2 #xa9))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 4))])
+        (bytevector-u32-set! v 1 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u32-set! v 1 (apply little-endian->unsigned (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u32-set! v 1 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s40-ref
+ ; wrong argument count
+  (error? (bytevector-s40-ref))
+  (error? (bytevector-s40-ref #vu8(3 252 5 0 0)))
+  (error? (bytevector-s40-ref #vu8(3 252 5 0 0) 0))
+  (error? (begin (bytevector-s40-ref #vu8(3 252 5 0 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s40-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-s40-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s40-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-s40-ref #vu8(3 252 5 0 0 0 0) 3 'little))
+  (error? (bytevector-s40-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-s40-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s40-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-s40-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-s40-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+      (unless (eqv? (bytevector-s40-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-s40-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-s40-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+      (unless (eqv? (eval `(bytevector-s40-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-s40-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-s40-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-u40-ref
+ ; wrong argument count
+  (error? (bytevector-u40-ref))
+  (error? (bytevector-u40-ref #vu8(3 252 5 0 0)))
+  (error? (bytevector-u40-ref #vu8(3 252 5 0 0) 0))
+  (error? (begin (bytevector-u40-ref #vu8(3 252 5 0 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u40-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-u40-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u40-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-u40-ref #vu8(3 252 5 0 0 0 0) 3 'little))
+  (error? (bytevector-u40-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-u40-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u40-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-u40-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-u40-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+      (unless (eqv? (bytevector-u40-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-u40-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-u40-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+      (unless (eqv? (eval `(bytevector-u40-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-u40-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-u40-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-s40-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s40-set!))
+  (error? (bytevector-s40-set! $v1))
+  (error? (bytevector-s40-set! $v1 0))
+  (error? (bytevector-s40-set! $v1 0 0))
+  (error? (begin (bytevector-s40-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s40-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-s40-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-s40-set! $v1 -1 0 'big))
+  (error? (bytevector-s40-set! $v1 19 0 (native-endianness)))
+  (error? (bytevector-s40-set! $v1 22 0 'little))
+  (error? (bytevector-s40-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-s40-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-s40-set! $v1 0 (expt 2 39) 'big))
+  (error? (bytevector-s40-set! $v1 4 (- -1 (expt 2 39)) (native-endianness)))
+  (error? (begin (bytevector-s40-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s40-set! $v1 0 #x7ffffff 'huge))
+  (error? (bytevector-s40-set! $v1 4 #x-80000000 "tiny"))
+  (error? (begin (bytevector-s40-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 5))])
+        (bytevector-s40-set! v 1 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s40-set! v 1 (apply little-endian->signed (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s40-set! v 1 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 5))])
+        (eval `(bytevector-s40-set! ,v 1 ,(apply big-endian->signed ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s40-set! ,v 1 ,(apply little-endian->signed (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s40-set! ,v 1 ,(apply native->signed ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u40-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u40-set!))
+  (error? (bytevector-u40-set! $v1))
+  (error? (bytevector-u40-set! $v1 0))
+  (error? (bytevector-u40-set! $v1 0 0))
+  (error? (begin (bytevector-u40-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u40-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-u40-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-u40-set! $v1 -1 0 'big))
+  (error? (bytevector-u40-set! $v1 19 0 (native-endianness)))
+  (error? (bytevector-u40-set! $v1 22 0 'little))
+  (error? (bytevector-u40-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-u40-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-u40-set! $v1 0 (expt 2 40) 'big))
+  (error? (bytevector-u40-set! $v1 4 -1 (native-endianness)))
+  (error? (begin (bytevector-u40-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u40-set! $v1 0 0 'huge))
+  (error? (bytevector-u40-set! $v1 4 0 "tiny"))
+  (error? (begin (bytevector-u40-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 5))])
+        (bytevector-u40-set! v 1 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u40-set! v 1 (apply little-endian->unsigned (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u40-set! v 1 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 5))])
+        (eval `(bytevector-u40-set! ,v 1 ,(apply big-endian->unsigned ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u40-set! ,v 1 ,(apply little-endian->unsigned (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u40-set! ,v 1 ,(apply native->unsigned ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s48-ref
+ ; wrong argument count
+  (error? (bytevector-s48-ref))
+  (error? (bytevector-s48-ref #vu8(3 252 5 0 0 0)))
+  (error? (bytevector-s48-ref #vu8(3 252 5 0 0 0) 0))
+  (error? (begin (bytevector-s48-ref #vu8(3 252 5 0 0 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s48-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-s48-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s48-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-s48-ref #vu8(3 252 5 0 0 0 0) 2 'little))
+  (error? (bytevector-s48-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-s48-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s48-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-s48-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-s48-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+      (unless (eqv? (bytevector-s48-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-s48-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-s48-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+      (unless (eqv? (eval `(bytevector-s48-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-s48-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-s48-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-u48-ref
+ ; wrong argument count
+  (error? (bytevector-u48-ref))
+  (error? (bytevector-u48-ref #vu8(3 252 5 0 0 0)))
+  (error? (bytevector-u48-ref #vu8(3 252 5 0 0 0) 0))
+  (error? (begin (bytevector-u48-ref #vu8(3 252 5 0 0 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u48-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-u48-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u48-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-u48-ref #vu8(3 252 5 0 0 0 0) 2 'little))
+  (error? (bytevector-u48-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-u48-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u48-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-u48-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-u48-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+      (unless (eqv? (bytevector-u48-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-u48-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-u48-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+      (unless (eqv? (eval `(bytevector-u48-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-u48-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-u48-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-s48-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s48-set!))
+  (error? (bytevector-s48-set! $v1))
+  (error? (bytevector-s48-set! $v1 0))
+  (error? (bytevector-s48-set! $v1 0 0))
+  (error? (begin (bytevector-s48-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s48-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-s48-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-s48-set! $v1 -1 0 'big))
+  (error? (bytevector-s48-set! $v1 18 0 (native-endianness)))
+  (error? (bytevector-s48-set! $v1 22 0 'little))
+  (error? (bytevector-s48-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-s48-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-s48-set! $v1 0 (expt 2 47) 'big))
+  (error? (bytevector-s48-set! $v1 4 (- -1 (expt 2 47)) (native-endianness)))
+  (error? (begin (bytevector-s48-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s48-set! $v1 0 0 'huge))
+  (error? (bytevector-s48-set! $v1 4 0 "tiny"))
+  (error? (begin (bytevector-s48-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+        (bytevector-s48-set! v 1 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s48-set! v 1 (apply little-endian->signed (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s48-set! v 1 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+        (eval `(bytevector-s48-set! ,v 1 ,(apply big-endian->signed ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s48-set! ,v 1 ,(apply little-endian->signed (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s48-set! ,v 1 ,(apply native->signed ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u48-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u48-set!))
+  (error? (bytevector-u48-set! $v1))
+  (error? (bytevector-u48-set! $v1 0))
+  (error? (bytevector-u48-set! $v1 0 0))
+  (error? (begin (bytevector-u48-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u48-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-u48-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-u48-set! $v1 -1 0 'big))
+  (error? (bytevector-u48-set! $v1 18 0 (native-endianness)))
+  (error? (bytevector-u48-set! $v1 22 0 'little))
+  (error? (bytevector-u48-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-u48-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-u48-set! $v1 0 (expt 2 48) 'big))
+  (error? (bytevector-u48-set! $v1 4 -1 (native-endianness)))
+  (error? (begin (bytevector-u48-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u48-set! $v1 0 0 'huge))
+  (error? (bytevector-u48-set! $v1 4 0 "tiny"))
+  (error? (begin (bytevector-u48-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+        (bytevector-u48-set! v 1 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u48-set! v 1 (apply little-endian->unsigned (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u48-set! v 1 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 6))])
+        (eval `(bytevector-u48-set! ,v 1 ,(apply big-endian->unsigned ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u48-set! ,v 1 ,(apply little-endian->unsigned (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u48-set! ,v 1 ,(apply native->unsigned ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s56-ref
+ ; wrong argument count
+  (error? (bytevector-s56-ref))
+  (error? (bytevector-s56-ref #vu8(3 252 5 0 0 0 0)))
+  (error? (bytevector-s56-ref #vu8(3 252 5 0 0 00 ) 0))
+  (error? (begin (bytevector-s56-ref #vu8(3 252 5 0 0 0 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s56-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-s56-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-s56-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-s56-ref #vu8(3 252 5 0 0 0 0) 1 'little))
+  (error? (bytevector-s56-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-s56-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s56-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-s56-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-s56-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-s56-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-s56-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-s56-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (eval `(bytevector-s56-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->signed (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-s56-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-s56-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->signed (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-u56-ref
+ ; wrong argument count
+  (error? (bytevector-u56-ref))
+  (error? (bytevector-u56-ref #vu8(3 252 5 0 0 0 0)))
+  (error? (bytevector-u56-ref #vu8(3 252 5 0 0 00 ) 0))
+  (error? (begin (bytevector-u56-ref #vu8(3 252 5 0 0 0 0) 0 (native-endianness) 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u56-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (begin (bytevector-u56-ref '#(3 252 5 0 0 0 0) 0 'big) #f))
+
+ ; invalid index
+  (error? (bytevector-u56-ref #vu8(3 252 5 0 0 0 0) -1 'big))
+  (error? (bytevector-u56-ref #vu8(3 252 5 0 0 0 0) 1 'little))
+  (error? (bytevector-u56-ref #vu8(3 252 5 0 0 0 0) 7 (native-endianness)))
+  (error? (begin (bytevector-u56-ref #vu8(3 252 5 0 0 0 0) 4.0 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u56-ref #vu8(0 1 2 3 4 5 6 7) 0 'bigger))
+  (error? (bytevector-u56-ref #vu8(0 1 2 3 4 5 6 7) 0 "little"))
+  (error? (begin (bytevector-u56-ref #vu8(0 1 2 3 4 5 6 7) 0 #t) #f))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-u56-ref (apply bytevector ls) 1 (native-endianness))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (bytevector-u56-ref (apply bytevector ls) 1 'little)
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (bytevector-u56-ref (apply bytevector ls) 1 'big)
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (eval `(bytevector-u56-ref ,(apply bytevector ls) 1 (native-endianness)))
+                    (apply native->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (native)" ls))
+      (unless (eqv? (eval `(bytevector-u56-ref ,(apply bytevector ls) 1 'little))
+                    (apply little-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (little)" ls))
+      (unless (eqv? (eval `(bytevector-u56-ref ,(apply bytevector ls) 1 'big))
+                    (apply big-endian->unsigned (cdr ls)))
+        (errorf #f "failed for ~s (big)" ls))))
+)
+
+(mat bytevector-s56-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s56-set!))
+  (error? (bytevector-s56-set! $v1))
+  (error? (bytevector-s56-set! $v1 0))
+  (error? (bytevector-s56-set! $v1 0 0))
+  (error? (begin (bytevector-s56-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-s56-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-s56-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-s56-set! $v1 -1 0 'big))
+  (error? (bytevector-s56-set! $v1 17 0 (native-endianness)))
+  (error? (bytevector-s56-set! $v1 22 0 'little))
+  (error? (bytevector-s56-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-s56-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-s56-set! $v1 0 (expt 2 55) 'big))
+  (error? (bytevector-s56-set! $v1 4 (- -1 (expt 2 55)) (native-endianness)))
+  (error? (begin (bytevector-s56-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-s56-set! $v1 0 0 'huge))
+  (error? (bytevector-s56-set! $v1 4 0 "tiny"))
+  (error? (begin (bytevector-s56-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+        (bytevector-s56-set! v 1 (apply big-endian->signed ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s56-set! v 1 (apply little-endian->signed (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s56-set! v 1 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+        (eval `(bytevector-s56-set! ,v 1 ,(apply big-endian->signed ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s56-set! ,v 1 ,(apply little-endian->signed (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-s56-set! ,v 1 ,(apply native->signed ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u56-set!
+  (begin
+    (define $v1 (make-bytevector 23 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u56-set!))
+  (error? (bytevector-u56-set! $v1))
+  (error? (bytevector-u56-set! $v1 0))
+  (error? (bytevector-u56-set! $v1 0 0))
+  (error? (begin (bytevector-u56-set! $v1 0 0 'big 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-u56-set! (make-vector 10) 0 0 (native-endianness)))
+  (error? (begin (bytevector-u56-set! (make-vector 10) 0 0 (native-endianness)) #f))
+
+ ; invalid index
+  (error? (bytevector-u56-set! $v1 -1 0 'big))
+  (error? (bytevector-u56-set! $v1 17 0 (native-endianness)))
+  (error? (bytevector-u56-set! $v1 22 0 'little))
+  (error? (bytevector-u56-set! $v1 23 0 (native-endianness)))
+  (error? (begin (bytevector-u56-set! $v1 'q 0 'big) #f))
+
+ ; invalid value
+  (error? (bytevector-u56-set! $v1 0 (expt 2 56) 'big))
+  (error? (bytevector-u56-set! $v1 4 -1 (native-endianness)))
+  (error? (begin (bytevector-u56-set! $v1 8 "hello" 'little) #f))
+
+ ; invalid endianness
+  (error? (bytevector-u56-set! $v1 0 0 'huge))
+  (error? (bytevector-u56-set! $v1 4 0 "tiny"))
+  (error? (begin (bytevector-u56-set! $v1 8 0 $v1) #f))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+        (bytevector-u56-set! v 1 (apply big-endian->unsigned ls) 'big)
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u56-set! v 1 (apply little-endian->unsigned (reverse ls)) 'little)
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u56-set! v 1 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 1000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 7))])
+        (eval `(bytevector-u56-set! ,v 1 ,(apply big-endian->unsigned ls) 'big))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u56-set! ,v 1 ,(apply little-endian->unsigned (reverse ls)) 'little))
+        (unless (equal? v (apply bytevector #xc7 (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (eval `(bytevector-u56-set! ,v 1 ,(apply native->unsigned ls) (native-endianness)))
+        (unless (equal? v (apply bytevector #xc7 ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s64-native-ref
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-s64-native-ref))
+  (error? (bytevector-s64-native-ref $v1))
+  (error? (if (bytevector-s64-native-ref $v1 0 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-s64-native-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0))
+  (error? (if (bytevector-s64-native-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-s64-native-ref $v1 -1))
+  (error? (bytevector-s64-native-ref $v1 1))
+  (error? (bytevector-s64-native-ref $v1 2))
+  (error? (bytevector-s64-native-ref $v1 3))
+  (error? (bytevector-s64-native-ref $v1 4))
+  (error? (bytevector-s64-native-ref $v1 5))
+  (error? (bytevector-s64-native-ref $v1 6))
+  (error? (bytevector-s64-native-ref $v1 7))
+  (error? (bytevector-s64-native-ref $v1 9))
+  (error? (bytevector-s64-native-ref $v1 18))
+  (error? (bytevector-s64-native-ref $v1 27))
+  (error? (bytevector-s64-native-ref $v1 36))
+  (error? (bytevector-s64-native-ref $v1 45))
+  (error? (bytevector-s64-native-ref $v1 54))
+  (error? (bytevector-s64-native-ref $v1 63))
+  (error? (bytevector-s64-native-ref $v1 73))
+  (error? (bytevector-s64-native-ref $v1 82))
+  (error? (bytevector-s64-native-ref $v1 91))
+  (error? (bytevector-s64-native-ref $v1 96))
+  (error? (bytevector-s64-native-ref $v1 97))
+  (error? (bytevector-s64-native-ref $v1 98))
+  (error? (bytevector-s64-native-ref $v1 99))
+  (error? (bytevector-s64-native-ref $v1 100))
+  (error? (bytevector-s64-native-ref $v1 101))
+  (error? (bytevector-s64-native-ref $v1 102))
+  (error? (bytevector-s64-native-ref $v1 103))
+  (error? (if (bytevector-s64-native-ref $v1 4.0) #f #t))
+
+  (eqv? (bytevector-s64-native-ref $v1 0) 0)
+  (eqv? (bytevector-s64-native-ref $v1 8) -1)
+  (eqv? (bytevector-s64-native-ref $v1 16)
+        (native->signed #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-native-ref $v1 24)
+        (native->signed #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-s64-native-ref $v1 32)
+        (native->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-s64-native-ref $v1 40)
+        (native->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-native-ref $v1 48)
+        (native->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-native-ref $v1 56)
+        (native->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-native-ref $v1 64)
+        (native->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-s64-native-ref $v1 72)
+        (native->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-s64-native-ref $v1 80)
+        (native->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-s64-native-ref $v1 88)
+        (native->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (test-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 0) 0)
+  (test-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 8) -1)
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 16)
+    (native->signed #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 24)
+    (native->signed #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 32)
+    (native->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 40)
+    (native->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 48)
+    (native->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 56)
+    (native->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 64)
+    (native->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 72)
+    (native->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 80)
+    (native->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (test-cp0-expansion eqv? 
+    `(bytevector-s64-native-ref ,$v1 88)
+    (native->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-s64-native-ref (apply bytevector ls) 0)
+                    (apply native->signed ls))
+        (errorf #f "failed for ~s" ls))))
+)
+
+(mat bytevector-u64-native-ref
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-u64-native-ref))
+  (error? (bytevector-u64-native-ref $v1))
+  (error? (if (bytevector-u64-native-ref $v1 0 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-u64-native-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0))
+  (error? (if (bytevector-u64-native-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-u64-native-ref $v1 -1))
+  (error? (bytevector-u64-native-ref $v1 1))
+  (error? (bytevector-u64-native-ref $v1 2))
+  (error? (bytevector-u64-native-ref $v1 3))
+  (error? (bytevector-u64-native-ref $v1 4))
+  (error? (bytevector-u64-native-ref $v1 5))
+  (error? (bytevector-u64-native-ref $v1 6))
+  (error? (bytevector-u64-native-ref $v1 7))
+  (error? (bytevector-u64-native-ref $v1 9))
+  (error? (bytevector-u64-native-ref $v1 18))
+  (error? (bytevector-u64-native-ref $v1 27))
+  (error? (bytevector-u64-native-ref $v1 36))
+  (error? (bytevector-u64-native-ref $v1 45))
+  (error? (bytevector-u64-native-ref $v1 54))
+  (error? (bytevector-u64-native-ref $v1 63))
+  (error? (bytevector-u64-native-ref $v1 73))
+  (error? (bytevector-u64-native-ref $v1 82))
+  (error? (bytevector-u64-native-ref $v1 91))
+  (error? (bytevector-u64-native-ref $v1 96))
+  (error? (bytevector-u64-native-ref $v1 97))
+  (error? (bytevector-u64-native-ref $v1 98))
+  (error? (bytevector-u64-native-ref $v1 99))
+  (error? (bytevector-u64-native-ref $v1 100))
+  (error? (bytevector-u64-native-ref $v1 101))
+  (error? (bytevector-u64-native-ref $v1 102))
+  (error? (bytevector-u64-native-ref $v1 103))
+  (error? (if (bytevector-u64-native-ref $v1 4.0) #f #t))
+
+  (eqv? (bytevector-u64-native-ref $v1 0) 0)
+  (eqv? (bytevector-u64-native-ref $v1 8) (- (expt 2 64) 1))
+  (eqv? (bytevector-u64-native-ref $v1 16)
+        (native->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-native-ref $v1 24)
+        (native->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-u64-native-ref $v1 32)
+        (native->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-u64-native-ref $v1 40)
+        (native->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-native-ref $v1 48)
+        (native->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-native-ref $v1 56)
+        (native->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-native-ref $v1 64)
+        (native->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-u64-native-ref $v1 72)
+        (native->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-u64-native-ref $v1 80)
+        (native->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-u64-native-ref $v1 88)
+        (native->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (test-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 0) 0)
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 8) 
+    (- (expt 2 64) 1))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 16)
+    (native->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 24)
+    (native->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 32)
+    (native->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 40)
+    (native->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 48)
+    (native->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 56)
+    (native->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 64)
+    (native->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 72)
+    (native->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 80)
+    (native->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (test-cp0-expansion eqv? 
+    `(bytevector-u64-native-ref ,$v1 88)
+    (native->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-u64-native-ref (apply bytevector ls) 0)
+                    (apply native->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+)
+
+(mat bytevector-s64-native-set!
+  (begin
+    (define $v1 (make-bytevector 39 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s64-native-set!))
+  (error? (bytevector-s64-native-set! $v1))
+  (error? (bytevector-s64-native-set! $v1 0))
+  (error? (if (bytevector-s64-native-set! $v1 0 0 15) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-s64-native-set! (make-vector 10) 0 0))
+  (error? (if (bytevector-s64-native-set! (make-vector 10) 0 0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-s64-native-set! $v1 -1 0))
+  (error? (bytevector-s64-native-set! $v1 1 0))
+  (error? (bytevector-s64-native-set! $v1 2 0))
+  (error? (bytevector-s64-native-set! $v1 3 0))
+  (error? (bytevector-s64-native-set! $v1 4 0))
+  (error? (bytevector-s64-native-set! $v1 5 0))
+  (error? (bytevector-s64-native-set! $v1 6 0))
+  (error? (bytevector-s64-native-set! $v1 7 0))
+  (error? (bytevector-s64-native-set! $v1 9 0))
+  (error? (bytevector-s64-native-set! $v1 10 0))
+  (error? (bytevector-s64-native-set! $v1 11 0))
+  (error? (bytevector-s64-native-set! $v1 12 0))
+  (error? (bytevector-s64-native-set! $v1 13 0))
+  (error? (bytevector-s64-native-set! $v1 14 0))
+  (error? (bytevector-s64-native-set! $v1 15 0))
+  (error? (bytevector-s64-native-set! $v1 17 0))
+  (error? (bytevector-s64-native-set! $v1 20 0))
+  (error? (bytevector-s64-native-set! $v1 23 0))
+  (error? (bytevector-s64-native-set! $v1 28 0))
+  (error? (bytevector-s64-native-set! $v1 32 0))
+  (error? (bytevector-s64-native-set! $v1 33 0))
+  (error? (bytevector-s64-native-set! $v1 34 0))
+  (error? (bytevector-s64-native-set! $v1 35 0))
+  (error? (bytevector-s64-native-set! $v1 36 0))
+  (error? (bytevector-s64-native-set! $v1 37 0))
+  (error? (bytevector-s64-native-set! $v1 38 0))
+  (error? (bytevector-s64-native-set! $v1 39 0))
+  (error? (if (bytevector-s64-native-set! $v1 'q 0) #f #t))
+
+ ; invalid value
+  (error? (bytevector-s64-native-set! $v1 0 #x8000000000000000))
+  (error? (bytevector-s64-native-set! $v1 8 #x-8000000000000001))
+  (error? (if (bytevector-s64-native-set! $v1 16 "hello") #f #t))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (begin
+    (bytevector-s64-native-set! $v1 0 0)
+    (bytevector-s64-native-set! $v1 8 -1)
+    (bytevector-s64-native-set! $v1 16
+      (native->signed #x7f #xff #xff #xff #xff #xff #xff #xff))
+    (bytevector-s64-native-set! $v1 24
+      (native->signed #xff #xff #xff #xff #xff #xff #xff #x7f))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xff #xff #xff #xff #xff #xff #xff #x7f
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s64-native-set! $v1 0
+      (native->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+    (bytevector-s64-native-set! $v1 8
+      (native->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+    (bytevector-s64-native-set! $v1 16
+      (native->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+    (bytevector-s64-native-set! $v1 24
+      (native->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s64-native-set! $v1 0
+      (native->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+    (bytevector-s64-native-set! $v1 8
+      (native->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+    (bytevector-s64-native-set! $v1 16
+      (native->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+    (bytevector-s64-native-set! $v1 24
+      (native->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+        (bytevector-s64-native-set! v 0 (apply native->signed ls))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-u64-native-set!
+  (begin
+    (define $v1 (make-bytevector 39 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u64-native-set!))
+  (error? (bytevector-u64-native-set! $v1))
+  (error? (bytevector-u64-native-set! $v1 0))
+  (error? (if (bytevector-u64-native-set! $v1 0 0 15) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-u64-native-set! (make-vector 10) 0 0))
+  (error? (if (bytevector-u64-native-set! (make-vector 10) 0 0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-u64-native-set! $v1 -1 0))
+  (error? (bytevector-u64-native-set! $v1 1 0))
+  (error? (bytevector-u64-native-set! $v1 2 0))
+  (error? (bytevector-u64-native-set! $v1 3 0))
+  (error? (bytevector-u64-native-set! $v1 4 0))
+  (error? (bytevector-u64-native-set! $v1 5 0))
+  (error? (bytevector-u64-native-set! $v1 6 0))
+  (error? (bytevector-u64-native-set! $v1 7 0))
+  (error? (bytevector-u64-native-set! $v1 9 0))
+  (error? (bytevector-u64-native-set! $v1 10 0))
+  (error? (bytevector-u64-native-set! $v1 11 0))
+  (error? (bytevector-u64-native-set! $v1 12 0))
+  (error? (bytevector-u64-native-set! $v1 13 0))
+  (error? (bytevector-u64-native-set! $v1 14 0))
+  (error? (bytevector-u64-native-set! $v1 15 0))
+  (error? (bytevector-u64-native-set! $v1 17 0))
+  (error? (bytevector-u64-native-set! $v1 20 0))
+  (error? (bytevector-u64-native-set! $v1 23 0))
+  (error? (bytevector-u64-native-set! $v1 28 0))
+  (error? (bytevector-u64-native-set! $v1 32 0))
+  (error? (bytevector-u64-native-set! $v1 33 0))
+  (error? (bytevector-u64-native-set! $v1 34 0))
+  (error? (bytevector-u64-native-set! $v1 35 0))
+  (error? (bytevector-u64-native-set! $v1 36 0))
+  (error? (bytevector-u64-native-set! $v1 37 0))
+  (error? (bytevector-u64-native-set! $v1 38 0))
+  (error? (bytevector-u64-native-set! $v1 39 0))
+  (error? (if (bytevector-u64-native-set! $v1 'q 0) #f #t))
+
+ ; invalid value
+  (error? (bytevector-u64-native-set! $v1 0 #x10000000000000000))
+  (error? (bytevector-u64-native-set! $v1 8 #x-1))
+  (error? (if (bytevector-u64-native-set! $v1 16 "hello") #f #t))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+  (begin
+    (bytevector-u64-native-set! $v1 0 0)
+    (bytevector-u64-native-set! $v1 8 #xffffffffffffffff)
+    (bytevector-u64-native-set! $v1 16
+      (native->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff))
+    (bytevector-u64-native-set! $v1 24
+      (native->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xff #xff #xff #xff #xff #xff #xff #x7f
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u64-native-set! $v1 0
+      (native->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+    (bytevector-u64-native-set! $v1 8
+      (native->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+    (bytevector-u64-native-set! $v1 16
+      (native->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+    (bytevector-u64-native-set! $v1 24
+      (native->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u64-native-set! $v1 0
+      (native->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+    (bytevector-u64-native-set! $v1 8
+      (native->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+    (bytevector-u64-native-set! $v1 16
+      (native->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+    (bytevector-u64-native-set! $v1 24
+      (native->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+        (bytevector-u64-native-set! v 0 (apply native->unsigned ls))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+)
+
+(mat bytevector-s64-ref
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-s64-ref))
+  (error? (bytevector-s64-ref $v1))
+  (error? (bytevector-s64-ref $v1 0))
+  (error? (if (bytevector-s64-ref $v1 0 'big 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-s64-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little))
+  (error? (if (bytevector-s64-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little) #f #t))
+
+ ; invalid index
+  (error? (bytevector-s64-ref $v1 -1 'big))
+  (error? (bytevector-s64-ref $v1 96 'little))
+  (error? (bytevector-s64-ref $v1 97 'big))
+  (error? (bytevector-s64-ref $v1 98 'little))
+  (error? (bytevector-s64-ref $v1 99 'big))
+  (error? (bytevector-s64-ref $v1 100 'little))
+  (error? (bytevector-s64-ref $v1 101 'big))
+  (error? (bytevector-s64-ref $v1 102 'little))
+  (error? (bytevector-s64-ref $v1 103 'big))
+  (error? (if (bytevector-s64-ref $v1 4.0 (native-endianness)) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-s64-ref $v1 0 ''bonkers))
+  (error? (bytevector-s64-ref $v1 0 'get-real))
+  (error? (if (bytevector-s64-ref $v1 0 1e23) #f #t))
+
+ ; (not bothering with native endianness, since it's either big or little)
+
+ ; aligned accesses, endianness little
+  (eqv? (bytevector-s64-ref $v1 0 'little) 0)
+  (eqv? (bytevector-s64-ref $v1 8 'little) -1)
+  (eqv? (bytevector-s64-ref $v1 16 'little)
+        (little-endian->signed #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-ref $v1 24 'little)
+        (little-endian->signed #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-s64-ref $v1 32 'little)
+        (little-endian->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-s64-ref $v1 40 'little)
+        (little-endian->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-ref $v1 48 'little)
+        (little-endian->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-ref $v1 56 'little)
+        (little-endian->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-ref $v1 64 'little)
+        (little-endian->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-s64-ref $v1 72 'little)
+        (little-endian->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-s64-ref $v1 80 'little)
+        (little-endian->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-s64-ref $v1 88 'little)
+        (little-endian->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-s64-ref (apply bytevector ls) 0 'little)
+                    (apply little-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+  (eqv? (bytevector-s64-ref $v1 0 'big) 0)
+  (eqv? (bytevector-s64-ref $v1 8 'big) -1)
+  (eqv? (bytevector-s64-ref $v1 16 'big)
+        (big-endian->signed #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-ref $v1 24 'big)
+        (big-endian->signed #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-s64-ref $v1 32 'big)
+        (big-endian->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-s64-ref $v1 40 'big)
+        (big-endian->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-ref $v1 48 'big)
+        (big-endian->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-ref $v1 56 'big)
+        (big-endian->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-ref $v1 64 'big)
+        (big-endian->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-s64-ref $v1 72 'big)
+        (big-endian->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-s64-ref $v1 80 'big)
+        (big-endian->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-s64-ref $v1 88 'big)
+        (big-endian->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-s64-ref (apply bytevector ls) 0 'big)
+                    (apply big-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1
+      '#vu8(#xc7
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00     ; 1
+            #xc7
+            #xff #xff #xff #xff #xff #xff #xff #xff     ; 10
+            #xc7
+            #x7f #xff #xff #xff #xff #xff #xff #xff     ; 19
+            #xc7
+            #xff #xff #xff #xff #xff #xff #xff #x7f     ; 28
+            #xc7
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00     ; 37
+            #xc7
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80     ; 46
+            #xc7
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff     ; 55
+            #xc7 #xc7
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80     ; 65
+            #xc7
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89     ; 74
+            #xc7
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12     ; 83
+            #xc7
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef     ; 92
+            #xc7
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78))   ; 101
+    (bytevector? $v1))
+
+  (eqv? (bytevector-s64-ref $v1 1 'big) 0)
+  (eqv? (bytevector-s64-ref $v1 10 'little) -1)
+  (eqv? (bytevector-s64-ref $v1 19 (native-endianness))
+        (native->signed #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-ref $v1 28 'big)
+        (big-endian->signed #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-s64-ref $v1 37 'little)
+        (little-endian->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-s64-ref $v1 46 'big)
+        (big-endian->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-ref $v1 55 'little)
+        (little-endian->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-s64-ref $v1 65 'big)
+        (big-endian->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-s64-ref $v1 74 'little)
+        (little-endian->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-s64-ref $v1 83 (native-endianness))
+        (native->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-s64-ref $v1 92 'big)
+        (big-endian->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-s64-ref $v1 101 'little)
+        (little-endian->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-s64-ref (apply bytevector #x3e ls) 1 (native-endianness))
+                    (apply native->signed ls))
+        (errorf #f "failed for ~s" ls))
+      (unless (eqv? (bytevector-s64-ref (apply bytevector #x3e ls) 1 'big)
+                    (apply big-endian->signed ls))
+        (errorf #f "failed for ~s" ls))
+      (unless (eqv? (bytevector-s64-ref (apply bytevector #x3e ls) 1 'little)
+                    (apply little-endian->signed ls))
+        (errorf #f "failed for ~s" ls))))
+)
+
+(mat bytevector-u64-ref
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-u64-ref))
+  (error? (bytevector-u64-ref $v1))
+  (error? (bytevector-u64-ref $v1 0))
+  (error? (if (bytevector-u64-ref $v1 0 'big 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-u64-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little))
+  (error? (if (bytevector-u64-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little) #f #t))
+
+ ; invalid index
+  (error? (bytevector-u64-ref $v1 -1 'big))
+  (error? (bytevector-u64-ref $v1 96 'little))
+  (error? (bytevector-u64-ref $v1 97 'big))
+  (error? (bytevector-u64-ref $v1 98 'little))
+  (error? (bytevector-u64-ref $v1 99 'big))
+  (error? (bytevector-u64-ref $v1 100 'little))
+  (error? (bytevector-u64-ref $v1 101 'big))
+  (error? (bytevector-u64-ref $v1 102 'little))
+  (error? (bytevector-u64-ref $v1 103 'big))
+  (error? (if (bytevector-u64-ref $v1 4.0 (native-endianness)) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-u64-ref $v1 0 ''bonkers))
+  (error? (bytevector-u64-ref $v1 0 'get-real))
+  (error? (if (bytevector-u64-ref $v1 0 1e23) #f #t))
+
+ ; (not bothering with native endianness, since it's either big or little)
+
+ ; aligned accesses, endianness little
+  (eqv? (bytevector-u64-ref $v1 0 'little) 0)
+  (eqv? (bytevector-u64-ref $v1 8 'little) #xffffffffffffffff)
+  (eqv? (bytevector-u64-ref $v1 16 'little)
+        (little-endian->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-ref $v1 24 'little)
+        (little-endian->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-u64-ref $v1 32 'little)
+        (little-endian->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-u64-ref $v1 40 'little)
+        (little-endian->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-ref $v1 48 'little)
+        (little-endian->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-ref $v1 56 'little)
+        (little-endian->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-ref $v1 64 'little)
+        (little-endian->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-u64-ref $v1 72 'little)
+        (little-endian->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-u64-ref $v1 80 'little)
+        (little-endian->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-u64-ref $v1 88 'little)
+        (little-endian->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+ ; aligned accesses, endianness big
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+  (eqv? (bytevector-u64-ref $v1 0 'big) 0)
+  (eqv? (bytevector-u64-ref $v1 8 'big) #xffffffffffffffff)
+  (eqv? (bytevector-u64-ref $v1 16 'big)
+        (big-endian->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-ref $v1 24 'big)
+        (big-endian->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-u64-ref $v1 32 'big)
+        (big-endian->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-u64-ref $v1 40 'big)
+        (big-endian->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-ref $v1 48 'big)
+        (big-endian->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-ref $v1 56 'big)
+        (big-endian->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-ref $v1 64 'big)
+        (big-endian->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-u64-ref $v1 72 'big)
+        (big-endian->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-u64-ref $v1 80 'big)
+        (big-endian->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-u64-ref $v1 88 'big)
+        (big-endian->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-u64-ref (apply bytevector ls) 0 'big)
+                    (apply big-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1
+      '#vu8(#xc7
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00     ; 1
+            #xc7
+            #xff #xff #xff #xff #xff #xff #xff #xff     ; 10
+            #xc7
+            #x7f #xff #xff #xff #xff #xff #xff #xff     ; 19
+            #xc7
+            #xff #xff #xff #xff #xff #xff #xff #x7f     ; 28
+            #xc7
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00     ; 37
+            #xc7
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80     ; 46
+            #xc7
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff     ; 55
+            #xc7 #xc7
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80     ; 65
+            #xc7
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89     ; 74
+            #xc7
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12     ; 83
+            #xc7
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef     ; 92
+            #xc7
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78))   ; 101
+    (bytevector? $v1))
+
+  (eqv? (bytevector-u64-ref $v1 1 'big) 0)
+  (eqv? (bytevector-u64-ref $v1 10 'little) #xffffffffffffffff)
+  (eqv? (bytevector-u64-ref $v1 19 (native-endianness))
+        (native->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-ref $v1 28 'big)
+        (big-endian->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f))
+  (eqv? (bytevector-u64-ref $v1 37 'little)
+        (little-endian->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+  (eqv? (bytevector-u64-ref $v1 46 'big)
+        (big-endian->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-ref $v1 55 'little)
+        (little-endian->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff))
+  (eqv? (bytevector-u64-ref $v1 65 'big)
+        (big-endian->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80))
+  (eqv? (bytevector-u64-ref $v1 74 'little)
+        (little-endian->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89))
+  (eqv? (bytevector-u64-ref $v1 83 (native-endianness))
+        (native->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12))
+  (eqv? (bytevector-u64-ref $v1 92 'big)
+        (big-endian->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef))
+  (eqv? (bytevector-u64-ref $v1 101 'little)
+        (little-endian->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78))
+
+  (do ([i 10000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+      (unless (eqv? (bytevector-u64-ref (apply bytevector #x3e ls) 1 (native-endianness))
+                    (apply native->unsigned ls))
+        (errorf #f "failed for ~s" ls))
+      (unless (eqv? (bytevector-u64-ref (apply bytevector #x3e ls) 1 'big)
+                    (apply big-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))
+      (unless (eqv? (bytevector-u64-ref (apply bytevector #x3e ls) 1 'little)
+                    (apply little-endian->unsigned ls))
+        (errorf #f "failed for ~s" ls))))
+)
+
+(mat bytevector-s64-set!
+  (begin
+    (define $v1 (make-bytevector 39 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-s64-set!))
+  (error? (bytevector-s64-set! $v1))
+  (error? (bytevector-s64-set! $v1 0))
+  (error? (bytevector-s64-set! $v1 0 0))
+  (error? (if (bytevector-s64-set! $v1 0 0 'big 15) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-s64-set! (make-vector 10) 0 0 'big))
+  (error? (if (bytevector-s64-set! (make-vector 10) 0 0 'big) #f #t))
+
+ ; invalid index
+  (error? (bytevector-s64-set! $v1 -1 0 'big))
+  (error? (bytevector-s64-set! $v1 32 0 'little))
+  (error? (bytevector-s64-set! $v1 33 0 'big))
+  (error? (bytevector-s64-set! $v1 34 0 'little))
+  (error? (bytevector-s64-set! $v1 35 0 (native-endianness)))
+  (error? (bytevector-s64-set! $v1 36 0 'big))
+  (error? (bytevector-s64-set! $v1 37 0 'little))
+  (error? (bytevector-s64-set! $v1 38 0 'big))
+  (error? (bytevector-s64-set! $v1 39 0 'little))
+  (error? (if (bytevector-s64-set! $v1 'q 0 (native-endianness)) #f #t))
+
+ ; invalid value
+  (error? (bytevector-s64-set! $v1 0 #x8000000000000000 'little))
+  (error? (bytevector-s64-set! $v1 8 #x-8000000000000001 'big))
+  (error? (if (bytevector-s64-set! $v1 16 "hello" (native-endianness)) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-s64-set! $v1 0 0 'gorgeous))
+  (error? (bytevector-s64-set! $v1 0 0 '#(ravenous)))
+  (error? (if (bytevector-s64-set! $v1 0 0 #t) #f #t))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; (not bothering with native endianness, since it's either big or little)
+
+ ; aligned accesses, endianness little
+  (begin
+    (bytevector-s64-set! $v1 0 0 'little)
+    (bytevector-s64-set! $v1 8 -1 'little)
+    (bytevector-s64-set! $v1 16
+      (little-endian->signed #x7f #xff #xff #xff #xff #xff #xff #xff)
+      'little)
+    (bytevector-s64-set! $v1 24
+      (little-endian->signed #xff #xff #xff #xff #xff #xff #xff #x7f)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xff #xff #xff #xff #xff #xff #xff #x7f
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s64-set! $v1 0
+      (little-endian->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+      'little)
+    (bytevector-s64-set! $v1 8
+      (little-endian->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)
+      'little)
+    (bytevector-s64-set! $v1 16
+      (little-endian->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff)
+      'little)
+    (bytevector-s64-set! $v1 24
+      (little-endian->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s64-set! $v1 0
+      (little-endian->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)
+      'little)
+    (bytevector-s64-set! $v1 8
+      (little-endian->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)
+      'little)
+    (bytevector-s64-set! $v1 16
+      (little-endian->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)
+      'little)
+    (bytevector-s64-set! $v1 24
+      (little-endian->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (bytevector-s64-set! $v1 0 0 'big)
+    (bytevector-s64-set! $v1 8 -1 'big)
+    (bytevector-s64-set! $v1 16
+      (big-endian->signed #x7f #xff #xff #xff #xff #xff #xff #xff)
+      'big)
+    (bytevector-s64-set! $v1 24
+      (big-endian->signed #xff #xff #xff #xff #xff #xff #xff #x7f)
+      'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xff #xff #xff #xff #xff #xff #xff #x7f
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s64-set! $v1 0
+      (little-endian->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+      'little)
+    (bytevector-s64-set! $v1 8
+      (little-endian->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)
+      'little)
+    (bytevector-s64-set! $v1 16
+      (little-endian->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff)
+      'little)
+    (bytevector-s64-set! $v1 24
+      (little-endian->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-s64-set! $v1 0
+      (little-endian->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)
+      'little)
+    (bytevector-s64-set! $v1 8
+      (little-endian->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)
+      'little)
+    (bytevector-s64-set! $v1 16
+      (little-endian->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)
+      'little)
+    (bytevector-s64-set! $v1 24
+      (little-endian->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; aligned accesses, endianness mixed
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+        (bytevector-s64-set! v 0 (apply native->signed ls) (native-endianness))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s64-set! v 0 (apply big-endian->signed (reverse ls)) 'big)
+        (unless (equal? v (apply bytevector (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-s64-set! v 0 (apply little-endian->signed ls) 'little)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 36 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 1
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 10
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 19
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad)))) ; 28
+
+  (begin
+    (bytevector-s64-set! $v1 1 0 'big)
+    (bytevector-s64-set! $v1 10 -1 'little)
+    (bytevector-s64-set! $v1 19
+      (big-endian->signed #x7f #xff #xff #xff #xff #xff #xff #xff)
+      'big)
+    (bytevector-s64-set! $v1 28
+      (little-endian->signed #xff #xff #xff #xff #xff #xff #xff #x7f)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xad
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #xad
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xad
+                        #xff #xff #xff #xff #xff #xff #xff #x7f))))
+
+  (begin
+    (define $v1 (make-bytevector 37 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 2
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 11
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 20
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad)))) ; 29
+
+  (begin
+    (bytevector-s64-set! $v1 2
+      (little-endian->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+      'little)
+    (bytevector-s64-set! $v1 11
+      (big-endian->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)
+      'big)
+    (bytevector-s64-set! $v1 20
+      (big-endian->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff)
+      'big)
+    (bytevector-s64-set! $v1 29
+      (little-endian->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad
+                        #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xad
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #xad
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xad
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80))))
+
+  (begin
+    (define $v1 (make-bytevector 38 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 3
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 12
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 21
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad)))) ; 30
+
+  (begin
+    (bytevector-s64-set! $v1 3
+      (big-endian->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)
+      'big)
+    (bytevector-s64-set! $v1 12
+      (little-endian->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)
+      'little)
+    (bytevector-s64-set! $v1 21
+      (little-endian->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)
+      'little)
+    (bytevector-s64-set! $v1 30
+      (big-endian->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78)
+      'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad
+                        #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #xad
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #xad
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xad
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78))))
+
+  (let ([v (make-bytevector 15)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([idx (fx+ (modulo i 7) 1)])
+        (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+          (bytevector-fill! v #xc7)
+          (bytevector-s64-set! v idx (apply native->signed ls) (native-endianness))
+          (unless (equal? v
+                    (apply bytevector
+                      (append
+                        (make-list idx #xc7)
+                        ls
+                        (make-list (fx- 7 idx) #xc7))))
+            (errorf #f "failed for ~s (native)" ls))
+          (bytevector-s64-set! v idx
+            (apply big-endian->signed (reverse ls))
+            'big)
+          (unless (equal? v
+                    (apply bytevector
+                      (append
+                        (make-list idx #xc7)
+                        (reverse ls)
+                        (make-list (fx- 7 idx) #xc7))))
+            (errorf #f "failed for ~s (big)" ls))
+          (bytevector-s64-set! v idx
+            (apply little-endian->signed ls)
+            'little)
+          (unless (equal? v
+                    (apply bytevector
+                      (append
+                        (make-list idx #xc7)
+                        ls
+                        (make-list (fx- 7 idx) #xc7))))
+            (errorf #f "failed for ~s (little)" ls))))))
+)
+
+(mat bytevector-u64-set!
+  (begin
+    (define $v1 (make-bytevector 39 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; wrong argument count
+  (error? (bytevector-u64-set!))
+  (error? (bytevector-u64-set! $v1))
+  (error? (bytevector-u64-set! $v1 0))
+  (error? (bytevector-u64-set! $v1 0 0))
+  (error? (if (bytevector-u64-set! $v1 0 0 'big 15) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-u64-set! (make-vector 10) 0 0 'big))
+  (error? (if (bytevector-u64-set! (make-vector 10) 0 0 'big) #f #t))
+
+ ; invalid index
+  (error? (bytevector-u64-set! $v1 -1 0 'big))
+  (error? (bytevector-u64-set! $v1 32 0 'little))
+  (error? (bytevector-u64-set! $v1 33 0 'big))
+  (error? (bytevector-u64-set! $v1 34 0 'little))
+  (error? (bytevector-u64-set! $v1 35 0 (native-endianness)))
+  (error? (bytevector-u64-set! $v1 36 0 'big))
+  (error? (bytevector-u64-set! $v1 37 0 'little))
+  (error? (bytevector-u64-set! $v1 38 0 'big))
+  (error? (bytevector-u64-set! $v1 39 0 'little))
+  (error? (if (bytevector-u64-set! $v1 'q 0 (native-endianness)) #f #t))
+
+ ; invalid value
+  (error? (bytevector-u64-set! $v1 0 #x10000000000000000 'little))
+  (error? (bytevector-u64-set! $v1 8 #x-1 'big))
+  (error? (if (bytevector-u64-set! $v1 16 "hello" (native-endianness)) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-u64-set! $v1 0 0 'gorgeous))
+  (error? (bytevector-u64-set! $v1 0 0 '#(ravenous)))
+  (error? (if (bytevector-u64-set! $v1 0 0 #t) #f #t))
+
+ ; make sure no damage done
+  (and
+    (bytevector? $v1)
+    (equal? $v1 '#vu8(#xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad #xad
+                      #xad #xad #xad #xad #xad #xad #xad)))
+
+ ; (not bothering with native endianness, since it's either big or little)
+
+ ; aligned accesses, endianness little
+  (begin
+    (bytevector-u64-set! $v1 0 0 'little)
+    (bytevector-u64-set! $v1 8 #xffffffffffffffff 'little)
+    (bytevector-u64-set! $v1 16
+      (little-endian->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff)
+      'little)
+    (bytevector-u64-set! $v1 24
+      (little-endian->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xff #xff #xff #xff #xff #xff #xff #x7f
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u64-set! $v1 0
+      (little-endian->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+      'little)
+    (bytevector-u64-set! $v1 8
+      (little-endian->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)
+      'little)
+    (bytevector-u64-set! $v1 16
+      (little-endian->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff)
+      'little)
+    (bytevector-u64-set! $v1 24
+      (little-endian->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u64-set! $v1 0
+      (little-endian->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)
+      'little)
+    (bytevector-u64-set! $v1 8
+      (little-endian->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)
+      'little)
+    (bytevector-u64-set! $v1 16
+      (little-endian->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)
+      'little)
+    (bytevector-u64-set! $v1 24
+      (little-endian->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; aligned accesses, endianness big
+  (begin
+    (bytevector-u64-set! $v1 0 0 'big)
+    (bytevector-u64-set! $v1 8 #xffffffffffffffff 'big)
+    (bytevector-u64-set! $v1 16
+      (big-endian->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff)
+      'big)
+    (bytevector-u64-set! $v1 24
+      (big-endian->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f)
+      'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xff #xff #xff #xff #xff #xff #xff #x7f
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u64-set! $v1 0
+      (little-endian->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+      'little)
+    (bytevector-u64-set! $v1 8
+      (little-endian->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)
+      'little)
+    (bytevector-u64-set! $v1 16
+      (little-endian->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff)
+      'little)
+    (bytevector-u64-set! $v1 24
+      (little-endian->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+  (begin
+    (bytevector-u64-set! $v1 0
+      (little-endian->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)
+      'little)
+    (bytevector-u64-set! $v1 8
+      (little-endian->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)
+      'little)
+    (bytevector-u64-set! $v1 16
+      (little-endian->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)
+      'little)
+    (bytevector-u64-set! $v1 24
+      (little-endian->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+                        #xad #xad #xad #xad #xad #xad #xad))))
+
+ ; aligned accesses, endianness mixed
+  (let ([v (bytevector #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7 #xc7)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+        (bytevector-u64-set! v 0 (apply native->unsigned ls) (native-endianness))
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u64-set! v 0 (apply big-endian->unsigned (reverse ls)) 'big)
+        (unless (equal? v (apply bytevector (reverse ls)))
+          (errorf #f "failed for ~s" ls))
+        (bytevector-u64-set! v 0 (apply little-endian->unsigned ls) 'little)
+        (unless (equal? v (apply bytevector ls))
+          (errorf #f "failed for ~s" ls)))))
+
+ ; unaligned accesses, endianness mixed
+  (begin
+    (define $v1 (make-bytevector 36 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 1
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 10
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 19
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad)))) ; 28
+
+  (begin
+    (bytevector-u64-set! $v1 1 0 'big)
+    (bytevector-u64-set! $v1 10 #xffffffffffffffff 'little)
+    (bytevector-u64-set! $v1 19
+      (big-endian->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff)
+      'big)
+    (bytevector-u64-set! $v1 28
+      (little-endian->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xad
+                        #xff #xff #xff #xff #xff #xff #xff #xff
+                        #xad
+                        #x7f #xff #xff #xff #xff #xff #xff #xff
+                        #xad
+                        #xff #xff #xff #xff #xff #xff #xff #x7f))))
+
+  (begin
+    (define $v1 (make-bytevector 37 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 2
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 11
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 20
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad)))) ; 29
+
+  (begin
+    (bytevector-u64-set! $v1 2
+      (little-endian->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+      'little)
+    (bytevector-u64-set! $v1 11
+      (big-endian->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)
+      'big)
+    (bytevector-u64-set! $v1 20
+      (big-endian->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff)
+      'big)
+    (bytevector-u64-set! $v1 29
+      (little-endian->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80)
+      'little)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad
+                        #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+                        #xad
+                        #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+                        #xad
+                        #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+                        #xad
+                        #xff #xff #xff #xff #x00 #x00 #x00 #x80))))
+
+  (begin
+    (define $v1 (make-bytevector 38 #xad))
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 3
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 12
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad     ; 21
+                        #xad
+                        #xad #xad #xad #xad #xad #xad #xad #xad)))) ; 30
+
+  (begin
+    (bytevector-u64-set! $v1 3
+      (big-endian->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)
+      'big)
+    (bytevector-u64-set! $v1 12
+      (little-endian->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)
+      'little)
+    (bytevector-u64-set! $v1 21
+      (little-endian->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)
+      'little)
+    (bytevector-u64-set! $v1 30
+      (big-endian->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78)
+      'big)
+    (and
+      (bytevector? $v1)
+      (equal? $v1 '#vu8(#xad #xad #xad
+                        #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+                        #xad
+                        #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+                        #xad
+                        #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+                        #xad
+                        #xef #xde #xcd #xbc #xab #x9a #x89 #x78))))
+
+  (let ([v (make-bytevector 15)])
+    (do ([i 10000 (fx- i 1)])
+        ((fx= i 0) #t)
+      (let ([idx (fx+ (modulo i 7) 1)])
+        (let ([ls (map (lambda (x) (random (expt 2 8))) (make-list 8))])
+          (bytevector-fill! v #xc7)
+          (bytevector-u64-set! v idx (apply native->unsigned ls) (native-endianness))
+          (unless (equal? v
+                    (apply bytevector
+                      (append
+                        (make-list idx #xc7)
+                        ls
+                        (make-list (fx- 7 idx) #xc7))))
+            (errorf #f "failed for ~s (native)" ls))
+          (bytevector-u64-set! v idx
+            (apply big-endian->unsigned (reverse ls))
+            'big)
+          (unless (equal? v
+                    (apply bytevector
+                      (append
+                        (make-list idx #xc7)
+                        (reverse ls)
+                        (make-list (fx- 7 idx) #xc7))))
+            (errorf #f "failed for ~s (big)" ls))
+          (bytevector-u64-set! v idx
+            (apply little-endian->unsigned ls)
+            'little)
+          (unless (equal? v
+                    (apply bytevector
+                      (append
+                        (make-list idx #xc7)
+                        ls
+                        (make-list (fx- 7 idx) #xc7))))
+            (errorf #f "failed for ~s (little)" ls))))))
+)
+
+(mat bytevector-ieee-single-native-ref
+  (begin
+    (define $v1
+      (case (native-endianness)
+        [(little)
+         '#vu8(#x00 #x00 #x00 #x00   ; 0.0
+               #x00 #x00 #x00 #x00   ; 0.0   ; extra for consistent mat errors between big- and little-endian machines
+               #x00 #x00 #x80 #x3f   ; 1.0
+               #x00 #x00 #x80 #xbf   ; -1.0
+               #x00 #x00 #xc0 #x3f   ; 1.5
+               #x00 #x00 #xc0 #xbf   ; -1.5
+               #xad #xe6 #xd5 #x65   ; #b1.10101011110011010101101e1001100
+               #x00 #x00 #x80 #x7f   ; +inf.0
+               #x00 #x00 #x80 #xff   ; -inf.0
+               #x01 #x02 #x03)]
+        [(big)
+         '#vu8(#x00 #x00 #x00 #x00   ; 0.0
+               #x00 #x00 #x00 #x00   ; 0.0   ; extra for consistent mat errors between big- and little-endian machines
+               #x3f #x80 #x00 #x00   ; 1.0
+               #xbf #x80 #x00 #x00   ; -1.0
+               #x3f #xc0 #x00 #x00   ; 1.5
+               #xbf #xc0 #x00 #x00   ; -1.5
+               #x65 #xd5 #xe6 #xad   ; #b1.10101011110011010101101e1001100
+               #x7f #x80 #x00 #x00   ; +inf.0
+               #xff #x80 #x00 #x00   ; -inf.0
+               #x01 #x02 #x03)]
+        [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-ieee-single-native-ref))
+  (error? (bytevector-ieee-single-native-ref $v1))
+  (error? (if (bytevector-ieee-single-native-ref $v1 0 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-single-native-ref '#(3 252 5 0 0 0 0) 0))
+  (error? (if (bytevector-ieee-single-native-ref '#(3 252 5 0 0 0 0) 0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-single-native-ref $v1 -1))
+  (error? (bytevector-ieee-single-native-ref $v1 1))
+  (error? (bytevector-ieee-single-native-ref $v1 2))
+  (error? (bytevector-ieee-single-native-ref $v1 3))
+  (error? (bytevector-ieee-single-native-ref $v1 5))
+  (error? (bytevector-ieee-single-native-ref $v1 6))
+  (error? (bytevector-ieee-single-native-ref $v1 7))
+  (error? (bytevector-ieee-single-native-ref $v1 9))
+  (error? (bytevector-ieee-single-native-ref $v1 10))
+  (error? (bytevector-ieee-single-native-ref $v1 11))
+  (error? (bytevector-ieee-single-native-ref $v1 13))
+  (error? (bytevector-ieee-single-native-ref $v1 14))
+  (error? (bytevector-ieee-single-native-ref $v1 15))
+  (error? (bytevector-ieee-single-native-ref $v1 17))
+  (error? (bytevector-ieee-single-native-ref $v1 18))
+  (error? (bytevector-ieee-single-native-ref $v1 19))
+  (error? (bytevector-ieee-single-native-ref $v1 21))
+  (error? (bytevector-ieee-single-native-ref $v1 22))
+  (error? (bytevector-ieee-single-native-ref $v1 23))
+  (error? (bytevector-ieee-single-native-ref $v1 25))
+  (error? (bytevector-ieee-single-native-ref $v1 26))
+  (error? (bytevector-ieee-single-native-ref $v1 27))
+  (error? (bytevector-ieee-single-native-ref $v1 29))
+  (error? (bytevector-ieee-single-native-ref $v1 30))
+  (error? (bytevector-ieee-single-native-ref $v1 31))
+  (error? (bytevector-ieee-single-native-ref $v1 33))
+  (error? (bytevector-ieee-single-native-ref $v1 34))
+  (error? (bytevector-ieee-single-native-ref $v1 35))
+  (error? (bytevector-ieee-single-native-ref $v1 36))
+  (error? (bytevector-ieee-single-native-ref $v1 37))
+  (error? (bytevector-ieee-single-native-ref $v1 38))
+  (error? (bytevector-ieee-single-native-ref $v1 39))
+  (error? (if (bytevector-ieee-single-native-ref $v1 4.0) #f #t))
+
+  (eqv? (bytevector-ieee-single-native-ref $v1 0) 0.0)
+  (eqv? (bytevector-ieee-single-native-ref $v1 4) 0.0)
+  (eqv? (bytevector-ieee-single-native-ref $v1 8) 1.0)
+  (eqv? (bytevector-ieee-single-native-ref $v1 12) -1.0)
+  (eqv? (bytevector-ieee-single-native-ref $v1 16) 1.5)
+  (eqv? (bytevector-ieee-single-native-ref $v1 20) -1.5)
+  (eqv? (bytevector-ieee-single-native-ref $v1 24) #b1.10101011110011010101101e1001100)
+  (eqv? (bytevector-ieee-single-native-ref $v1 28) +inf.0)
+  (eqv? (bytevector-ieee-single-native-ref $v1 32) -inf.0)
+)
+
+(mat bytevector-ieee-double-native-ref
+  (begin
+    (define $v1
+      (case (native-endianness)
+        [(little)
+         '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0
+               #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x3f   ; 1.0
+               #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xbf   ; -1.0
+               #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #x3f   ; 1.5
+               #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #xbf   ; -1.5
+               #xef #xcd #xab #x89 #x67 #x45 #xa3 #x9c   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101
+               #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x7f   ; +inf.0
+               #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xff   ; -inf.0
+               #x01 #x02 #x03 #x04 #x05 #x06 #x07)]
+        [(big)
+         '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0
+               #x3f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.0
+               #xbf #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.0
+               #x3f #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.5
+               #xbf #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.5
+               #x9c #xa3 #x45 #x67 #x89 #xab #xcd #xef   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101
+               #x7f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; +inf.0
+               #xff #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; -inf.0
+               #x01 #x02 #x03 #x04 #x05 #x06 #x07)]
+        [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-ieee-double-native-ref))
+  (error? (bytevector-ieee-double-native-ref $v1))
+  (error? (if (bytevector-ieee-double-native-ref $v1 0 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-double-native-ref '#(3 252 5 0 0 0 0) 0))
+  (error? (if (bytevector-ieee-double-native-ref '#(3 252 5 0 0 0 0) 0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-double-native-ref $v1 -1))
+  (error? (bytevector-ieee-double-native-ref $v1 1))
+  (error? (bytevector-ieee-double-native-ref $v1 2))
+  (error? (bytevector-ieee-double-native-ref $v1 3))
+  (error? (bytevector-ieee-double-native-ref $v1 4))
+  (error? (bytevector-ieee-double-native-ref $v1 5))
+  (error? (bytevector-ieee-double-native-ref $v1 6))
+  (error? (bytevector-ieee-double-native-ref $v1 7))
+  (error? (bytevector-ieee-double-native-ref $v1 9))
+  (error? (bytevector-ieee-double-native-ref $v1 10))
+  (error? (bytevector-ieee-double-native-ref $v1 11))
+  (error? (bytevector-ieee-double-native-ref $v1 12))
+  (error? (bytevector-ieee-double-native-ref $v1 13))
+  (error? (bytevector-ieee-double-native-ref $v1 14))
+  (error? (bytevector-ieee-double-native-ref $v1 15))
+  (error? (bytevector-ieee-double-native-ref $v1 17))
+  (error? (bytevector-ieee-double-native-ref $v1 18))
+  (error? (bytevector-ieee-double-native-ref $v1 19))
+  (error? (bytevector-ieee-double-native-ref $v1 20))
+  (error? (bytevector-ieee-double-native-ref $v1 21))
+  (error? (bytevector-ieee-double-native-ref $v1 22))
+  (error? (bytevector-ieee-double-native-ref $v1 23))
+  (error? (bytevector-ieee-double-native-ref $v1 25))
+  (error? (bytevector-ieee-double-native-ref $v1 26))
+  (error? (bytevector-ieee-double-native-ref $v1 27))
+  (error? (bytevector-ieee-double-native-ref $v1 28))
+  (error? (bytevector-ieee-double-native-ref $v1 29))
+  (error? (bytevector-ieee-double-native-ref $v1 30))
+  (error? (bytevector-ieee-double-native-ref $v1 31))
+  (error? (bytevector-ieee-double-native-ref $v1 33))
+  (error? (bytevector-ieee-double-native-ref $v1 42))
+  (error? (bytevector-ieee-double-native-ref $v1 51))
+  (error? (bytevector-ieee-double-native-ref $v1 60))
+  (error? (bytevector-ieee-double-native-ref $v1 69))
+  (error? (bytevector-ieee-double-native-ref $v1 70))
+  (error? (bytevector-ieee-double-native-ref $v1 71))
+  (error? (if (bytevector-ieee-double-native-ref $v1 4.0) #f #t))
+
+  (eqv? (bytevector-ieee-double-native-ref $v1 0) 0.0)
+  (eqv? (bytevector-ieee-double-native-ref $v1 8) 1.0)
+  (eqv? (bytevector-ieee-double-native-ref $v1 16) -1.0)
+  (eqv? (bytevector-ieee-double-native-ref $v1 24) 1.5)
+  (eqv? (bytevector-ieee-double-native-ref $v1 32) -1.5)
+  (eqv? (bytevector-ieee-double-native-ref $v1 40) #b-1.0011010001010110011110001001101010111100110111101111e-1000110101)
+  (eqv? (bytevector-ieee-double-native-ref $v1 48) +inf.0)
+  (eqv? (bytevector-ieee-double-native-ref $v1 56) -inf.0)
+)
+
+(mat bytevector-ieee-single-native-set!
+  (begin
+    (define $v1 (make-bytevector 35 #xeb))
+    (and (bytevector? $v1)
+         (equal? $v1
+           '#vu8(#xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb))))
+
+ ; wrong argument count
+  (error? (bytevector-ieee-single-native-set!))
+  (error? (bytevector-ieee-single-native-set! $v1))
+  (error? (bytevector-ieee-single-native-set! $v1 0))
+  (error? (if (bytevector-ieee-single-native-set! $v1 0 0.0 0.0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-single-native-set! '#(3 252 5 0 0 0 0) 0 0.0))
+  (error? (if (bytevector-ieee-single-native-set! '#(3 252 5 0 0 0 0) 0 0.0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-single-native-set! $v1 -1 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 1 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 2 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 3 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 5 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 6 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 7 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 9 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 10 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 11 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 13 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 14 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 15 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 17 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 18 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 19 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 21 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 22 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 23 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 25 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 26 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 27 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 29 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 30 0.0))
+  (error? (bytevector-ieee-single-native-set! $v1 31 0.0))
+  (error? (if (bytevector-ieee-single-native-set! $v1 4.0 0.0) #f #t))
+
+ ; invalid value
+  (error? (bytevector-ieee-single-native-set! $v1 0 1+2i))
+  (error? (bytevector-ieee-single-native-set! $v1 0 1.0+3.0i))
+  (error? (bytevector-ieee-single-native-set! $v1 0 1.0+0.0i))
+  (error? (bytevector-ieee-single-native-set! $v1 0 1.0-0.0i))
+  (error? (if (bytevector-ieee-single-native-set! $v1 0 "oops") #f #t))
+
+ ; make sure no damage done
+  (and (bytevector? $v1)
+       (equal? $v1
+         '#vu8(#xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb)))
+
+  (begin
+    (bytevector-ieee-single-native-set! $v1 0 0.0)
+    (bytevector-ieee-single-native-set! $v1 4 1)
+    (bytevector-ieee-single-native-set! $v1 8 -1)
+    (bytevector-ieee-single-native-set! $v1 12 3/2)
+    (bytevector-ieee-single-native-set! $v1 16 -3/2)
+    (bytevector-ieee-single-native-set! $v1 20 #b1.10101011110011010101101e1001100)
+    (bytevector-ieee-single-native-set! $v1 24 +inf.0)
+    (bytevector-ieee-single-native-set! $v1 28 -inf.0)
+    (and (bytevector? $v1)
+         (equal? $v1
+           (case (native-endianness)
+             [(little)
+              '#vu8(#x00 #x00 #x00 #x00   ; 0.0
+                    #x00 #x00 #x80 #x3f   ; 1.0
+                    #x00 #x00 #x80 #xbf   ; -1.0
+                    #x00 #x00 #xc0 #x3f   ; 1.5
+                    #x00 #x00 #xc0 #xbf   ; -1.5
+                    #xad #xe6 #xd5 #x65   ; #b1.10101011110011010101101e1001100
+                    #x00 #x00 #x80 #x7f   ; +inf.0
+                    #x00 #x00 #x80 #xff   ; -inf.0
+                    #xeb #xeb #xeb)]
+             [(big)
+              '#vu8(#x00 #x00 #x00 #x00   ; 0.0
+                    #x3f #x80 #x00 #x00   ; 1.0
+                    #xbf #x80 #x00 #x00   ; -1.0
+                    #x3f #xc0 #x00 #x00   ; 1.5
+                    #xbf #xc0 #x00 #x00   ; -1.5
+                    #x65 #xd5 #xe6 #xad   ; #b1.10101011110011010101101e1001100
+                    #x7f #x80 #x00 #x00   ; +inf.0
+                    #xff #x80 #x00 #x00   ; -inf.0
+                    #xeb #xeb #xeb)]
+             [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))))
+)
+
+(mat bytevector-ieee-double-native-set!
+  (begin
+    (define $v1 (make-bytevector 71 #xeb))
+    (and (bytevector? $v1)
+         (equal? $v1
+           '#vu8(#xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb))))
+
+ ; wrong argument count
+  (error? (bytevector-ieee-double-native-set!))
+  (error? (bytevector-ieee-double-native-set! $v1))
+  (error? (bytevector-ieee-double-native-set! $v1 0))
+  (error? (if (bytevector-ieee-double-native-set! $v1 0 0.0 0.0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-double-native-set! '#(3 252 5 0 0 0 0) 0 0.0))
+  (error? (if (bytevector-ieee-double-native-set! '#(3 252 5 0 0 0 0) 0 0.0) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-double-native-set! $v1 -1 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 1 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 2 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 3 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 4 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 5 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 6 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 7 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 9 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 10 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 11 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 12 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 13 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 14 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 15 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 17 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 18 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 19 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 20 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 21 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 22 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 23 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 25 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 26 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 27 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 28 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 29 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 30 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 31 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 33 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 42 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 51 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 60 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 69 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 70 0.0))
+  (error? (bytevector-ieee-double-native-set! $v1 71 0.0))
+  (error? (if (bytevector-ieee-double-native-set! $v1 4.0 0.0) #f #t))
+
+ ; invalid value
+  (error? (bytevector-ieee-double-native-set! $v1 0 1+2i))
+  (error? (bytevector-ieee-double-native-set! $v1 0 1.0-7.3i))
+  (error? (bytevector-ieee-double-native-set! $v1 0 -i))
+  (error? (bytevector-ieee-double-native-set! $v1 0 1.0+0.0i))
+  (error? (bytevector-ieee-double-native-set! $v1 0 1.0-0.0i))
+  (error? (if (bytevector-ieee-double-native-set! $v1 0 "oops") #f #t))
+
+ ; make sure no damage done
+  (and (bytevector? $v1)
+       (equal? $v1
+         '#vu8(#xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb)))
+
+  (begin
+    (bytevector-ieee-double-native-set! $v1 0 0.0)
+    (bytevector-ieee-double-native-set! $v1 8 1)
+    (bytevector-ieee-double-native-set! $v1 16 -1)
+    (bytevector-ieee-double-native-set! $v1 24 3/2)
+    (bytevector-ieee-double-native-set! $v1 32 -3/2)
+    (bytevector-ieee-double-native-set! $v1 40 #b-1.0011010001010110011110001001101010111100110111101111e-1000110101)
+    (bytevector-ieee-double-native-set! $v1 48 +inf.0)
+    (bytevector-ieee-double-native-set! $v1 56 -inf.0)
+    (and (bytevector? $v1)
+         (equal? $v1
+           (case (native-endianness)
+             [(little)
+              '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0
+                    #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x3f   ; 1.0
+                    #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xbf   ; -1.0
+                    #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #x3f   ; 1.5
+                    #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #xbf   ; -1.5
+                    #xef #xcd #xab #x89 #x67 #x45 #xa3 #x9c   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101
+                    #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x7f   ; +inf.0
+                    #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xff   ; -inf.0
+                    #xeb #xeb #xeb #xeb #xeb #xeb #xeb)]
+             [(big)
+              '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0
+                    #x3f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.0
+                    #xbf #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.0
+                    #x3f #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.5
+                    #xbf #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.5
+                    #x9c #xa3 #x45 #x67 #x89 #xab #xcd #xef   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101
+                    #x7f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; +inf.0
+                    #xff #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; -inf.0
+                    #xeb #xeb #xeb #xeb #xeb #xeb #xeb)]
+             [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))))
+)
+
+(mat bytevector-ieee-single-ref
+  (begin
+    (define $vlittle
+      '#vu8(#x00 #x00 #x00 #x00   ; 0.0   ; 0
+            #xc7
+            #x00 #x00 #x00 #x00   ; 0.0   ; 5
+            #xc7
+            #x00 #x00 #x80 #x3f   ; 1.0   ; 10
+            #xc7
+            #x00 #x00 #x80 #xbf   ; -1.0  ; 15
+            #xc7
+            #x00 #x00 #xc0 #x3f   ; 1.5   ; 20
+            #xc7
+            #x00 #x00 #xc0 #xbf   ; -1.5  ; 25
+            #xc7
+            #xad #xe6 #xd5 #x65   ; #b1.10101011110011010101101e1001100 ; 30
+            #xc7
+            #x00 #x00 #x80 #x7f   ; +inf.0 ; 35
+            #xc7
+            #x00 #x00 #x80 #xff   ; -inf.0 ; 40
+            #xc7))
+    (define $vbig
+      '#vu8(#x00 #x00 #x00 #x00   ; 0.0   ; 0
+            #xc7
+            #x00 #x00 #x00 #x00   ; 0.0   ; 5
+            #xc7
+            #x3f #x80 #x00 #x00   ; 1.0   ; 10
+            #xc7
+            #xbf #x80 #x00 #x00   ; -1.0  ; 15
+            #xc7
+            #x3f #xc0 #x00 #x00   ; 1.5   ; 20
+            #xc7
+            #xbf #xc0 #x00 #x00   ; -1.5  ; 25
+            #xc7
+            #x65 #xd5 #xe6 #xad   ; #b1.10101011110011010101101e1001100 ; 30
+            #xc7
+            #x7f #x80 #x00 #x00   ; +inf.0 ; 35
+            #xc7
+            #xff #x80 #x00 #x00   ; -inf.0 ; 40
+            #xc7))
+    (define $vnative
+      (case (native-endianness)
+        [(little) $vlittle]
+        [(big) $vbig]
+        [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))
+    (andmap bytevector? (list $vlittle $vbig $vnative)))
+
+ ; wrong argument count
+  (error? (bytevector-ieee-single-ref))
+  (error? (bytevector-ieee-single-ref $vnative))
+  (error? (bytevector-ieee-single-ref $vnative 0))
+  (error? (if (bytevector-ieee-single-ref $vnative 0 'big 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-single-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (if (bytevector-ieee-single-ref '#(3 252 5 0 0 0 0) 0 'big) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-single-ref $vnative -1 'big))
+  (error? (bytevector-ieee-single-ref $vnative 42 'little))
+  (error? (bytevector-ieee-single-ref $vnative 43 'big))
+  (error? (bytevector-ieee-single-ref $vnative 44 (native-endianness)))
+  (error? (bytevector-ieee-single-ref $vnative 45 'little))
+  (error? (if (bytevector-ieee-single-ref $vnative 4.0 'big) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-ieee-single-ref $vnative 0 "nuts"))
+  (error? (bytevector-ieee-single-ref $vnative 0 'crazy))
+  (error? (if (bytevector-ieee-single-ref $vnative 0 35) #f #t))
+
+  (eqv? (bytevector-ieee-single-ref $vnative 0 (native-endianness)) 0.0)
+  (eqv? (bytevector-ieee-single-ref $vnative 5 (native-endianness)) 0.0)
+  (eqv? (bytevector-ieee-single-ref $vnative 10 (native-endianness)) 1.0)
+  (eqv? (bytevector-ieee-single-ref $vnative 15 (native-endianness)) -1.0)
+  (eqv? (bytevector-ieee-single-ref $vnative 20 (native-endianness)) 1.5)
+  (eqv? (bytevector-ieee-single-ref $vnative 25 (native-endianness)) -1.5)
+  (eqv? (bytevector-ieee-single-ref $vnative 30 (native-endianness)) #b1.10101011110011010101101e1001100)
+  (eqv? (bytevector-ieee-single-ref $vnative 35 (native-endianness)) +inf.0)
+  (eqv? (bytevector-ieee-single-ref $vnative 40 (native-endianness)) -inf.0)
+
+  (eqv? (bytevector-ieee-single-ref $vlittle 0 'little) 0.0)
+  (eqv? (bytevector-ieee-single-ref $vlittle 5 'little) 0.0)
+  (eqv? (bytevector-ieee-single-ref $vlittle 10 'little) 1.0)
+  (eqv? (bytevector-ieee-single-ref $vlittle 15 'little) -1.0)
+  (eqv? (bytevector-ieee-single-ref $vlittle 20 'little) 1.5)
+  (eqv? (bytevector-ieee-single-ref $vlittle 25 'little) -1.5)
+  (eqv? (bytevector-ieee-single-ref $vlittle 30 'little) #b1.10101011110011010101101e1001100)
+  (eqv? (bytevector-ieee-single-ref $vlittle 35 'little) +inf.0)
+  (eqv? (bytevector-ieee-single-ref $vlittle 40 'little) -inf.0)
+
+  (eqv? (bytevector-ieee-single-ref $vbig 0 'big) 0.0)
+  (eqv? (bytevector-ieee-single-ref $vbig 5 'big) 0.0)
+  (eqv? (bytevector-ieee-single-ref $vbig 10 'big) 1.0)
+  (eqv? (bytevector-ieee-single-ref $vbig 15 'big) -1.0)
+  (eqv? (bytevector-ieee-single-ref $vbig 20 'big) 1.5)
+  (eqv? (bytevector-ieee-single-ref $vbig 25 'big) -1.5)
+  (eqv? (bytevector-ieee-single-ref $vbig 30 'big) #b1.10101011110011010101101e1001100)
+  (eqv? (bytevector-ieee-single-ref $vbig 35 'big) +inf.0)
+  (eqv? (bytevector-ieee-single-ref $vbig 40 'big) -inf.0)
+)
+
+(mat bytevector-ieee-double-ref
+  (begin
+    (define $vlittle
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0    ; 0
+            #xed
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x3f   ; 1.0    ; 9
+            #xed
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xbf   ; -1.0   ; 18
+            #xed
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #x3f   ; 1.5    ; 27
+            #xed
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #xbf   ; -1.5   ; 36
+            #xed
+            #xef #xcd #xab #x89 #x67 #x45 #xa3 #x9c   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101 ; 45
+            #xed
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x7f   ; +inf.0 ; 54
+            #xed
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xff)) ; -inf.0 ; 63
+    (define $vbig
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0    ; 0
+            #xed
+            #x3f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.0    ; 9
+            #xed
+            #xbf #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.0   ; 18
+            #xed
+            #x3f #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.5    ; 27
+            #xed
+            #xbf #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.5   ; 36
+            #xed
+            #x9c #xa3 #x45 #x67 #x89 #xab #xcd #xef   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101 ; 45
+            #xed
+            #x7f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; +inf.0 ; 54
+            #xed
+            #xff #xf0 #x00 #x00 #x00 #x00 #x00 #x00)) ; -inf.0 ; 63
+    (define $vnative
+      (case (native-endianness)
+        [(little) $vlittle]
+        [(big) $vbig]
+        [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))
+    (andmap bytevector? (list $vlittle $vbig $vnative)))
+
+ ; wrong argument count
+  (error? (bytevector-ieee-double-ref))
+  (error? (bytevector-ieee-double-ref $vnative))
+  (error? (bytevector-ieee-double-ref $vnative 0))
+  (error? (if (bytevector-ieee-double-ref $vnative 0 'big 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-double-ref '#(3 252 5 0 0 0 0) 0 'big))
+  (error? (if (bytevector-ieee-double-ref '#(3 252 5 0 0 0 0) 0 'big) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-double-ref $vnative -1 'big))
+  (error? (bytevector-ieee-double-ref $vnative 64 'big))
+  (error? (bytevector-ieee-double-ref $vnative 65 (native-endianness)))
+  (error? (bytevector-ieee-double-ref $vnative 66 'little))
+  (error? (bytevector-ieee-double-ref $vnative 67 'big))
+  (error? (bytevector-ieee-double-ref $vnative 68 (native-endianness)))
+  (error? (bytevector-ieee-double-ref $vnative 69 'little))
+  (error? (bytevector-ieee-double-ref $vnative 70 'big))
+  (error? (bytevector-ieee-double-ref $vnative 71 'little))
+  (error? (if (bytevector-ieee-double-ref $vnative 4.0 'big) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-ieee-double-ref $vnative 0 "nuts"))
+  (error? (bytevector-ieee-double-ref $vnative 0 'crazy))
+  (error? (if (bytevector-ieee-double-ref $vnative 0 35) #f #t))
+
+  (eqv? (bytevector-ieee-double-ref $vnative 0 (native-endianness)) 0.0)
+  (eqv? (bytevector-ieee-double-ref $vnative 9 (native-endianness)) 1.0)
+  (eqv? (bytevector-ieee-double-ref $vnative 18 (native-endianness)) -1.0)
+  (eqv? (bytevector-ieee-double-ref $vnative 27 (native-endianness)) 1.5)
+  (eqv? (bytevector-ieee-double-ref $vnative 36 (native-endianness)) -1.5)
+  (eqv? (bytevector-ieee-double-ref $vnative 45 (native-endianness)) #b-1.0011010001010110011110001001101010111100110111101111e-1000110101)
+  (eqv? (bytevector-ieee-double-ref $vnative 54 (native-endianness)) +inf.0)
+  (eqv? (bytevector-ieee-double-ref $vnative 63 (native-endianness)) -inf.0)
+
+  (eqv? (bytevector-ieee-double-ref $vlittle 0 'little) 0.0)
+  (eqv? (bytevector-ieee-double-ref $vlittle 9 'little) 1.0)
+  (eqv? (bytevector-ieee-double-ref $vlittle 18 'little) -1.0)
+  (eqv? (bytevector-ieee-double-ref $vlittle 27 'little) 1.5)
+  (eqv? (bytevector-ieee-double-ref $vlittle 36 'little) -1.5)
+  (eqv? (bytevector-ieee-double-ref $vlittle 45 'little) #b-1.0011010001010110011110001001101010111100110111101111e-1000110101)
+  (eqv? (bytevector-ieee-double-ref $vlittle 54 'little) +inf.0)
+  (eqv? (bytevector-ieee-double-ref $vlittle 63 'little) -inf.0)
+
+  (eqv? (bytevector-ieee-double-ref $vbig 0 'big) 0.0)
+  (eqv? (bytevector-ieee-double-ref $vbig 9 'big) 1.0)
+  (eqv? (bytevector-ieee-double-ref $vbig 18 'big) -1.0)
+  (eqv? (bytevector-ieee-double-ref $vbig 27 'big) 1.5)
+  (eqv? (bytevector-ieee-double-ref $vbig 36 'big) -1.5)
+  (eqv? (bytevector-ieee-double-ref $vbig 45 'big) #b-1.0011010001010110011110001001101010111100110111101111e-1000110101)
+  (eqv? (bytevector-ieee-double-ref $vbig 54 'big) +inf.0)
+  (eqv? (bytevector-ieee-double-ref $vbig 63 'big) -inf.0)
+)
+
+(mat bytevector-ieee-single-set!
+  (begin
+    (define $v1 (make-bytevector 39 #xeb))
+    (and (bytevector? $v1)
+         (equal? $v1
+           '#vu8(#xeb #xeb #xeb #xeb     ; 0
+                 #xeb
+                 #xeb #xeb #xeb #xeb     ; 5
+                 #xeb
+                 #xeb #xeb #xeb #xeb     ; 10
+                 #xeb
+                 #xeb #xeb #xeb #xeb     ; 15
+                 #xeb
+                 #xeb #xeb #xeb #xeb     ; 20
+                 #xeb
+                 #xeb #xeb #xeb #xeb     ; 25
+                 #xeb
+                 #xeb #xeb #xeb #xeb     ; 30
+                 #xeb
+                 #xeb #xeb #xeb #xeb)))) ; 35
+
+ ; wrong argument count
+  (error? (bytevector-ieee-single-set!))
+  (error? (bytevector-ieee-single-set! $v1))
+  (error? (bytevector-ieee-single-set! $v1 0))
+  (error? (bytevector-ieee-single-set! $v1 0 0.0))
+  (error? (if (bytevector-ieee-single-set! $v1 0 0.0 'big 'bigger) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-single-set! '#(3 252 5 0 0 0 0) 0 0.0 'little))
+  (error? (if (bytevector-ieee-single-set! '#(3 252 5 0 0 0 0) 0 0.0 'little) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-single-set! $v1 -1 0.0 'little))
+  (error? (bytevector-ieee-single-set! $v1 36 0.0 'little))
+  (error? (bytevector-ieee-single-set! $v1 37 0.0 'big))
+  (error? (bytevector-ieee-single-set! $v1 38 0.0 'big))
+  (error? (bytevector-ieee-single-set! $v1 39 0.0 'little))
+  (error? (if (bytevector-ieee-single-set! $v1 4.0 0.0 (native-endianness)) #f #t))
+
+ ; invalid value
+  (error? (bytevector-ieee-single-set! $v1 0 1+2i 'big))
+  (error? (bytevector-ieee-single-set! $v1 0 1.0+3.0i 'little))
+  (error? (bytevector-ieee-single-set! $v1 0 1.0+0.0i 'big))
+  (error? (bytevector-ieee-single-set! $v1 0 1.0-0.0i (native-endianness)))
+  (error? (if (bytevector-ieee-single-set! $v1 0 "oops" 'little) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-ieee-single-set! $v1 0 0.0 "ouch"))
+  (error? (bytevector-ieee-single-set! $v1 0 0.0 'what?))
+  (error? (if (bytevector-ieee-single-set! $v1 0 0.0 #\newline) #f #t))
+
+ ; make sure no damage done
+  (and (bytevector? $v1)
+       (equal? $v1
+         '#vu8(#xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb
+               #xeb
+               #xeb #xeb #xeb #xeb)))
+
+  (begin
+    (define $vlittle
+      '#vu8(#x00 #x00 #x00 #x00   ; 0.0
+            #xeb
+            #x00 #x00 #x80 #x3f   ; 1.0
+            #xeb
+            #x00 #x00 #x80 #xbf   ; -1.0
+            #xeb
+            #x00 #x00 #xc0 #x3f   ; 1.5
+            #xeb
+            #x00 #x00 #xc0 #xbf   ; -1.5
+            #xeb
+            #xad #xe6 #xd5 #x65   ; #b1.10101011110011010101101e1001100
+            #xeb
+            #x00 #x00 #x80 #x7f   ; +inf.0
+            #xeb
+            #x00 #x00 #x80 #xff)) ; -inf.0
+
+    (define $vbig
+      '#vu8(#x00 #x00 #x00 #x00   ; 0.0
+            #xeb
+            #x3f #x80 #x00 #x00   ; 1.0
+            #xeb
+            #xbf #x80 #x00 #x00   ; -1.0
+            #xeb
+            #x3f #xc0 #x00 #x00   ; 1.5
+            #xeb
+            #xbf #xc0 #x00 #x00   ; -1.5
+            #xeb
+            #x65 #xd5 #xe6 #xad   ; #b1.10101011110011010101101e1001100
+            #xeb
+            #x7f #x80 #x00 #x00   ; +inf.0
+            #xeb
+            #xff #x80 #x00 #x00)) ; -inf.0
+
+    (define $vnative
+      (case (native-endianness)
+        [(little) $vlittle]
+        [(big) $vbig]
+        [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))
+    (andmap bytevector? (list $vlittle $vbig $vnative)))
+
+  (begin
+    (bytevector-ieee-single-set! $v1 0 0.0 (native-endianness))
+    (bytevector-ieee-single-set! $v1 5 1 (native-endianness))
+    (bytevector-ieee-single-set! $v1 10 -1 (native-endianness))
+    (bytevector-ieee-single-set! $v1 15 3/2 (native-endianness))
+    (bytevector-ieee-single-set! $v1 20 -3/2 (native-endianness))
+    (bytevector-ieee-single-set! $v1 25 #b1.10101011110011010101101e1001100 (native-endianness))
+    (bytevector-ieee-single-set! $v1 30 +inf.0 (native-endianness))
+    (bytevector-ieee-single-set! $v1 35 -inf.0 (native-endianness))
+    (and (bytevector? $v1) (equal? $v1 $vnative)))
+
+  (begin
+    (bytevector-ieee-single-set! $v1 0 0.0 'little)
+    (bytevector-ieee-single-set! $v1 5 1 'little)
+    (bytevector-ieee-single-set! $v1 10 -1 'little)
+    (bytevector-ieee-single-set! $v1 15 3/2 'little)
+    (bytevector-ieee-single-set! $v1 20 -3/2 'little)
+    (bytevector-ieee-single-set! $v1 25 #b1.10101011110011010101101e1001100 'little)
+    (bytevector-ieee-single-set! $v1 30 +inf.0 'little)
+    (bytevector-ieee-single-set! $v1 35 -inf.0 'little)
+    (and (bytevector? $v1) (equal? $v1 $vlittle)))
+
+  (begin
+    (bytevector-ieee-single-set! $v1 0 0.0 'big)
+    (bytevector-ieee-single-set! $v1 5 1 'big)
+    (bytevector-ieee-single-set! $v1 10 -1 'big)
+    (bytevector-ieee-single-set! $v1 15 3/2 'big)
+    (bytevector-ieee-single-set! $v1 20 -3/2 'big)
+    (bytevector-ieee-single-set! $v1 25 #b1.10101011110011010101101e1001100 'big)
+    (bytevector-ieee-single-set! $v1 30 +inf.0 'big)
+    (bytevector-ieee-single-set! $v1 35 -inf.0 'big)
+    (and (bytevector? $v1) (equal? $v1 $vbig)))
+)
+
+(mat bytevector-ieee-double-set!
+  (begin
+    (define $v1 (make-bytevector 71 #xeb))
+    (and (bytevector? $v1)
+         (equal? $v1
+           '#vu8(#xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 0
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 9
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 18
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 27
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 36
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 45
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 54
+                 #xeb
+                 #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb)))) ; 63
+
+ ; wrong argument count
+  (error? (bytevector-ieee-double-set!))
+  (error? (bytevector-ieee-double-set! $v1))
+  (error? (bytevector-ieee-double-set! $v1 0))
+  (error? (bytevector-ieee-double-set! $v1 0 0.0))
+  (error? (if (bytevector-ieee-double-set! $v1 0 0.0 'big 'bigger) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-ieee-double-set! '#(3 252 5 0 0 0 0) 0 0.0 'little))
+  (error? (if (bytevector-ieee-double-set! '#(3 252 5 0 0 0 0) 0 0.0 'little) #f #t))
+
+ ; invalid index
+  (error? (bytevector-ieee-double-set! $v1 -1 0.0 'little))
+  (error? (bytevector-ieee-double-set! $v1 64 0.0 'little))
+  (error? (bytevector-ieee-double-set! $v1 65 0.0 'little))
+  (error? (bytevector-ieee-double-set! $v1 66 0.0 'little))
+  (error? (bytevector-ieee-double-set! $v1 67 0.0 'little))
+  (error? (bytevector-ieee-double-set! $v1 68 0.0 'little))
+  (error? (bytevector-ieee-double-set! $v1 69 0.0 'big))
+  (error? (bytevector-ieee-double-set! $v1 70 0.0 'big))
+  (error? (bytevector-ieee-double-set! $v1 71 0.0 'little))
+  (error? (if (bytevector-ieee-double-set! $v1 4.0 0.0 (native-endianness)) #f #t))
+
+ ; invalid value
+  (error? (bytevector-ieee-double-set! $v1 0 1+2i 'big))
+  (error? (bytevector-ieee-double-set! $v1 0 1.0+3.0i 'little))
+  (error? (bytevector-ieee-double-set! $v1 0 1.0+0.0i 'big))
+  (error? (bytevector-ieee-double-set! $v1 0 1.0-0.0i (native-endianness)))
+  (error? (if (bytevector-ieee-double-set! $v1 0 "oops" 'little) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-ieee-double-set! $v1 0 0.0 "ouch"))
+  (error? (bytevector-ieee-double-set! $v1 0 0.0 'what?))
+  (error? (if (bytevector-ieee-double-set! $v1 0 0.0 #\newline) #f #t))
+
+ ; make sure no damage done
+  (and (bytevector? $v1)
+       (equal? $v1
+         '#vu8(#xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 0
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 9
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 18
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 27
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 36
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 45
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb     ; 54
+               #xeb
+               #xeb #xeb #xeb #xeb #xeb #xeb #xeb #xeb)))  ; 63
+
+  (begin
+    (define $vlittle
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0
+            #xeb
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x3f   ; 1.0
+            #xeb
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xbf   ; -1.0
+            #xeb
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #x3f   ; 1.5
+            #xeb
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf8 #xbf   ; -1.5
+            #xeb
+            #xef #xcd #xab #x89 #x67 #x45 #xa3 #x9c   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101
+            #xeb
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #x7f   ; +inf.0
+            #xeb
+            #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xff)) ; -inf.0
+
+    (define $vbig
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00   ; 0.0
+            #xeb
+            #x3f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.0
+            #xeb
+            #xbf #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.0
+            #xeb
+            #x3f #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; 1.5
+            #xeb
+            #xbf #xf8 #x00 #x00 #x00 #x00 #x00 #x00   ; -1.5
+            #xeb
+            #x9c #xa3 #x45 #x67 #x89 #xab #xcd #xef   ; #b-1.0011010001010110011110001001101010111100110111101111e-1000110101
+            #xeb
+            #x7f #xf0 #x00 #x00 #x00 #x00 #x00 #x00   ; +inf.0
+            #xeb
+            #xff #xf0 #x00 #x00 #x00 #x00 #x00 #x00)) ; -inf.0
+
+    (define $vnative
+      (case (native-endianness)
+        [(little) $vlittle]
+        [(big) $vbig]
+        [else (errorf #f "mat doesn't handled endianness ~s" (native-endianness))]))
+    (andmap bytevector? (list $vlittle $vbig $vnative)))
+
+  (begin
+    (bytevector-ieee-double-set! $v1 0 0.0 (native-endianness))
+    (bytevector-ieee-double-set! $v1 9 1 (native-endianness))
+    (bytevector-ieee-double-set! $v1 18 -1 (native-endianness))
+    (bytevector-ieee-double-set! $v1 27 3/2 (native-endianness))
+    (bytevector-ieee-double-set! $v1 36 -3/2 (native-endianness))
+    (bytevector-ieee-double-set! $v1 45 #b-1.0011010001010110011110001001101010111100110111101111e-1000110101 (native-endianness))
+    (bytevector-ieee-double-set! $v1 54 +inf.0 (native-endianness))
+    (bytevector-ieee-double-set! $v1 63 -inf.0 (native-endianness))
+    (and (bytevector? $v1) (equal? $v1 $vnative)))
+
+  (begin
+    (bytevector-ieee-double-set! $v1 0 0.0 'big)
+    (bytevector-ieee-double-set! $v1 9 1 'big)
+    (bytevector-ieee-double-set! $v1 18 -1 'big)
+    (bytevector-ieee-double-set! $v1 27 3/2 'big)
+    (bytevector-ieee-double-set! $v1 36 -3/2 'big)
+    (bytevector-ieee-double-set! $v1 45 #b-1.0011010001010110011110001001101010111100110111101111e-1000110101 'big)
+    (bytevector-ieee-double-set! $v1 54 +inf.0 'big)
+    (bytevector-ieee-double-set! $v1 63 -inf.0 'big)
+    (and (bytevector? $v1) (equal? $v1 $vbig)))
+
+  (begin
+    (bytevector-ieee-double-set! $v1 0 0.0 'little)
+    (bytevector-ieee-double-set! $v1 9 1 'little)
+    (bytevector-ieee-double-set! $v1 18 -1 'little)
+    (bytevector-ieee-double-set! $v1 27 3/2 'little)
+    (bytevector-ieee-double-set! $v1 36 -3/2 'little)
+    (bytevector-ieee-double-set! $v1 45 #b-1.0011010001010110011110001001101010111100110111101111e-1000110101 'little)
+    (bytevector-ieee-double-set! $v1 54 +inf.0 'little)
+    (bytevector-ieee-double-set! $v1 63 -inf.0 'little)
+    (and (bytevector? $v1) (equal? $v1 $vlittle)))
+)
+
+(mat bytevector-sint-ref
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-sint-ref))
+  (error? (bytevector-sint-ref $v1))
+  (error? (bytevector-sint-ref $v1 0))
+  (error? (bytevector-sint-ref $v1 0 'big))
+  (error? (if (bytevector-sint-ref $v1 0 'big 5 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-sint-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little 1))
+  (error? (if (bytevector-sint-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little 1) #f #t))
+
+ ; invalid index
+  (error? (bytevector-sint-ref $v1 -1 'big 1))
+  (error? (bytevector-sint-ref $v1 -1 'big 2))
+  (error? (bytevector-sint-ref $v1 -1 'big 3))
+  (error? (bytevector-sint-ref $v1 -1 'big 4))
+  (error? (bytevector-sint-ref $v1 -1 'big 8))
+  (error? (bytevector-sint-ref $v1 -1 'big 9))
+  (error? (if (bytevector-sint-ref $v1 -1 'big 10) #f #t))
+
+  (error? (bytevector-sint-ref $v1 96 'little 8))
+  (error? (bytevector-sint-ref $v1 96 'little 9))
+  (error? (bytevector-sint-ref $v1 97 'big 7))
+  (error? (bytevector-sint-ref $v1 98 'little 6))
+  (error? (bytevector-sint-ref $v1 99 'big 5))
+  (error? (bytevector-sint-ref $v1 100 'big 4))
+  (error? (bytevector-sint-ref $v1 100 'big 5))
+  (error? (bytevector-sint-ref $v1 100 'big 8))
+  (error? (bytevector-sint-ref $v1 101 'big 3))
+  (error? (bytevector-sint-ref $v1 101 'little 4))
+  (error? (bytevector-sint-ref $v1 102 'little 2))
+  (error? (bytevector-sint-ref $v1 102 'big 3))
+  (error? (bytevector-sint-ref $v1 103 'big 1))
+  (error? (bytevector-sint-ref $v1 103 'big 2))
+  (error? (bytevector-sint-ref $v1 103 'big 3))
+  (error? (if (bytevector-sint-ref $v1 4.0 (native-endianness) 3) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-sint-ref $v1 0 'bonkers 1))
+  (error? (bytevector-sint-ref $v1 0 'bonkers 2))
+  (error? (bytevector-sint-ref $v1 0 'bonkers 3))
+  (error? (bytevector-sint-ref $v1 0 'bonkers 4))
+  (error? (bytevector-sint-ref $v1 0 'bonkers 8))
+  (error? (if (bytevector-sint-ref $v1 0 'bonkers 35) #f #t))
+
+ ; invalid size
+  (error? (bytevector-sint-ref $v1 0 'little 0))
+  (error? (bytevector-sint-ref $v1 1 'big -1))
+  (error? (if (bytevector-sint-ref $v1 4 'little 'byte) #f #t))
+
+ ; constant args
+  (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (define (sublist ls i j)
+            (list-head (list-tail ls i) j))
+          (let* ([ls '(1 254 3 252 5 250 7 249 8 248
+                       9 247 10 246 40 216 80 176 100 156)]
+                 [n (length ls)])
+            #`(let ()
+                (define v '#,(apply bytevector ls))
+                (list #,@(let f ([i 0])
+                          (if (fx= i n)
+                              '()
+                              #`((list #,@(let g ([j 1])
+                                           (if (fx<= j (fx- n i))
+                                               #`((eqv? (bytevector-sint-ref v #,i 'little #,j)
+                                                        #,(apply little-endian->signed (sublist ls i j)))
+                                                  (eqv? (bytevector-sint-ref v #,i 'big #,j)
+                                                        #,(apply big-endian->signed (sublist ls i j)))
+                                                  #,@(g (fx+ j 1)))
+                                               '())))
+                                 #,@(f (fx+ i 1))))))))))
+      a))
+
+ ; nonconstant args
+  (do ([i 100 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random 256)) (make-list (random 25)))])
+      (unless (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+                (let ()
+                  (define (sublist ls i j)
+                    (list-head (list-tail ls i) j))
+                  (let ([n (length ls)])
+                    (define v (apply bytevector ls))
+                    (let f ([i 0])
+                      (if (fx= i n)
+                          '()
+                          (cons (let g ([j 1])
+                                  (if (fx<= j (fx- n i))
+                                      (cons*
+                                        (eqv? (bytevector-sint-ref v i 'little j)
+                                              (apply little-endian->signed (sublist ls i j)))
+                                        (eqv? (bytevector-sint-ref v i 'big j)
+                                              (apply big-endian->signed (sublist ls i j)))
+                                        (g (fx+ j 1)))
+                                      '()))
+                                (f (fx+ i 1))))))))
+        (pretty-print ls)
+        (errorf #f "failed for for ~s" ls))))
+)
+
+(mat bytevector-uint-ref
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-uint-ref))
+  (error? (bytevector-uint-ref $v1))
+  (error? (bytevector-uint-ref $v1 0))
+  (error? (bytevector-uint-ref $v1 0 'big))
+  (error? (if (bytevector-uint-ref $v1 0 'big 5 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-uint-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little 1))
+  (error? (if (bytevector-uint-ref '#(3 252 5 0 0 0 0 0 0 0 0) 0 'little 1) #f #t))
+
+ ; invalid index
+  (error? (bytevector-uint-ref $v1 -1 'big 1))
+  (error? (bytevector-uint-ref $v1 -1 'big 2))
+  (error? (bytevector-uint-ref $v1 -1 'big 3))
+  (error? (bytevector-uint-ref $v1 -1 'big 4))
+  (error? (bytevector-uint-ref $v1 -1 'big 8))
+  (error? (bytevector-uint-ref $v1 -1 'big 9))
+  (error? (if (bytevector-uint-ref $v1 -1 'big 10) #f #t))
+
+  (error? (bytevector-uint-ref $v1 96 'little 8))
+  (error? (bytevector-uint-ref $v1 96 'little 9))
+  (error? (bytevector-uint-ref $v1 97 'big 7))
+  (error? (bytevector-uint-ref $v1 98 'little 6))
+  (error? (bytevector-uint-ref $v1 99 'big 5))
+  (error? (bytevector-uint-ref $v1 100 'big 4))
+  (error? (bytevector-uint-ref $v1 100 'big 5))
+  (error? (bytevector-uint-ref $v1 100 'big 8))
+  (error? (bytevector-uint-ref $v1 101 'big 3))
+  (error? (bytevector-uint-ref $v1 101 'little 4))
+  (error? (bytevector-uint-ref $v1 102 'little 2))
+  (error? (bytevector-uint-ref $v1 102 'big 3))
+  (error? (bytevector-uint-ref $v1 103 'big 1))
+  (error? (bytevector-uint-ref $v1 103 'big 2))
+  (error? (bytevector-uint-ref $v1 103 'big 3))
+  (error? (if (bytevector-uint-ref $v1 4.0 (native-endianness) 3) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-uint-ref $v1 0 'bonkers 1))
+  (error? (bytevector-uint-ref $v1 0 'bonkers 2))
+  (error? (bytevector-uint-ref $v1 0 'bonkers 3))
+  (error? (bytevector-uint-ref $v1 0 'bonkers 4))
+  (error? (bytevector-uint-ref $v1 0 'bonkers 8))
+  (error? (if (bytevector-uint-ref $v1 0 'bonkers 35) #f #t))
+
+ ; invalid size
+  (error? (bytevector-uint-ref $v1 0 'little 0))
+  (error? (bytevector-uint-ref $v1 0 'little (+ (bytevector-length $v1) 1)))
+  (error? (bytevector-uint-ref $v1 7 'little (- (bytevector-length $v1) 6)))
+  (error? (bytevector-uint-ref #vu8(1 2 3 4) 0 'big 32))
+  (error? (bytevector-uint-ref $v1 1 'big -1))
+  (error? (if (bytevector-uint-ref $v1 4 'little 'byte) #f #t))
+
+ ; constant args
+  (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (define (sublist ls i j)
+            (list-head (list-tail ls i) j))
+          (let* ([ls '(1 254 3 252 5 250 7 249 8 248
+                       9 247 10 246 40 216 80 176 100 156)]
+                 [n (length ls)])
+            #`(let ()
+                (define v '#,(apply bytevector ls))
+                (list #,@(let f ([i 0])
+                          (if (fx= i n)
+                              '()
+                              #`((list #,@(let g ([j 1])
+                                           (if (fx<= j (fx- n i))
+                                               #`((eqv? (bytevector-uint-ref v #,i 'little #,j)
+                                                        #,(apply little-endian->unsigned (sublist ls i j)))
+                                                  (eqv? (bytevector-uint-ref v #,i 'big #,j)
+                                                        #,(apply big-endian->unsigned (sublist ls i j)))
+                                                  #,@(g (fx+ j 1)))
+                                               '())))
+                                 #,@(f (fx+ i 1))))))))))
+      a))
+
+ ; nonconstant args
+  (do ([i 100 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random 256)) (make-list (random 25)))])
+      (unless (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+                (let ()
+                  (define (sublist ls i j)
+                    (list-head (list-tail ls i) j))
+                  (let ([n (length ls)])
+                    (define v (apply bytevector ls))
+                    (let f ([i 0])
+                      (if (fx= i n)
+                          '()
+                          (cons (let g ([j 1])
+                                  (if (fx<= j (fx- n i))
+                                      (cons*
+                                        (eqv? (bytevector-uint-ref v i 'little j)
+                                              (apply little-endian->unsigned (sublist ls i j)))
+                                        (eqv? (bytevector-uint-ref v i 'big j)
+                                              (apply big-endian->unsigned (sublist ls i j)))
+                                        (g (fx+ j 1)))
+                                      '()))
+                                (f (fx+ i 1))))))))
+        (pretty-print ls)
+        (errorf #f "failed for for ~s" ls))))
+)
+
+(mat bytevector-sint-set!
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-sint-set!))
+  (error? (bytevector-sint-set! $v1))
+  (error? (bytevector-sint-set! $v1 0))
+  (error? (bytevector-sint-set! $v1 0 7))
+  (error? (bytevector-sint-set! $v1 0 7 'big))
+  (error? (if (bytevector-sint-set! $v1 0 7 'big 5 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-sint-set! '#(3 252 5 0 0 0 0 0 0 0 0) 0 7 'little 1))
+  (error? (if (bytevector-sint-set! '#(3 252 5 0 0 0 0 0 0 0 0) 0 7 'little 1) #f #t))
+
+ ; invalid index
+  (error? (bytevector-sint-set! $v1 -1 7 'big 1))
+  (error? (bytevector-sint-set! $v1 -1 7 'big 2))
+  (error? (bytevector-sint-set! $v1 -1 7 'big 3))
+  (error? (bytevector-sint-set! $v1 -1 7 'big 4))
+  (error? (bytevector-sint-set! $v1 -1 7 'big 8))
+  (error? (bytevector-sint-set! $v1 -1 7 'big 9))
+  (error? (if (bytevector-sint-set! $v1 -1 7 'big 10) #f #t))
+
+  (error? (bytevector-sint-set! $v1 96 7 'little 8))
+  (error? (bytevector-sint-set! $v1 96 7 'little 9))
+  (error? (bytevector-sint-set! $v1 97 7 'big 7))
+  (error? (bytevector-sint-set! $v1 98 7 'little 6))
+  (error? (bytevector-sint-set! $v1 99 7 'big 5))
+  (error? (bytevector-sint-set! $v1 100 7 'big 4))
+  (error? (bytevector-sint-set! $v1 100 7 'big 5))
+  (error? (bytevector-sint-set! $v1 100 7 'big 8))
+  (error? (bytevector-sint-set! $v1 101 7 'big 3))
+  (error? (bytevector-sint-set! $v1 101 7 'little 4))
+  (error? (bytevector-sint-set! $v1 102 7 'little 2))
+  (error? (bytevector-sint-set! $v1 102 7 'big 3))
+  (error? (bytevector-sint-set! $v1 103 7 'big 1))
+  (error? (bytevector-sint-set! $v1 103 7 'big 2))
+  (error? (bytevector-sint-set! $v1 103 7 'big 3))
+  (error? (if (bytevector-sint-set! $v1 4.0 7 (native-endianness) 3) #f #t))
+
+ ; invalid value
+  (error? (bytevector-sint-set! $v1 0 #x-81 'big 1))
+  (error? (bytevector-sint-set! $v1 0 #x-81 'little 1))
+  (error? (bytevector-sint-set! $v1 0 #x80 'big 1))
+  (error? (bytevector-sint-set! $v1 0 #x80 'little 1))
+  (error? (bytevector-sint-set! $v1 0 #x-8001 'big 2))
+  (error? (bytevector-sint-set! $v1 0 #x-8001 'little 2))
+  (error? (bytevector-sint-set! $v1 0 #x8000 'big 2))
+  (error? (bytevector-sint-set! $v1 0 #x8000 'little 2))
+  (error? (bytevector-sint-set! $v1 0 #x-800001 'big 3))
+  (error? (bytevector-sint-set! $v1 0 #x-800001 'little 3))
+  (error? (bytevector-sint-set! $v1 0 #x800000 'big 3))
+  (error? (bytevector-sint-set! $v1 0 #x800000 'little 3))
+  (error? (bytevector-sint-set! $v1 0 #x-80000001 'big 4))
+  (error? (bytevector-sint-set! $v1 0 #x-80000001 'little 4))
+  (error? (bytevector-sint-set! $v1 0 #x80000000 'big 4))
+  (error? (bytevector-sint-set! $v1 0 #x80000000 'little 4))
+  (error? (bytevector-sint-set! $v1 0 #x-8000000000000001 'big 8))
+  (error? (bytevector-sint-set! $v1 0 #x-8000000000000001 'little 8))
+  (error? (bytevector-sint-set! $v1 0 #x8000000000000000 'big 8))
+  (error? (bytevector-sint-set! $v1 0 #x8000000000000000 'little 8))
+  (error? (bytevector-sint-set! $v1 0 #x-80000000000000000001 'big 10))
+  (error? (bytevector-sint-set! $v1 0 #x-80000000000000000001 'little 10))
+  (error? (bytevector-sint-set! $v1 0 #x80000000000000000000 'big 10))
+  (error? (if (bytevector-sint-set! $v1 0 #x80000000000000000000 'little 10) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-sint-set! $v1 0 7 'bonkers 1))
+  (error? (bytevector-sint-set! $v1 0 7 'bonkers 2))
+  (error? (bytevector-sint-set! $v1 0 7 'bonkers 3))
+  (error? (bytevector-sint-set! $v1 0 7 'bonkers 4))
+  (error? (bytevector-sint-set! $v1 0 7 'bonkers 8))
+  (error? (if (bytevector-sint-set! $v1 0 7 'bonkers 35) #f #t))
+
+ ; invalid size
+  (error? (bytevector-sint-set! $v1 0 7 'little 0))
+  (error? (bytevector-sint-set! $v1 1 7 'big -1))
+  (error? (if (bytevector-sint-set! $v1 4 7 'little 'byte) #f #t))
+
+ ; constant args
+  (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (define (sublist ls i j)
+            (list-head (list-tail ls i) j))
+          (define (cmp-vec ls i j)
+            (apply bytevector
+              `(,@(make-list i #xc7)
+                ,@(sublist ls i j)
+                ,@(make-list (fx- (length ls) (+ i j)) #xc7))))
+          (let* ([ls '(1 254 3) #;'(1 254 3 252 5 250 7 249 8 248
+                       9 247 10 246 40 216 80 176 100 156)]
+                 [n (length ls)])
+            #`(list #,@(let f ([i 0])
+                         (if (fx= i n)
+                           '()
+                           #`((list #,@(let g ([j 1])
+                                        (if (fx<= j (fx- n i))
+                                            #`((equal?
+                                                 (let ([v (make-bytevector #,n #xc7)])
+                                                   (bytevector-sint-set! v #,i
+                                                     #,(apply little-endian->signed (sublist ls i j))
+                                                     'little #,j)
+                                                   v)
+                                                 '#,(cmp-vec ls i j))
+                                               (equal?
+                                                 (let ([v (make-bytevector #,n #xc7)])
+                                                   (bytevector-sint-set! v #,i
+                                                     #,(apply big-endian->signed (sublist ls i j))
+                                                     'big #,j)
+                                                   v)
+                                                 '#,(cmp-vec ls i j))
+                                               #,@(g (fx+ j 1)))
+                                            '())))
+                              #,@(f (fx+ i 1)))))))))
+      a))
+
+ ; nonconstant args
+  (do ([i 100 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random 256)) (make-list (random 25)))])
+      (unless (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+                (let ()
+                  (define (sublist ls i j)
+                    (list-head (list-tail ls i) j))
+                  (define (cmp-vec ls i j)
+                    (apply bytevector
+                      `(,@(make-list i #xc7)
+                        ,@(sublist ls i j)
+                        ,@(make-list (fx- (length ls) (+ i j)) #xc7))))
+                  (let ([n (length ls)])
+                    (let f ([i 0])
+                      (if (fx= i n)
+                          '()
+                           (cons (let g ([j 1])
+                                   (if (fx<= j (fx- n i))
+                                       (cons*
+                                         (equal?
+                                           (let ([v (make-bytevector n #xc7)])
+                                             (bytevector-sint-set! v i
+                                               (apply little-endian->signed (sublist ls i j))
+                                               'little j)
+                                             v)
+                                           (cmp-vec ls i j))
+                                         (equal?
+                                           (let ([v (make-bytevector n #xc7)])
+                                             (bytevector-sint-set! v i
+                                               (apply big-endian->signed (sublist ls i j))
+                                               'big j)
+                                             v)
+                                           (cmp-vec ls i j))
+                                         (g (fx+ j 1)))
+                                       '()))
+                                 (f (fx+ i 1))))))))
+        (pretty-print ls)
+        (errorf #f "failed for for ~s" ls))))
+)
+
+(mat bytevector-uint-set!
+  (begin
+    (define $v1
+      '#vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #xff #xff #xff #xff #xff #xff #xff #xff
+            #x7f #xff #xff #xff #xff #xff #xff #xff
+            #xff #xff #xff #xff #xff #xff #xff #x7f
+            #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+            #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80
+            #x80 #x00 #x00 #x00 #xff #xff #xff #xff
+            #xff #xff #xff #xff #x00 #x00 #x00 #x80
+            #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89
+            #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12
+            #x78 #x89 #x9a #xab #xbc #xcd #xde #xef
+            #xef #xde #xcd #xbc #xab #x9a #x89 #x78
+            #xfe #xed #xdc #xcb #xba #xa9 #x98))
+    (bytevector? $v1))
+
+ ; wrong argument count
+  (error? (bytevector-uint-set!))
+  (error? (bytevector-uint-set! $v1))
+  (error? (bytevector-uint-set! $v1 0))
+  (error? (bytevector-uint-set! $v1 0 7))
+  (error? (bytevector-uint-set! $v1 0 7 'big))
+  (error? (if (bytevector-uint-set! $v1 0 7 'big 5 0) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-uint-set! '#(3 252 5 0 0 0 0 0 0 0 0) 0 7 'little 1))
+  (error? (if (bytevector-uint-set! '#(3 252 5 0 0 0 0 0 0 0 0) 0 7 'little 1) #f #t))
+
+ ; invalid index
+  (error? (bytevector-uint-set! $v1 -1 7 'big 1))
+  (error? (bytevector-uint-set! $v1 -1 7 'big 2))
+  (error? (bytevector-uint-set! $v1 -1 7 'big 3))
+  (error? (bytevector-uint-set! $v1 -1 7 'big 4))
+  (error? (bytevector-uint-set! $v1 -1 7 'big 8))
+  (error? (bytevector-uint-set! $v1 -1 7 'big 9))
+  (error? (if (bytevector-uint-set! $v1 -1 7 'big 10) #f #t))
+
+  (error? (bytevector-uint-set! $v1 96 7 'little 8))
+  (error? (bytevector-uint-set! $v1 96 7 'little 9))
+  (error? (bytevector-uint-set! $v1 97 7 'big 7))
+  (error? (bytevector-uint-set! $v1 98 7 'little 6))
+  (error? (bytevector-uint-set! $v1 99 7 'big 5))
+  (error? (bytevector-uint-set! $v1 100 7 'big 4))
+  (error? (bytevector-uint-set! $v1 100 7 'big 5))
+  (error? (bytevector-uint-set! $v1 100 7 'big 8))
+  (error? (bytevector-uint-set! $v1 101 7 'big 3))
+  (error? (bytevector-uint-set! $v1 101 7 'little 4))
+  (error? (bytevector-uint-set! $v1 102 7 'little 2))
+  (error? (bytevector-uint-set! $v1 102 7 'big 3))
+  (error? (bytevector-uint-set! $v1 103 7 'big 1))
+  (error? (bytevector-uint-set! $v1 103 7 'big 2))
+  (error? (bytevector-uint-set! $v1 103 7 'big 3))
+  (error? (if (bytevector-uint-set! $v1 4.0 7 (native-endianness) 3) #f #t))
+
+ ; invalid value
+  (error? (bytevector-uint-set! $v1 0 #x-1 'big 1))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'little 1))
+  (error? (bytevector-uint-set! $v1 0 #x100 'big 1))
+  (error? (bytevector-uint-set! $v1 0 #x100 'little 1))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'big 2))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'little 2))
+  (error? (bytevector-uint-set! $v1 0 #x10000 'big 2))
+  (error? (bytevector-uint-set! $v1 0 #x10000 'little 2))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'big 3))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'little 3))
+  (error? (bytevector-uint-set! $v1 0 #x1000000 'big 3))
+  (error? (bytevector-uint-set! $v1 0 #x1000000 'little 3))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'big 4))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'little 4))
+  (error? (bytevector-uint-set! $v1 0 #x100000000 'big 4))
+  (error? (bytevector-uint-set! $v1 0 #x100000000 'little 4))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'big 8))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'little 8))
+  (error? (bytevector-uint-set! $v1 0 #x10000000000000000 'big 8))
+  (error? (bytevector-uint-set! $v1 0 #x10000000000000000 'little 8))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'big 10))
+  (error? (bytevector-uint-set! $v1 0 #x-1 'little 10))
+  (error? (bytevector-uint-set! $v1 0 #x100000000000000000000 'big 10))
+  (error? (if (bytevector-uint-set! $v1 0 #x100000000000000000000 'little 10) #f #t))
+
+ ; invalid endianness
+  (error? (bytevector-uint-set! $v1 0 7 'bonkers 1))
+  (error? (bytevector-uint-set! $v1 0 7 'bonkers 2))
+  (error? (bytevector-uint-set! $v1 0 7 'bonkers 3))
+  (error? (bytevector-uint-set! $v1 0 7 'bonkers 4))
+  (error? (bytevector-uint-set! $v1 0 7 'bonkers 8))
+  (error? (if (bytevector-uint-set! $v1 0 7 'bonkers 35) #f #t))
+
+ ; invalid size
+  (error? (bytevector-uint-set! $v1 0 7 'little 0))
+  (error? (bytevector-uint-set! $v1 1 7 'big -1))
+  (error? (if (bytevector-uint-set! $v1 4 7 'little 'byte) #f #t))
+
+ ; constant args
+  (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+    (let ()
+      (define-syntax a
+        (lambda (x)
+          (define (sublist ls i j)
+            (list-head (list-tail ls i) j))
+          (define (cmp-vec ls i j)
+            (apply bytevector
+              `(,@(make-list i #xc7)
+                ,@(sublist ls i j)
+                ,@(make-list (fx- (length ls) (+ i j)) #xc7))))
+          (let* ([ls '(1 254 3) #;'(1 254 3 252 5 250 7 249 8 248
+                       9 247 10 246 40 216 80 176 100 156)]
+                 [n (length ls)])
+            #`(list #,@(let f ([i 0])
+                         (if (fx= i n)
+                           '()
+                           #`((list #,@(let g ([j 1])
+                                        (if (fx<= j (fx- n i))
+                                            #`((equal?
+                                                 (let ([v (make-bytevector #,n #xc7)])
+                                                   (bytevector-uint-set! v #,i
+                                                     #,(apply little-endian->unsigned (sublist ls i j))
+                                                     'little #,j)
+                                                   v)
+                                                 '#,(cmp-vec ls i j))
+                                               (equal?
+                                                 (let ([v (make-bytevector #,n #xc7)])
+                                                   (bytevector-uint-set! v #,i
+                                                     #,(apply big-endian->unsigned (sublist ls i j))
+                                                     'big #,j)
+                                                   v)
+                                                 '#,(cmp-vec ls i j))
+                                               #,@(g (fx+ j 1)))
+                                            '())))
+                              #,@(f (fx+ i 1)))))))))
+      a))
+
+ ; nonconstant args
+  (do ([i 100 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (map (lambda (x) (random 256)) (make-list (random 25)))])
+      (unless (andmap (lambda (b*) (andmap (lambda (b) (eq? b #t)) b*))
+                (let ()
+                  (define (sublist ls i j)
+                    (list-head (list-tail ls i) j))
+                  (define (cmp-vec ls i j)
+                    (apply bytevector
+                      `(,@(make-list i #xc7)
+                        ,@(sublist ls i j)
+                        ,@(make-list (fx- (length ls) (+ i j)) #xc7))))
+                  (let ([n (length ls)])
+                    (let f ([i 0])
+                      (if (fx= i n)
+                          '()
+                           (cons (let g ([j 1])
+                                   (if (fx<= j (fx- n i))
+                                       (cons*
+                                         (equal?
+                                           (let ([v (make-bytevector n #xc7)])
+                                             (bytevector-uint-set! v i
+                                               (apply little-endian->unsigned (sublist ls i j))
+                                               'little j)
+                                             v)
+                                           (cmp-vec ls i j))
+                                         (equal?
+                                           (let ([v (make-bytevector n #xc7)])
+                                             (bytevector-uint-set! v i
+                                               (apply big-endian->unsigned (sublist ls i j))
+                                               'big j)
+                                             v)
+                                           (cmp-vec ls i j))
+                                         (g (fx+ j 1)))
+                                       '()))
+                                 (f (fx+ i 1))))))))
+        (pretty-print ls)
+        (errorf #f "failed for for ~s" ls))))
+)
+
+(mat bytevector-copy
+ ; wrong argument count
+  (error? (bytevector-copy))
+  (error? (if (bytevector-copy #vu8() '#vu8()) #f #t))
+
+ ; not a bytevector
+  (error? (bytevector-copy '(a b c)))
+  (error? (if (bytevector-copy '(a b c)) #f #t))
+
+  (equal? (bytevector-copy #vu8()) '#vu8())
+  (equal? (bytevector-copy #vu8(3 252 5)) '#vu8(3 252 5))
+  (let* ([x1 (bytevector 1 2 3)] [x2 (bytevector-copy x1)])
+    (and (equal? x2 x1) (not (eq? x2 x1))))
+)
+
+(mat bytevector-copy!
+  (begin
+    (define $v1 (bytevector 1 2 3 4))
+    (define $v2 (bytevector 255 254 253 252 251 250 249 248 247))
+    (and (bytevector? $v1)
+         (bytevector? $v2)
+         (eqv? (bytevector-length $v1) 4)
+         (eqv? (bytevector-length $v2) 9)))
+
+ ; wrong number of arguments
+  (error? (bytevector-copy!))
+  (error? (bytevector-copy! $v2))
+  (error? (bytevector-copy! $v2 3))
+  (error? (bytevector-copy! $v2 3 $v1))
+  (error? (bytevector-copy! $v2 3 $v1 1))
+  (error? (if (bytevector-copy! $v2 3 $v1 1 2 3) #f #t))
+
+ ; not bytevector
+  (error? (bytevector-copy! 0 0 $v2 0 0))
+  (error? (if (bytevector-copy! $v1 0 (vector 1 2 3) 0 0) #f #t))
+
+ ; bad index
+  (error? (bytevector-copy! $v1 -1 $v2 0 0))
+  (error? (bytevector-copy! $v1 0 $v2 -1 0))
+  (error? (bytevector-copy! $v1 'a $v2 0 0))
+  (error? (bytevector-copy! $v1 0 $v2 0.0 0))
+  (error? (bytevector-copy! $v1 (+ (most-positive-fixnum) 1) $v2 0 0))
+  (error? (if (bytevector-copy! $v1 0 $v2 (+ (most-positive-fixnum) 1) 0) #f #t))
+
+ ; bad count
+  (error? (bytevector-copy! $v1 0 $v2 0 -1))
+  (error? (bytevector-copy! $v1 0 $v2 0 (+ (most-positive-fixnum) 1)))
+  (error? (if (bytevector-copy! $v1 0 $v2 0 'a) #f #t))
+
+ ; beyond end
+  (error? (bytevector-copy! $v1 0 $v2 0 5))
+  (error? (bytevector-copy! $v2 0 $v1 0 5))
+  (error? (bytevector-copy! $v1 1 $v2 0 4))
+  (error? (bytevector-copy! $v2 0 $v1 1 4))
+  (error? (bytevector-copy! $v1 2 $v2 0 3))
+  (error? (bytevector-copy! $v2 0 $v1 2 3))
+  (error? (bytevector-copy! $v1 3 $v2 0 2))
+  (error? (bytevector-copy! $v2 0 $v1 3 2))
+  (error? (bytevector-copy! $v1 4 $v2 0 1))
+  (error? (bytevector-copy! $v2 0 $v1 4 1))
+  (error? (bytevector-copy! $v2 0 $v1 0 500))
+  (error? (if (bytevector-copy! $v2 500 $v1 0 0) #f #t))
+
+ ; make sure no damage done
+  (and (bytevector? $v1)
+       (bytevector? $v2)
+       (equal? $v1 #vu8(1 2 3 4))
+       (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247)))
+
+  (begin
+    (bytevector-copy! $v2 3 $v1 1 2)
+    (and (equal? $v1 #vu8(1 252 251 4))
+         (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247))))
+  (begin
+    (bytevector-copy! $v2 6 $v1 2 2)
+    (and (equal? $v1 #vu8(1 252 249 248))
+         (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247))))
+  (begin
+    (bytevector-copy! $v2 0 $v1 4 0)
+    (and (equal? $v1 #vu8(1 252 249 248))
+         (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247))))
+  (begin
+    (bytevector-copy! $v2 3 $v1 4 0)
+    (and (equal? $v1 #vu8(1 252 249 248))
+         (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247))))
+  (begin
+    (bytevector-copy! $v2 3 $v2 4 0)
+    (and (equal? $v1 #vu8(1 252 249 248))
+         (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247))))
+  (begin
+    (bytevector-copy! $v2 2 $v1 1 3)
+    (and (equal? $v1 #vu8(1 253 252 251))
+         (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247))))
+  (begin
+    (bytevector-copy! $v1 0 $v2 3 4)
+    (and (equal? $v1 #vu8(1 253 252 251))
+         (equal? $v2 #vu8(255 254 253 1 253 252 251 248 247))))
+  (begin
+    (bytevector-copy! $v2 0 $v2 3 5)
+    (and (equal? $v1 #vu8(1 253 252 251))
+         (equal? $v2 #vu8(255 254 253 255 254 253 1 253 247))))
+  (begin
+    (bytevector-copy! $v2 4 $v2 2 5)
+    (and (equal? $v1 #vu8(1 253 252 251))
+         (equal? $v2 #vu8(255 254 254 253 1 253 247 253 247))))
+  (begin
+    (bytevector-copy! $v2 1 $v2 1 7)
+    (and (equal? $v1 #vu8(1 253 252 251))
+         (equal? $v2 #vu8(255 254 254 253 1 253 247 253 247))))
+)
+
+(mat bytevector-truncate!
+  (begin
+    (define $v (bytevector 1 2 3 4 5 6 7 8 9))
+    (and (bytevector? $v)
+         (fx= (bytevector-length $v) 9)
+         (bytevector=? $v #vu8(1 2 3 4 5 6 7 8 9))))
+
+ ; wrong number of arguments
+  (error? (bytevector-truncate!))
+  (error? (bytevector-truncate! $v))
+  (error? (bytevector-truncate! $v 3 15))
+
+ ; not bytevector
+  (error? (bytevector-truncate! 0 0))
+  (error? (if (bytevector-truncate! (string #\a #\b #\c) 2) #f #t))
+
+ ; bad length
+  (error? (bytevector-truncate! $v -1))
+  (error? (bytevector-truncate! $v 10))
+  (error? (bytevector-truncate! $v 1000))
+  (error? (bytevector-truncate! $v (+ (most-positive-fixnum) 1)))
+  (error? (bytevector-truncate! $v 'a))
+
+  (begin
+    (bytevector-truncate! $v 9)
+    (and (bytevector? $v)
+         (fx= (bytevector-length $v) 9)
+         (bytevector=? $v #vu8(1 2 3 4 5 6 7 8 9))))
+
+  (begin
+    (bytevector-truncate! $v 8)
+    (and (bytevector? $v)
+         (fx= (bytevector-length $v) 8)
+         (bytevector=? $v #vu8(1 2 3 4 5 6 7 8))))
+
+  (begin
+    (bytevector-truncate! $v 6)
+    (and (bytevector? $v)
+         (fx= (bytevector-length $v) 6)
+         (bytevector=? $v #vu8(1 2 3 4 5 6))))
+
+  (begin
+    (bytevector-truncate! $v 3)
+    (and (bytevector? $v)
+         (fx= (bytevector-length $v) 3)
+         (bytevector=? $v #vu8(1 2 3))))
+
+  (begin
+    (define $v2 (bytevector-truncate! $v 0))
+    (and (eqv? $v2 #vu8())
+         (bytevector? $v)
+         (fx= (bytevector-length $v) 3)
+         (bytevector=? $v #vu8(1 2 3))))
+)
+
+(mat bytevector-fill!
+  (begin
+    (define $v1 (bytevector 1 2 3 4))
+    (define $v2 (bytevector 255 254 253 252 251 250 249 248 247))
+    (and (bytevector? $v1)
+         (bytevector? $v2)
+         (eqv? (bytevector-length $v1) 4)
+         (eqv? (bytevector-length $v2) 9)))
+
+ ; wrong argument count
+  (error? (bytevector-fill!))
+  (error? (bytevector-fill! $v1))
+  (error? (begin (bytevector-fill! $v1 0 0) #f))
+
+ ; not a bytevector
+  (error? (bytevector-fill! 'a 3))
+  (error? (begin (let ([v (vector 1)]) (bytevector-fill! v 3)) #f))
+
+ ; invalid fill
+  (error? (bytevector-fill! $v1 -129))
+  (error? (bytevector-fill! $v1 256))
+  (error? (begin (bytevector-fill! $v1 'a) #f))
+
+ ; make sure no damage done
+  (and (bytevector? $v1)
+       (bytevector? $v2)
+       (equal? $v1 #vu8(1 2 3 4))
+       (equal? $v2 #vu8(255 254 253 252 251 250 249 248 247)))
+
+  (begin
+    (bytevector-fill! $v1 -128)
+    (and (bytevector? $v1)
+         (equal? $v1 #vu8(128 128 128 128))))
+  (begin
+    (bytevector-fill! $v1 -1)
+    (and (bytevector? $v1)
+         (equal? $v1 #vu8(255 255 255 255))))
+  (begin
+    (bytevector-fill! $v1 0)
+    (and (bytevector? $v1)
+         (equal? $v1 #vu8(0 0 0 0))))
+  (begin
+    (bytevector-fill! $v1 127)
+    (and (bytevector? $v1)
+         (equal? $v1 #vu8(127 127 127 127))))
+  (begin
+    (bytevector-fill! $v1 128)
+    (and (bytevector? $v1)
+         (equal? $v1 #vu8(128 128 128 128))))
+  (begin
+    (bytevector-fill! $v1 255)
+    (and (bytevector? $v1)
+         (equal? $v1 #vu8(255 255 255 255))))
+  (begin
+    (bytevector-fill! $v2 -128)
+    (and (bytevector? $v2)
+         (equal? $v2 #vu8(128 128 128 128 128 128 128 128 128))))
+  (begin
+    (bytevector-fill! $v2 -1)
+    (and (bytevector? $v2)
+         (equal? $v2 #vu8(255 255 255 255 255 255 255 255 255))))
+  (begin
+    (bytevector-fill! $v2 0)
+    (and (bytevector? $v2)
+         (equal? $v2 #vu8(0 0 0 0 0 0 0 0 0))))
+  (begin
+    (bytevector-fill! $v2 127)
+    (and (bytevector? $v2)
+         (equal? $v2 #vu8(127 127 127 127 127 127 127 127 127))))
+  (begin
+    (bytevector-fill! $v2 128)
+    (and (bytevector? $v2)
+         (equal? $v2 #vu8(128 128 128 128 128 128 128 128 128))))
+  (begin
+    (bytevector-fill! $v2 255)
+    (and (bytevector? $v2)
+         (equal? $v2 #vu8(255 255 255 255 255 255 255 255 255))))
+
+  (let ([v (bytevector-copy '#5vu8(1 2 3 4 5))])
+    (and (equal? v '#5vu8(1 2 3 4 5))
+         (begin
+           (bytevector-fill! v 9)
+           (equal? v '#5vu8(9)))))
+  (let ([v (bytevector-copy '#5vu8(1 2 3 4 5))])
+    (and (equal? v '#5vu8(1 2 3 4 5))
+         (begin
+           (bytevector-fill! v -17)
+           (equal? v '#5vu8(239)))))
+  (do ([q 10000 (fx- q 1)])
+      ((fx= q 0) #t)
+    (let ([v (bytevector 3 4 5)])
+      (do ([n -128 (fx+ n 1)])
+          ((fx= n 128) #t)
+        (bytevector-fill! v n)
+        (unless (and (eqv? (bytevector-s8-ref v 0) n)
+                     (eqv? (bytevector-s8-ref v 1) n)
+                     (eqv? (bytevector-s8-ref v 2) n))
+          (errorf #f "wrong value for ~s" n)))))
+  (do ([q 10000 (fx- q 1)])
+      ((fx= q 0) #t)
+    (let ([v (bytevector 3 4 5)])
+      (do ([n 0 (fx+ n 1)])
+          ((fx= n 255) #t)
+        (bytevector-fill! v n)
+        (unless (and (eqv? (bytevector-u8-ref v 0) n)
+                     (eqv? (bytevector-u8-ref v 1) n)
+                     (eqv? (bytevector-u8-ref v 2) n))
+          (errorf #f "wrong value for ~s" n)))))
+)
+
+(mat s8-list->bytevector
+ ; wrong argument count
+  (error? (s8-list->bytevector))
+  (error? (begin (s8-list->bytevector '(1 -2 3) '(1 -2 3)) #t))
+
+ ; not a list
+  (error? (s8-list->bytevector '#(a b c)))
+  (error? (begin (s8-list->bytevector '#(a b c)) #t))
+
+ ; improper or cyclic list
+  (error? (s8-list->bytevector '(1 2 . 3)))
+  (error? (s8-list->bytevector (let ([ls (list 1 2 3)]) (set-cdr! (cddr ls) (cdr ls)) ls)))
+
+ ; invalid value
+  (error? (s8-list->bytevector '(1 -129 3)))
+  (error? (begin (s8-list->bytevector '(1 128 3)) #t))
+
+  (equal? (s8-list->bytevector '(1 -2 3)) #vu8(1 254 3))
+  (equal? (s8-list->bytevector '()) #vu8())
+  (do ([n -128 (fx+ n 1)])
+      ((fx= n 128) #t)
+    (let ([v (s8-list->bytevector (list 3 n 4))])
+      (unless (and (eqv? (bytevector-s8-ref v 0) 3)
+                   (eqv? (bytevector-s8-ref v 1) n)
+                   (eqv? (bytevector-s8-ref v 2) 4))
+        (errorf #f "wrong value for ~s" n))))
+)
+
+(mat u8-list->bytevector
+ ; wrong argument count
+  (error? (u8-list->bytevector))
+  (error? (begin (u8-list->bytevector '(1 2 3) '(1 2 3)) #t))
+
+ ; not a bytevector
+  (error? (u8-list->bytevector '#(a b c)))
+  (error? (begin (u8-list->bytevector '#(a b c)) #t))
+
+ ; invalid value
+  (error? (u8-list->bytevector '(1 -129 3)))
+  (error? (begin (u8-list->bytevector '(1 -1 3)) #t))
+
+ ; improper or cyclic list
+  (error? (u8-list->bytevector '(1 2 . 3)))
+  (error? (u8-list->bytevector (let ([ls (list 1 2 3)]) (set-cdr! (cddr ls) (cdr ls)) ls)))
+
+  (equal? (u8-list->bytevector '(1 2 3)) #vu8(1 2 3))
+  (equal? (u8-list->bytevector '()) #vu8())
+  (do ([n 0 (fx+ n 1)])
+      ((fx= n 255) #t)
+    (let ([v (u8-list->bytevector (list 3 n 4))])
+      (unless (and (eqv? (bytevector-u8-ref v 0) 3)
+                   (eqv? (bytevector-u8-ref v 1) n)
+                   (eqv? (bytevector-u8-ref v 2) 4))
+        (errorf #f "wrong value for ~s" n))))
+)
+
+(mat bytevector->s8-list
+ ; wrong argument count
+  (error? (bytevector->s8-list))
+  (error? (begin (bytevector->s8-list #vu8(1 2 3) '#vu8(1 2 3)) #t))
+
+ ; not a bytevector
+  (error? (begin (bytevector->s8-list "hello") #t))
+  (error? (bytevector->s8-list '(a b c)))
+
+  (equal? (bytevector->s8-list #vu8(1 255 3)) '(1 -1 3))
+  (equal? (bytevector->s8-list #vu8(1 255 253 4)) '(1 -1 -3 4))
+  (equal? (bytevector->s8-list #vu8()) '())
+)
+
+(mat bytevector->u8-list
+ ; wrong argument count
+  (error? (bytevector->u8-list))
+  (error? (begin (bytevector->u8-list #vu8(1 2 3) '#vu8(1 2 3)) #t))
+
+ ; not a bytevector
+  (error? (bytevector->u8-list "hello"))
+  (error? (begin (bytevector->u8-list '(a b c)) #t))
+
+  (equal? (bytevector->u8-list #vu8(1 2 3)) '(1 2 3))
+  (equal? (bytevector->u8-list #vu8(1 255 253 4)) '(1 255 253 4))
+  (equal? (bytevector->u8-list #vu8()) '())
+)
+
+(mat sint-list->bytevector
+ ; wrong argument count
+  (error? (sint-list->bytevector))
+  (error? (sint-list->bytevector '(1 3 7) 'little))
+  (error? (begin (sint-list->bytevector '(1 -3 7) 'big 1 0) #t))
+
+ ; not a list
+  (error? (sint-list->bytevector '#(a b c) 'little 1))
+  (error? (begin (sint-list->bytevector '#(a b c) 'little 1) #t))
+
+ ; improper or cyclic list
+  (error? (sint-list->bytevector '(1 2 . 3) 'little 1))
+  (error? (sint-list->bytevector (let ([ls (list 1 2 3)]) (set-cdr! (cddr ls) (cdr ls)) ls) 'little 1))
+
+ ; invalid value
+  (error? (sint-list->bytevector '(0 #x-81 0) 'big 1))
+  (error? (sint-list->bytevector '(0 #x-81 0) 'little 1))
+  (error? (sint-list->bytevector '(0 #x80 0) (native-endianness) 1))
+  (error? (sint-list->bytevector '(0 #x80 0) 'little 1))
+  (error? (sint-list->bytevector '(0 #x-8001 0) (native-endianness) 2))
+  (error? (sint-list->bytevector '(0 #x-8001 0) 'little 2))
+  (error? (sint-list->bytevector '(0 #x8000 0) 'big 2))
+  (error? (sint-list->bytevector '(0 #x8000 0) 'little 2))
+  (error? (sint-list->bytevector '(0 #x-800001 0) 'big 3))
+  (error? (sint-list->bytevector '(0 #x-800001 0) 'little 3))
+  (error? (sint-list->bytevector '(0 #x800000 0) 'big 3))
+  (error? (sint-list->bytevector '(0 #x800000 0) (native-endianness) 3))
+  (error? (sint-list->bytevector '(0 #x-80000001 0) 'big 4))
+  (error? (sint-list->bytevector '(0 #x-80000001 0) 'little 4))
+  (error? (sint-list->bytevector '(0 #x80000000 0) (native-endianness) 4))
+  (error? (sint-list->bytevector '(0 #x80000000 0) 'little 4))
+  (error? (sint-list->bytevector '(0 #x-8000000000000001 0) 'big 8))
+  (error? (sint-list->bytevector '(0 #x-8000000000000001 0) (native-endianness) 8))
+  (error? (sint-list->bytevector '(0 #x8000000000000000 0) 'big 8))
+  (error? (sint-list->bytevector '(0 #x8000000000000000 0) 'little 8))
+  (error? (sint-list->bytevector '(0 #x-80000000000000000001 0) (native-endianness) 10))
+  (error? (sint-list->bytevector '(0 #x-80000000000000000001 0) 'little 10))
+  (error? (sint-list->bytevector '(0 #x80000000000000000000 0) 'big 10))
+  (error? (begin (sint-list->bytevector '(0 #x80000000000000000000 0) 'little 10) #t))
+
+ ; invalid endianness
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 1))
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 2))
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 3))
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 4))
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 6))
+  (error? (begin (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 12) #t))
+
+ ; invalid size
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big -1))
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big 0))
+  (error? (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big 1.0))
+  (error? (begin (sint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big "oops") #t))
+
+  (equal?
+    (sint-list->bytevector '(#x-1 #x01 #x02 #x-5 #x-80 #x7f) 'little 1)
+    #vu8(#xff #x01 #x02 #xfb #x80 #x7f))
+
+  (equal?
+    (sint-list->bytevector '(#x7f #x-80 -5 #x2 #x1 -1) 'big 1)
+    #vu8(#x7f #x80 #xfb #x2 #x1 #xff))
+
+  (equal?
+    (sint-list->bytevector '(#x-ff #x2FB #x-7f81) 'big 2)
+    #vu8(#xff #x01 #x02 #xfb #x80 #x7f))
+
+  (equal?
+    (sint-list->bytevector
+      (list (little-endian->signed #xff 1 3 #xa0)
+            (little-endian->signed #x71 #x82 #x95 #x61)
+            (little-endian->signed #x91 #xa2 #xb5 #xc1)
+            (little-endian->signed 5 2 3 4))
+      'little 4)
+    #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x61 #x91 #xa2 #xb5 #xc1 5 2 3 4))
+
+  (equal?
+    (sint-list->bytevector
+      (list (little-endian->signed #xff 1 3 #xa0 #x55)
+            (little-endian->signed #x71 #x82 #x95 #x61 #x85)
+            (little-endian->signed #x91 #xa2 #xb5 #xc1 #x99)
+            (little-endian->signed 5 2 3 4 6))
+      'little 5)
+    #vu8(#xff #x01 #x03 #xa0 #x55 #x71 #x82 #x95 #x61 #x85 #x91 #xa2 #xb5 #xc1 #x99 5 2 3 4 6))
+
+  (equal?
+    (sint-list->bytevector
+      (list (little-endian->signed #xff 1 3 #xa0 #x71 #x82 #x95 #x98)
+            (little-endian->signed #x91 #xa2 #xb5 #xc1 5 2 3 4))
+      'little 8)
+    #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x98 #x91 #xa2 #xb5 #xc1 5 2 3 4))
+
+  (do ([q 500 (fx- q 1)])
+      ((fx= q 0) #t)
+    (do ([i 1 (fx+ i 1)])
+        ((fx= i 25))
+      (let ([ls* (map (lambda (x) (map (lambda (x) (random 256)) (make-list i)))
+                      (make-list (random 10)))])
+        (unless (equal?
+                  (sint-list->bytevector (map (lambda (ls) (apply little-endian->signed ls)) ls*) 'little i)
+                  (apply bytevector (apply append ls*)))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (little)" ls*))
+        (unless (equal?
+                  (sint-list->bytevector (map (lambda (ls) (apply big-endian->signed ls)) ls*) 'big i)
+                  (apply bytevector (apply append ls*)))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (big)" ls*)))))
+)
+
+(mat uint-list->bytevector
+ ; wrong argument count
+  (error? (uint-list->bytevector))
+  (error? (uint-list->bytevector '(1 3 7) 'little))
+  (error? (begin (uint-list->bytevector '(1 -3 7) 'big 1 0) #t))
+
+ ; not a list
+  (error? (uint-list->bytevector '#(a b c) 'little 1))
+  (error? (begin (uint-list->bytevector '#(a b c) 'little 1) #t))
+
+ ; improper or cyclic list
+  (error? (uint-list->bytevector '(1 2 . 3) 'little 1))
+  (error? (uint-list->bytevector (let ([ls (list 1 2 3)]) (set-cdr! (cddr ls) (cdr ls)) ls) 'little 1))
+
+ ; invalid value
+  (error? (uint-list->bytevector '(0 #x-1 0) 'big 1))
+  (error? (uint-list->bytevector '(0 #x-1 0) 'little 1))
+  (error? (uint-list->bytevector '(0 #x100 0) (native-endianness) 1))
+  (error? (uint-list->bytevector '(0 #x100 0) 'little 1))
+  (error? (uint-list->bytevector '(0 x-1 0) (native-endianness) 2))
+  (error? (uint-list->bytevector '(0 x-1 0) 'little 2))
+  (error? (uint-list->bytevector '(0 #x10000 0) 'big 2))
+  (error? (uint-list->bytevector '(0 #x10000 0) 'little 2))
+  (error? (uint-list->bytevector '(0 x-1 0) 'big 3))
+  (error? (uint-list->bytevector '(0 x-1 0) 'little 3))
+  (error? (uint-list->bytevector '(0 #x1000000 0) 'big 3))
+  (error? (uint-list->bytevector '(0 #x1000000 0) (native-endianness) 3))
+  (error? (uint-list->bytevector '(0 x-1 0) 'big 4))
+  (error? (uint-list->bytevector '(0 x-1 0) 'little 4))
+  (error? (uint-list->bytevector '(0 #x100000000 0) (native-endianness) 4))
+  (error? (uint-list->bytevector '(0 #x100000000 0) 'little 4))
+  (error? (uint-list->bytevector '(0 x-1 0) 'big 8))
+  (error? (uint-list->bytevector '(0 x-1 0) (native-endianness) 8))
+  (error? (uint-list->bytevector '(0 #x10000000000000000 0) 'big 8))
+  (error? (uint-list->bytevector '(0 #x10000000000000000 0) 'little 8))
+  (error? (uint-list->bytevector '(0 x-1 0) (native-endianness) 10))
+  (error? (uint-list->bytevector '(0 x-1 0) 'little 10))
+  (error? (uint-list->bytevector '(0 #x100000000000000000000 0) 'big 10))
+  (error? (begin (uint-list->bytevector '(0 #x100000000000000000000 0) 'little 10) #t))
+
+ ; invalid endianness
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 1))
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 2))
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 3))
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 4))
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 6))
+  (error? (begin (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'spam 12) #t))
+
+ ; invalid size
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big -1))
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big 0))
+  (error? (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big 1.0))
+  (error? (begin (uint-list->bytevector '(1 3 7 4 3 -3 5 -6 127 -128 -50 50) 'big "oops") #t))
+
+  (equal?
+    (uint-list->bytevector '(#xff #x01 #x02 #xfb #x80 #x7f) 'little 1)
+    #vu8(#xff #x01 #x02 #xfb #x80 #x7f))
+
+  (equal?
+    (uint-list->bytevector '(#x7f #x80 #xfb #x2 #x1 #xff) 'big 1)
+    #vu8(#x7f #x80 #xfb #x2 #x1 #xff))
+
+  (equal?
+    (uint-list->bytevector '(#xff01 #x2FB #x807f) 'big 2)
+    #vu8(#xff #x01 #x02 #xfb #x80 #x7f))
+
+  (equal?
+    (uint-list->bytevector
+      (list (little-endian->unsigned #xff 1 3 #xa0)
+            (little-endian->unsigned #x71 #x82 #x95 #x61)
+            (little-endian->unsigned #x91 #xa2 #xb5 #xc1)
+            (little-endian->unsigned 5 2 3 4))
+      'little 4)
+    #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x61 #x91 #xa2 #xb5 #xc1 5 2 3 4))
+
+  (equal?
+    (uint-list->bytevector
+      (list (little-endian->unsigned #xff 1 3 #xa0 #x55)
+            (little-endian->unsigned #x71 #x82 #x95 #x61 #x85)
+            (little-endian->unsigned #x91 #xa2 #xb5 #xc1 #x99)
+            (little-endian->unsigned 5 2 3 4 6))
+      'little 5)
+    #vu8(#xff #x01 #x03 #xa0 #x55 #x71 #x82 #x95 #x61 #x85 #x91 #xa2 #xb5 #xc1 #x99 5 2 3 4 6))
+
+  (equal?
+    (uint-list->bytevector
+      (list (little-endian->unsigned #xff 1 3 #xa0 #x71 #x82 #x95 #x98)
+            (little-endian->unsigned #x91 #xa2 #xb5 #xc1 5 2 3 4))
+      'little 8)
+    #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x98 #x91 #xa2 #xb5 #xc1 5 2 3 4))
+
+  (do ([q 500 (fx- q 1)])
+      ((fx= q 0) #t)
+    (do ([i 1 (fx+ i 1)])
+        ((fx= i 25))
+      (let ([ls* (map (lambda (x) (map (lambda (x) (random 256)) (make-list i)))
+                      (make-list (random 10)))])
+        (unless (equal?
+                  (uint-list->bytevector (map (lambda (ls) (apply little-endian->unsigned ls)) ls*) 'little i)
+                  (apply bytevector (apply append ls*)))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (little)" ls*))
+        (unless (equal?
+                  (uint-list->bytevector (map (lambda (ls) (apply big-endian->unsigned ls)) ls*) 'big i)
+                  (apply bytevector (apply append ls*)))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (big)" ls*)))))
+)
+
+(mat bytevector->sint-list
+ ; wrong argument count
+  (error? (bytevector->sint-list))
+  (error? (bytevector->sint-list #vu8(1 3 7) 'little))
+  (error? (begin (bytevector->sint-list #vu8(1 253 7) 'big 1 0) #t))
+
+ ; not a bytevector
+  (error? (bytevector->sint-list '#(a b c) 'little 1))
+  (error? (begin (bytevector->sint-list '#(a b c) 'little 1) #t))
+
+ ; invalid endianness
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 1))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 2))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 3))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 4))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 6))
+  (error? (begin (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 12) #t))
+
+ ; invalid size
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big -1))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 0))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 1.0))
+  (error? (begin (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big "oops") #t))
+
+ ; length not multiple of size
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 5))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'little 7))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 8))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) (native-endianness) 9))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 10))
+  (error? (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'little 11))
+  (error? (begin (bytevector->sint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) (native-endianness) 50) #t))
+
+  (equal?
+    (bytevector->sint-list #vu8(#xff #x01 #x02 #xfb #x80 #x7f) 'little 1)
+    '(#x-1 #x01 #x02 #x-5 #x-80 #x7f))
+
+  (equal?
+    (bytevector->sint-list #vu8(#x7f #x80 #xfb #x2 #x1 #xff) 'big 1)
+    '(#x7f #x-80 -5 #x2 #x1 -1))
+
+  (equal?
+    (bytevector->sint-list #vu8(#xff #x01 #x02 #xfb #x80 #x7f) 'big 2)
+    '(#x-ff #x2FB #x-7f81))
+
+  (equal?
+    (bytevector->sint-list
+      #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x61 #x91 #xa2 #xb5 #xc1 5 2 3 4)
+      'little 4)
+    (list (little-endian->signed #xff 1 3 #xa0)
+          (little-endian->signed #x71 #x82 #x95 #x61)
+          (little-endian->signed #x91 #xa2 #xb5 #xc1)
+          (little-endian->signed 5 2 3 4)))
+
+  (equal?
+    (bytevector->sint-list
+      #vu8(#xff #x01 #x03 #xa0 #x55 #x71 #x82 #x95 #x61 #x85 #x91 #xa2 #xb5 #xc1 #x99 5 2 3 4 6)
+      'little 5)
+    (list (little-endian->signed #xff 1 3 #xa0 #x55)
+          (little-endian->signed #x71 #x82 #x95 #x61 #x85)
+          (little-endian->signed #x91 #xa2 #xb5 #xc1 #x99)
+          (little-endian->signed 5 2 3 4 6)))
+
+  (equal?
+    (bytevector->sint-list
+      #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x98 #x91 #xa2 #xb5 #xc1 5 2 3 4)
+      'little 8)
+    (list (little-endian->signed #xff 1 3 #xa0 #x71 #x82 #x95 #x98)
+          (little-endian->signed #x91 #xa2 #xb5 #xc1 5 2 3 4)))
+
+  (do ([q 500 (fx- q 1)])
+      ((fx= q 0) #t)
+    (do ([i 1 (fx+ i 1)])
+        ((fx= i 25))
+      (let ([ls* (map (lambda (x) (map (lambda (x) (random 256)) (make-list i)))
+                      (make-list (random 10)))])
+        (unless (equal?
+                  (bytevector->sint-list (apply bytevector (apply append ls*)) 'little i)
+                  (map (lambda (ls) (apply little-endian->signed ls)) ls*))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (little)" ls*))
+        (unless (equal?
+                  (bytevector->sint-list (apply bytevector (apply append ls*)) 'big i)
+                  (map (lambda (ls) (apply big-endian->signed ls)) ls*))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (big)" ls*)))))
+)
+
+(mat bytevector->uint-list
+ ; wrong argument count
+  (error? (bytevector->uint-list))
+  (error? (bytevector->uint-list #vu8(1 3 7) 'little))
+  (error? (begin (bytevector->uint-list #vu8(1 253 7) 'big 1 0) #t))
+
+ ; not a bytevector
+  (error? (bytevector->uint-list '#(a b c) 'little 1))
+  (error? (begin (bytevector->uint-list '#(a b c) 'little 1) #t))
+
+ ; invalid endianness
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 1))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 2))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 3))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 4))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 6))
+  (error? (begin (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'spam 12) #t))
+
+ ; invalid size
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big -1))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 0))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 1.0))
+  (error? (begin (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big "oops") #t))
+
+ ; length not multiple of size
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 5))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'little 7))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 8))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) (native-endianness) 9))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'big 10))
+  (error? (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) 'little 11))
+  (error? (begin (bytevector->uint-list #vu8(1 3 7 4 3 253 5 250 127 128 206 50) (native-endianness) 50) #t))
+
+  (equal?
+    (bytevector->uint-list #vu8(#xff #x01 #x02 #xfb #x80 #x7f) 'little 1)
+    '(#xff #x01 #x02 #xfb #x80 #x7f))
+
+  (equal?
+    (bytevector->uint-list #vu8(#x7f #x80 #xfb #x2 #x1 #xff) 'big 1)
+    '(#x7f #x80 #xfb #x2 #x1 #xff))
+
+  (equal?
+    (bytevector->uint-list #vu8(#xff #x01 #x02 #xfb #x80 #x7f) 'big 2)
+    '(#xff01 #x2FB #x807f))
+
+  (equal?
+    (bytevector->uint-list
+      #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x61 #x91 #xa2 #xb5 #xc1 5 2 3 4)
+      'little 4)
+    (list (little-endian->unsigned #xff 1 3 #xa0)
+          (little-endian->unsigned #x71 #x82 #x95 #x61)
+          (little-endian->unsigned #x91 #xa2 #xb5 #xc1)
+          (little-endian->unsigned 5 2 3 4)))
+
+  (equal?
+    (bytevector->uint-list
+      #vu8(#xff #x01 #x03 #xa0 #x55 #x71 #x82 #x95 #x61 #x85 #x91 #xa2 #xb5 #xc1 #x99 5 2 3 4 6)
+      'little 5)
+    (list (little-endian->unsigned #xff 1 3 #xa0 #x55)
+          (little-endian->unsigned #x71 #x82 #x95 #x61 #x85)
+          (little-endian->unsigned #x91 #xa2 #xb5 #xc1 #x99)
+          (little-endian->unsigned 5 2 3 4 6)))
+
+  (equal?
+    (bytevector->uint-list
+      #vu8(#xff #x01 #x03 #xa0 #x71 #x82 #x95 #x98 #x91 #xa2 #xb5 #xc1 5 2 3 4)
+      'little 8)
+    (list (little-endian->unsigned #xff 1 3 #xa0 #x71 #x82 #x95 #x98)
+          (little-endian->unsigned #x91 #xa2 #xb5 #xc1 5 2 3 4)))
+
+  (do ([q 500 (fx- q 1)])
+      ((fx= q 0) #t)
+    (do ([i 1 (fx+ i 1)])
+        ((fx= i 25))
+      (let ([ls* (map (lambda (x) (map (lambda (x) (random 256)) (make-list i)))
+                      (make-list (random 10)))])
+        (unless (equal?
+                  (bytevector->uint-list (apply bytevector (apply append ls*)) 'little i)
+                  (map (lambda (ls) (apply little-endian->unsigned ls)) ls*))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (little)" ls*))
+        (unless (equal?
+                  (bytevector->uint-list (apply bytevector (apply append ls*)) 'big i)
+                  (map (lambda (ls) (apply big-endian->unsigned ls)) ls*))
+          (pretty-print ls*)
+          (errorf #f "failed for ~s (big)" ls*)))))
+)
+
+(mat bytevector=?
+ ; wrong argument count
+  (error? (bytevector=?))
+  (error? (bytevector=? #vu8()))
+  (error? (begin (bytevector=? #vu8() '#vu8() '#vu8()) #t))
+
+ ; not a bytevector
+  (error? (bytevector=? #vu8() 'a))
+  (error? (begin (bytevector=? "a" #vu8()) #t))
+
+  (bytevector=? #vu8() (bytevector))
+  (bytevector=? #vu8() (make-bytevector 0))
+  (bytevector=? #vu8() (make-bytevector 0 17))
+  (bytevector=? #vu8() (make-bytevector 0 -17))
+  (not (bytevector=? #vu8() (bytevector 1)))
+  (not (bytevector=? #vu8() (make-bytevector 1)))
+  (not (bytevector=? #vu8() (make-bytevector 1 17)))
+  (not (bytevector=? #vu8() (make-bytevector 1 -17)))
+  (bytevector=? #vu8(1 2 3 4) (bytevector 1 2 3 4))
+  (not (bytevector=? #vu8(1 2 3 4) (bytevector 1 2 4 3)))
+  (not (bytevector=? #vu8(1 2 3 4) (bytevector 1 2 3)))
+  (not (bytevector=? #vu8(1 2 3 4) (bytevector 1 2)))
+  (not (bytevector=? #vu8(1 2 3 4) (bytevector 1)))
+  (not (bytevector=? #vu8(1 2 3 4) (bytevector)))
+  (bytevector=? (bytevector 255 254 253) (bytevector -1 -2 -3))
+  (do ([n 1 (fx+ n 1)])
+      ((fx= n 1000) #t)
+    (let* ([v1 (u8-list->bytevector
+                 (map (lambda (x) (random 256)) (make-list n)))]
+           [v2 (bytevector-copy v1)])
+      (when (eq? v1 v2) (errorf #f "copy is eq to original"))
+      (unless (bytevector=? v1 v2)
+        (pretty-print v1)
+        (errorf #f "first bytevector=? failed for ~s (see output for vector)" n))
+      (do ([i 0 (fx+ i 1)])
+          ((fx= i n))
+        (let ([k (bytevector-u8-ref v2 i)])
+          (bytevector-u8-set! v2 i (fxmodulo (fx+ k 1) 256))
+          (when (bytevector=? v1 v2)
+            (pretty-print v1)
+            (pretty-print v2)
+            (errorf #f "second bytevector=? failed for n=~s and i=~s (see output for vector)" n i))
+          (bytevector-u8-set! v2 i k))
+        (unless (bytevector=? v1 v2)
+          (pretty-print v1)
+          (errorf #f "third bytevector=? failed for n=~s and i=~s (see output for vector)" n i)))))
+)
+
+(mat r6rs-bytevector-examples
+  (equal?
+    (let ([b (u8-list->bytevector '(1 2 3 4 5 6 7 8))])
+      (bytevector-copy! b 0 b 3 4)
+      (bytevector->u8-list b))
+    '(1 2 3 1 2 3 4 8))
+
+
+  (equal?
+    (let ([b1 (make-bytevector 16 -127)]
+          [b2 (make-bytevector 16 255)])
+      (list
+        (bytevector-s8-ref b1 0)
+        (bytevector-u8-ref b1 0)
+        (bytevector-s8-ref b2 0)
+        (bytevector-u8-ref b2 0)))
+    '(-127 129 -1 255))
+
+  (equal?
+    (let ([b (make-bytevector 16 -127)])
+      (bytevector-s8-set! b 0 -126)
+      (bytevector-u8-set! b 1 246)
+      (list
+        (bytevector-s8-ref b 0)
+        (bytevector-u8-ref b 0)
+        (bytevector-s8-ref b 1)
+        (bytevector-u8-ref b 1)))
+    '(-126 130 -10 246))
+
+  (begin
+    (define $bv (make-bytevector 16 -127))
+    (bytevector? $bv))
+
+  (eqv?
+    (begin
+      (bytevector-uint-set! $bv 0 (- (expt 2 128) 3)
+        (endianness little) 16)
+      (bytevector-uint-ref $bv 0 (endianness little) 16))
+    #xfffffffffffffffffffffffffffffffd)
+
+  (eqv? (bytevector-sint-ref $bv 0 (endianness little) 16) -3)
+
+  (equal?
+    (bytevector->u8-list $bv)
+    '(253 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255))
+
+  (eqv?
+    (begin
+      (bytevector-uint-set! $bv 0 (- (expt 2 128) 3)
+        (endianness big) 16)
+      (bytevector-uint-ref $bv 0 (endianness big) 16))
+    #xfffffffffffffffffffffffffffffffd)
+
+  (eqv? (bytevector-sint-ref $bv 0 (endianness big) 16) -3)
+
+  (equal?
+    (bytevector->u8-list $bv)
+    '(255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 253))
+
+  (equal?
+    (let ([b (u8-list->bytevector '(1 2 3 255 1 2 1 2))])
+      (bytevector->sint-list b (endianness little) 2))
+    '(513 -253 513 513))
+
+  (equal?
+    (let ([b (u8-list->bytevector '(1 2 3 255 1 2 1 2))])
+      (bytevector->uint-list b (endianness little) 2))
+    '(513 65283 513 513))
+
+  (begin
+    (define $bv
+      (u8-list->bytevector
+        '(255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 253)))
+    (bytevector? $bv))
+
+  (eqv? (bytevector-u16-ref $bv 14 (endianness little)) 65023)
+  (eqv? (bytevector-s16-ref $bv 14 (endianness little)) -513)
+  (eqv? (bytevector-u16-ref $bv 14 (endianness big)) 65533)
+  (eqv? (bytevector-s16-ref $bv 14 (endianness big)) -3)
+
+  (eqv?
+    (begin
+      (bytevector-u16-set! $bv 0 12345 (endianness little))
+      (bytevector-u16-ref $bv 0 (endianness little)))
+    12345)
+
+  (eqv?
+    (begin
+      (bytevector-u16-native-set! $bv 0 12345)
+      (bytevector-u16-native-ref $bv 0))
+    12345)
+
+  (and (memv (bytevector-u16-ref $bv 0 (endianness little)) '(12345 14640)) #t)
+
+  (begin
+    (define $bv
+      (u8-list->bytevector
+        '(255 255 255 255 255 255 255 255
+          255 255 255 255 255 255 255 253)))
+    (bytevector? $bv))
+
+  (eqv? (bytevector-u32-ref $bv 12 (endianness little)) 4261412863)
+  (eqv? (bytevector-s32-ref $bv 12 (endianness little)) -33554433)
+  (eqv? (bytevector-u32-ref $bv 12 (endianness big)) 4294967293)
+  (eqv? (bytevector-s32-ref $bv 12 (endianness big)) -3)
+
+  (begin
+    (define $bv
+      (u8-list->bytevector
+        '(255 255 255 255 255 255 255 255
+          255 255 255 255 255 255 255 253)))
+    (bytevector? $bv))
+
+  (eqv? (bytevector-u64-ref $bv 8 (endianness little)) '18302628885633695743)
+  (eqv? (bytevector-s64-ref $bv 8 (endianness little)) '-144115188075855873)
+  (eqv? (bytevector-u64-ref $bv 8 (endianness big)) '18446744073709551613)
+  (eqv? (bytevector-s64-ref $bv 8 (endianness big)) '-3)
+)
+
+(mat refimpl-tests
+  ; rkd: the following tests are adapted from the bytevector reference
+  ; implementation tests bytevector-tests.sch, which is:
+  
+  ; Copyright 2007 William D Clinger.
+  ;
+  ; Permission to copy this software, in whole or in part, to use this
+  ; software for any lawful purpose, and to redistribute this software
+  ; is granted subject to the restriction that all copies made of this
+  ; software must include this copyright notice in full.
+  ;
+  ; I also request that you send me a copy of any improvements that you
+  ; make to this software so that they may be incorporated within it to
+  ; the benefit of the Scheme community.
+
+  ; rkd: commented out some tests (look for "rkd") because they are
+  ; implementation-dependent or require non-R6RS functionality or behavior.
+  (begin
+    ; rkd: writing code to a file first to get useful file positions for errors
+    (with-output-to-file "testfile-bytevector.ss"
+      (lambda ()
+        (pretty-print '
+          (define (bytevector-refimpl-tests)
+            (define *random-stress-tests* 100)
+            (define *random-stress-test-max-size* 50)
+
+            ; rkd: rewrote to support for our test infrastructure
+            (define okay? #t)
+            (define-syntax test
+              (syntax-rules (=> error)
+                ((test exp => result)
+                 (guard (c [#t (display-condition c) (newline) (set! okay? #f)])
+                   (unless (equal? exp 'result) (syntax-error #'exp "failed"))))))
+
+            (define (basic-bytevector-tests)
+              (test (endianness big) => big)
+              (test (endianness little) => little)
+
+              (test (or (eq? (native-endianness) 'big)
+                        (eq? (native-endianness) 'little)) => #t)
+
+              (test (bytevector? (vector)) => #f)
+              (test (bytevector? (make-bytevector 3)) => #t)
+
+              (test (bytevector-length (make-bytevector 44)) => 44)
+
+              (test (let ((b1 (make-bytevector 16 -127))
+                          (b2 (make-bytevector 16 255)))
+                      (list
+                        (bytevector-s8-ref b1 0)
+                        (bytevector-u8-ref b1 0)
+                        (bytevector-s8-ref b2 0)
+                        (bytevector-u8-ref b2 0))) => (-127 129 -1 255))
+
+              (test (let ((b (make-bytevector 16 -127)))
+                      (bytevector-s8-set! b 0 -126)
+                      (bytevector-u8-set! b 1 246)
+                      (list
+                        (bytevector-s8-ref b 0)
+                        (bytevector-u8-ref b 0)
+                        (bytevector-s8-ref b 1)
+                        (bytevector-u8-ref b 1))) => (-126 130 -10 246))
+
+              (let ()
+                (define b (make-bytevector 16 -127))
+                (bytevector-uint-set! b 0 (- (expt 2 128) 3) (endianness little) 16)
+
+                (test (bytevector-uint-ref b 0 (endianness little) 16)
+                  => #xfffffffffffffffffffffffffffffffd)
+
+                (test (bytevector-sint-ref b 0 (endianness little) 16) => -3)
+
+                (test (bytevector->u8-list b)
+                  => (253 255 255 255 255 255 255 255
+                       255 255 255 255 255 255 255 255))
+
+                (bytevector-uint-set! b 0 (- (expt 2 128) 3) (endianness big) 16)
+
+                (test (bytevector-uint-ref b 0 (endianness big) 16)
+                  => #xfffffffffffffffffffffffffffffffd)
+
+                (test (bytevector-sint-ref b 0 (endianness big) 16) => -3)
+
+                (test (bytevector->u8-list b)
+                  => (255 255 255 255 255 255 255 255
+                       255 255 255 255 255 255 255 253)))
+
+              (let ()
+                (define b
+                  (u8-list->bytevector
+                    '(255 255 255 255 255 255 255 255
+                       255 255 255 255 255 255 255 253)))
+
+                (test (bytevector-u16-ref b 14 (endianness little)) => 65023)
+
+                (test (bytevector-s16-ref b 14 (endianness little)) => -513)
+
+                (test (bytevector-u16-ref b 14 (endianness big)) => 65533)
+
+                (test (bytevector-s16-ref b 14 (endianness big)) => -3)
+
+                (bytevector-u16-set! b 0 12345 (endianness little))
+
+                (test (bytevector-u16-ref b 0 (endianness little)) => 12345)
+
+                (bytevector-u16-native-set! b 0 12345)
+
+                (test (bytevector-u16-native-ref b 0) => 12345))
+
+              (let ()
+                (define b
+                  (u8-list->bytevector
+                    '(255 255 255 255 255 255 255 255
+                       255 255 255 255 255 255 255 253)))
+
+                (test (bytevector-u32-ref b 12 (endianness little)) => 4261412863)
+
+                (test (bytevector-s32-ref b 12 (endianness little)) => -33554433)
+
+                (test (bytevector-u32-ref b 12 (endianness big)) => 4294967293)
+
+                (test (bytevector-s32-ref b 12 (endianness big)) => -3))
+
+              (let ()
+                (define b
+                  (u8-list->bytevector
+                    '(255 255 255 255 255 255 255 255
+                       255 255 255 255 255 255 255 253)))
+
+                (test (bytevector-u64-ref b 8 (endianness little))
+                  => 18302628885633695743)
+
+                (test (bytevector-s64-ref b 8 (endianness little))
+                  => -144115188075855873)
+
+                (test (bytevector-u64-ref b 8 (endianness big))
+                  => 18446744073709551613)
+
+                (test (bytevector-s64-ref b 8 (endianness big)) => -3))
+
+              (let ()
+                (define b1 (u8-list->bytevector '(255 2 254 3 255)))
+                (define b2 (u8-list->bytevector '(255 3 254 2 255)))
+                (define b3 (u8-list->bytevector '(255 3 254 2 255)))
+                (define b4 (u8-list->bytevector '(255 3 255)))
+
+                (test (bytevector=? b1 b2) => #f)
+                (test (bytevector=? b2 b3) => #t)
+                (test (bytevector=? b3 b4) => #f)
+                (test (bytevector=? b4 b3) => #f))
+
+              (let ()
+                (define b
+                  (u8-list->bytevector
+                    '(63 240 0 0 0 0 0 0)))
+
+                (test (bytevector-ieee-single-ref b 4 'little) => 0.0)
+
+                (test (bytevector-ieee-double-ref b 0 'big) => 1.0)
+
+                (bytevector-ieee-single-native-set! b 4 3.0)
+
+                (test (bytevector-ieee-single-native-ref b 4) => 3.0)
+
+                (bytevector-ieee-double-native-set! b 0 5.0)
+
+                (test (bytevector-ieee-double-native-ref b 0) => 5.0)
+
+                (bytevector-ieee-double-set! b 0 1.75 'big)
+
+                (test (bytevector->u8-list b) => (63 252 0 0 0 0 0 0)))
+
+              (let ((b (make-bytevector 7 12)))
+                (bytevector-fill! b 127)
+                (test (bytevector->u8-list b) => (127 127 127 127 127 127 127)))
+
+              (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))
+                (bytevector-copy! b 0 b 3 4)
+                (test (bytevector->u8-list b) => (1 2 3 1 2 3 4 8))
+                (test (bytevector=? b (bytevector-copy b)) => #t))
+
+              (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+                (test (bytevector->sint-list b (endianness little) 2)
+                  => (513 -253 513 513))
+                (test (bytevector->uint-list b (endianness little) 2)
+                  => (513 65283 513 513))))
+
+            (define (ieee-bytevector-tests)
+
+              (define (roundtrip x getter setter! k endness)
+                (let ((b (make-bytevector 100)))
+                  (setter! b k x endness)
+                  (getter b k endness)))
+
+              (define (->single x)
+                (roundtrip
+                  x bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'big))
+
+              (define (->double x)
+                (roundtrip
+                  x bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'big))
+
+              ; Single precision, offset 0, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               0 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'big)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 0, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               0 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 0 'little)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 1, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               1 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'big)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 1, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               1 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 1 'little)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 2, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               2 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'big)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 2, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               2 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 2 'little)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 3, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               3 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'big)
+                => -0.2822580337524414)
+
+              ; Single precision, offset 3, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-single-ref bytevector-ieee-single-set!
+                               3 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-single-ref bytevector-ieee-single-set! 3 'little)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 0, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               0 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'big)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 0, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               0 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 0 'little)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 1, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               1 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'big)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 1, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               1 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 1 'little)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 2, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               2 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'big)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 2, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               2 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 2 'little)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 3, big-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'big)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'big)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               3 'big)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'big)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'big)
+                => -0.2822580337524414)
+
+              ; Double precision, offset 3, little-endian
+
+              (test (roundtrip
+                      +inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'little)
+                => +inf.0)
+
+              (test (roundtrip
+                      -inf.0
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'little)
+                => -inf.0)
+
+              (test (let ((x (roundtrip
+                               +nan.0
+                               bytevector-ieee-double-ref bytevector-ieee-double-set!
+                               3 'little)))
+                      (= x x))
+                => #f)
+
+              (test (roundtrip
+                      1e10
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'little)
+                => 1e10)
+
+              (test (roundtrip
+                      -0.2822580337524414
+                      bytevector-ieee-double-ref bytevector-ieee-double-set! 3 'little)
+                => -0.2822580337524414)
+
+              ; Denormalized numbers.
+
+              (do ((x (expt .5 100) (* .5 x)))
+                ((= x 0.0))
+                (let ((y (->single x)))
+                  (test (or (= y 0.0) (= x y)) => #t)))
+
+              (do ((x (expt .5 100) (* .5 x)))
+                ((= x 0.0))
+                (let ((y (->double x)))
+                  (test (= x y) => #t))))
+
+            (define (string-bytevector-tests)
+
+              ; rkd: rewrote to support for our test infrastructure
+              (define-syntax test-roundtrip
+                (syntax-rules ()
+                  [(_ bvec tostring tobvec)
+                   (let* ((s1 (tostring bvec))
+                          (b2 (tobvec s1))
+                          (s2 (tostring b2)))
+                     (test (string=? s1 s2) => #t))]))
+
+              (define random
+                (letrec ((random14
+                           (lambda (n)
+                             (set! x (remainder (+ (* a x) c) (+ m 1)))
+                             (remainder (quotient x 8) n)))
+                         (a 701)
+                         (x 1)
+                         (c 743483)
+                         (m 524287)
+                         (loop
+                           (lambda (q r n)
+                             (if (zero? q)
+                                 (remainder r n)
+                                 (loop (quotient q 16384)
+                                   (+ (* 16384 r) (random14 16384))
+                                   n)))))
+                  (lambda (n)
+                    (if (< n 16384)
+                        (random14 n)
+                        (loop (quotient n 16384) (random14 16384) n)))))
+
+              ; Returns a random bytevector of length up to n.
+
+              (define (random-bytevector n)
+                (let* ((n (random n))
+                       (bv (make-bytevector n)))
+                  (do ((i 0 (+ i 1)))
+                    ((= i n) bv)
+                    (bytevector-u8-set! bv i (random 256)))))
+
+              ; Returns a random bytevector of even length up to n.
+
+              (define (random-bytevector2 n)
+                (let* ((n (random n))
+                       (n (if (odd? n) (+ n 1) n))
+                       (bv (make-bytevector n)))
+                  (do ((i 0 (+ i 1)))
+                    ((= i n) bv)
+                    (bytevector-u8-set! bv i (random 256)))))
+
+              ; Returns a random bytevector of multiple-of-4 length up to n.
+
+              (define (random-bytevector4 n)
+                (let* ((n (random n))
+                       (n (* 4 (round (/ n 4))))
+                       (bv (make-bytevector n)))
+                  (do ((i 0 (+ i 1)))
+                    ((= i n) bv)
+                    (bytevector-u8-set! bv i (random 256)))))
+
+              (test (bytevector=? (string->utf8 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
+                      '#vu8(#x6b
+                             #x7f
+                             #b11000010 #b10000000
+                             #b11011111 #b10111111
+                             #b11100000 #b10100000 #b10000000
+                             #b11101111 #b10111111 #b10111111))
+                => #t)
+
+              (test (bytevector=? (string->utf8 "\x010000;\x10ffff;")
+                      '#vu8(#b11110000 #b10010000 #b10000000 #b10000000
+                             #b11110100 #b10001111 #b10111111 #b10111111))
+                => #t)
+
+              (test (string=? (utf8->string '#vu8(#x61                             ; a
+                                                   #xc0 #x62                        ; ?b
+                                                   #xc1 #x63                        ; ?c
+                                                   #xc2 #x64                        ; ?d
+                                                   #x80 #x65                        ; ?e
+                                                   #xc0 #xc0 #x66                   ; ??f
+                                                   #xe0 #x67                        ; ?g
+                                                   ))
+                      "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e\xfffd;\xfffd;f\xfffd;g")
+                => #t)
+
+              #; ; rkd: implementation dependent number of replacement characters
+              (test (string=? (utf8->string '#vu8(#xe0 #x80 #x80 #x68              ; ???h
+                                                   #xe0 #xc0 #x80 #x69              ; ???i
+                                                   #xf0 #x6a                        ; ?j
+                                                   ))
+                      "\xfffd;\xfffd;\xfffd;h\xfffd;\xfffd;\xfffd;i\xfffd;j")
+                => #t)
+
+              #; ; rkd: implementation dependent number of replacement characters
+              (test (string=? (utf8->string '#vu8(#x61                             ; a
+                                                   #xf0 #x80 #x80 #x80 #x62         ; ????b
+                                                   #xf0 #x90 #x80 #x80 #x63         ; .c
+                                                   ))
+                      "a\xfffd;\xfffd;\xfffd;\xfffd;b\x10000;c")
+                => #t)
+
+              (test (string=? (utf8->string '#vu8(#x61                             ; a
+                                                   #xf0 #xbf #xbf #xbf #x64         ; .d
+                                                   #xf0 #xbf #xbf #x65              ; ?e
+                                                   #xf0 #xbf #x66                   ; ?f
+                                                   ))
+                      "a\x3ffff;d\xfffd;e\xfffd;f")
+                => #t)
+
+              #; ; rkd: implementation dependent number of replacement characters
+              (test (string=? (utf8->string '#vu8(#x61                             ; a
+                                                   #xf4 #x8f #xbf #xbf #x62         ; .b
+                                                   #xf4 #x90 #x80 #x80 #x63         ; ????c
+                                                   ))
+
+                      "a\x10ffff;b\xfffd;\xfffd;\xfffd;\xfffd;c")
+                => #t)
+
+              (test (string=? (utf8->string '#vu8(#x61                             ; a
+                                                   #xf5 #x80 #x80 #x80 #x64         ; ????d
+                                                   ))
+
+                      "a\xfffd;\xfffd;\xfffd;\xfffd;d")
+                => #t)
+
+              ; ignores BOM signature
+
+              (test (string=? (utf8->string '#vu8(#xef #xbb #xbf #x61 #x62 #x63 #x64))
+                      "abcd")
+                => #t)
+
+              (test-roundtrip (random-bytevector 10) utf8->string string->utf8)
+
+              (do ((i 0 (+ i 1)))
+                ((= i *random-stress-tests*))
+                (test-roundtrip (random-bytevector *random-stress-test-max-size*)
+                  utf8->string string->utf8))
+
+              (test (bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
+                      '#vu8(#x00 #x6b
+                             #x00 #x7f
+                             #x00 #x80
+                             #x07 #xff
+                             #x08 #x00
+                             #xff #xff))
+                => #t)
+
+              (test (bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                                    'little)
+                      '#vu8(#x6b #x00
+                             #x7f #x00
+                             #x80 #x00
+                             #xff #x07
+                             #x00 #x08
+                             #xff #xff))
+                => #t)
+
+              (test (bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;")
+                      '#vu8(#xd8 #x00 #xdc #x00
+                             #xdb #xb7 #xdc #xba
+                             #xdb #xff #xdf #xff))
+                => #t)
+
+              (test (bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;" 'little)
+                      '#vu8(#x00 #xd8 #x00 #xdc
+                             #xb7 #xdb #xba #xdc
+                             #xff #xdb #xff #xdf))
+                => #t)
+
+              (test (bytevector=? (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd")
+                      (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd" 'big))
+                => #t)
+
+              #; ; rkd: utf16->string requires endianness argument
+              (test (string=? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                      (utf16->string
+                        '#vu8(#x00 #x6b
+                               #x00 #x7f
+                               #x00 #x80
+                               #x07 #xff
+                               #x08 #x00
+                               #xff #xff)))
+                => #t)
+
+              (test (string=? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                      (utf16->string
+                        '#vu8(#x00 #x6b
+                               #x00 #x7f
+                               #x00 #x80
+                               #x07 #xff
+                               #x08 #x00
+                               #xff #xff)
+                        'big))
+                => #t)
+
+              #; ; rkd: utf16->string requires endianness argument
+              (test (string=? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                      (utf16->string
+                        '#vu8(#xfe #xff     ; big-endian BOM
+                               #x00 #x6b
+                               #x00 #x7f
+                               #x00 #x80
+                               #x07 #xff
+                               #x08 #x00
+                               #xff #xff)))
+                => #t)
+
+              (test (string=? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                      (utf16->string
+                        '#vu8(#x6b #x00
+                               #x7f #x00
+                               #x80 #x00
+                               #xff #x07
+                               #x00 #x08
+                               #xff #xff)
+                        'little))
+                => #t)
+
+              #; ; rkd: utf16->string requires endianness argument
+              (test (string=? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                      (utf16->string
+                        '#vu8(#xff #xfe     ; little-endian BOM
+                               #x6b #x00
+                               #x7f #x00
+                               #x80 #x00
+                               #xff #x07
+                               #x00 #x08
+                               #xff #xff)))
+                => #t)
+
+              (let ((tostring        utf16->string)
+                    (tostring-big    (lambda (bv) (utf16->string bv 'big)))
+                    (tostring-little (lambda (bv) (utf16->string bv 'little)))
+                    (tobvec          string->utf16)
+                    (tobvec-big      (lambda (s) (string->utf16 s 'big)))
+                    (tobvec-little   (lambda (s) (string->utf16 s 'little))))
+
+                (do ((i 0 (+ i 1)))
+                  ((= i *random-stress-tests*))
+                  #; ; rkd: utf16->string requires endianness argument
+                  (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
+                    tostring tobvec)
+                  (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
+                    tostring-big tobvec-big)
+                  (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
+                    tostring-little tobvec-little)))
+
+              (test (bytevector=? (string->utf32 "abc")
+                      '#vu8(#x00 #x00 #x00 #x61
+                             #x00 #x00 #x00 #x62
+                             #x00 #x00 #x00 #x63))
+                => #t)
+
+              (test (bytevector=? (string->utf32 "abc" 'big)
+                      '#vu8(#x00 #x00 #x00 #x61
+                             #x00 #x00 #x00 #x62
+                             #x00 #x00 #x00 #x63))
+                => #t)
+
+              (test (bytevector=? (string->utf32 "abc" 'little)
+                      '#vu8(#x61 #x00 #x00 #x00
+                             #x62 #x00 #x00 #x00
+                             #x63 #x00 #x00 #x00))
+                => #t)
+
+              #; ; rkd: utf32->string requires endianness argument
+              (test (string=? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)))
+                => #t)
+
+              (test (string=? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)
+                        'big))
+                => #t)
+
+              #; ; rkd: utf32->string requires endianness argument
+              (test (string=? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#x00 #x00 #xfe #xff   ; big-endian BOM
+                               #x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)))
+                => #t)
+
+              (test (string=? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#x00 #x00 #xfe #xff   ; big-endian BOM
+                               #x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)
+                        'big
+                        ; rkd: added endianness-mandatory? flag
+                        #t))
+                => #t)
+
+              (test (string=? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#x61 #x00 #x00 #x00
+                               #x00 #xd9 #x00 #x00
+                               #x62 #x00 #x00 #x00
+                               #xab #xdd #x00 #x00
+                               #x63 #x00 #x00 #x00
+                               #x00 #x00 #x11 #x00
+                               #x64 #x00 #x00 #x00
+                               #x65 #x00 #x00 #x01
+                               #x65 #x00 #x00 #x00)
+                        'little))
+                => #t)
+
+              #; ; rkd: utf32->string requires endianness argument
+              (test (string=? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#xff #xfe #x00 #x00   ; little-endian BOM
+                               #x61 #x00 #x00 #x00
+                               #x00 #xd9 #x00 #x00
+                               #x62 #x00 #x00 #x00
+                               #xab #xdd #x00 #x00
+                               #x63 #x00 #x00 #x00
+                               #x00 #x00 #x11 #x00
+                               #x64 #x00 #x00 #x00
+                               #x65 #x00 #x00 #x01
+                               #x65 #x00 #x00 #x00)))
+                => #t)
+
+              (test (string=? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                      (utf32->string
+                        '#vu8(#xff #xfe #x00 #x00   ; little-endian BOM
+                               #x61 #x00 #x00 #x00
+                               #x00 #xd9 #x00 #x00
+                               #x62 #x00 #x00 #x00
+                               #xab #xdd #x00 #x00
+                               #x63 #x00 #x00 #x00
+                               #x00 #x00 #x11 #x00
+                               #x64 #x00 #x00 #x00
+                               #x65 #x00 #x00 #x01
+                               #x65 #x00 #x00 #x00)
+                        'little
+                        ; rkd: added endianness-mandatory? flag
+                        #t))
+                => #t)
+
+              (let ((tostring        utf32->string)
+                    (tostring-big    (lambda (bv) (utf32->string bv 'big)))
+                    (tostring-little (lambda (bv) (utf32->string bv 'little)))
+                    (tobvec          string->utf32)
+                    (tobvec-big      (lambda (s) (string->utf32 s 'big)))
+                    (tobvec-little   (lambda (s) (string->utf32 s 'little))))
+
+                (do ((i 0 (+ i 1)))
+                  ((= i *random-stress-tests*))
+                  #; ; rkd: utf32->string requires endianness argument
+                  (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
+                    tostring tobvec)
+                  (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
+                    tostring-big tobvec-big)
+                  (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
+                    tostring-little tobvec-little)))
+
+              )
+
+            ; Tests string <-> bytevector conversion on strings
+            ; that contain every Unicode scalar value.
+            (define (exhaustive-string-bytevector-tests)
+
+              ; Tests throughout an inclusive range.
+
+              (define (test-char-range lo hi tostring tobytevector)
+                (let* ((n (+ 1 (- hi lo)))
+                       (s (make-string n))
+                       (replacement-character (integer->char #xfffd)))
+                  (do ((i lo (+ i 1)))
+                    ((> i hi))
+                    (let ((c (if (or (<= 0 i #xd7ff)
+                                     (<= #xe000 i #x10ffff))
+                                 (integer->char i)
+                                 replacement-character)))
+                      (string-set! s (- i lo) c)))
+                  (test (string=? (tostring (tobytevector s)) s) => #t)))
+
+              (define (test-exhaustively name tostring tobytevector)
+                (display "Testing ")
+                (display name)
+                (display " conversions...")
+                (newline)
+                (test-char-range 0 #xffff tostring tobytevector)
+                (test-char-range #x10000 #x1ffff tostring tobytevector)
+                (test-char-range #x20000 #x2ffff tostring tobytevector)
+                (test-char-range #x30000 #x3ffff tostring tobytevector)
+                (test-char-range #x40000 #x4ffff tostring tobytevector)
+                (test-char-range #x50000 #x5ffff tostring tobytevector)
+                (test-char-range #x60000 #x6ffff tostring tobytevector)
+                (test-char-range #x70000 #x7ffff tostring tobytevector)
+                (test-char-range #x80000 #x8ffff tostring tobytevector)
+                (test-char-range #x90000 #x9ffff tostring tobytevector)
+                (test-char-range #xa0000 #xaffff tostring tobytevector)
+                (test-char-range #xb0000 #xbffff tostring tobytevector)
+                (test-char-range #xc0000 #xcffff tostring tobytevector)
+                (test-char-range #xd0000 #xdffff tostring tobytevector)
+                (test-char-range #xe0000 #xeffff tostring tobytevector)
+                (test-char-range #xf0000 #xfffff tostring tobytevector)
+                (test-char-range #x100000 #x10ffff tostring tobytevector))
+
+              ; Feel free to replace this with your favorite timing macro.
+
+              (define (timeit x) x)
+
+              (timeit (test-exhaustively "UTF-8" utf8->string string->utf8))
+
+              #; ; rkd: utf16->string requires endianness argument
+              (timeit (test-exhaustively "UTF-16" utf16->string string->utf16))
+
+              (timeit (test-exhaustively "UTF-16BE"
+                        (lambda (bv) (utf16->string bv 'big))
+                        (lambda (s) (string->utf16 s 'big))))
+
+              (timeit (test-exhaustively "UTF-16LE"
+                        (lambda (bv) (utf16->string bv 'little))
+                        (lambda (s) (string->utf16 s 'little))))
+
+              #; ; rkd: utf32->string requires endianness argument
+              (timeit (test-exhaustively "UTF-32" utf32->string string->utf32))
+
+              (timeit (test-exhaustively "UTF-32BE"
+                        (lambda (bv) (utf32->string bv 'big))
+                        (lambda (s) (string->utf32 s 'big))))
+
+              (timeit (test-exhaustively "UTF-32LE"
+                        (lambda (bv) (utf32->string bv 'little))
+                        (lambda (s) (string->utf32 s 'little)))))
+
+            (basic-bytevector-tests)
+            (ieee-bytevector-tests)
+            (string-bytevector-tests)
+            (exhaustive-string-bytevector-tests)
+            okay?)))
+      'replace)
+    #t)
+  (begin
+    (load "testfile-bytevector.ss")
+    #t)
+  (bytevector-refimpl-tests)
+)
+
+(mat tspl/csug-examples
+  (equal? '#vu8(1 2 3) #vu8(1 2 3))
+  (equal? #vu8(1 2 3) #vu8(1 2 3))
+  (equal? #vu8(#x3f #x7f #xbf #xff) #vu8(63 127 191 255))
+  (equal? (endianness little) 'little)
+  (equal? (endianness big) 'big)
+  (error? (endianness "spam"))
+  (equal? (symbol? (native-endianness)) #t)
+  (equal? (bytevector? #vu8()) #t)
+  (equal? (bytevector? '#()) #f)
+  (equal? (bytevector? "abc") #f)
+  (equal? (bytevector) #vu8())
+  (equal? (bytevector 1 3 5) #vu8(1 3 5))
+  (equal? (bytevector -1 -3 -5) #vu8(255 253 251))
+  (equal? (make-bytevector 0) #vu8())
+  (equal? (make-bytevector 0 7) #vu8())
+  (equal? (make-bytevector 5 7) #vu8(7 7 7 7 7))
+  (equal? (make-bytevector 5 -7) #vu8(249 249 249 249 249))
+  (equal? (bytevector-length #vu8()) 0)
+  (equal? (bytevector-length #vu8(1 2 3)) 3)
+  (equal? (bytevector-length (make-bytevector 300)) 300)
+  (equal? (bytevector=? #vu8() #vu8()) #t)
+  (equal? (bytevector=? (make-bytevector 3 0) #vu8(0 0 0)) #t)
+  (equal? (bytevector=? (make-bytevector 5 0) #vu8(0 0 0)) #f)
+  (equal? (bytevector=? #vu8(1 127 128 255) #vu8(255 128 127 1)) #f)
+  (equal?
+    (let ([v (make-bytevector 6)])
+      (bytevector-fill! v 255)
+      v)
+    #vu8(255 255 255 255 255 255))
+  
+  (equal?
+    (let ([v (make-bytevector 6)])
+      (bytevector-fill! v -128)
+      v)
+    #vu8(128 128 128 128 128 128))
+  (equal? (bytevector-copy #vu8(1 127 128 255)) #vu8(1 127 128 255))
+  
+  (equal?
+    (let ([v #vu8(1 127 128 255)])
+      (eq? v (bytevector-copy v)))
+    #f)
+  (begin
+    (define $v1 #vu8(31 63 95 127 159 191 223 255))
+    (define $v2 (make-bytevector 10 0))
+    (bytevector-copy! $v1 2 $v2 1 4)
+    (equal? $v2 #vu8(0 95 127 159 191 0 0 0 0 0)))
+   
+  (begin
+    (bytevector-copy! $v1 5 $v2 7 3)
+    (equal? $v2 #vu8(0 95 127 159 191 0 0 191 223 255)))
+   
+  (begin
+    (bytevector-copy! $v2 3 $v2 0 6)
+    (equal? $v2 #vu8(159 191 0 0 191 223 0 191 223 255)))
+   
+  (begin
+    (bytevector-copy! $v2 0 $v2 1 9)
+    (equal? $v2 #vu8(159 159 191 0 0 191 223 0 191 223)))
+
+  (equal? (bytevector-u8-ref #vu8(1 127 128 255) 0) 1)
+  (equal? (bytevector-u8-ref #vu8(1 127 128 255) 2) 128)
+  (equal? (bytevector-u8-ref #vu8(1 127 128 255) 3) 255)
+  (equal? (bytevector-s8-ref #vu8(1 127 128 255) 0) 1)
+  (equal? (bytevector-s8-ref #vu8(1 127 128 255) 1) 127)
+  (equal? (bytevector-s8-ref #vu8(1 127 128 255) 2) -128)
+  (equal? (bytevector-s8-ref #vu8(1 127 128 255) 3) -1)
+  (equal?
+    (let ([v (make-bytevector 5 -1)])
+      (bytevector-u8-set! v 2 128)
+      v)
+    #vu8(255 255 128 255 255))
+  (equal?
+    (let ([v (make-bytevector 4 0)])
+      (bytevector-s8-set! v 1 100)
+      (bytevector-s8-set! v 2 -100)
+      v)
+    #vu8(0 100 156 0))
+  (equal? (bytevector->u8-list (make-bytevector 0)) '())
+  (equal? (bytevector->u8-list #vu8(1 127 128 255)) '(1 127 128 255))
+  
+  (equal?
+    (let ([v #vu8(1 2 3 255)])
+      (apply * (bytevector->u8-list v)))
+    1530)
+  
+  (equal? (bytevector->s8-list (make-bytevector 0)) '())
+  (equal? (bytevector->s8-list #vu8(1 127 128 255)) '(1 127 -128 -1))
+  
+  (equal?
+    (let ([v #vu8(1 2 3 255)])
+      (apply * (bytevector->s8-list v)))
+    -6)
+  (equal? (u8-list->bytevector '()) #vu8())
+  (equal? (u8-list->bytevector '(1 127 128 255)) #vu8(1 127 128 255))
+  
+  (equal?
+    (let ([v #vu8(1 2 3 4 5)])
+      (let ([ls (bytevector->u8-list v)])
+        (u8-list->bytevector (map * ls ls))))
+    #vu8(1 4 9 16 25))
+  
+  (equal? (s8-list->bytevector '()) #vu8())
+  (equal? (s8-list->bytevector '(1 127 -128 -1)) #vu8(1 127 128 255))
+  
+  (equal?
+    (let ([v #vu8(1 2 3 4 5)])
+      (let ([ls (bytevector->s8-list v)])
+        (s8-list->bytevector (map - ls))))
+    #vu8(255 254 253 252 251))
+  (begin
+    (define $v #vu8(#x12 #x34 #xfe #x56 #xdc #xba #x78 #x98))
+    (bytevector? $v))
+  
+  (equal?
+    (case (native-endianness)
+      [(big)
+       (list
+         (equal? (bytevector-u16-native-ref $v 2) #xfe56)
+         (equal? (bytevector-s16-native-ref $v 2) #x-1aa)
+         (equal? (bytevector-s16-native-ref $v 6) #x7898)
+  
+         (equal? (bytevector-u32-native-ref $v 0) #x1234fe56)
+         (equal? (bytevector-s32-native-ref $v 0) #x1234fe56)
+         (equal? (bytevector-s32-native-ref $v 4) #x-23458768)
+  
+         (equal? (bytevector-u64-native-ref $v 0) #x1234fe56dcba7898)
+         (equal? (bytevector-s64-native-ref $v 0) #x1234fe56dcba7898))]
+      [(little)
+       (list
+         (equal? (bytevector-u16-native-ref $v 2) #x56fe)
+         (equal? (bytevector-s16-native-ref $v 2) #x56fe)
+         (equal? (bytevector-s16-native-ref $v 6) #x-6788)
+  
+         (equal? (bytevector-u32-native-ref $v 0) #x56fe3412)
+         (equal? (bytevector-s32-native-ref $v 0) #x56fe3412)
+         (equal? (bytevector-s32-native-ref $v 4) #x-67874524)
+  
+         (equal? (bytevector-u64-native-ref $v 0) #x9878badc56fe3412)
+         (equal? (bytevector-s64-native-ref $v 0) #x-67874523a901cbee))]
+      [else (errorf #f "mat does not handle endianness ~s" (native-endianness))])
+    '(#t #t #t #t #t #t #t #t))
+
+  (let ()
+    (define v (make-bytevector 8 0))
+    (bytevector-u16-native-set! v 0 #xfe56)
+    (bytevector-s16-native-set! v 2 #x-1aa)
+    (bytevector-s16-native-set! v 4 #x7898)
+    (case (native-endianness)
+      [(big) (equal? v #vu8(#xfe #x56 #xfe #x56 #x78 #x98 #x00 #x00))]
+      [(little) (equal? v #vu8(#x56 #xfe #x56 #xfe #x98 #x78 #x00 #x00))]
+      [else (errorf #f "mat does not handle endianness ~s" (native-endianness))]))
+  
+  (let ()
+    (define v (make-bytevector 16 0))
+    (bytevector-u32-native-set! v 0 #x1234fe56)
+    (bytevector-s32-native-set! v 4 #x1234fe56)
+    (bytevector-s32-native-set! v 8 #x-23458768)
+    (case (native-endianness)
+      [(big) (equal? v #vu8(#x12 #x34 #xfe #x56 #x12 #x34 #xfe #x56
+                            #xdc #xba #x78 #x98 #x00 #x00 #x00 #x00))]
+      [(little) (equal? v #vu8(#x56 #xfe #x34 #x12 #x56 #xfe #x34 #x12
+                               #x98 #x78 #xba #xdc #x00 #x00 #x00 #x00))]
+      [else (errorf #f "mat does not handle endianness ~s" (native-endianness))]))
+  
+  (let ()
+    (define v (make-bytevector 24 0))
+    (bytevector-u64-native-set! v 0 #x1234fe56dcba7898)
+    (bytevector-s64-native-set! v 8 #x1234fe56dcba7898)
+    (bytevector-s64-native-set! v 16 #x-67874523a901cbee)
+    (case (native-endianness)
+      [(big) (equal? v #vu8(#x12 #x34 #xfe #x56 #xdc #xba #x78 #x98
+                            #x12 #x34 #xfe #x56 #xdc #xba #x78 #x98
+                            #x98 #x78 #xba #xdc #x56 #xfe #x34 #x12))]
+      [(little) (equal? v #vu8(#x98 #x78 #xba #xdc #x56 #xfe #x34 #x12
+                               #x98 #x78 #xba #xdc #x56 #xfe #x34 #x12
+                               #x12 #x34 #xfe #x56 #xdc #xba #x78 #x98))]
+      [else (errorf #f "mat does not handle endianness ~s" (native-endianness))]))
+
+  (begin
+    (define $v #vu8(#x12 #x34 #xfe #x56 #xdc #xba #x78 #x98 #x9a #x76))
+    (bytevector? $v))
+  (equal? (bytevector-u16-ref $v 0 (endianness big)) #x1234)
+  (equal? (bytevector-s16-ref $v 1 (endianness big)) #x34fe)
+  (equal? (bytevector-s16-ref $v 5 (endianness big)) #x-4588)
+  
+  (equal? (bytevector-u32-ref $v 2 'big) #xfe56dcba)
+  (equal? (bytevector-s32-ref $v 3 'big) #x56dcba78)
+  (equal? (bytevector-s32-ref $v 4 'big) #x-23458768)
+  
+  (equal? (bytevector-u64-ref $v 0 'big) #x1234fe56dcba7898)
+  (equal? (bytevector-s64-ref $v 1 'big) #x34fe56dcba78989a)
+  
+  (equal? (bytevector-u16-ref $v 0 (endianness little)) #x3412)
+  (equal? (bytevector-s16-ref $v 1 (endianness little)) #x-1cc)
+  (equal? (bytevector-s16-ref $v 5 (endianness little)) #x78ba)
+  
+  (equal? (bytevector-u32-ref $v 2 'little) #xbadc56fe)
+  (equal? (bytevector-s32-ref $v 3 'little) #x78badc56)
+  (equal? (bytevector-s32-ref $v 4 'little) #x-67874524)
+  
+  (equal? (bytevector-u64-ref $v 0 'little) #x9878badc56fe3412)
+  (equal? (bytevector-s64-ref $v 1 'little) #x-6567874523a901cc)
+
+  (let ()
+    (define v (make-bytevector 8 0))
+    (bytevector-u16-set! v 0 #xfe56 (endianness big))
+    (bytevector-s16-set! v 3 #x-1aa (endianness little))
+    (bytevector-s16-set! v 5 #x7898 (endianness big))
+    (equal? v #vu8(#xfe #x56 #x0 #x56 #xfe #x78 #x98 #x0)))
+  
+  (let ()
+    (define v (make-bytevector 16 0))
+    (bytevector-u32-set! v 0 #x1234fe56 'little)
+    (bytevector-s32-set! v 6 #x1234fe56 'big)
+    (bytevector-s32-set! v 11 #x-23458768 'little)
+    (equal? v #vu8(#x56 #xfe #x34 #x12 #x0 #x0
+                   #x12 #x34 #xfe #x56 #x0
+                   #x98 #x78 #xba #xdc #x0)))
+  
+  (let ()
+    (define v (make-bytevector 28 0))
+    (bytevector-u64-set! v 0 #x1234fe56dcba7898 'little)
+    (bytevector-s64-set! v 10 #x1234fe56dcba7898 'big)
+    (bytevector-s64-set! v 19 #x-67874523a901cbee 'big)
+    (equal? v #vu8(#x98 #x78 #xba #xdc #x56 #xfe #x34 #x12 #x0 #x0
+               #x12 #x34 #xfe #x56 #xdc #xba #x78 #x98 #x0
+               #x98 #x78 #xba #xdc #x56 #xfe #x34 #x12 #x0)))
+
+  (let ()
+    (define v #vu8(#x12 #x34 #xfe #x56 #xdc #xba #x78 #x98 #x9a #x76))
+    (and
+      (equal? (bytevector-uint-ref v 0 'big 1) #x12)
+      (equal? (bytevector-uint-ref v 0 'little 1) #x12)
+      (equal? (bytevector-uint-ref v 1 'big 3) #x34fe56)
+      (equal? (bytevector-uint-ref v 2 'little 7) #x9a9878badc56fe)
+  
+      (equal? (bytevector-sint-ref v 2 'big 1) #x-02)
+      (equal? (bytevector-sint-ref v 1 'little 6) #x78badc56fe34)
+      (equal? (bytevector-sint-ref v 2 'little 7) #x-6567874523a902)
+  
+      (equal? (bytevector-sint-ref (make-bytevector 1000 -1) 0 'big 1000) -1)))
+
+  (let ()
+    (define v (make-bytevector 5 0))
+    (bytevector-uint-set! v 1 #x123456 (endianness big) 3)
+    (equal? v #vu8(0 #x12 #x34 #x56 0)))
+  
+  (let ()
+    (define v (make-bytevector 7 -1))
+    (bytevector-sint-set! v 1 #x-8000000000 (endianness little) 5)
+    (equal? v #vu8(#xff 0 0 0 0 #x80 #xff)))
+
+  (equal? (bytevector->uint-list (make-bytevector 0) 'little 3) '())
+  
+  (equal?
+    (let ([v #vu8(1 2 3 4 5 6)])
+      (bytevector->uint-list v 'big 3))
+    '(#x010203 #x040506))
+  
+  (equal?
+    (let ([v (make-bytevector 80 -1)])
+      (bytevector->sint-list v 'big 20))
+    '(-1 -1 -1 -1))
+  (equal? (uint-list->bytevector '() 'big 25) #vu8())
+  (equal? (sint-list->bytevector '(0 -1) 'big 3) #vu8(0 0 0 #xff #xff #xff))
+  
+  (equal?
+    (let ()
+      (define (f size)
+        (let ([ls (list (- (expt 2 (- (* 8 size) 1)))
+                        (- (expt 2 (- (* 8 size) 1)) 1))])
+          (sint-list->bytevector ls 'little size)))
+      (f 6))
+    #vu8(#x00 #x00 #x00 #x00 #x00 #x80 #xff #xff #xff #xff #xff #x7f))
+
+  (begin
+    (define $v (make-bytevector 8 0))
+    (bytevector-ieee-single-native-set! $v 0 .125)
+    (bytevector-ieee-single-native-set! $v 4 -3/2)
+    (equal?
+      (list
+        (bytevector-ieee-single-native-ref $v 0)
+        (bytevector-ieee-single-native-ref $v 4))
+      '(0.125 -1.5)))
+  
+  (begin
+    (bytevector-ieee-double-native-set! $v 0 1e23)
+    (equal? (bytevector-ieee-double-native-ref $v 0) 1e23))
+
+  (begin
+    (define $v (make-bytevector 10 #xc7))
+    (bytevector-ieee-single-set! $v 1 .125 'little)
+    (bytevector-ieee-single-set! $v 6 -3/2 'big)
+    (equal?
+      (list
+        (bytevector-ieee-single-ref $v 1 'little)
+        (bytevector-ieee-single-ref $v 6 'big))
+      '(0.125 -1.5)))
+  (equal? $v #vu8(#xc7 #x0 #x0 #x0 #x3e #xc7 #xbf #xc0 #x0 #x0))
+  
+  (begin
+    (bytevector-ieee-double-set! $v 1 1e23 'big)
+    (equal? (bytevector-ieee-double-ref $v 1 'big) 1e23))
+)
+
+#;(mat bytevector-logical
+ ; A reference implementation in scheme
+  (begin
+    (define $bytevector-blurp
+      (lambda (f)
+        (lambda (bv1 bv2)
+          (let ([len1 (bytevector-length bv1)]
+                [len2 (bytevector-length bv2)])
+            (let ([len (max len1 len2)])
+              (if (fx= len 0)
+                  bv1
+                  (let ([new (make-bytevector len)])
+                    (define endianness 'big)
+                    (define (uint-ref bv len)
+                      (if (fx= len 0)
+                          0
+                          (bytevector-uint-ref bv 0 endianness len)))
+                    (bytevector-uint-set! new 0
+                      (f (uint-ref bv1 len1) (uint-ref bv2 len2))
+                      endianness len)
+                    new)))))))
+
+    (define $bytevector-and ($bytevector-blurp bitwise-and))
+
+    (define $bytevector-ior ($bytevector-blurp bitwise-ior))
+
+    (define $bytevector-xor ($bytevector-blurp bitwise-xor))
+    
+    (define $bytevector-not 
+      (lambda (bv)
+        (let ([len (bytevector-length bv)])
+          (if (fx= len 0)
+              bv
+              (let ([new (make-bytevector len)])
+                #;
+                (bytevector-uint-set! new 0
+                  (- (- (expt 256 len) 1)
+                     (bytevector-uint-ref bv 0 (native-endianness) len))
+                  (native-endianness) len)
+                (bytevector-sint-set! new 0
+                  (bitwise-not
+                    (bytevector-sint-ref bv 0 (native-endianness) len))
+                  (native-endianness) len)
+                new)))))
+
+    (define $make-random-bytevector
+      (lambda (len)
+        (let ([bv (make-bytevector len)])
+          (do ([n len (- n 1)])
+              ((zero? n) bv)
+              (bytevector-u8-set! bv (- n 1) (random 256))))))
+
+    #t)
+
+ ; Currently the reference implementation is the only implementation,
+ ; so go ahead and use it for the tests and the random tests below.
+  (define bytevector-and $bytevector-and)
+  (define bytevector-ior $bytevector-ior)
+  (define bytevector-xor $bytevector-xor)
+  (define bytevector-not $bytevector-not)
+
+  (error? (bytevector-not '#()))
+  (error? (bytevector-not 75))
+  (error? (bytevector-not #vu8(5) '#()))
+  (error? (bytevector-not 75 #vu8(5)))
+  (equal? (bytevector-not #vu8()) #vu8())
+  (equal? (bytevector-not #vu8(23)) #vu8(232))
+  (equal? (bytevector-not #vu8(23 129)) #vu8(232 126))
+  (equal? (bytevector-not #vu8(23 129 99)) #vu8(232 126 156))
+  (equal? (bytevector-not #vu8(#x7f #xff #xff #xff)) #vu8(128 0 0 0))
+  (equal? (bytevector-not #vu8(#xff #xff #xff #xff)) #vu8(0 0 0 0))
+  (equal?
+    (bytevector-not #vu8(#x00 #x00 #x00 #x00))
+    #vu8(#xff #xff #xff #xff))
+  (equal? (bytevector-not #vu8(0 255 170 85)) #vu8(255 0 85 170))
+  (equal?
+    (bytevector-not #vu8(#x00 #x00 #x00 #x02))
+    #vu8(#xff #xff #xff #xfd))
+  (equal?
+    (bytevector-not #vu8(#x0f #xff #xff #xff #xff #xff #xff #xff #xff #xff))
+    #vu8(#xf0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
+
+  (error? (bytevector-and '#()))
+  (error? (bytevector-and 75))
+  (error? (bytevector-and #vu8(5) '#()))
+  (error? (bytevector-and 75 #vu8(5)))
+  (equal?
+    (bytevector-and #vu8() #vu8())
+    #vu8())
+  (equal?
+    (bytevector-and #vu8(#xff #xff #xff) #vu8(#x54 #x27 #x86))
+    #vu8(#x54 #x27 #x86))
+  (equal?
+    (bytevector-and #vu8(#x00 #x00 #x00) #vu8(#x54 #x27 #x86))
+    #vu8(#x00 #x00 #x00))
+  (equal?
+    (bytevector-and #vu8(#x65 #x33 #xf0) #vu8(#x54 #x27 #x86))
+    #vu8(#x44 #x23 #x80))
+  (equal?
+    (bytevector-and #vu8(#x65 #x33 #xf0 #x75 #x83 #x99 #x41)
+                    #vu8(#x54 #x27 #x86 #x99 #x87 #x76 #x63))
+    #vu8(#x44 #x23 #x80 #x11 #x83 #x10 #x41))
+  (equal?
+    (bytevector-and #vu8(#x65 #x33 #xf0 #x75 #x83 #x99)
+                    #vu8(#x54 #x27 #x86 #x99 #x87 #x76))
+    #vu8(#x44 #x23 #x80 #x11 #x83 #x10))
+  (equal?
+    (bytevector-and #vu8(#x0 #x0 #x0 #x0) #vu8(#x0 #x0 #x0 #x0))
+    #vu8(#x0 #x0 #x0 #x0))
+  (equal?
+    (bytevector-and #vu8(#xff #xff #xff #xff) #vu8(#x0 #x0 #x0 #x0))
+    #vu8(#x0 #x0 #x0 #x0))
+  (equal?
+    (bytevector-and #vu8(#x0 #x0 #x0 #x0) #vu8(#xff #xff #xff #xff))
+    #vu8(#x0 #x0 #x0 #x0))
+  (equal?
+    (bytevector-and #vu8(20) #vu8(0))
+    #vu8(0))
+  (equal?
+    (bytevector-and #vu8(20) #vu8(#xff))
+    #vu8(20))
+  (equal?
+    (bytevector-and #vu8(#x0f #xff #xff #xff #xff #xff #xff #xff #xff #xff)
+                    #vu8(#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff))
+    #vu8(#x0f #xff #xff #xff #xff #xff #xff #xff #xff #xff))
+  (equal?
+    (bytevector-and #vu8(#x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11)
+                    #vu8(#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff))
+    #vu8(#x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11))
+  (equal?
+    (bytevector-and
+      #vu8(#x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11)
+      #vu8(#x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22))
+    #vu8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00)) 
+  (equal?
+    (bytevector-and
+      #vu8(#x12 #x12 #x12 #x12 #x12 #x12 #x12 #x12 #x12 #x12 #x12 #x12 #x12)
+      #vu8(#x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22))
+    #vu8(#x02 #x02 #x02 #x02 #x02 #x02 #x02 #x02 #x02 #x02 #x02 #x02 #x02))
+  (equal?
+    (bytevector-and
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03)
+      #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1f #x36 #x65 #x67))
+    #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x30 #x01 #x03))
+  (equal? 
+    (bytevector-and
+      #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1f #x36 #x65 #x67)
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03))
+    #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x30 #x01 #x03))
+ ; different length bytevectors, how should they work?
+  (equal?
+    (bytevector-and
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03)
+      #vu8(#x1f #x36 #x65 #x67))
+    #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x30 #x01 #x03))
+  (equal? 
+    (bytevector-and
+      #vu8(#x1f #x36 #x65 #x67)
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03))
+    #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x30 #x01 #x03))
+
+  (error? (bytevector-ior '#()))
+  (error? (bytevector-ior 75))
+  (error? (bytevector-ior #vu8(5) '#()))
+  (error? (bytevector-ior 75 #vu8(5)))
+  (equal? 
+    (bytevector-ior #vu8() #vu8())
+    #vu8())
+  (equal?
+    (bytevector-ior #vu8(0 0 0) #vu8(0 0 0))
+    #vu8(0 0 0))
+  (equal?
+    (bytevector-ior #vu8(#xff #xff #xff #xff) #vu8(0 0 0 0))
+    #vu8(#xff #xff #xff #xff))
+  (equal?
+    (bytevector-ior #vu8(0 0 0 0) #vu8(#xff #xff #xff #xff))
+    #vu8(#xff #xff #xff #xff))
+  (equal?
+    (bytevector-ior #vu8(#xff #xff #xff) #vu8(#x54 #x27 #x86))
+    #vu8(#xff #xff #xff))
+  (equal?
+    (bytevector-ior #vu8(#x00 #x00 #x00) #vu8(#x54 #x27 #x86))
+    #vu8(#x54 #x27 #x86))
+  (equal?
+    (bytevector-ior #vu8(#x65 #x33 #xf0) #vu8(#x54 #x27 #x86))
+    #vu8(#x75 #x37 #xf6))
+  (equal?
+    (bytevector-ior #vu8(#x65 #x33 #xf0 #x75 #x83 #x99 #x41)
+                    #vu8(#x54 #x27 #x86 #x99 #x87 #x76 #x63))
+    #vu8(#x75 #x37 #xf6 #xfd #x87 #xff #x63))
+  (equal?
+    (bytevector-ior #vu8(#x65 #x33 #xf0 #x75 #x83 #x99)
+                    #vu8(#x54 #x27 #x86 #x99 #x87 #x76))
+    #vu8(#x75 #x37 #xf6 #xfd #x87 #xff))
+  (equal?
+    (bytevector-ior #vu8(20) #vu8(#xff))
+    #vu8(#xff))
+  (equal? 
+    (bytevector-ior
+      #vu8(#x1 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11)
+      #vu8(#x2 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22))
+    #vu8(#x3 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33))
+  (equal?
+    (bytevector-ior
+      #vu8(#x1 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21)
+      #vu8(#x2 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22))
+    #vu8(#x3 #x23 #x23 #x23 #x23 #x23 #x23 #x23 #x23 #x23 #x23 #x23 #x23))
+  (equal?
+    (bytevector-ior
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03)
+      #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1f #x36 #x65 #x67))
+    #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x1f #xbe #xf5 #x67))
+  (equal?
+    (bytevector-ior
+      #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1f #x36 #x65 #x67)
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03))
+    #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x1f #xbe #xf5 #x67))
+ ; different size bytevectors how should the work?
+  (equal?
+    (bytevector-ior
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03)
+      #vu8(#x1f #x36 #x65 #x67))
+    #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x1f #xbe #xf5 #x67))
+  (equal?
+    (bytevector-ior
+      #vu8(#x1f #x36 #x65 #x67)
+      #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x01 #xb8 #x91 #x03))
+    #vu8(#x2 #xb2 #x25 #xd2 #x7f #x49 #xc1 #xfe #xd3 #x1f #xbe #xf5 #x67))
+
+  (error? (bytevector-xor '#()))
+  (error? (bytevector-xor 75))
+  (error? (bytevector-xor #vu8(5) '#()))
+  (error? (bytevector-xor 75 #vu8(5)))
+  (equal?
+    (bytevector-xor #vu8() #vu8())
+    #vu8())
+  (equal?
+    (bytevector-xor #vu8(#xff #xff #xff) #vu8(#x00 #x00 #x00))
+    #vu8(#xff #xff #xff))
+  (equal?
+    (bytevector-xor #vu8(#x00 #x00 #x00) #vu8(#xff #xff #xff))
+    #vu8(#xff #xff #xff))
+  (equal?
+    (bytevector-xor #vu8(#xff #xff #xff) #vu8(#xff #xff #xff))
+    #vu8(#x00 #x00 #x00))
+  (equal?
+    (bytevector-xor #vu8(#x0f #x0f #x0f #x0f) #vu8(#xff #xff #xff #xff))
+    #vu8(#xf0 #xf0 #xf0 #xf0))
+  (equal?
+    (bytevector-xor #vu8(#x00 #x14) #vu8(#xff #xff))
+    #vu8(#xff #xeb))
+  (equal?
+    (bytevector-xor
+      #vu8(#x1 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11 #x11)
+      #vu8(#x2 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22))
+    #vu8(#x3 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33 #x33))
+  (equal?
+    (bytevector-xor
+       #vu8(#x1 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21 #x21)
+       #vu8(#x2 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22 #x22))
+    #vu8(#x3 #x03 #x03 #x03 #x03 #x03 #x03 #x03 #x03 #x03 #x03 #x03 #x03))
+  (equal?
+    (bytevector-xor
+      #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x01 #xB8 #x91 #x03)
+      #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1F #x36 #x65 #x67))
+    #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x1E #x8E #xF4 #x64))
+  (equal?
+    (bytevector-xor
+      #vu8(#x0 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1F #x36 #x65 #x67)
+      #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x01 #xB8 #x91 #x03))
+    #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x1E #x8E #xF4 #x64))
+ ; different length bytevectors: how should they work?
+   (equal?
+    (bytevector-xor
+      #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x01 #xB8 #x91 #x03)
+      #vu8(#x1F #x36 #x65 #x67))
+    #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x1E #x8E #xF4 #x64))
+  (equal?
+    (bytevector-xor
+      #vu8(#x1F #x36 #x65 #x67)
+      #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x01 #xB8 #x91 #x03))
+    #vu8(#x2 #xB2 #x25 #xD2 #x7F #x49 #xC1 #xFE #xD3 #x1E #x8E #xF4 #x64))
+
+ ; random tests
+  (do ([n 1000 (fx- n 1)])
+      ((fxzero? n) #t)
+    (let ([size (random 30)])
+      (let ([bv1 ($make-random-bytevector size)]
+            [bv2 ($make-random-bytevector size)])
+        (unless (equal? (bytevector-not bv1)
+                        ($bytevector-not bv1))
+          (errorf #f "bytevector-not failed on ~s" bv1))
+        (unless (equal? (bytevector-and bv1 bv2)
+                        ($bytevector-and bv1 bv2))
+          (errorf #f "bytevector-and failed on ~s and ~s" bv1 bv2))
+        (unless (equal? (bytevector-and bv2 bv1)
+                        ($bytevector-and bv2 bv1))
+          (errorf #f "bytevector-and failed on ~s and ~s" bv2 bv1))
+        (unless (equal? (bytevector-and bv1 bv1)
+                        ($bytevector-and bv1 bv1))
+          (errorf #f "bytevector-and failed on ~s and ~s" bv1 bv1))
+        (unless (equal? (bytevector-ior bv1 bv2)
+                        ($bytevector-ior bv1 bv2))
+          (errorf #f "bytevector-ior failed on ~s and ~s" bv1 bv2))
+        (unless (equal? (bytevector-ior bv2 bv1)
+                        ($bytevector-ior bv2 bv1))
+          (errorf #f "bytevector-ior failed on ~s and ~s" bv2 bv1))
+        (unless (equal? (bytevector-ior bv1 bv1)
+                        ($bytevector-ior bv1 bv1))
+          (errorf #f "bytevector-ior failed on ~s and ~s" bv1 bv1))
+        (unless (equal? (bytevector-xor bv1 bv2)
+                        ($bytevector-xor bv1 bv2))
+          (errorf #f "bytevector-xor failed on ~s and ~s" bv1 bv2))
+        (unless (equal? (bytevector-xor bv2 bv1)
+                        ($bytevector-xor bv2 bv1))
+          (errorf #f "bytevector-xor failed on ~s and ~s" bv2 bv1))
+        (unless (equal? (bytevector-xor bv1 bv1)
+                        ($bytevector-xor bv1 bv1))
+          (errorf #f "bytevector-xor failed on ~s and ~s" bv1 bv1)))))
+)
+
+(mat bytevector->immutable-bytevector
+    (begin
+      (define immutable-100-bytevector
+        (bytevector->immutable-bytevector (make-bytevector 100 42)))
+      #t)
+    
+    (immutable-bytevector? immutable-100-bytevector)
+    (not (mutable-bytevector? immutable-100-bytevector))
+    
+    (equal? (make-bytevector 100 42) immutable-100-bytevector)
+    (eq? immutable-100-bytevector
+         (bytevector->immutable-bytevector immutable-100-bytevector))
+    
+    (not (immutable-bytevector? (make-bytevector 5)))
+    (mutable-bytevector? (make-bytevector 5))
+    
+    (immutable-bytevector? (bytevector->immutable-bytevector (bytevector)))
+    (not (mutable-bytevector? (bytevector->immutable-bytevector (bytevector))))
+    (not (immutable-bytevector? (bytevector)))
+    (mutable-bytevector? (bytevector))
+    
+    (not (immutable-bytevector? (bytevector-copy immutable-100-bytevector)))
+
+    ;; Make sure `...set!` functions check for mutability:
+    (error? (bytevector-uint-set! immutable-100-bytevector 0 1 (endianness big) 4))
+    (error? (bytevector-sint-set! immutable-100-bytevector 0 1 (endianness big) 4))
+    (error? (bytevector-u8-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-s8-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-u16-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s16-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u16-native-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-s16-native-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-u24-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s24-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u32-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s32-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u32-native-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-s32-native-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-u40-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s40-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u48-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s48-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u56-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s56-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u64-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-s64-set! immutable-100-bytevector 0 1 (endianness big)))
+    (error? (bytevector-u64-native-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-s64-native-set! immutable-100-bytevector 0 1))
+    (error? (bytevector-ieee-single-set! immutable-100-bytevector 0 1.0 (endianness big)))
+    (error? (bytevector-ieee-double-set! immutable-100-bytevector 0 1.0 (endianness big)))
+    (error? (bytevector-ieee-single-native-set! immutable-100-bytevector 0 1.0))
+    (error? (bytevector-ieee-double-native-set! immutable-100-bytevector 0 1.0))
+    
+    (error? (bytevector-fill! immutable-100-bytevector 0))
+    (error? (bytevector-copy! '#vu8(4 5 6) 0 immutable-100-bytevector 0 3))
+    (error? (bytevector-truncate! immutable-100-bytevector 1))
+
+    ;; Make sure `...ref!` functions *don't* accidentally check for mutability:
+    (number? (bytevector-uint-ref immutable-100-bytevector 0 (endianness big) 4))
+    (number? (bytevector-sint-ref immutable-100-bytevector 0 (endianness big) 4))
+    (number? (bytevector-u8-ref immutable-100-bytevector 0))
+    (number? (bytevector-s8-ref immutable-100-bytevector 0))
+    (number? (bytevector-u16-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s16-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u16-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-s16-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-u24-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s24-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u32-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s32-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u32-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-s32-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-u40-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s40-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u48-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s48-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u56-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s56-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u64-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-s64-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-u64-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-s64-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-ieee-single-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-ieee-double-ref immutable-100-bytevector 0 (endianness big)))
+    (number? (bytevector-ieee-single-native-ref immutable-100-bytevector 0))
+    (number? (bytevector-ieee-double-native-ref immutable-100-bytevector 0))
+)
+
+(mat bytevector-compress
+    (parameters [compress-format 'gzip 'lz4] [compress-level 'minimum 'low 'medium 'high 'maximum])
+    (error? (bytevector-compress 7))
+    (error? (bytevector-compress "hello"))
+    (error? (bytevector-uncompress 7))
+    (error? (bytevector-uncompress "hello"))
+    (begin
+      (define (round-trip-bytevector-compress bv)
+        (and
+          (equal? (#%$bytevector-uncompress (#%$bytevector-compress bv 0) (bytevector-length bv) 0) bv)
+          (equal? (bytevector-uncompress (bytevector-compress bv)) bv)))
+      (round-trip-bytevector-compress (string->utf8 "hello")))
+    (round-trip-bytevector-compress '#vu8())
+    (round-trip-bytevector-compress (apply bytevector
+                                           (let loop ([i 0])
+                                             (if (= i 4096)
+                                                 '()
+                                                 (cons (bitwise-and i 255)
+                                                       (loop (+ i 1)))))))
+    (round-trip-bytevector-compress 
+      (call-with-port (open-file-input-port (format "~a/prettytest.ss" *mats-dir*)) get-bytevector-all))
+    (error?
+     ;; Need at least 8 bytes for result size
+     (bytevector-uncompress '#vu8()))
+    (error?
+     ;; Need at least 8 bytes for result size
+     (bytevector-uncompress '#vu8(0 0 0 0 0 0 255)))
+    (error?
+     ;; Claming a too-large size in the header should fail with a suitable message:
+     (bytevector-uncompress '#vu8(255 255 255 255 255 255 255 255 1 2 3)))
+)
diff --git a/mats/cat_flush.c b/mats/cat_flush.c
new file mode 100644
index 0000000..381c46c
--- /dev/null
+++ b/mats/cat_flush.c
@@ -0,0 +1,38 @@
+/* cat_flush.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include 
+#include 
+#ifdef WIN32
+#include 
+#include 
+#endif
+
+int main() {
+  int c;
+
+#ifdef WIN32
+  _setmode(_fileno(stdin), O_BINARY);
+  _setmode(_fileno(stdout), O_BINARY);
+#endif
+
+  while ((c = getchar()) != EOF) {
+    putchar(c);
+    fflush(stdout);
+  }
+
+  exit(0);
+}
diff --git a/mats/cfl.ms b/mats/cfl.ms
new file mode 100644
index 0000000..4a3400b
--- /dev/null
+++ b/mats/cfl.ms
@@ -0,0 +1,377 @@
+;;; cfl.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define *fuzz* 1e-14)
+
+(define ~=
+   (lambda (x y)
+      (or (= x y)
+          (and (fl~= (inexact (real-part x))
+                     (inexact (real-part y)))
+               (fl~= (inexact (imag-part x))
+                     (inexact (imag-part y)))))))
+
+(define fl~=
+   (lambda (x y)
+      (cond
+         [(and (fl>= (flabs x) 2.0) (fl>= (flabs y) 2.0))
+          (fl~= (fl/ x 2.0) (fl/ y 2.0))]
+         [(and (fl< 0.0 (flabs x) 1.0) (fl< 0.0 (flabs y) 1.0))
+          (fl~= (fl* x 2.0) (fl* y 2.0))]
+         [else (let ([d (flabs (fl- x y))])
+                  (or (fl<= d *fuzz*)
+                      (begin (printf "fl~~=: ~s~%" d) #f)))])))
+
+(define cfl~=
+   (lambda (x y)
+      (and (fl~= (cfl-real-part x) (cfl-real-part y))
+           (fl~= (cfl-imag-part x) (cfl-imag-part y)))))
+
+(define zero 0.0)
+(define a 1.1)
+(define b +1.1i)
+(define c 1.1+1.1i)
+(define aa 1.21)
+(define ab +1.21i)
+(define ac 1.21+1.21i)
+(define bb -1.21)
+(define bc -1.21+1.21i)
+(define cc +2.42i)
+
+(mat cflonum?
+    (not (cflonum? 3))
+    (not (cflonum? 18/2))
+    (not (cflonum? 1+0i))
+    (not (cflonum? 23084982309482034820348023423048230482304))
+    (not (cflonum? 203480234802384/23049821))
+    (not (cflonum? -3/4))
+    (not (cflonum? -1))
+    (not (cflonum? 0))
+    (not (cflonum? -12))
+    (cflonum? 3.5)
+    (cflonum? 1.8e-10)
+    (cflonum? -3e5)
+    (cflonum? -1231.2344)
+    (cflonum? 3+5.0i)
+    (cflonum? 1.8e10@10)
+    (cflonum? -3e5+1.0i)
+    (cflonum? -1.0i)
+    (cflonum? +1.0i)
+    (not (cflonum? 'a))
+    (not (cflonum? "hi"))
+    (not (cflonum? (cons 3 4)))
+    (cflonum? a)
+    (cflonum? b)
+    (cflonum? c)
+ )
+
+(mat fl-make-rectangular
+   (error? (fl-make-rectangular 3 'a))
+   (error? (fl-make-rectangular 'b 4))
+   (error? (fl-make-rectangular 3 -4))
+   (eqv? (fl-make-rectangular 3.0 -4.0) 3.0-4.0i)
+   (eqv? (fl-make-rectangular a a) c)
+ )
+
+(mat cfl-real-part
+    (error? (cfl-real-part 'a))
+    (error? (cfl-real-part 3/2))
+    (eqv? (cfl-real-part 3.2) 3.2)
+    (eqv? (cfl-real-part -1.0+2.0i) -1.0)
+    (eqv? (cfl-real-part a) a)
+    (eqv? (cfl-real-part c) a)
+    (eqv? (cfl-real-part b) zero)
+ )
+
+(mat cfl-imag-part
+    (error? (cfl-imag-part 'a))
+    (error? (cfl-imag-part -3))
+    (eqv? (cfl-imag-part 3.2) zero)
+    (eqv? (cfl-imag-part -1.0+2.0i) 2.0)
+    (eqv? (cfl-imag-part a) zero)
+    (eqv? (cfl-imag-part c) a)
+    (eqv? (cfl-imag-part b) a)
+ )
+
+(mat cfl-conjugate
+    (error? (cfl-conjugate 'a))
+    (eqv? (cfl-conjugate 3.2) 3.2)
+    (eqv? (cfl-conjugate 3.2+2.0i) 3.2-2.0i)
+    (eqv? (cfl-conjugate a) a)
+    (eqv? (cfl-conjugate c) (+ a (- b)))
+    (eqv? (cfl-conjugate b) -1.1i)
+ )
+
+(mat conjugate
+    (error? (conjugate 'a))
+    (eqv? (conjugate 3.2) 3.2)
+    (eqv? (conjugate 3.2+2.0i) 3.2-2.0i)
+ )
+
+(mat cfl-magnitude-squared
+    (error? (cfl-magnitude-squared 'a))
+    (eqv? (cfl-magnitude-squared 3.2) (fl* 3.2 3.2))
+    (eqv? (cfl-magnitude-squared 3.5-2.0i) 16.25)
+    (fl~= (cfl-magnitude-squared 3.5@2.0) 12.25)
+ )
+
+(mat magnitude-squared
+    (error? (magnitude-squared 'a))
+    (eqv? (magnitude-squared 3.5) 12.25)
+    (eqv? (magnitude-squared 3.5-2.0i) 16.25)
+    (fl~= (magnitude-squared 3.5@2.0) 12.25)
+ )
+
+(mat cfl+
+    (error? (cfl+ 'a))
+    (error? (cfl+ 'a 3))
+    (error? (cfl+ 'a 3 4))
+    (eqv? (cfl+) zero)
+    (eqv? (cfl+ a) a)
+    (eqv? (cfl+ b) b)
+    (eqv? (cfl+ c) c)
+    (eqv? (cfl+ a b) c)
+    (cfl~= (cfl+ a b c) (cfl+ a (cfl+ b c)))
+    (cfl~= (cfl+ a b c a b c) (cfl+ (cfl+ a b c) (cfl+ a b c)))
+    (cfl~= (cfl+ 1+2.0i 3.0) 4.0+2.0i)
+    (cfl~= (cfl+ 1.0+2.2i -3.7+5.3i) -2.7+7.5i)
+    (cfl~= (cfl+ 1.0+2.2i -3.7) -2.7+2.2i)
+    (cfl~= (cfl+ 1.0 -3.7+5.3i) -2.7+5.3i)
+    (cfl~= (cfl+ 1.0+2.2i +5.3i) 1.0+7.5i)
+    (cfl~= (cfl+ +2.2i -3.7+5.3i) -3.7+7.5i)
+    (cfl~= (cfl+ 26.0 2.0) 28.0)
+    (test-cp0-expansion eqv? '(cfl+) zero)
+    (test-cp0-expansion eqv? `(cfl+ ,a) a)
+    (test-cp0-expansion eqv? `(cfl+ ,b) b)
+    (test-cp0-expansion eqv? `(cfl+ ,c) c)
+    (test-cp0-expansion eqv? `(cfl+ ,a ,b) c)
+    (test-cp0-expansion cfl~= `(cfl+ ,a ,b ,c) (cfl+ a (cfl+ b c)))
+    (test-cp0-expansion cfl~= `(cfl+ ,a ,b ,c ,a ,b ,c) (cfl+ (cfl+ a b c) (cfl+ a b c)))
+    (test-cp0-expansion cfl~= '(cfl+ 1+2.0i 3.0) 4.0+2.0i)
+    (test-cp0-expansion cfl~= '(cfl+ 1.0+2.2i -3.7+5.3i) -2.7+7.5i)
+    (test-cp0-expansion cfl~= '(cfl+ 1.0+2.2i -3.7) -2.7+2.2i)
+    (test-cp0-expansion cfl~= '(cfl+ 1.0 -3.7+5.3i) -2.7+5.3i)
+    (test-cp0-expansion cfl~= '(cfl+ 1.0+2.2i +5.3i) 1.0+7.5i)
+    (test-cp0-expansion cfl~= '(cfl+ +2.2i -3.7+5.3i) -3.7+7.5i)
+    (test-cp0-expansion cfl~= '(cfl+ 26.0 2.0) 28.0)
+ )
+
+(mat cfl-
+    (error? (cfl- 'a))
+    (error? (cfl- 'a 3))
+    (error? (cfl- 'a 3 4))
+    (error? (cfl-))
+    (eqv? (cfl- a) -1.1)
+    (eqv? (cfl- b) -0.0-1.1i)
+    (eqv? (cfl- c) -1.1-1.1i)
+    (eqv? (cfl- a a) zero)
+    (cfl~= (cfl- b b) zero)
+    (cfl~= (cfl- c c) zero)
+    (eqv? (cfl- c a) b)
+    (cfl~= (cfl- c b) a)
+    (cfl~= (cfl- a b c) (cfl- (cfl- a b) c))
+    (cfl~= (cfl- a b c a b c) (cfl- a (cfl+ b c a b c)))
+    (cfl~= (cfl- 1+2.0i 3.0) -2.0+2.0i)
+    (cfl~= (cfl- 1.0+2.2i -3.7+5.3i) 4.7-3.1i)
+    (cfl~= (cfl- 1.0+2.2i -3.7) 4.7+2.2i)
+    (cfl~= (cfl- 1.0 -3.7+5.3i) 4.7-5.3i)
+    (cfl~= (cfl- 1.0+2.2i +5.3i) 1.0-3.1i)
+    (cfl~= (cfl- +2.2i -3.7+5.3i) 3.7-3.1i)
+    (cfl~= (cfl- 26.0 2.0) 24.0)
+   (andmap
+     (lambda (a)
+       (andmap
+         (lambda (b)
+           (andmap
+             (lambda (c) (eqv? (cfl- a b c) (cfl- (cfl- a b) c)))
+             '(0.0 -0.0)))
+         '(0.0 -0.0)))
+     '(0.0 -0.0))
+   (let ()
+     (define-syntax ff
+       (syntax-rules ()
+         [(_ k1 k2) (lambda (x) (eqv? (cfl- k1 x k2) (cfl- (cfl- k1 x) k2)))]))
+     (andmap
+       (lambda (p) (and (p +0.0) (p -0.0)))
+       (list (ff +0.0 +0.0) (ff +0.0 -0.0) (ff -0.0 +0.0) (ff -0.0 -0.0))))
+   (error? (cfl- 3.0 5.4 'a))
+   (error? (cfl- 'a 3.0 5.4))
+   (error? (cfl- 3.0 'a 5.4))
+   (eqv? (cfl- 5.0 4.0 3.0 2.0) -4.0)
+   (eqv? (cfl- 5.0 4.0 3.0 2.0 1.0 0.0 -1.0 -2.0) -2.0)
+   (cfl~= (cfl- 1e30 1e30 7.0) -7.0)
+   
+   (test-cp0-expansion eqv? `(cfl- ,a) -1.1)
+   (test-cp0-expansion eqv? `(cfl- ,b) -0.0-1.1i)
+   (test-cp0-expansion eqv? `(cfl- ,c) -1.1-1.1i)
+   (test-cp0-expansion eqv? `(cfl- ,a ,a) zero)
+   (test-cp0-expansion cfl~= `(cfl- ,b ,b) zero)
+   (test-cp0-expansion cfl~= `(cfl- ,c ,c) zero)
+   (test-cp0-expansion eqv? `(cfl- ,c ,a) b)
+   (test-cp0-expansion cfl~= `(cfl- ,c ,b) a)
+   (test-cp0-expansion cfl~= `(cfl- ,a ,b ,c) (cfl- (cfl- a b) c))
+   (test-cp0-expansion cfl~= `(cfl- ,a ,b ,c ,a ,b ,c) (cfl- a (cfl+ b c a b c)))
+   (test-cp0-expansion cfl~= '(cfl- 1+2.0i 3.0) -2.0+2.0i)
+   (test-cp0-expansion cfl~= '(cfl- 1.0+2.2i -3.7+5.3i) 4.7-3.1i)
+   (test-cp0-expansion cfl~= '(cfl- 1.0+2.2i -3.7) 4.7+2.2i)
+   (test-cp0-expansion cfl~= '(cfl- 1.0 -3.7+5.3i) 4.7-5.3i)
+   (test-cp0-expansion cfl~= '(cfl- 1.0+2.2i +5.3i) 1.0-3.1i)
+   (test-cp0-expansion cfl~= '(cfl- +2.2i -3.7+5.3i) 3.7-3.1i)
+   (test-cp0-expansion cfl~= '(cfl- 26.0 2.0) 24.0)
+   (test-cp0-expansion eqv? '(cfl- 5.0 4.0 3.0 2.0) -4.0)
+   (test-cp0-expansion eqv? '(cfl- 5.0 4.0 3.0 2.0 1.0 0.0 -1.0 -2.0) -2.0)
+   (test-cp0-expansion cfl~= '(cfl- 1e30 1e30 7.0) -7.0)
+ )
+
+(mat cfl*
+    (error? (cfl* 'a))
+    (error? (cfl* 'a 3))
+    (error? (cfl* 'a 3 4))
+    (eqv? (cfl*) 1.0)
+    (eqv? (cfl* a) a)
+    (eqv? (cfl* b) b)
+    (eqv? (cfl* c) c)
+    (eqv? (cfl* zero a) zero)
+    (cfl~= (cfl* zero b) zero)
+    (cfl~= (cfl* zero c) zero)
+    (cfl~= (cfl* a a) aa)
+    (cfl~= (cfl* a b) ab)
+    (cfl~= (cfl* a c) ac)
+    (cfl~= (cfl* b b) bb)
+    (cfl~= (cfl* b c) bc)
+    (cfl~= (cfl* c c) cc)
+    (cfl~= (cfl* a b c) (cfl* a (cfl* b c)))
+    (cfl~= (cfl* a b c a b c) (cfl* (cfl* a b c) (cfl* a b c)))
+    (cfl~= (cfl* 1+2.0i 3.0) 3.0+6.0i)
+    (cfl~= (cfl* 1.0+2.0i 3.0+4.0i) -5.0+10.0i)
+    (cfl~= (cfl* 1.0+2.0i 3.0) 3.0+6.0i)
+    (cfl~= (cfl* -2.0 3.0+4.0i) -6.0-8.0i)
+    (cfl~= (cfl* 1.0+2.0i +4.0i) -8.0+4.0i)
+    (cfl~= (cfl* +2.0i 3.0+4.0i) -8.0+6.0i)
+    (cfl~= (cfl* 26.0 2.0) 52.0)
+    (test-cp0-expansion eqv? '(cfl*) 1.0)
+    (test-cp0-expansion eqv? `(cfl* ,a) a)
+    (test-cp0-expansion eqv? `(cfl* ,b) b)
+    (test-cp0-expansion eqv? `(cfl* ,c) c)
+    (test-cp0-expansion eqv? `(cfl* ,zero ,a) zero)
+    (test-cp0-expansion cfl~= `(cfl* ,zero ,b) zero)
+    (test-cp0-expansion cfl~= `(cfl* ,zero ,c) zero)
+    (test-cp0-expansion cfl~= `(cfl* ,a ,a) aa)
+    (test-cp0-expansion cfl~= `(cfl* ,a ,b) ab)
+    (test-cp0-expansion cfl~= `(cfl* ,a ,c) ac)
+    (test-cp0-expansion cfl~= `(cfl* ,b ,b) bb)
+    (test-cp0-expansion cfl~= `(cfl* ,b ,c) bc)
+    (test-cp0-expansion cfl~= `(cfl* ,c ,c) cc)
+    (test-cp0-expansion cfl~= `(cfl* ,a ,b ,c) (cfl* a (cfl* b c)))
+    (test-cp0-expansion cfl~= `(cfl* ,a ,b ,c ,a ,b ,c) (cfl* (cfl* a b c) (cfl* a b c)))
+    (test-cp0-expansion cfl~= '(cfl* 1+2.0i 3.0) 3.0+6.0i)
+    (test-cp0-expansion cfl~= '(cfl* 1.0+2.0i 3.0+4.0i) -5.0+10.0i)
+    (test-cp0-expansion cfl~= '(cfl* 1.0+2.0i 3.0) 3.0+6.0i)
+    (test-cp0-expansion cfl~= '(cfl* -2.0 3.0+4.0i) -6.0-8.0i)
+    (test-cp0-expansion cfl~= '(cfl* 1.0+2.0i +4.0i) -8.0+4.0i)
+    (test-cp0-expansion cfl~= '(cfl* +2.0i 3.0+4.0i) -8.0+6.0i)
+    (test-cp0-expansion cfl~= '(cfl* 26.0 2.0) 52.0)
+ )
+
+(mat cfl/
+    (error? (cfl/ 'a))
+    (error? (cfl/ 'a 3))
+    (error? (cfl/ 'a 3 4))
+    (error? (cfl/))
+    (fl~= (cfl/ a) (fl/ a))
+    (eqv? (cfl/ zero a) zero)
+    (cfl~= (cfl/ zero b) zero)
+    (cfl~= (cfl/ zero c) zero)
+    (cfl~= (cfl/ a a) 1.0)
+    (cfl~= (cfl/ b b) 1.0)
+    (cfl~= (cfl/ c c) 1.0)
+    (cfl~= (cfl/ aa a) a)
+    (cfl~= (cfl/ ab b) a)
+    (cfl~= (cfl/ ab a) b)
+    (cfl~= (cfl/ ac c) a)
+    (cfl~= (cfl/ ac a) c)
+    (cfl~= (cfl/ bc c) b)
+    (cfl~= (cfl/ bc b) c)
+    (cfl~= (cfl/ cc c) c)
+    (cfl~= (cfl/ a b c) (cfl/ (cfl/ a b) c))
+    (cfl~= (cfl/ a b c a b c) (cfl/ a (cfl* b c a b c)))
+    (cfl~= (cfl/ 3+6.0i 3.0) 1.0+2.0i)
+    (cfl~= (cfl/ -5.0+10.0i 1.0+2.0i) 3.0+4.0i)
+    (cfl~= (cfl/ -6.0-8.0i -2.0) 3.0+4.0i)
+    (cfl~= (cfl/ 26.0 3.0-2.0i) 6.0+4.0i)
+    (cfl~= (cfl/ -8.0+6.0i +2.0i) 3.0+4.0i)
+    (cfl~= (cfl/ +26.0i 3.0+2.0i) 4.0+6.0i)
+    (cfl~= (cfl/ 26.0 2.0) 13.0)
+   (andmap
+     (lambda (a)
+       (andmap
+         (lambda (b)
+           (andmap
+             (lambda (c) (eqv? (cfl/ a b c) (cfl/ (cfl/ a b) c)))
+             '(1e300 1e250)))
+         '(1e300 1e250)))
+     '(1e300 1e250))
+   (error? (cfl/ 3.0 5.4 'a))
+   (error? (cfl/ 'a 3.0 5.4))
+   (error? (cfl/ 3.0 'a 5.4))
+   (eqv? (cfl/ 16.0 2.0 -2.0 2.0) -2.0)
+   (eqv? (cfl/ 16.0 2.0 -2.0 2.0 4.0 1.0 -1.0) 0.5)
+   (test-cp0-expansion eqv? `(cfl/ ,zero ,a) zero)
+   (test-cp0-expansion eqv? '(cfl/ 16.0 2.0 -2.0 2.0) -2.0)
+   (test-cp0-expansion eqv? '(cfl/ 16.0 2.0 -2.0 2.0 4.0 1.0 -1.0) 0.5)
+   (test-cp0-expansion cfl~= `(cfl/ ,zero ,b) zero)
+   (test-cp0-expansion cfl~= `(cfl/ ,zero ,c) zero)
+   (test-cp0-expansion cfl~= `(cfl/ ,a ,a) 1.0)
+   (test-cp0-expansion cfl~= `(cfl/ ,b ,b) 1.0)
+   (test-cp0-expansion cfl~= `(cfl/ ,c ,c) 1.0)
+   (test-cp0-expansion cfl~= `(cfl/ ,aa ,a) a)
+   (test-cp0-expansion cfl~= `(cfl/ ,ab ,b) a)
+   (test-cp0-expansion cfl~= `(cfl/ ,ab ,a) b)
+   (test-cp0-expansion cfl~= `(cfl/ ,ac ,c) a)
+   (test-cp0-expansion cfl~= `(cfl/ ,ac ,a) c)
+   (test-cp0-expansion cfl~= `(cfl/ ,bc ,c) b)
+   (test-cp0-expansion cfl~= `(cfl/ ,bc ,b) c)
+   (test-cp0-expansion cfl~= `(cfl/ ,cc ,c) c)
+   (test-cp0-expansion cfl~= `(cfl/ ,a ,b ,c) (cfl/ (cfl/ a b) c))
+   (test-cp0-expansion cfl~= `(cfl/ ,a ,b ,c ,a ,b ,c) (cfl/ a (cfl* b c a b c)))
+   (test-cp0-expansion cfl~= '(cfl/ 3+6.0i 3.0) 1.0+2.0i)
+   (test-cp0-expansion cfl~= '(cfl/ -5.0+10.0i 1.0+2.0i) 3.0+4.0i)
+   (test-cp0-expansion cfl~= '(cfl/ -6.0-8.0i -2.0) 3.0+4.0i)
+   (test-cp0-expansion cfl~= '(cfl/ 26.0 3.0-2.0i) 6.0+4.0i)
+   (test-cp0-expansion cfl~= '(cfl/ -8.0+6.0i +2.0i) 3.0+4.0i)
+   (test-cp0-expansion cfl~= '(cfl/ +26.0i 3.0+2.0i) 4.0+6.0i)
+   (test-cp0-expansion cfl~= '(cfl/ 26.0 2.0) 13.0)
+ )
+
+(mat cfl=
+    (error? (cfl= 'a))
+    (error? (cfl= 'a 3))
+    (error? (cfl= 'a 3 4))
+    (error? (cfl=))
+    (cfl= a a)
+    (cfl= b b)
+    (cfl= c c)
+    (cfl= (- c c) zero)
+    (cfl= (+ a b) c)
+    (not (cfl= a b))
+    (cfl= 1.1+1.1i c)
+    (cfl= c 1.1+1.1i c)
+    (not (cfl= c 1.1+1.1i c a))
+    (not (cfl= 3+6.0i 3.0))
+    (not (cfl= 3+6.0i +6.0i))
+    (cfl= 1.0+2.0i 1.0+2.0i)
+    (cfl= 5.4 5.4)
+ )
+
diff --git a/mats/cp0.ms b/mats/cp0.ms
new file mode 100644
index 0000000..9476978
--- /dev/null
+++ b/mats/cp0.ms
@@ -0,0 +1,2889 @@
+;;; cp0.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-syntax cp0-mat
+  (syntax-rules ()
+    [(_ name form ...)
+     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+       (mat name form ...))]))
+
+(cp0-mat cp0-regression
+ ; test to keep cp0 honest about letrec's implicit assignment
+  #;(letrec ((x (call/cc (lambda (k) k)))) ; invalid in r6rs
+    (let ((y x))
+      (y (lambda (z) (not (eq? x y))))))
+ ; make sure compiler doesn't loop...
+  (begin
+    (define omega
+      (lambda ()
+        ((lambda (x) (x x)) (lambda (x) (x x)))))
+    (procedure? omega))
+ ; make sure cp0 doesn't assume read returns #t
+  (not (read (open-input-string "#f")))
+ ; test proper visiting of assigned variables
+  (letrec ((x (lambda () x)) (y (lambda () x)))
+    (set! y (y))
+    (eq? y (y)))
+ ; test proper quote propagation from seq w/side effect
+  (equal?
+    (let ((x 0))
+      (let ((y (begin (set! x (+ x 1)) 0)))
+        (let ((z (+ y 1)))
+          (list x z))))
+    '(1 1))
+ ; test that we reset integrated? flags for outer calls when we bug out of
+ ; an inner call in cases where operator of call is itself a call
+  (begin
+    (define whack! (lambda () (set! whack! 'okay)))
+    (define ignore list)
+    (letrec ([g
+              (lambda x
+                  ((lambda (x)
+                     (ignore)
+                     (when (null? x) (g #f))
+                     (lambda (y) (ignore x y y y)))
+                   (ignore (ignore ignore))))])
+      ((g) (whack!)))
+    (eq? whack! 'okay))
+ ; make sure cp0 does not go to lala land
+  (error? (letrec ((x x)) x))
+ ; make sure residual assignments to unref'd vars don's blow
+  (eq? (let ((x (void)))
+         (set! x 0)
+         (letrec ((f (lambda () (set! x (+ x 1)) x)) (g (lambda (x) x)))
+           (g 3)))
+       3)
+  (eq? (let ()
+         (define kons-proc
+           (lambda (a) (lambda (b) (lambda (g) ((g a) b)))))
+         (define-syntax kons
+           (syntax-rules () [(_ x y) ((kons-proc x) y)]))
+         (define kar (lambda (pr) (pr (lambda (a) (lambda (b) a)))))
+         (define kdr (lambda (pr) (pr (lambda (a) (lambda (b) b)))))
+         ((kar (kons (lambda (x y) (kar (kons x y)))
+                 (kons (lambda (x y) (kdr (kons x y)))
+                       (lambda (x y) (kdr (kar (kons (kons x y) 'nil)))))))
+          3 4))
+       3)
+ ; test for various bugs fixed in 5.9i, all relating to resetting an
+ ; outer context when we abort from an inner one
+  (begin
+    (define **a 1)
+    (define-syntax **huge
+      (identifier-syntax
+        (set! **output
+          (cons
+            (list (list **a **a **a **a **a **a **a **a **a **a)
+                  (list **a **a **a **a **a **a **a **a **a **a)
+                  (list **a **a **a **a **a **a **a **a **a **a)
+                  (list **a **a **a **a **a **a **a **a **a **a)
+                  (list **a **a **a **a **a **a **a **a **a **a))
+            **output))))
+    (define **test-output
+      (case-lambda
+        [(th) (**test-output 1 th)]
+        [(n th)
+         (set! **output '())
+         (and (th)
+           (equal? **output
+             (make-list n
+               '((1 1 1 1 1 1 1 1 1 1)
+                 (1 1 1 1 1 1 1 1 1 1)
+                 (1 1 1 1 1 1 1 1 1 1)
+                 (1 1 1 1 1 1 1 1 1 1)
+                 (1 1 1 1 1 1 1 1 1 1)))))]))
+    (**test-output (lambda () **huge #t)))
+  (**test-output
+    (lambda ()
+      (equal?
+        (let ((f (lambda ()
+                   (let ((x **huge))
+                     (let ((g (lambda () x)))
+                       (g) memq)))))
+          ((f) (+ 1 2) '(1 2 3 4 5)))
+        '(3 4 5))))
+  (**test-output
+    (lambda ()
+      (equal?
+        (let ((f (lambda ()
+                   (let ((x **huge))
+                     (let ((g (begin 0 (lambda () x)))) (g) memq)))))
+          ((f) (+ 1 2) '(1 2 3 4 5)))
+        '(3 4 5))))
+  (**test-output
+    (lambda ()
+      (equal?
+        (let ((f (lambda ()
+                   (let ((x **huge))
+                     (let ((g (lambda () x))) (g) (g) memq)))))
+          ((f) (+ 1 2) '(1 2 3 4 5)))
+        '(3 4 5))))
+  (**test-output
+    (lambda ()
+      (eq?
+        (let ((f (lambda () (let ((x **huge)) (lambda (y z) (or (= y 3) x))))))
+          ((f) (+ 1 2) 4))
+        #t)))
+  (**test-output 2
+    (lambda ()
+      (eq? (let ((f (lambda ()
+                      (let ((x **huge)) (lambda (y z) (or (= y 3) x))))))
+            ((f) (+ 1 2) 4)
+            ((f) (+ 1 2) 4))
+        #t)))
+  (**test-output 2
+    (lambda ()
+      (eq?
+        (let ((f (lambda ()
+                   (let ((x **huge)) (lambda (y z) (if (y z) 'ok x))))))
+          ((f) + 3)
+          ((f) + 3))
+        'ok)))
+  (eq?
+    (let ((f (lambda () (let ((x 0)) (lambda (y z) (if (y z) 'ok x))))))
+      ((f) + 3))
+    'ok)
+  (not (let ((f (lambda (x)
+             (eq? (begin (set! x 4) x)
+                  (begin (set! x 5) x)))))
+         (f 'a)))
+  (not (let ((f #f) (g #f))
+         (let ((x 0))
+           (set! g (lambda () (eq? (begin (f) x) (begin (f) x))))
+           (set! f (lambda () (set! x (+ x 1))))
+           (g))))
+  (eq? (let ([g% (lambda (cp)
+                   (let ([t1 0])
+                     (set! t1 (car cp))
+                     (let ([t2 t1]) 4)))])
+         g%
+         (g% '(0)))
+       4)
+  (error? (let ((f (lambda (x) x))) (let ((g f)) (g))))
+  (begin
+    (define $foo$
+      (letrec ((func1
+                (lambda (cont0)
+                  (cont0 'x)))) ; incorrect # args to cont0 (func3)
+         (lambda ()
+           (letrec ((func3
+                     (lambda (cont2 x)
+                       (cont2 x))))
+              (lambda ()
+                (func1 func3))))))
+    #t)
+  (error? (($foo$)))
+  (begin
+    (define $foo$
+      (letrec ((func1
+                (lambda (cont0)
+                  (cont0 list 'x)))) ; correct # args to cont0 (func3)
+         (lambda ()
+           (letrec ((func3
+                     (lambda (cont2 x)
+                       (cont2 x))))
+              (lambda ()
+                (func1 func3))))))
+    #t)
+  (equal? (($foo$)) '(x))
+ ; make sure cpletrec doesn't toss bindings for assigned variables
+  (equal?
+    (let ()
+      (define *root* '())
+      (define (init-traverse) (set! *root* 0))
+      (define (run-traverse) (traverse *root*))
+      (init-traverse))
+    (void))
+ ; make sure nested cp0 doesn't assimilate letrec bindings when
+ ; body is simple but not pure
+  ((lambda (x ls) (and (member x ls) #t))
+    (let ([x 0])
+      (letrec ([a (letrec ([b (set! x 1)]) x)]
+               [c (letrec ([d (set! x 2)]) x)])
+        (list a c)))
+    '((1 2) (2 1)))
+  ((lambda (x ls) (and (member x ls) #t))
+    (let ([x 0])
+      (letrec ([a (letrec ([b x]) (set! x 1) b)]
+               [c (letrec ([d x]) (set! x 2) d)])
+        (list a c x)))
+    '((2 0 1) (0 1 2)))
+ ; make sure (r6rs:fx+ x 0) isn't folded to (r6rs:fx+ x), since
+ ; r6rs:fx+ doesn't accept just one argument.
+  (begin
+    (define $cp0-f (let ([z 0]) (lambda (x) (r6rs:fx+ x z))))
+    (define $cp0-g (let ([z 0]) (lambda (x) (r6rs:fx* x 1))))
+    #t)
+  (eqv? ($cp0-f 17) 17)
+  (eqv? ($cp0-g 17) 17)
+  (error? ($cp0-f 'a))
+  (error? ($cp0-g 'a))
+ ; make sure cp0 isn't overeager about moving discardable but
+ ; not pure primitive calls
+  (and
+    (member
+      (let ([p (cons 1 2)])
+        (list
+          (let ([x (car p)]) (set-car! p 3) x)
+          (let ([x (car p)]) (set-car! p 4) x)))
+      '((4 1) (1 3)))
+    #t)
+  ; make sure cp0 doesn't screw up on an "almost" or pattern
+  (error? ; #f is not a number
+    (if (let ([x (eqv? (random 2) 2)]) (if x x (+ x 1))) 4 5))
+   (begin
+     (define f
+       (lambda (x)
+         (letrec ([foo (lambda (ls)
+                         (let loop ([ls ls] [rls '()])
+                           (if (null? ls)
+                               rls
+                               (loop (cdr ls) (cons (car ls) rls)))))])
+           (apply foo (list x)))))
+     #t)
+   (equal?
+     (f (list 1 2))
+     '(2 1))
+   (begin
+     (define f
+       (lambda (x)
+         (letrec ([foo (lambda (x ls)
+                         (let loop ([ls ls] [rls '()])
+                           (if (null? ls)
+                               (cons x rls)
+                               (loop (cdr ls) (cons (car ls) rls)))))])
+           (apply (begin (write 'a) foo) (begin (write 'b) 'bar) (begin (write 'c) (list x))))))
+     #t)
+   (equal?
+     (f (list 1 2))
+     '(bar 2 1))
+   ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string (lambda () (f (list 1 2))))
+    '("abc" "acb" "bac" "bca" "cab" "cba"))
+   (begin
+     (define $x 17)
+     #t)
+   ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (apply
+          (begin (write 'a) member)
+          (begin (write 'b) $x)
+          (begin (write 'c) (list (begin (write 'd) '()))))))
+    '("abcd" "acdb" "bacd" "bcda" "cdab" "cdba"))
+   ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (apply
+          (begin (write 'a) ash)
+          (begin (write 'b) $x)
+          (begin (write 'c) (list (begin (write 'd) 0))))))
+    '("abcd" "acdb" "bacd" "bcda" "cdab" "cdba"))
+   ; check to see if this turns up a missing referenced flag due to an extra
+   ; binding for p.  (missing referenced flags are presently detected only when
+   ; cpletrec is compiled with d=k, k > 0.)
+   (equal?
+     (apply (let ([p (box 0)]) (lambda () p)) '())
+     '#&0)
+   ; check for some corrected flags
+   (not (and (record-type-parent #!base-rtd) #t))
+   (error? ; invalid report specifier
+     (begin
+       (null-environment #f)
+       #t))
+   (error? ; not a source object
+     (begin
+       (source-object-bfp #f)
+       #t))
+   (error? ; not a source object
+     (begin
+       (source-object-efp #f)
+       #t))
+   (error? ; not a source object
+     (begin
+       (source-object-sfd #f)
+       #t))
+   (error? ; not a condition
+     (begin
+       (condition #f)
+       #t))
+   ; nested if optimization
+   (begin
+     (define $cp0-f
+       (lambda (x y a b c)
+         (if (if (if (if (#3%zero? (a)) #f #t) (begin (b) #t) #f)
+                 (c)
+                 #f)
+             (x)
+             (y))))
+     #t)
+   (equal?
+     (with-output-to-string
+       (lambda ()
+         ($cp0-f
+           (lambda () (printf "x\n"))
+           (lambda () (printf "y\n"))
+           (lambda () (printf "a\n") 0)
+           (lambda () (printf "b\n"))
+           (lambda () (printf "c\n") #t))))
+     "a\ny\n")
+   (equivalent-expansion?
+     (expand/optimize
+       '(lambda (x y a b c)
+          (if (if (if (if (#3%zero? (a)) #f #t) (begin (b) #t) #f)
+                  (c)
+                  #f)
+              (x)
+              (y))))
+     '(lambda (x y a b c)
+        (if (if (#3%zero? (a))
+                #f
+                (begin (b) (c)))
+            (x)
+            (y))))
+   (equivalent-expansion?
+     (expand/optimize
+       '(lambda (x y a b c)
+          (if (if (if (not (#3%zero? (a))) (begin (b) #t) #f)
+                  (c)
+                  #f)
+              (x)
+              (y))))
+     '(lambda (x y a b c)
+        (if (if (#3%zero? (a))
+                #f
+                (begin (b) (c)))
+            (x)
+            (y))))
+   (error? (apply zero? 0))
+   (error? (if (apply eof-object 1 2) 3 4))
+  ; test for folding of multiple-value primitives
+   (equivalent-expansion?
+     (expand/optimize '(lambda () (div-and-mod 7 3)))
+     '(lambda () (#3%values 2 1)))
+   (equivalent-expansion?
+     (expand/optimize '(lambda () (exact-integer-sqrt 19)))
+     '(lambda () (#3%values 4 3)))
+   (equivalent-expansion?
+     (expand/optimize
+       '(call-with-values
+          (lambda () (div-and-mod 7 3))
+          (lambda (x y) (#2%cons (* x 10) (/ y 10)))))
+     '(#2%cons 20 1/10))
+)
+
+(cp0-mat cp0-mrvs
+  (eqv? (call-with-values (lambda () (values 1 2 3)) +) 6)
+  (begin
+    (define **cwv-test
+      (lambda (out p)
+        (define x '())
+        (define pp (lambda (a) (set! x (cons a x))))
+        (and (p pp)
+             (if (procedure? out)
+                 (out (reverse x))
+                 (equal? (reverse x) out)))))
+    (**cwv-test '(1 2 2 3)
+      (lambda (pretty-print)
+        (pretty-print 1)
+        (pretty-print 2)
+        (pretty-print 2)
+        (pretty-print 3)
+        #t)))
+  (**cwv-test '(1 1 2 3)
+    (lambda (pretty-print)
+      (equal?
+        (call-with-values
+          (begin
+            (pretty-print 1)
+            (lambda () (pretty-print 2) (+ 1 2 3)))
+          (begin
+            (pretty-print 1)
+            (lambda (n) (pretty-print 3) (list n n n))))
+        '(6 6 6))))
+  (**cwv-test '(1 1 2 3)
+    (lambda (pretty-print)
+      (eqv?
+        (call-with-values
+          (begin
+            (pretty-print '1)
+            (lambda () (pretty-print '2) (values 1 2 3)))
+          (begin
+            (pretty-print '1)
+            (lambda (a b c) (pretty-print '3) (+ c b a))))
+        6)))
+  (**cwv-test '(1 1 2 3 4)
+    (lambda (pretty-print)
+      (eqv?
+        (call-with-values
+          (begin
+            (pretty-print '1)
+            (lambda ()
+              (pretty-print '2)
+              (values 1 (begin (pretty-print '3) 2) 3)))
+          (begin
+            (pretty-print '1)
+            (lambda (a b c) (pretty-print '4) (+ c b a))))
+        6)))
+  (begin
+    (define **foo (lambda () (values 'a 'b 'c)))
+    (define **bar vector)
+    (equal? (call-with-values **foo **bar) '#(a b c)))
+  (equal?
+    (call-with-values
+      (lambda () (values 1 2 3))
+      (case-lambda [(x) (list x x x)] [(a b c) (list c b a)]))
+    '(3 2 1))
+  (equal? (call-with-values (lambda () (values 1 2 3)) **bar) '#(1 2 3))
+  (**cwv-test '(1 2)
+    (lambda (pretty-print)
+      (equal?
+        (call-with-values
+          (lambda () (pretty-print '2) (values 1 2 3))
+          (begin (pretty-print '1) **bar))
+        '#(1 2 3))))
+  (**cwv-test '(1 1 2)
+    (lambda (pretty-print)
+      (equal?
+        (call-with-values
+          (begin
+            (pretty-print '1)
+            (lambda () (pretty-print '2) (values 1 2 3)))
+          (begin (pretty-print '1) **bar))
+        '#(1 2 3))))
+  (equal? (call-with-values **foo (lambda (a b c) (list c b a))) '(c b a))
+  (equal? (let ((f (lambda (a b c) (list c b a))))
+            (call-with-values **foo f))
+    '(c b a))
+  (**cwv-test '(1)
+    (lambda (pretty-print)
+      (equal? (call-with-values
+                **foo
+                (begin
+                  (pretty-print '1)
+                  (lambda (a b c) (vector c b a))))
+        '#(c b a))))
+  (**cwv-test (lambda (x) (or (equal? x '(1 2 3)) (equal? x '(2 3 4))))
+    (lambda (pretty-print)
+      (define n 1)
+      (define boof
+        (lambda ()
+          (pretty-print 3)
+          (lambda (a b c) (list c b a))))
+      (equal?
+        (call-with-values
+          (begin (pretty-print n) **foo)
+          (begin (set! n 4) (pretty-print 2) (boof)))
+        '(c b a))))
+  (**cwv-test '(1 2 3)
+    (lambda (pretty-print)
+      (define n 1)
+      (define boof
+        (lambda ()
+          (pretty-print 3)
+          (lambda (a b c) (list c b a))))
+      (equal?
+        (let* ((prod (begin (pretty-print n) **foo))
+               (csmr (begin (set! n 4) (pretty-print 2) (boof))))
+          (call-with-values prod csmr))
+        '(c b a))))
+  (**cwv-test '(2 3 4)
+    (lambda (pretty-print)
+      (define n 1)
+      (define boof
+        (lambda ()
+          (pretty-print 3)
+          (lambda (a b c) (list c b a))))
+      (equal?
+        (let* ((csmr (begin (set! n 4) (pretty-print 2) (boof)))
+               (prod (begin (pretty-print n) **foo)))
+          (call-with-values prod csmr))
+        '(c b a))))
+  (**cwv-test '(1 1)
+    (lambda (pretty-print)
+      (equal?
+        (call-with-values
+          (begin
+            (pretty-print '1)
+            **foo)
+          (begin
+            (pretty-print '1)
+            (lambda (a b c) (list c b a))))
+        '(c b a))))
+  (begin
+    (set! **a #t)
+    (equal?
+      (call-with-values
+        (lambda () (if **a (values 1) (values 1 2 3)))
+        (case-lambda [(x) (list x x x)] [(a b c) (list c b a)]))
+      '(1 1 1)))
+  (begin
+    (set! **a #f)
+    (equal?
+      (call-with-values
+        (lambda () (if **a (values 1) (values 1 2 3)))
+        (case-lambda [(x) (list x x x)] [(a b c) (list c b a)]))
+      '(3 2 1)))
+  (begin
+    (set! **a #t)
+    (equal?
+      (let ((f (lambda (a) (if **a (values 1) (values 1 2 3)))))
+        (call-with-values
+          (lambda () (f #t))
+          (case-lambda [(x) (list x x x)] [(a b c) (list c b a)])))
+      '(1 1 1)))
+  (begin
+    (set! **a #f)
+    (equal?
+      (let ((f (lambda (a) (if **a (values 1) (values 1 2 3)))))
+        (call-with-values
+          (lambda () (f #t))
+          (case-lambda [(x) (list x x x)] [(a b c) (list c b a)])))
+      '(3 2 1)))
+  (equal?
+    (call-with-values
+      (lambda ()
+        (define foo
+          (lambda (x)
+            (if (zero? x)
+                (values 1 2 3)
+                (call-with-values
+                  (lambda () (foo (- x 1)))
+                  (lambda (a b c)
+                    (values (+ a 1) (+ b a) (+ c 2)))))))
+        (call-with-values
+          (lambda () (foo 0))
+          (lambda (a b c)
+            (foo (+ a b c)))))
+      list)
+    '(7 23 15))
+  (equal?
+    (let ((f (lambda ()
+               (let loop ((n 10))
+                 (if (zero? n)
+                     call-with-values
+                     (loop (fx- n 1)))))))
+      ((f) (lambda () (values 1 2)) cons))
+    '(1 . 2))
+  (equal?
+    (let ()
+      (define (go n)
+        (let ((f (lambda ()
+                   (let loop ((n n))
+                     (if (zero? n)
+                         call-with-values
+                         (loop (fx- n 1)))))))
+          ((f) (lambda () (values 1 2)) cons)))
+      (go 1000))
+    '(1 . 2))
+  (begin
+    (define **bozo
+      (lambda (pretty-print)
+        (pretty-print '3)
+        (lambda x
+          (pretty-print 6)
+          x)))
+    (define **clown (lambda () (values 1 2 3)))
+    (**cwv-test '(3 6)
+      (lambda (pretty-print)
+        (equal?
+          (call-with-values **clown (**bozo pretty-print))
+          '(1 2 3)))))
+  (**cwv-test '(1 2)
+    (lambda (pretty-print)
+      (equal?
+        (let ((f (lambda () (pretty-print '2) (values 1 2 3))))
+          (call-with-values
+            (begin (pretty-print '1) f)
+            (lambda x x)))
+        '(1 2 3))))
+  (**cwv-test '(1 2)
+    (lambda (pretty-print)
+      (equal?
+        (let ((f (lambda () (pretty-print '2) (**foo))))
+          (call-with-values
+            (begin (pretty-print '1) f)
+            (lambda x x)))
+        '(a b c))))
+  (**cwv-test '(1 2 3 4)
+    (lambda (pretty-print)
+      (equal?
+        (let ([f
+               (lambda ()
+                 (pretty-print '2)
+                 (lambda () (pretty-print '3) (**foo)))])
+          (call-with-values
+            (begin (pretty-print '1) (f))
+            (lambda x (pretty-print 4) x)))
+        '(a b c))))
+  (**cwv-test '(1)
+    (lambda (pretty-print)
+      (equal?
+        (call-with-values
+          (begin (pretty-print '1) (lambda () (**foo)))
+          (lambda (x y z) (list y z x)))
+        '(b c a))))
+  (procedure?
+    (lambda ()
+      (define test1 (lambda () void))
+      (define test2
+        (lambda ()
+          (call-with-values test1 (lambda (tester) (tester)))))
+      (test2)))
+  (eqv?
+    (let ()
+      (define test1 (lambda (x) (values (lambda () (+ x 1)))))
+      (define test2
+        (lambda (x)
+          (let-values ([(tester) (test1 x)])
+            (tester))))
+      (test2 10))
+    11)
+)
+
+(cp0-mat apply-partial-folding
+  (test-cp0-expansion
+    '(apply fx+ '(1 2 3 4 5))
+    15)
+  (test-cp0-expansion
+    '(apply fx+ 3 x 4 '(5 7 9))
+    (if (eqv? (optimize-level) 3)
+        '(#3%fx+ 28 x)
+        '(#2%fx+ 28 x)))
+  (test-cp0-expansion
+    '(apply fx+ 3 x 4 (begin (write 'hi) '(5 7 9)))
+    (if (eqv? (optimize-level) 3)
+        '(let ([g x]) (#3%write 'hi) (#3%fx+ 28 g))
+        '(let ([g x]) (#2%write 'hi) (#2%fx+ 28 g))))
+  (test-cp0-expansion
+    '(apply fx+ 3 x 4 '(5 7 9.0))
+    (if (eqv? (optimize-level) 3)
+        '(#3%fx+ 19 x 9.0)
+        '(#2%fx+ 19 x 9.0)))
+  (test-cp0-expansion
+    `(apply apply '(,list 2 3 (4 5 6)))
+    `(',list 2 3 4 5 6))
+  (test-cp0-expansion
+    `(#3%apply #3%apply #3%+ '(1 (2 3 4)))
+    10)
+  (test-cp0-expansion
+    `(apply apply apply + 1 '(2 3 (4 5 (6 7))))
+    28)
+  (test-cp0-expansion
+    `(let ([f apply]) (f f f * 1 '(2 3 (4 5 (6)))))
+    720)
+  (test-cp0-expansion
+   `(lambda (x) (apply (lambda (prim ls) (apply prim ls)) zero? (list x)))
+   (if (eqv? (optimize-level) 3)
+       '(lambda (x) (#3%apply #3%zero? x))
+       '(lambda (x) (#2%apply #2%zero? x))))
+  (test-cp0-expansion
+   `(apply (lambda (prim ls) (apply prim ls)) zero? (list (cons 0 '())))
+   #t)
+  (test-cp0-expansion
+   `(apply (lambda (prim ls) (apply prim ls)) zero? (cons 0 '()))
+   (if (eqv? (optimize-level) 3)
+       '(#3%apply #3%zero? 0)
+       '(#2%apply #2%zero? 0)))
+)
+
+(mat expand/optimize
+  (error? (expand/optimize))
+  (error? (expand/optimize 'a 'b))
+  (error? (expand/optimize 'a 'b 'c))
+  (eqv? (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))])
+          (expand/optimize 3))
+        3)
+  (equal? (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))])
+            (expand/optimize '(#2%cdr '(3 4))))
+          ''(4))
+  (eqv? (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+          (expand/optimize ; from cp0 talk
+            '(let ([n (expt 2 10)])
+               (define even?
+                 (lambda (x) (or (zero? x) (not (odd? x)))))
+               (define odd?
+                 (lambda (x) (not (even? (- x 1)))))
+               (define f
+                 (lambda (x)
+                   (lambda (y)
+                     (lambda (z)
+                       (if (= z 0) (omega) (+ x y z))))))
+               (define omega
+                 (lambda ()
+                   ((lambda (x) (x x)) (lambda (x) (x x)))))
+               (let ([g (f 1)] [m (f n)])
+                 (let ([h
+                        (if (> ((g 2) 3) 5)
+                            (lambda (x) (+ x 1))
+                            odd?)])
+                   (h n))))))
+        1025)
+  (let ([x (parameterize ([#%$suppress-primitive-inlining #f]
+                          [run-cp0 (lambda (cp0 x) (cp0 x))]
+                          [optimize-level 3])
+             (expand/optimize ; from mwbor talk
+               '(let ()
+                  (import scheme)
+                  (define opcode-pos 27)
+                  (define src1-pos 22)
+                  (define src2-pos 0)
+                  (define dst-pos 17)
+                  (define imm-bit (ash 1 16))
+                  (define regops '((ld . 22) (add . 28)))
+                  (define immops '((addi . 28)))
+                  (define regcodes
+                    '((r0 . 0) (r1 . 1) (r2 . 2) (r3 . 3)))
+                  (define-syntax reg
+                    (syntax-rules ()
+                      [(_ r) (cdr (assq 'r regcodes))]))
+                  (define imm
+                    (lambda (n)
+                      (unless (< -32768 n 32767)
+                        (errorf 'imm "invalid immediate ~s" n))
+                      n))
+                  (define $emit!
+                    (lambda (op a1 a2 a3)
+                      (emit-word!
+                        (+ (cond
+                             [(assq op regops) =>
+                              (lambda (a)
+                                (ash (cdr a) opcode-pos))]
+                             [(assq op immops) =>
+                              (lambda (a)
+                                (+ (ash (cdr a) opcode-pos)
+                                   imm-bit))]
+                             [else
+                              (errorf 'emit
+                                "unrecognized operator ~s"
+                                op)])
+                           (ash a1 src1-pos)
+                           (ash a2 src2-pos)
+                           (ash a3 dst-pos)))))
+                  (define-syntax emit
+                    (syntax-rules ()
+                      [(_ op a1 a2 a3) ($emit! 'op a1 a2 a3)]))
+                  (set! test
+                    (lambda (r)
+                      (emit ld (reg r0) (reg r1) (reg r2))
+                      (emit addi (reg r2) 320 (reg r2))
+                      (emit add (reg r2) r (reg r2)))))))])
+    (and
+      (equivalent-expansion? x
+        '(set! test
+           (lambda (r)
+             (emit-word! 2953052161)
+             (emit-word! 3766812992)
+             (emit-word! (#3%+ 3766747136 r)))))
+      (syntax-case x ()
+        [(set! test
+           (lambda (r1)
+             (ew1! 2953052161)
+             (ew2! 3766812992)
+             (ew3! (#3%+ 3766747136 r2))))
+         (eq? #'r1 #'r2)])))
+  (let ([x (parameterize ([#%$suppress-primitive-inlining #f]
+                          [run-cp0 (lambda (cp0 x) (cp0 x))]
+                          [optimize-level 2])
+             (expand/optimize ; from mwbor talk
+               '(let ()
+                  (import scheme)
+                  (define opcode-pos 27)
+                  (define src1-pos 22)
+                  (define src2-pos 0)
+                  (define dst-pos 17)
+                  (define imm-bit (ash 1 16))
+                  (define regops '((ld . 22) (add . 28)))
+                  (define immops '((addi . 28)))
+                  (define regcodes
+                    '((r0 . 0) (r1 . 1) (r2 . 2) (r3 . 3)))
+                  (define-syntax reg
+                    (syntax-rules ()
+                      [(_ r) (cdr (assq 'r regcodes))]))
+                  (define imm
+                    (lambda (n)
+                      (unless (< -32768 n 32767)
+                        (errorf 'imm "invalid immediate ~s" n))
+                      n))
+                  (define $emit!
+                    (lambda (op a1 a2 a3)
+                      (emit-word!
+                        (+ (cond
+                             [(assq op regops) =>
+                              (lambda (a)
+                                (ash (cdr a) opcode-pos))]
+                             [(assq op immops) =>
+                              (lambda (a)
+                                (+ (ash (cdr a) opcode-pos)
+                                   imm-bit))]
+                             [else
+                              (errorf 'emit
+                                "unrecognized operator ~s"
+                                op)])
+                           (ash a1 src1-pos)
+                           (ash a2 src2-pos)
+                           (ash a3 dst-pos)))))
+                  (define-syntax emit
+                    (syntax-rules ()
+                      [(_ op a1 a2 a3) ($emit! 'op a1 a2 a3)]))
+                  (set! test
+                    (lambda (r)
+                      (emit ld (reg r0) (reg r1) (reg r2))
+                      (emit addi (reg r2) 320 (reg r2))
+                      (emit add (reg r2) r (reg r2)))))))])
+    (and
+      (equivalent-expansion? x
+        '(set! test
+           (lambda (r)
+             (emit-word! 2953052161)
+             (emit-word! 3766812992)
+             (emit-word! (#2%+ 3766747136 (#2%ash r 0))))))
+      (syntax-case x ($primitive)
+        [(set! test
+           (lambda (r1)
+             (ew1! 2953052161)
+             (ew2! 3766812992)
+             (ew3! (#2%+ 3766747136 (#2%ash r2 0)))))
+         (eq? #'r1 #'r2)])))
+ ; verify optimization of (if e s s) => (begin e s)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(lambda (x) (if e x x))))
+    '(lambda (x) e x))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(lambda (y x) (if y x x))))
+    '(lambda (y x) x))
+ ; verify optimization of (if s s #f) => s
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(lambda (x) (if x x #f))))
+    '(lambda (x) x))
+ ; verify optimization of (if s s #f) => s
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(let ()
+           (define-syntax broken-or
+             (syntax-rules ()
+               [(_) #f]
+               [(_ x y ...)
+                (let ([t x])
+                  (if t t (broken-or y ...)))]))
+           (broken-or a))))
+    'a)
+ ; verify optimization of or pattern
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y))))
+    '(lambda (x.0 y.1)
+       (if (if (#2%fx< x.0 y.1) #t (#2%fx> y.1 x.0))
+           y.1
+           x.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(lambda (x y) (if (or (fx< x y) (fx> y x)) x y))))
+    '(lambda (x y) (if (if (#2%fx< x y) #t (#2%fx> y x)) x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(let ([q #f])
+           (lambda (x y) (if (or q (fx> x y)) x y)))))
+    '(lambda (x y) (if (#2%fx> x y) x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(let ([q #t])
+           (lambda (x y) (if (or q (fx> x y)) x y)))))
+    '(lambda (x y) x))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(begin 3 4)))
+    4)
+  ; verify expansion of not pattern
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        `(not #t)))
+    #f)
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        `(not #f)))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        `(not '(a b c))))
+    #f)
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        `(let ([x 2] [y 3])
+           (not (begin (set! x (* x y)) (set! y (* x y)) 10)))))
+    `(let ([x 2] [y 3])
+       (set! x (#2%* x y))
+       (set! y (#2%* x y))
+       #f))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        `(not (let ([x 2] [y 3]) (set! x (* x y)) (set! y (* x y)) 10))))
+    `(let ([x 2])
+       (let ([y 3])
+         (set! x (#2%* x y))
+         (set! y (#2%* x y))
+         #f)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        `(if (not (or #t (futz))) 17 32)))
+    32)
+)
+
+(mat expand-output
+  (error? ; not a textual output port or #f
+    (expand-output #t))
+  (error?  ; not a textual output port or #f
+    (let-values ([(bop get) (open-bytevector-output-port)])
+      (expand-output bop)))
+  (begin
+    (define $eospam 17)
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (parameterize ([expand-output (current-output-port)] [#%$suppress-primitive-inlining #f])
+          (pretty-print (compile '(let () (import (chezscheme)) (+ 3 4 $eospam)))))))
+    (if (eqv? (optimize-level) 3)
+        "(#3%+ 3 4 $eospam)\n24\n"
+        "(#2%+ 3 4 $eospam)\n24\n"))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (parameterize ([expand-output (current-output-port)] [#%$suppress-primitive-inlining #f])
+          (pretty-print (interpret '(let () (import (chezscheme)) (+ 3 4 $eospam)))))))
+    (if (eqv? (optimize-level) 3)
+        "(#3%+ 3 4 $eospam)\n24\n"
+        "(#2%+ 3 4 $eospam)\n24\n"))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print '(eval-when (visit revisit) (define $eo-q (* 2 2))))
+        (pretty-print '(define $eo-x 3))
+        (pretty-print '(define-syntax $eo-a (identifier-syntax 5)))
+        (pretty-print '(pretty-print (vector $eo-x $eo-q (+ $eo-a 1)))))
+      'replace)
+    #t)
+  (begin
+    (define $eo-sop
+      (let ()
+        (define syntax-record-writer
+          (case-lambda
+            [() (record-writer (record-rtd #'a))]
+            [(x) (record-writer (record-rtd #'a) x)]))
+        (open-input-string
+          (with-output-to-string
+            (lambda ()
+              (parameterize ([expand-output (current-output-port)]
+                             [print-gensym #t]
+                             [optimize-level 2]
+                             [compile-file-message #f]
+                             [enable-cp0 #t]
+                             [#%$suppress-primitive-inlining #f]
+                             [syntax-record-writer (lambda (x p wr) (display "syntax-object" p))])
+                (compile-file "testfile")))))))
+    #t)
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (begin
+         (set! $eo-q (#2%* 2 2))
+         (#3%$sc-put-cte
+           'syntax-object
+           '(global . ,gensym?)
+           '*top*))))
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (eval-when (revisit)
+         (set! $eo-x 3))
+       (eval-when (visit)
+         (#3%$sc-put-cte
+           'syntax-object
+           '(global . ,gensym?)
+           '*top*))))
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (eval-when (visit)
+         (#3%$sc-put-cte
+           'syntax-object
+           ,list?
+           '*top*))))
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (eval-when (revisit)
+         (#2%pretty-print (#2%vector $eo-x $eo-q (#2%+ 5 1))))))
+  (begin (set! $eo-sop #f) #t)
+)
+
+(mat expand/optimize-output
+  (error? ; not a textual output port or #f
+    (expand/optimize-output #t))
+  (error?  ; not a textual output port or #f
+    (let-values ([(bop get) (open-bytevector-output-port)])
+      (expand/optimize-output bop)))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (parameterize ([expand/optimize-output (current-output-port)]
+                       [enable-cp0 #t]
+                       [#%$suppress-primitive-inlining #f])
+          (pretty-print (compile '(let () (import (chezscheme)) (+ 3 4 $eospam)))))))
+    (if (eqv? (optimize-level) 3)
+        "(#3%+ 7 $eospam)\n24\n"
+        "(#2%+ 7 $eospam)\n24\n"))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (parameterize ([expand/optimize-output (current-output-port)]
+                       [enable-cp0 #t]
+                       [#%$suppress-primitive-inlining #f])
+          (pretty-print (interpret '(let () (import (chezscheme)) (+ 3 4 $eospam)))))))
+    (if (eqv? (optimize-level) 3)
+        "(#3%+ 7 $eospam)\n24\n"
+        "(#2%+ 7 $eospam)\n24\n"))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print '(eval-when (visit revisit) (define $eo-q (* 2 2))))
+        (pretty-print '(define $eo-x 3))
+        (pretty-print '(define-syntax $eo-a (identifier-syntax 5)))
+        (pretty-print '(pretty-print (vector $eo-x $eo-q (+ $eo-a 1)))))
+      'replace)
+    #t)
+  (begin
+    (define $eo-sop
+      (let ()
+        (define syntax-record-writer
+          (case-lambda
+            [() (record-writer (record-rtd #'a))]
+            [(x) (record-writer (record-rtd #'a) x)]))
+        (open-input-string
+          (with-output-to-string
+            (lambda ()
+              (parameterize ([expand/optimize-output (current-output-port)]
+                             [print-gensym #t]
+                             [optimize-level 2]
+                             [compile-file-message #f]
+                             [enable-cp0 #t]
+                             [#%$suppress-primitive-inlining #f]
+                             [syntax-record-writer (lambda (x p wr) (display "syntax-object" p))])
+                (compile-file "testfile")))))))
+    #t)
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (begin
+         (set! $eo-q 4)
+         (#3%$sc-put-cte
+           'syntax-object
+           '(global . ,gensym?)
+           '*top*))))
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (eval-when (revisit)
+         (set! $eo-x 3))
+       (eval-when (visit)
+         (#3%$sc-put-cte
+           'syntax-object
+           '(global . ,gensym?)
+           '*top*))))
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (eval-when (visit)
+         (#3%$sc-put-cte
+           'syntax-object
+           ,list?
+           '*top*))))
+  (equivalent-expansion?
+    (read $eo-sop)
+    `(begin
+       (recompile-requirements () ())
+       (eval-when (revisit)
+         (#2%pretty-print (#2%vector $eo-x $eo-q 6)))))
+  (begin (set! $eo-sop #f) #t)
+)
+
+(mat cp0-partial-folding
+ ; check partial folding of +, fx+, fl+, and cfl+
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] 
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (+) (+ 3) (+ 3 4) (+ x) (+ x 0) (+ 0 x) (+ x 3)
+           (+ x 3 4) (+ 3 x 4) (+ 3 x -3) (+ 3 x 4 y 5)
+           (+ +nan.0 x 4 y 5))))
+    '(#2%list 0 3 7 (#2%+ x) (#2%+ x) (#2%+ x) (#2%+ 3 x)
+       (#2%+ 7 x) (#2%+ 7 x) (#2%+ x) (#2%+ 12 x y)
+       (begin (#2%+ x y) +nan.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (+) (+ 3) (+ 3 4) (+ x) (+ x 0) (+ 0 x) (+ x 3)
+           (+ x 3 4) (+ 3 x 4) (+ 3 x -3) (+ 3 x 4 y 5)
+           (+ +nan.0 x 4 y 5))))
+    '(#3%list 0 3 7 x x x (#3%+ 3 x)
+       (#3%+ 7 x) (#3%+ 7 x) x (#3%+ 12 x y)
+       +nan.0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fx+) (fx+ 3) (fx+ 3 4) (fx+ x) (fx+ x 0) (fx+ 0 x) (fx+ x 3)
+           (fx+ x 3 4) (fx+ 3 x 4) (fx+ 3 x -3) (fx+ 3 x 4 y 5))))
+    '(#2%list 0 3 7 (#2%fx+ x) (#2%fx+ x) (#2%fx+ x) (#2%fx+ 3 x)
+       (#2%fx+ 7 x) (#2%fx+ 7 x) (#2%fx+ x) (#2%fx+ 12 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fx+) (fx+ 3) (fx+ 3 4) (fx+ x) (fx+ x 0) (fx+ 0 x) (fx+ x 3)
+           (fx+ x 3 4) (fx+ 3 x 4) (fx+ 3 x -3) (fx+ 3 x 4 y 5))))
+    '(#3%list 0 3 7 x x x (#3%fx+ 3 x)
+       (#3%fx+ 7 x) (#3%fx+ 7 x) x (#3%fx+ 12 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fl+) (fl+ 3.0) (fl+ 3.0 4.0) (fl+ x) (fl+ x 0.0) (fl+ x -0.0) (fl+ 0.0 x) (fl+ -0.0 x) (fl+ x 3.0)
+           (fl+ x 3.0 4.0) (fl+ 3.0 x 4.0) (fl+ 3.0 x -3.0) (fl+ (truncate -.5) x (/ -inf.0)) (fl+ 3.0 x 4.0 y 5.0)
+           (fl+ 3.0 x +nan.0 y 5.0))))
+    '(#2%list 0.0 3.0 7.0 (#2%fl+ x) (#2%fl+ 0.0 x) (#2%fl+ x) (#2%fl+ 0.0 x) (#2%fl+ x) (#2%fl+ 3.0 x)
+       (#2%fl+ 7.0 x) (#2%fl+ 7.0 x) (#2%fl+ 0.0 x) (#2%fl+ x) (#2%fl+ 12.0 x y)
+       (begin (#2%fl+ x y) +nan.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fl+) (fl+ 3.0) (fl+ 3.0 4.0) (fl+ x) (fl+ x 0.0) (fl+ x -0.0) (fl+ 0.0 x) (fl+ -0.0 x) (fl+ x 3.0)
+           (fl+ x 3.0 4.0) (fl+ 3.0 x 4.0) (fl+ 3.0 x -3.0) (fl+ (truncate -.5) x (/ -inf.0)) (fl+ 3.0 x 4.0 y 5.0)
+           (fl+ 3.0 x +nan.0 y 5.0))))
+    '(#3%list 0.0 3.0 7.0 x (#3%fl+ 0.0 x) x (#3%fl+ 0.0 x) x (#3%fl+ 3.0 x)
+       (#3%fl+ 7.0 x) (#3%fl+ 7.0 x) (#3%fl+ 0.0 x) x (#3%fl+ 12.0 x y)
+       +nan.0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (cfl+) (cfl+ 3.0) (cfl+ 3.0 4.0) (cfl+ x) (cfl+ x 0.0) (cfl+ x -0.0) (cfl+ 0.0 x) (cfl+ -0.0 x) (cfl+ x 3.0)
+           (cfl+ x 3.0 4.0) (cfl+ 3.0 x 4.0) (cfl+ 3.0 x -3.0) (cfl+ (truncate -.5) x (/ -inf.0)) (cfl+ 3.0 x 4.0 y 5.0)
+           (cfl+ 3.0 x +nan.0+nan.0i y 5.0))))
+    '(#2%list 0.0 3.0 7.0 (#2%cfl+ x) (#2%cfl+ 0.0 x) (#2%cfl+ x) (#2%cfl+ 0.0 x) (#2%cfl+ x) (#2%cfl+ 3.0 x)
+       (#2%cfl+ 7.0 x) (#2%cfl+ 7.0 x) (#2%cfl+ 0.0 x) (#2%cfl+ x) (#2%cfl+ 12.0 x y)
+       (begin (#2%cfl+ x y) +nan.0+nan.0i)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (cfl+) (cfl+ 3.0) (cfl+ 3.0 4.0) (cfl+ x) (cfl+ x 0.0) (cfl+ x -0.0) (cfl+ 0.0 x) (cfl+ -0.0 x) (cfl+ x 3.0)
+           (cfl+ x 3.0 4.0) (cfl+ 3.0 x 4.0) (cfl+ 3.0 x -3.0) (cfl+ (truncate -.5) x (/ -inf.0)) (cfl+ 3.0 x 4.0 y 5.0)
+           (cfl+ 3.0 x +nan.0+nan.0i y 5.0))))
+    '(#3%list 0.0 3.0 7.0 x (#3%cfl+ 0.0 x) x (#3%cfl+ 0.0 x) x (#3%cfl+ 3.0 x)
+       (#3%cfl+ 7.0 x) (#3%cfl+ 7.0 x) (#3%cfl+ 0.0 x) x (#3%cfl+ 12.0 x y)
+       +nan.0+nan.0i))
+
+ ; check partial folding of *, fx*, fl*, and cfl*
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (*) (* 3) (* 3 4) (* x) (* x 1) (* 1 x) (* x 3)
+           (* x 3 4) (* 3 x 4) (* 3 x 1/3) (* 3 x 4 y 5)
+           (* 3 x 0 y 5))))
+    '(#2%list 1 3 12 (#2%* x) (#2%* x) (#2%* x) (#2%* 3 x)
+       (#2%* 12 x) (#2%* 12 x) (#2%* x) (#2%* 60 x y)
+       (begin (#2%* x y) 0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (*) (* 3) (* 3 4) (* x) (* x 1) (* 1 x) (* x 3)
+           (* x 3 4) (* 3 x 4) (* 3 x 1/3) (* 3 x 4 y 5)
+           (* 3 x 0 y 5))))
+    '(#3%list 1 3 12 x x x (#3%* 3 x)
+       (#3%* 12 x) (#3%* 12 x) x (#3%* 60 x y)
+       0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fx*) (fx* 3) (fx* 3 4) (fx* x) (fx* x 1) (fx* 1 x) (fx* x 3)
+           (fx* x 3 4) (fx* 3 x 4) (fx* 1 x 1) (fx* 3 x 4 y 5)
+           (fx* 3 x 0 y 5))))
+    '(#2%list 1 3 12 (#2%fx* x) (#2%fx* x) (#2%fx* x) (#2%fx* 3 x)
+       (#2%fx* 12 x) (#2%fx* 12 x) (#2%fx* x) (#2%fx* 60 x y)
+       (begin (#2%fx* x y) 0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fx*) (fx* 3) (fx* 3 4) (fx* x) (fx* x 1) (fx* 1 x) (fx* x 3)
+           (fx* x 3 4) (fx* 3 x 4) (fx* 1 x 1) (fx* 3 x 4 y 5)
+           (fx* 3 x 0 y 5))))
+    '(#3%list 1 3 12 x x x (#3%fx* 3 x)
+       (#3%fx* 12 x) (#3%fx* 12 x) x (#3%fx* 60 x y)
+       0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fl*) (fl* 3.0) (fl* 3.0 4.0) (fl* x) (fl* x 1.0) (fl* 1.0 x) (fl* x 3.0)
+           (fl* x 3.0 4.0) (fl* 3.0 x 4.0) (fl* 3.0 x #i1/3) (fl* 3.0 x 4.0 y 5.0)
+           (fl* 3.0 x 4.0 y +nan.0))))
+    '(#2%list 1.0 3.0 12.0 (#2%fl* x) (#2%fl* x) (#2%fl* x) (#2%fl* 3.0 x)
+       (#2%fl* 12.0 x) (#2%fl* 12.0 x) (#2%fl* x) (#2%fl* 60.0 x y)
+       (begin (#2%fl* x y) +nan.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fl*) (fl* 3.0) (fl* 3.0 4.0) (fl* x) (fl* x 1.0) (fl* 1.0 x) (fl* x 3.0)
+           (fl* x 3.0 4.0) (fl* 3.0 x 4.0) (fl* 3.0 x #i1/3) (fl* 3.0 x 4.0 y 5.0)
+           (fl* 3.0 x 4.0 y +nan.0))))
+    '(#3%list 1.0 3.0 12.0 x x x (#3%fl* 3.0 x)
+       (#3%fl* 12.0 x) (#3%fl* 12.0 x) x (#3%fl* 60.0 x y)
+       +nan.0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (cfl*) (cfl* 3.0) (cfl* 3.0 4.0) (cfl* x) (cfl* x 1.0) (cfl* 1.0 x) (cfl* x 3.0)
+           (cfl* x 3.0 4.0) (cfl* 3.0 x 4.0) (cfl* 3.0 x #i1/3) (cfl* 3.0 x 4.0 y 5.0)
+           (cfl* 3.0 x 4.0 y +nan.0+nan.0i))))
+    '(#2%list 1.0 3.0 12.0 (#2%cfl* x) (#2%cfl* x) (#2%cfl* x) (#2%cfl* 3.0 x)
+       (#2%cfl* 12.0 x) (#2%cfl* 12.0 x) (#2%cfl* x) (#2%cfl* 60.0 x y)
+       (begin (#2%cfl* x y) +nan.0+nan.0i)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (cfl*) (cfl* 3.0) (cfl* 3.0 4.0) (cfl* x) (cfl* x 1.0) (cfl* 1.0 x) (cfl* x 3.0)
+           (cfl* x 3.0 4.0) (cfl* 3.0 x 4.0) (cfl* 3.0 x #i1/3) (cfl* 3.0 x 4.0 y 5.0)
+           (cfl* 3.0 x 4.0 y +nan.0+nan.0i))))
+    '(#3%list 1.0 3.0 12.0 x x x (#3%cfl* 3.0 x)
+       (#3%cfl* 12.0 x) (#3%cfl* 12.0 x) x (#3%cfl* 60.0 x y)
+       +nan.0+nan.0i))
+
+ ; check partial folding of -, fx-, fl-, and cfl-
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (- 3) (- 3 4) (- x) (- x 0) (- 0 x) (- x 3) (- x 3 4)
+           (- 3 x 4) (- 3 x 3) (- x 3 -3) (- 4 x 3 -3) (- 3 x 4 y 5))))
+    '(#2%list -3 -1 (#2%- x) (#2%- x 0) (#2%- x) (#2%- x 3) (#2%- x 3 4) (#2%- 3 x 4)
+       (#2%- 3 x 3) (#2%- x 3 -3) (#2%- 4 x 3 -3) (#2%- 3 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (- 3) (- 3 4) (- x) (- x 0) (- 0 x) (- x 3) (- x 3 4)
+           (- 3 x 4) (- 3 x 3) (- x 3 -3) (- 4 x 3 -3) (- 3 x 4 y 5))))
+    '(#3%list -3 -1 (#3%- x) (#3%- x 0) (#3%- x) (#3%- x 3) (#3%- x 3 4) (#3%- 3 x 4)
+       (#3%- 3 x 3) (#3%- x 3 -3) (#3%- 4 x 3 -3) (#3%- 3 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fx- 3) (fx- 3 4) (fx- x) (fx- x 0) (fx- 0 x) (fx- x 3) (fx- x 3 4)
+           (fx- 3 x 4) (fx- 3 x 3) (fx- x 3 -3) (fx- 4 x 3 -3) (fx- 3 x 4 y 5))))
+    '(#2%list -3 -1 (#2%fx- x) (#2%fx- x 0) (#2%fx- x) (#2%fx- x 3) (#2%fx- x 3 4) (#2%fx- 3 x 4)
+       (#2%fx- 3 x 3) (#2%fx- x 3 -3) (#2%fx- 4 x 3 -3) (#2%fx- 3 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fx- 3) (fx- 3 4) (fx- x) (fx- x 0) (fx- 0 x) (fx- x 3) (fx- x 3 4)
+           (fx- 3 x 4) (fx- 3 x 3) (fx- x 3 -3) (fx- 4 x 3 -3) (fx- 3 x 4 y 5))))
+    '(#3%list -3 -1 (#3%fx- x) (#3%fx- x 0) (#3%fx- x) (#3%fx- x 3) (#3%fx- x 3 4) (#3%fx- 3 x 4)
+       (#3%fx- 3 x 3) (#3%fx- x 3 -3) (#3%fx- 4 x 3 -3) (#3%fx- 3 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fl- 3.0) (fl- 3.0 4.0) (fl- x) (fl- x 0.0) (fl- x -0.0) (fl- 0.0 x) (fl- -0.0 x) (fl- x 3.0) (fl- x 3.0 4.0)
+           (fl- 3.0 x 4.0) (fl- 3.0 x 3.0) (fl- -0.0 x 0.0) (fl- x 3.0 -3.0) (fl- x 0.0 y) (fl- x -0.0 3.0) (fl- 4.0 x 3.0 -3.0)
+           (fl- 3.0 x 4.0 y 5.0))))
+    '(#2%list -3.0 -1.0 (#2%fl- x) (#2%fl- x 0.0) (#2%fl- x -0.0) (#2%fl- 0.0 x) (#2%fl- x) (#2%fl- x 3.0)
+       (#2%fl- x 3.0 4.0) (#2%fl- 3.0 x 4.0) (#2%fl- 3.0 x 3.0) (#2%fl- -0.0 x 0.0) (#2%fl- x 3.0 -3.0)
+       (#2%fl- x 0.0 y) (#2%fl- x -0.0 3.0) (#2%fl- 4.0 x 3.0 -3.0) (#2%fl- 3.0 x 4.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fl- 3.0) (fl- 3.0 4.0) (fl- x) (fl- x 0.0) (fl- x -0.0) (fl- 0.0 x) (fl- -0.0 x) (fl- x 3.0) (fl- x 3.0 4.0)
+           (fl- 3.0 x 4.0) (fl- 3.0 x 3.0) (fl- -0.0 x 0.0) (fl- x 3.0 -3.0) (fl- x 0.0 y) (fl- x -0.0 3.0) (fl- 4.0 x 3.0 -3.0)
+           (fl- 3.0 x 4.0 y 5.0))))
+    '(#3%list -3.0 -1.0 (#3%fl- x) (#3%fl- x 0.0) (#3%fl- x -0.0) (#3%fl- 0.0 x) (#3%fl- x) (#3%fl- x 3.0)
+       (#3%fl- x 3.0 4.0) (#3%fl- 3.0 x 4.0) (#3%fl- 3.0 x 3.0) (#3%fl- -0.0 x 0.0) (#3%fl- x 3.0 -3.0)
+       (#3%fl- x 0.0 y) (#3%fl- x -0.0 3.0) (#3%fl- 4.0 x 3.0 -3.0) (#3%fl- 3.0 x 4.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (cfl- 3.0) (cfl- 3.0 4.0) (cfl- x) (cfl- x 0.0) (cfl- x -0.0) (cfl- 0.0 x) (cfl- -0.0 x) (cfl- x 3.0) (cfl- x 3.0 4.0)
+           (cfl- 3.0 x 4.0) (cfl- 3.0 x 3.0) (cfl- -0.0 x 0.0) (cfl- x 3.0 -3.0) (cfl- x 0.0 y) (cfl- x -0.0 3.0) (cfl- 4.0 x 3.0 -3.0)
+           (cfl- 3.0 x 4.0 y 5.0))))
+    '(#2%list
+       -3.0 -1.0 (#2%cfl- x) (#2%cfl- x 0.0) (#2%cfl- x -0.0) (#2%cfl- 0.0 x) (#2%cfl- x) (#2%cfl- x 3.0) (#2%cfl- x 3.0 4.0)
+       (#2%cfl- 3.0 x 4.0) (#2%cfl- 3.0 x 3.0) (#2%cfl- -0.0 x 0.0) (#2%cfl- x 3.0 -3.0) (#2%cfl- x 0.0 y) (#2%cfl- x -0.0 3.0) (#2%cfl- 4.0 x 3.0 -3.0)
+       (#2%cfl- 3.0 x 4.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (cfl- 3.0) (cfl- 3.0 4.0) (cfl- x) (cfl- x 0.0) (cfl- x -0.0) (cfl- 0.0 x) (cfl- -0.0 x) (cfl- x 3.0) (cfl- x 3.0 4.0)
+           (cfl- 3.0 x 4.0) (cfl- 3.0 x 3.0) (cfl- -0.0 x 0.0) (cfl- x 3.0 -3.0) (cfl- x 0.0 y) (cfl- x -0.0 3.0) (cfl- 4.0 x 3.0 -3.0)
+           (cfl- 3.0 x 4.0 y 5.0))))
+    '(#3%list
+       -3.0 -1.0 (#3%cfl- x) (#3%cfl- x 0.0) (#3%cfl- x -0.0) (#3%cfl- 0.0 x) (#3%cfl- x) (#3%cfl- x 3.0) (#3%cfl- x 3.0 4.0)
+       (#3%cfl- 3.0 x 4.0) (#3%cfl- 3.0 x 3.0) (#3%cfl- -0.0 x 0.0) (#3%cfl- x 3.0 -3.0) (#3%cfl- x 0.0 y) (#3%cfl- x -0.0 3.0) (#3%cfl- 4.0 x 3.0 -3.0)
+       (#3%cfl- 3.0 x 4.0 y 5.0)))
+
+ ; check partial folding of /, fx/, fl/, and cfl/
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (/ 3) (/ 9 4) (/ x) (/ x 1) (/ 1 x) (/ x 3) (/ x 3 4)
+           (/ 9 x 4) (/ 3 x 3) (/ x 3 1/3) (/ 4 x 3 1/3) (/ 50 x 4 y 5))))
+    '(#2%list
+       1/3 9/4 (#2%/ x) (#2%/ x 1) (#2%/ x) (#2%/ x 3) (#2%/ x 3 4)
+       (#2%/ 9 x 4) (#2%/ 3 x 3) (#2%/ x 3 1/3) (#2%/ 4 x 3 1/3) (#2%/ 50 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (/ 3) (/ 9 4) (/ x) (/ x 1) (/ 1 x) (/ x 3) (/ x 3 4)
+           (/ 9 x 4) (/ 3 x 3) (/ x 3 1/3) (/ 4 x 3 1/3) (/ 50 x 4 y 5))))
+    '(#3%list
+       1/3 9/4 (#3%/ x) (#3%/ x 1) (#3%/ x) (#3%/ x 3) (#3%/ x 3 4)
+       (#3%/ 9 x 4) (#3%/ 3 x 3) (#3%/ x 3 1/3) (#3%/ 4 x 3 1/3) (#3%/ 50 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fx/ 3) (fx/ 9 4) (fx/ x) (fx/ x 1) (fx/ 1 x) (fx/ x 3) (fx/ x 3 4)
+           (fx/ 9 x 4) (fx/ 1 x 1) (fx/ x 1 1) (fx/ 4 x 1 1) (fx/ 50 x 4 y 5))))
+    '(#2%list
+       0 2 (#2%fx/ x) (#2%fx/ x 1) (#2%fx/ x) (#2%fx/ x 3) (#2%fx/ x 3 4)
+       (#2%fx/ 9 x 4) (#2%fx/ 1 x 1) (#2%fx/ x 1 1) (#2%fx/ 4 x 1 1) (#2%fx/ 50 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fx/ 3) (fx/ 9 4) (fx/ x) (fx/ x 1) (fx/ 1 x) (fx/ x 3) (fx/ x 3 4)
+           (fx/ 9 x 4) (fx/ 1 x 1) (fx/ x 1 1) (fx/ 4 x 1 1) (fx/ 50 x 4 y 5))))
+    '(#3%list
+       0 2 (#3%fx/ x) (#3%fx/ x 1) (#3%fx/ x) (#3%fx/ x 3) (#3%fx/ x 3 4)
+       (#3%fx/ 9 x 4) (#3%fx/ 1 x 1) (#3%fx/ x 1 1) (#3%fx/ 4 x 1 1) (#3%fx/ 50 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fxquotient 3) (fxquotient 9 4) (fxquotient x) (fxquotient x 1) (fxquotient 1 x) (fxquotient x 3) (fxquotient x 3 4)
+           (fxquotient 9 x 4) (fxquotient 1 x 1) (fxquotient x 1 1) (fxquotient 4 x 1 1) (fxquotient 50 x 4 y 5))))
+    '(#2%list
+       0 2 (#2%fxquotient x) (#2%fxquotient x 1) (#2%fxquotient x) (#2%fxquotient x 3) (#2%fxquotient x 3 4)
+       (#2%fxquotient 9 x 4) (#2%fxquotient 1 x 1) (#2%fxquotient x 1 1) (#2%fxquotient 4 x 1 1) (#2%fxquotient 50 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fxquotient 3) (fxquotient 9 4) (fxquotient x) (fxquotient x 1) (fxquotient 1 x) (fxquotient x 3) (fxquotient x 3 4)
+           (fxquotient 9 x 4) (fxquotient 1 x 1) (fxquotient x 1 1) (fxquotient 4 x 1 1) (fxquotient 50 x 4 y 5))))
+    '(#3%list
+       0 2 (#3%fxquotient x) (#3%fxquotient x 1) (#3%fxquotient x) (#3%fxquotient x 3) (#3%fxquotient x 3 4)
+       (#3%fxquotient 9 x 4) (#3%fxquotient 1 x 1) (#3%fxquotient x 1 1) (#3%fxquotient 4 x 1 1) (#3%fxquotient 50 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fl/ 2.0) (fl/ 9.0 4.0) (fl/ x) (fl/ x 1.0) (fl/ 1.0 x) (fl/ x 3.0) (fl/ x 3.0 4.0)
+           (fl/ 9.0 x 4.0) (fl/ 3.0 x 3.0) (fl/ x 2.0 .5) (fl/ 4.0 x 2.0 .5)
+           (fl/ 50.0 x 4.0 y 5.0))))
+    '(#2%list
+       .5 2.25 (#2%fl/ x) (#2%fl/ x 1.0) (#2%fl/ x) (#2%fl/ x 3.0) (#2%fl/ x 3.0 4.0)
+       (#2%fl/ 9.0 x 4.0) (#2%fl/ 3.0 x 3.0) (#2%fl/ x 2.0 .5) (#2%fl/ 4.0 x 2.0 .5)
+       (#2%fl/ 50.0 x 4.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fl/ 2.0) (fl/ 9.0 4.0) (fl/ x) (fl/ x 1.0) (fl/ 1.0 x) (fl/ x 3.0) (fl/ x 3.0 4.0)
+           (fl/ 9.0 x 4.0) (fl/ 3.0 x 3.0) (fl/ x 2.0 .5) (fl/ 4.0 x 2.0 .5)
+           (fl/ 50.0 x 4.0 y 5.0))))
+    '(#3%list
+       .5 2.25 (#3%fl/ x) (#3%fl/ x 1.0) (#3%fl/ x) (#3%fl/ x 3.0) (#3%fl/ x 3.0 4.0)
+       (#3%fl/ 9.0 x 4.0) (#3%fl/ 3.0 x 3.0) (#3%fl/ x 2.0 .5) (#3%fl/ 4.0 x 2.0 .5)
+       (#3%fl/ 50.0 x 4.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (cfl/ 2.0) (cfl/ 9.0 4.0) (cfl/ x) (cfl/ x 1.0) (cfl/ 1.0 x) (cfl/ x 3.0) (cfl/ x 3.0 4.0)
+           (cfl/ 9.0 x 4.0) (cfl/ 3.0 x 3.0) (cfl/ x 2.0 .5) (cfl/ 4.0 x 2.0 .5)
+           (cfl/ 50.0 x 4.0 y 5.0))))
+    '(#2%list
+       .5 2.25 (#2%cfl/ x) (#2%cfl/ x 1.0) (#2%cfl/ x) (#2%cfl/ x 3.0) (#2%cfl/ x 3.0 4.0)
+       (#2%cfl/ 9.0 x 4.0) (#2%cfl/ 3.0 x 3.0) (#2%cfl/ x 2.0 .5) (#2%cfl/ 4.0 x 2.0 .5)
+       (#2%cfl/ 50.0 x 4.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (cfl/ 2.0) (cfl/ 9.0 4.0) (cfl/ x) (cfl/ x 1.0) (cfl/ 1.0 x) (cfl/ x 3.0) (cfl/ x 3.0 4.0)
+           (cfl/ 9.0 x 4.0) (cfl/ 3.0 x 3.0) (cfl/ x 2.0 .5) (cfl/ 4.0 x 2.0 .5)
+           (cfl/ 50.0 x 4.0 y 5.0))))
+    '(#3%list
+       .5 2.25 (#3%cfl/ x) (#3%cfl/ x 1.0) (#3%cfl/ x) (#3%cfl/ x 3.0) (#3%cfl/ x 3.0 4.0)
+       (#3%cfl/ 9.0 x 4.0) (#3%cfl/ 3.0 x 3.0) (#3%cfl/ x 2.0 .5) (#3%cfl/ 4.0 x 2.0 .5)
+       (#3%cfl/ 50.0 x 4.0 y 5.0)))
+
+ ; check partial folding of #{2,3}%{fx,}log{and,or,xor}
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (logand)
+           (logand -1) (logand 0) (logand 7)
+           (logand 5 0) (logand 0 5) (logand 5 -1) (logand -1 x) (logand x 0) (logand 5 3) (logand 5 x) (logand x y)
+           (logand 5 0 3) (logand 5 7 -1 6) (logand x -1 y) (logand 13 x 7 y) (logand 13 x 7 0 y) (logand 13 x 7 -1 y))))
+    '(#2%list
+       -1
+       -1 0 7
+       0 0 5 (#2%logand x) (begin (#2%logand x) 0) 1 (#2%logand 5 x) (#2%logand x y)
+       0 4 (#2%logand x y) (#2%logand 5 x y) (begin (#2%logand x y) 0) (#2%logand 5 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (logand)
+           (logand -1) (logand 0) (logand 7)
+           (logand 5 0) (logand 0 5) (logand 5 -1) (logand -1 x) (logand x 0) (logand 5 3) (logand 5 x) (logand x y)
+           (logand 5 0 3) (logand 5 7 -1 6) (logand x -1 y) (logand 13 x 7 y) (logand 13 x 7 0 y) (logand 13 x 7 -1 y))))
+    '(#3%list
+       -1
+       -1 0 7
+       0 0 5 x 0 1 (#3%logand 5 x) (#3%logand x y)
+       0 4 (#3%logand x y) (#3%logand 5 x y) 0 (#3%logand 5 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fxlogand)
+           (fxlogand -1) (fxlogand 0) (fxlogand 7)
+           (fxlogand 5 0) (fxlogand 0 5) (fxlogand 5 -1) (fxlogand -1 x) (fxlogand x 0) (fxlogand 5 3) (fxlogand 5 x) (fxlogand x y)
+           (fxlogand 5 0 3) (fxlogand 5 7 -1 6) (fxlogand x -1 y) (fxlogand 13 x 7 y) (fxlogand 13 x 7 0 y) (fxlogand 13 x 7 -1 y))))
+    '(#2%list
+       -1
+       -1 0 7
+       0 0 5 (#2%fxlogand x) (begin (#2%fxlogand x) 0) 1 (#2%fxlogand 5 x) (#2%fxlogand x y)
+       0 4 (#2%fxlogand x y) (#2%fxlogand 5 x y) (begin (#2%fxlogand x y) 0) (#2%fxlogand 5 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fxlogand)
+           (fxlogand -1) (fxlogand 0) (fxlogand 7)
+           (fxlogand 5 0) (fxlogand 0 5) (fxlogand 5 -1) (fxlogand -1 x) (fxlogand x 0) (fxlogand 5 3) (fxlogand 5 x) (fxlogand x y)
+           (fxlogand 5 0 3) (fxlogand 5 7 -1 6) (fxlogand x -1 y) (fxlogand 13 x 7 y) (fxlogand 13 x 7 0 y) (fxlogand 13 x 7 -1 y))))
+    '(#3%list
+       -1
+       -1 0 7
+       0 0 5 x 0 1 (#3%fxlogand 5 x) (#3%fxlogand x y)
+       0 4 (#3%fxlogand x y) (#3%fxlogand 5 x y) 0 (#3%fxlogand 5 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fxlogor)
+           (fxlogor -1) (fxlogor 0) (fxlogor 7)
+           (fxlogor 5 0) (fxlogor 0 5) (fxlogor 5 -1) (fxlogor -1 x) (fxlogor x 0) (fxlogor 5 3) (fxlogor 5 x) (fxlogor x y)
+           (fxlogor 5 0 3) (fxlogor 5 7 -1 6) (fxlogor x 0 y) (fxlogor 13 x 7 y) (fxlogor 13 x 7 -1 y) (fxlogor 13 x 7 0 y))))
+    '(#2%list
+       0
+       -1 0 7
+       5 5 -1 (begin (#2%fxlogor x) -1) (#2%fxlogor x) 7 (#2%fxlogor 5 x) (#2%fxlogor x y)
+       7 -1 (#2%fxlogor x y) (#2%fxlogor 15 x y) (begin (#2%fxlogor x y) -1) (#2%fxlogor 15 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fxlogor)
+           (fxlogor -1) (fxlogor 0) (fxlogor 7)
+           (fxlogor 5 0) (fxlogor 0 5) (fxlogor 5 -1) (fxlogor -1 x) (fxlogor x 0) (fxlogor 5 3) (fxlogor 5 x) (fxlogor x y)
+           (fxlogor 5 0 3) (fxlogor 5 7 -1 6) (fxlogor x 0 y) (fxlogor 13 x 7 y) (fxlogor 13 x 7 -1 y) (fxlogor 13 x 7 0 y))))
+    '(#3%list
+       0
+       -1 0 7
+       5 5 -1 -1 x 7 (#3%fxlogor 5 x) (#3%fxlogor x y)
+       7 -1 (#3%fxlogor x y) (#3%fxlogor 15 x y) -1 (#3%fxlogor 15 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (logor)
+           (logor -1) (logor 0) (logor 7)
+           (logor 5 0) (logor 0 5) (logor 5 -1) (logor -1 x) (logor x 0) (logor 5 3) (logor 5 x) (logor x y)
+           (logor 5 0 3) (logor 5 7 -1 6) (logor x 0 y) (logor 13 x 7 y) (logor 13 x 7 -1 y) (logor 13 x 7 0 y))))
+    '(#2%list
+       0
+       -1 0 7
+       5 5 -1 (begin (#2%logor x) -1) (#2%logor x) 7 (#2%logor 5 x) (#2%logor x y)
+       7 -1 (#2%logor x y) (#2%logor 15 x y) (begin (#2%logor x y) -1) (#2%logor 15 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (logor)
+           (logor -1) (logor 0) (logor 7)
+           (logor 5 0) (logor 0 5) (logor 5 -1) (logor -1 x) (logor x 0) (logor 5 3) (logor 5 x) (logor x y)
+           (logor 5 0 3) (logor 5 7 -1 6) (logor x 0 y) (logor 13 x 7 y) (logor 13 x 7 -1 y) (logor 13 x 7 0 y))))
+    '(#3%list
+       0
+       -1 0 7
+       5 5 -1 -1 x 7 (#3%logor 5 x) (#3%logor x y)
+       7 -1 (#3%logor x y) (#3%logor 15 x y) -1 (#3%logor 15 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (logxor)
+           (logxor -1) (logxor 0) (logxor 7)
+           (logxor 5 0) (logxor 0 5) (logxor 5 -1) (logxor -1 x) (logxor x 0) (logxor 5 3) (logxor 5 x) (logxor x y)
+           (logxor 5 0 3) (logxor 5 7 -1 6) (logxor x 0 y) (logxor 13 x 7 y) (logxor 13 x 7 -1 y) (logxor 13 x 7 0 y))))
+    '(#2%list
+       0
+       -1 0 7
+       5 5 -6 (#2%logxor -1 x) (#2%logxor x) 6 (#2%logxor 5 x) (#2%logxor x y)
+       6 -5 (#2%logxor x y) (#2%logxor 10 x y) (#2%logxor -11 x y) (#2%logxor 10 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (logxor)
+           (logxor -1) (logxor 0) (logxor 7)
+           (logxor 5 0) (logxor 0 5) (logxor 5 -1) (logxor -1 x) (logxor x 0) (logxor 5 3) (logxor 5 x) (logxor x y)
+           (logxor 5 0 3) (logxor 5 7 -1 6) (logxor x 0 y) (logxor 13 x 7 y) (logxor 13 x 7 -1 y) (logxor 13 x 7 0 y))))
+    '(#3%list
+       0
+       -1 0 7
+       5 5 -6 (#3%logxor -1 x) x 6 (#3%logxor 5 x) (#3%logxor x y)
+       6 -5 (#3%logxor x y) (#3%logxor 10 x y) (#3%logxor -11 x y) (#3%logxor 10 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fxlogxor)
+           (fxlogxor -1) (fxlogxor 0) (fxlogxor 7)
+           (fxlogxor 5 0) (fxlogxor 0 5) (fxlogxor 5 -1) (fxlogxor -1 x) (fxlogxor x 0) (fxlogxor 5 3) (fxlogxor 5 x) (fxlogxor x y)
+           (fxlogxor 5 0 3) (fxlogxor 5 7 -1 6) (fxlogxor x 0 y) (fxlogxor 13 x 7 y) (fxlogxor 13 x 7 -1 y) (fxlogxor 13 x 7 0 y))))
+    '(#2%list
+       0
+       -1 0 7
+       5 5 -6 (#2%fxlogxor -1 x) (#2%fxlogxor x) 6 (#2%fxlogxor 5 x) (#2%fxlogxor x y)
+       6 -5 (#2%fxlogxor x y) (#2%fxlogxor 10 x y) (#2%fxlogxor -11 x y) (#2%fxlogxor 10 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fxlogxor)
+           (fxlogxor -1) (fxlogxor 0) (fxlogxor 7)
+           (fxlogxor 5 0) (fxlogxor 0 5) (fxlogxor 5 -1) (fxlogxor -1 x) (fxlogxor x 0) (fxlogxor 5 3) (fxlogxor 5 x) (fxlogxor x y)
+           (fxlogxor 5 0 3) (fxlogxor 5 7 -1 6) (fxlogxor x 0 y) (fxlogxor 13 x 7 y) (fxlogxor 13 x 7 -1 y) (fxlogxor 13 x 7 0 y))))
+    '(#3%list
+       0
+       -1 0 7
+       5 5 -6 (#3%fxlogxor -1 x) x 6 (#3%fxlogxor 5 x) (#3%fxlogxor x y)
+       6 -5 (#3%fxlogxor x y) (#3%fxlogxor 10 x y) (#3%fxlogxor -11 x y) (#3%fxlogxor 10 x y)))
+)
+
+(mat cp0-apply
+  (begin
+    (define $permutations
+      (rec permutations
+        (lambda (x*)
+          (if (null? x*)
+              '()
+              (if (null? (cdr x*))
+                  (list x*)
+                  (let f ([x* x*] [rx* '()])
+                    (if (null? x*)
+                        '()
+                        (append
+                          (map (lambda (ls) (cons (car x*) ls)) (permutations (append (cdr x*) rx*)))
+                          (f (cdr x*) (cons (car x*) rx*))))))))))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply (lambda () 7) '())))
+    '7)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%+ x y z)) '(3 4 5))))
+    '12)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%+ x y z)) (#%list 3 4 5))))
+    '12)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply
+           (lambda (x y z) (#%+ (begin (#%write 'a) x) y z))
+           (#%list e1 e2 e3))))
+    (if (= (optimize-level) 3)
+        '(let ([x e1] [y e2] [z e3])
+           (#3%+ (begin (#3%write 'a) x) y z))
+        '(let ([x e1] [y e2] [z e3])
+           (#2%+ (begin (#2%write 'a) x) y z))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply #%+ '(1 2 3 4))))
+    '10)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply #%+ (#%list 1 2 3 4))))
+    '10)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(lambda (x) (#%apply #%+ (#%list 1 2 x 4)))))
+    (if (= (optimize-level) 3)
+        '(lambda (x) (#3%+ 7 x))
+        '(lambda (x) (#2%+ 7 x))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%+ x y z)) (#%list e1 e2 e3))))
+    (if (= (optimize-level) 3)
+        '(#3%+ e1 e2 e3)
+        '(#2%+ e1 e2 e3)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply #%+ (#%list 1 (begin (#%write 'a) 2) 3))))
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) 6)
+        '(begin (#2%write 'a) 6)))
+  (let ([expr (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+                (expand/optimize
+                  '(#%apply (begin (#%write 'a) #%+)
+                     (begin (#%write 'b) 4)
+                     (begin
+                       (#%write 'c)
+                       (#%list
+                         1
+                         (begin (#%write 'd) 2)
+                         (begin (#%write 'e) 3))))))])
+    (ormap
+      (lambda (groups) (equivalent-expansion? expr `(begin ,@(apply append groups) 10)))
+      ($permutations
+        (if (= (optimize-level) 3)
+            '(((#3%write 'a)) ((#3%write 'b)) ((#3%write 'c) (#3%write 'd) (#3%write 'e)))
+            '(((#2%write 'a)) ((#2%write 'b)) ((#2%write 'c) (#2%write 'd) (#2%write 'e)))))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%vector x y)) (#%list e1 2 e3))))
+    (if (= (optimize-level) 3)
+        '(#3%vector e1 2)
+        '(begin e3 (#2%vector e1 2))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(lambda (x) (#%apply x '(1 2 3)))))
+    '(lambda (x) (x 1 2 3)))
+  (let ([q (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize '(#%apply e0 (#%list e1 e2 e3))))])
+    (or (equivalent-expansion?  q '(let ([t1 e1] [t2 e2] [t3 e3]) (e0 t1 t2 t3)))
+        (equivalent-expansion?  q '(let ([t0 e0]) (t0 e1 e2 e3)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply
+           (case-lambda [(x y) x] [(a b c d e) c])
+           (#%list 1 2 3 4 5))))
+    '3)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (case-lambda [(x y) x] [r r]) (#%list 1 2 3 4 5))))
+    '(#3%list 1 2 3 4 5))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (case-lambda [(x y) x] [r r]) (#%list 1 2 q 4 5))))
+    '(#3%list 1 2 q 4 5))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply #%apply #%+ (#%list 1 2 3 (#%list 4 5)))))
+    15)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply #%apply #%apply #%apply #%apply #%+ (#%list 1 2 3 (#%list 4 5 (#%list 6 7 (#%list* 8 9 (#%list (#%list 10)))))))))
+    55)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply #%apply #%apply #%apply #%+ (#%cons 1 (#%list 2 3 (#%cons* 4 (#%list 5 (#%cons 6 (#%list* 7 (#%list 8 (#%cons 9 '(10))))))))))))
+    55)
+  (begin
+    (define $check-writes
+      (lambda (eepat x)
+        (define ordered?
+          (lambda (ls)
+            (define same-prefix?
+              (lambda (ls1 ls2)
+                (or (null? ls2)
+                    (and (eqv? (car ls1) (car ls2))
+                         (same-prefix? (cdr ls1) (cdr ls2))))))
+            (null?
+              (let f ([ls ls] [q '()] [qlen 0])
+                (if (null? ls)
+                    '()
+                    (let ([x (car ls)])
+                      (let ([xlen (length x)])
+                        (cond
+                          [(fx= xlen qlen) (f (cdr ls) x xlen)]
+                          [(fx< xlen qlen) ls]
+                          [else (and (fx= xlen (fx+ qlen 1))
+                                     (same-prefix? x q)
+                                     (let ([ls (f (cdr ls) x xlen)])
+                                       (and ls (f ls q qlen))))]))))))))
+        (syntax-case x (begin $primitive quote)
+          [(begin
+             (($primitive level write) (quote (d ...)))
+             ...
+             ans)
+           (begin
+             (unless (equivalent-expansion? #'ans eepat) (errorf #f "~s is not equivalent to ~s" #'ans eepat))
+             (unless (ordered? #'((d ...) ...)) (errorf #f "writes are out-of-order in ~s" x))
+             #t)]
+          [_ (errorf #f "unexpected output pattern for ~s" x)])))
+    #t)
+  ($check-writes 55
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '(let ()
+                         (import (chezscheme))
+                         (let ([list (begin (write '()) list)] [list* (if #t list* list)])
+                           (write '(1))
+                           ((begin (write '(1 1)) apply)
+                            (begin (write '(1 2)) apply)
+                            (begin (write '(1 3)) apply)
+                            (let ([waste (write '(1 4))]) apply)
+                            (begin (write '(1 5)) apply)
+                            (begin (write '(1 6)) +)
+                            (begin (write '(1 7))
+                              ((begin (write '(1 7 1)) list)
+                               (begin (write '(1 7 2)) 1)
+                               (begin (write '(1 7 3)) 2)
+                               (begin (write '(1 7 4)) 3)
+                               (begin (write '(1 7 5))
+                                 ((begin (write '(1 7 5 1)) list)
+                                  (begin (write '(1 7 5 2)) 4)
+                                  (begin (write '(1 7 5 3)) 5)
+                                  (begin (write '(1 7 5 4))
+                                    ((begin (write '(1 7 5 4 1)) list)
+                                     (begin (write '(1 7 5 4 2)) 6)
+                                     (begin (write '(1 7 5 4 3)) 7)
+                                     (begin (write '(1 7 5 4 4))
+                                       ((begin (write '(1 7 5 4 4 1)) list*)
+                                        (begin (write '(1 7 5 4 4 2)) 8)
+                                        (begin (write '(1 7 5 4 4 3)) 9)
+                                        (begin (write '(1 7 5 4 4 4))
+                                          ((begin (write '(1 7 5 4 4 1)) list)
+                                           (begin (write '(1 7 5 4 4 2))
+                                             ((begin (write '(1 7 5 4 4 2 1)) list)
+                                              (begin (write '(1 7 5 4 4 2 2)) 10)))))))))))))))))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 (cp0 (cp0 x))))])
+      (expand/optimize '(#%apply #%apply #%+ (#%list 1 2 3 (#%list 4 5)))))
+    '15)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply (lambda () 7) (#%list* '()))))
+    '7)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%+ x y z)) (#%list* 3 4 '(5)))))
+    '12)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply #%+ (#%list* e '(2 3)))))
+    (if (= (optimize-level) 3)
+        '(#3%+ 5 e)
+        '(#2%+ 5 e)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply
+           (lambda (x y z) (#%+ (begin (#%write 'a) x) y z))
+           (#%list* e1 e2 e3 '()))))
+    (if (= (optimize-level) 3)
+        '(let ([x e1] [y e2] [z e3])
+           (#3%+ (begin (#3%write 'a) x) y z))
+        '(let ([x e1] [y e2] [z e3])
+           (#2%+ (begin (#2%write 'a) x) y z))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%+ x y z)) (#%list* e1 e2 e3 '()))))
+    (if (= (optimize-level) 3)
+        '(#3%+ e1 e2 e3)
+        '(#2%+ e1 e2 e3)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply #%+ (#%list* 1 (begin (#%write 'a) 2) '(3)))))
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) 6)
+        '(begin (#2%write 'a) 6)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(#%apply (lambda (x y z) (#%vector x y)) (#%list* e1 2 e3 '()))))
+    (if (= (optimize-level) 3)
+        '(#3%vector e1 2)
+        '(begin e3 (#2%vector e1 2))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(#%apply (lambda (x y z) (#%vector x y z)) (#%list* 1 '(2 3)))))
+    (if (= (optimize-level) 3)
+        '(#3%vector 1 2 3)
+        '(#2%vector 1 2 3)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(lambda (r) (#%apply (lambda (x y z) (#%vector x y z)) (#%list* 1 r)))))
+    (if (= (optimize-level) 3)
+        '(lambda (r) (let ([y (#3%car r)]) (#3%vector 1 y (#3%car (#3%cdr r)))))
+        '(lambda (r) (#2%apply (lambda (x y z) (#2%vector x y z)) 1 r))))
+  (let ([expr (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+                (expand/optimize
+                  '(#%apply (begin (#%write 'a) #%+)
+                     (begin (#%write 'b) 4)
+                     (begin
+                       (#%write 'c)
+                       (#%list*
+                         1
+                         (begin (#%write 'd) 2)
+                         (begin (#%write 'e) '(3)))))))])
+    (ormap
+      (lambda (groups) (equivalent-expansion? expr `(begin ,@(apply append groups) 10)))
+      ($permutations
+        (if (= (optimize-level) 3)
+            '(((#3%write 'a)) ((#3%write 'b)) ((#3%write 'c) (#3%write 'd) (#3%write 'e)))
+            '(((#2%write 'a)) ((#2%write 'b)) ((#2%write 'c) (#2%write 'd) (#2%write 'e)))))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(let ([x (cons 0 (list))]) (#%apply #%zero? x))))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      ;; don't fold primitive in value context with bad apply convention
+      (expand/optimize '(#%apply #%zero? 0)))
+    (if (= (optimize-level) 3)
+        '(#3%apply #3%zero? 0)
+        '(#2%apply #2%zero? 0)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      ;; don't fold primitive in test context with bad apply convention
+      (expand/optimize '(if (#%apply #%eof-object 1 2 3) 4 5)))
+    (if (= (optimize-level) 3)
+        '(if (#3%apply #3%eof-object 1 2 3) 4 5)
+        '(if (#2%apply #2%eof-object 1 2 3) 4 5)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      ;; don't fold primitive in effect context with bad apply convention
+      (expand/optimize '(begin (#%apply #%box? 'step) 3)))
+    (if (= (optimize-level) 3)
+        '(begin (#3%apply #3%box? 'step) 3)
+        '(begin (#2%apply #2%box? 'step) 3)))
+ )
+
+(mat cp0-car/cdr
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%car)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%cons)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'e) ($xxx))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) ($xxx))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%car)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%list)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))
+               (begin (#%write 'g) ($zzz))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%car)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%list*)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))
+               (begin (#%write 'g) ($zzz))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%car)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%cons*)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))
+               (begin (#%write 'g) ($zzz))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%cons)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%list)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))
+               (begin (#%write 'g) ($zzz))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%list (begin (#3%write 'f) ($yyy)) (begin (#3%write 'g) ($zzz))))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%list (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz))))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%list*)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))
+               (begin (#%write 'g) ($zzz))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%list* (begin (#3%write 'f) ($yyy)) (begin (#3%write 'g) ($zzz))))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%list* (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz))))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%cons*)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))
+               (begin (#%write 'g) ($zzz))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%cons* (begin (#3%write 'f) ($yyy)) (begin (#3%write 'g) ($zzz))))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%cons* (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz))))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%list*)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%cons*)
+               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'f) ($yyy))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%list*)
+               (begin (#%write 'e) ($xxx))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%cdr (begin (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx))))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%cdr (begin (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx))))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(begin (#%write 'a)
+           ((begin (#%write 'b) #%cdr)
+            (begin (#%write 'c)
+              ((begin (#%write 'd) #%cons*)
+               (begin (#%write 'e) ($xxx))))))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%cdr (begin (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx))))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%cdr (begin (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx))))))
+ )
+
+(mat cp0-seq-ref
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(vector-ref (vector 1 2 3) 1)))
+    2)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(list-ref (list 1 2 3) 1)))
+    2)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(list-ref (list* 1 2 3) 1)))
+    2)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(list-ref (cons* 1 2 3) 1)))
+    2)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(fxvector-ref (fxvector 1 2 3) 1)))
+    2)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(string-ref (string #\1 #\2 #\3) 1)))
+    #\2)
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) vector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) vector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) vector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) vector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 3)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin
+           (#3%write 'a)
+           (#3%write 'b)
+           (#3%vector-ref
+             (begin
+               (#3%write 'c)
+               (#3%write 'd)
+               (#3%vector
+                 (begin (#3%write 'e) ($xxx))
+                 (begin (#3%write 'f) ($yyy))
+                 (begin (#3%write 'g) ($zzz))))
+             (begin (#3%write 'h) 3)))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%vector-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%vector
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 3)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) list-ref)
+            (begin (write 'c)
+              ((begin (write 'd) list)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) list-ref)
+            (begin (write 'c)
+              ((begin (write 'd) list*)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) list-ref)
+            (begin (write 'c)
+              ((begin (write 'd) cons*)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) list-ref)
+            (begin (write 'c)
+              ((begin (write 'd) cons*)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 2)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin
+           (#3%write 'a)
+           (#3%write 'b)
+           (#3%list-ref
+             (begin
+               (#3%write 'c)
+               (#3%write 'd)
+               (#3%cons*
+                 (begin (#3%write 'e) ($xxx))
+                 (begin (#3%write 'f) ($yyy))
+                 (begin (#3%write 'g) ($zzz))))
+             (begin (#3%write 'h) 2)))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%list-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%cons*
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 2)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) string-ref)
+            (begin (write 'c)
+              ((begin (write 'd) string)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) #\y)
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) #\y)
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) #\y)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) string-ref)
+            (begin (write 'c)
+              ((begin (write 'd) string)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) 'oops)
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) 'oops)
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%string-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%string
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) 'oops)
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 1)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) string-ref)
+            (begin (write 'c)
+              ((begin (write 'd) string)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%string-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%string
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 1)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) string-ref)
+            (begin (write 'c)
+              ((begin (write 'd) #2%string)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin
+           (#3%write 'a)
+           (#3%write 'b)
+           (#3%string-ref
+             (begin
+               (#3%write 'c)
+               (#3%write 'd)
+               (#2%string
+                 (begin (#3%write 'e) ($xxx))
+                 (begin (#3%write 'f) ($yyy))
+                 (begin (#3%write 'g) ($zzz))))
+             (begin (#3%write 'h) 1)))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%string-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%string
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 1)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) string-ref)
+            (begin (write 'c)
+              ((begin (write 'd) string)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 3)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin
+           (#3%write 'a)
+           (#3%write 'b)
+           (#3%string-ref
+             (begin
+               (#3%write 'c)
+               (#3%write 'd)
+               (#3%string
+                 (begin (#3%write 'e) ($xxx))
+                 (begin (#3%write 'f) ($yyy))
+                 (begin (#3%write 'g) ($zzz))))
+             (begin (#3%write 'h) 3)))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%string-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%string
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 3)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) fxvector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) fxvector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) 121)
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) 121)
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) 121)))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) fxvector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) fxvector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) 'oops)
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) 'oops)
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%fxvector-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%fxvector
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) 'oops)
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 1)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) fxvector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) fxvector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%fxvector-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%fxvector
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 1)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) fxvector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) #2%fxvector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 1)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin
+           (#3%write 'a)
+           (#3%write 'b)
+           (#3%fxvector-ref
+             (begin
+               (#3%write 'c)
+               (#3%write 'd)
+               (#2%fxvector
+                 (begin (#3%write 'e) ($xxx))
+                 (begin (#3%write 'f) ($yyy))
+                 (begin (#3%write 'g) ($zzz))))
+             (begin (#3%write 'h) 1)))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%fxvector-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%fxvector
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 1)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
+      (expand/optimize
+        '(begin (write 'a)
+           ((begin (write 'b) fxvector-ref)
+            (begin (write 'c)
+              ((begin (write 'd) fxvector)
+               (begin (write 'e) ($xxx))
+               (begin (write 'f) ($yyy))
+               (begin (write 'g) ($zzz))))
+            (begin (write 'h) 3)))))
+    ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
+    ; if you see a problem, convert to use $check-writes (defined above)
+    (if (= (optimize-level) 3)
+        '(begin
+           (#3%write 'a)
+           (#3%write 'b)
+           (#3%fxvector-ref
+             (begin
+               (#3%write 'c)
+               (#3%write 'd)
+               (#3%fxvector
+                 (begin (#3%write 'e) ($xxx))
+                 (begin (#3%write 'f) ($yyy))
+                 (begin (#3%write 'g) ($zzz))))
+             (begin (#3%write 'h) 3)))
+        '(begin
+           (#2%write 'a)
+           (#2%write 'b)
+           (#2%fxvector-ref
+             (begin
+               (#2%write 'c)
+               (#2%write 'd)
+               (#2%fxvector
+                 (begin (#2%write 'e) ($xxx))
+                 (begin (#2%write 'f) ($yyy))
+                 (begin (#2%write 'g) ($zzz))))
+             (begin (#2%write 'h) 3)))))
+ )
+
+(mat let-pushing
+  ; make sure letify doesn't drop the let binding for x into the call to cons which would
+  ; cause the allocation of z's location not to be in the continuation of the rhs of x.
+  (equal?
+    (let ([ls '()])
+      (let ([th.k (let ([x (call/cc (lambda (k) k))] [z 0])
+                    (cons (lambda () (set! z (+ z 1)) z) x))])
+        (and (set! ls (cons ((car th.k)) ls))
+             (set! ls (cons ((car th.k)) ls))
+             ((cdr th.k) (lambda (x) (set! ls (cons 17 ls))))))
+      ls)
+    '(17 2 1 2 1))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(lambda (x) (letrec ([y (if (pair? x) (#3%car x) x)]) 4))))
+    '(lambda (x) 4))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(let ([x e]) (list (list x)))))
+    '(#2%list (#2%list e)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(let ([x (lambda (x) x)]) (list (list x) (list 3)))))
+    '(#2%list (#2%list (lambda (x) x)) (#2%list 3)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(lambda (y) (let ([x (+ y y)] [z #f]) (list (lambda () (set! z 15) z) x)))))
+    '(lambda (y) (let ([x (#2%+ y y)] [z #f]) (#2%list (lambda () (set! z 15) z) x))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 3])
+      (expand/optimize
+        '(lambda (y) (let ([x (+ y y)] [z #f]) (list (lambda () (set! z 15) z) x)))))
+    ; doesn't push (+ y y) because it's not pure and one of the vars (z) is assigned
+    '(lambda (y) (let ([x (#3%+ y y)] [z #f]) (#3%list (lambda () (set! z 15) z) x))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 3])
+      (expand/optimize
+        '(lambda (y) (let ([x (make-message-condition y)] [z #f]) (list (lambda () (set! z 15) z) x)))))
+    ; does push (make-message-condition y) because it is pure, even though one of the vars (z) is assigned
+    '(lambda (y) (let ([z #f]) (#3%list (lambda () (set! z 15) z) (#3%make-message-condition y)))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2] [compile-profile #f])
+      (expand/optimize
+        '(let ()
+           (define-record foo ((immutable boolean x)))
+           (or (foo-x e1) e2))))
+    `(if (let ([g0 e1])
+           (if (#3%record? g0 ',record-type-descriptor?)
+               (#2%void)
+               (#3%$record-oops 'foo-x g0 ',record-type-descriptor?))
+           (#3%$object-ref 'boolean g0 ,fixnum?))
+         #t
+         e2))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 3] [compile-profile #f])
+      (expand/optimize
+        '(let ()
+           (define-record foo ((immutable boolean x)))
+           (or (foo-x e1) e2))))
+    `(if (#3%$object-ref 'boolean e1 ,fixnum?) #t e2))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(lambda (v)
+           (let ([v2 (if (vector? v) v (error))])
+             (let ([q (vector-sort v2)] [n (#3%vector-length v)])
+               (display "1")
+               (list q n))))))
+    '(lambda (v)
+       (let ([v2 (if (#2%vector? v) v (#2%error))])
+         (let ([q (#2%vector-sort v2)] [n (#3%vector-length v)])
+           (#2%display "1")
+           (#2%list q n)))))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+      (expand/optimize
+        '(lambda (v)
+           (let ([v2 (if (vector? v) v (error))])
+             (let ([q (vector-sort v2)] [n (or v 72)])
+               (display "1")
+               (list q n))))))
+    '(lambda (v)
+       (let ([q (#2%vector-sort (if (#2%vector? v) v (#2%error)))]
+             [n (if v v 72)])
+         (#2%display "1")
+         (#2%list q n))))
+)
+
+(mat equality-of-refs
+  (begin
+    (define-syntax eqtest
+      (syntax-rules ()
+        [(_ eqprim) (eqtest eqprim #f)]
+        [(_ eqprim generic?)
+         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+           (let ([arity-mask (procedure-arity-mask eqprim)] [primref `($primitive ,(if (= (optimize-level) 3) 3 2) eqprim)])
+             (define-syntax ifsafe
+               (syntax-rules ()
+                 [(_ n e1 e2)
+                  (if (and (fxbit-set? arity-mask n) (or generic? (= (optimize-level) 3))) e1 e2)]))
+             (and
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim x)))
+                 (ifsafe 1
+                   `(lambda (x) #t)
+                   `(lambda (x) (,primref x))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim (begin (x) x))))
+                 (ifsafe 1
+                   `(lambda (x) (x) #t)
+                   `(lambda (x) (,primref (begin (x) x)))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (set! x (x x)) (x (eqprim x))))
+                 (ifsafe 1
+                   `(lambda (x) (set! x (x x)) (x #t))
+                   `(lambda (x) (set! x (x x)) (x (,primref x)))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim (x x))))
+                 (ifsafe 1
+                   `(lambda (x) (x x) #t)
+                   `(lambda (x) (,primref (x x)))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim x x)))
+                 (ifsafe 2
+                   `(lambda (x) #t)
+                   `(lambda (x) (,primref x x))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim (begin (x) x) x)))
+                 (ifsafe 2
+                   `(lambda (x) (x) #t)
+                   `(lambda (x) (,primref (begin (x) x) x))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim x (begin (x) x))))
+                 (ifsafe 2
+                   `(lambda (x) (x) #t)
+                   `(lambda (x) (,primref x (begin (x) x)))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim (begin (x) x) (begin (x x) x))))
+                 (ifsafe 2
+                   `(lambda (x) (x) (x x) #t)
+                   `(lambda (x) (,primref (begin (x) x) (begin (x x) x)))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x y) (eqprim x y)))
+                 `(lambda (x y) (,primref x y)))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim x x x x x)))
+                 (ifsafe 5
+                   `(lambda (x) #t)
+                   `(lambda (x) (,primref x x x x x))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x y) (eqprim x x x x y)))
+                 `(lambda (x y) (,primref x x x x y)))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim x x (begin (x) x) x x)))
+                 (ifsafe 5
+                   `(lambda (x) (x) #t)
+                   `(lambda (x) (,primref x x (begin (x) x) x x))))
+               (equivalent-expansion?
+                 (expand/optimize
+                   `(lambda (x) (eqprim x x (begin (set! x 15) x) x x)))
+                 `(lambda (x) (,primref x x (begin (set! x 15) x) x x)))
+               )))]))
+    #t)
+  (eqtest eq? #t)
+  (eqtest eqv? #t)
+  (eqtest equal? #t)
+  (eqtest bytevector=?)
+  (eqtest enum-set=?)
+  (eqtest bound-identifier=?)
+  (eqtest free-identifier=?)
+  (eqtest ftype-pointer=?)
+  (eqtest literal-identifier=?)
+  (eqtest time=?)
+  (eqtest boolean=?)
+  (eqtest symbol=?)
+  (eqtest char=?)
+  (eqtest char-ci=?)
+  (eqtest string=?)
+  (eqtest string-ci=?)
+  (eqtest r6rs:char=?)
+  (eqtest r6rs:char-ci=?)
+  (eqtest r6rs:string=?)
+  (eqtest r6rs:string-ci=?)
+  (eqtest fx=)
+  (eqtest fx=?)
+  (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (equivalent-expansion?
+      (expand/optimize
+        `(lambda (x) (fl= x x))) ; x could be +nan.0
+      `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) fl=) x x))))
+  (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (equivalent-expansion?
+      (expand/optimize
+        `(lambda (x) (= x x))) ; x could be +nan.0
+      `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x))))
+)
diff --git a/mats/date.ms b/mats/date.ms
new file mode 100644
index 0000000..72c2f46
--- /dev/null
+++ b/mats/date.ms
@@ -0,0 +1,639 @@
+;;; date.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat time
+  (error? ; wrong number of arguments
+    (make-time))
+  (error? ; wrong number of arguments
+    (make-time 'time-utc))
+  (error? ; wrong number of arguments
+    (make-time 'time-utc 17))
+  (error? ; wrong number of arguments
+    (make-time 'time-utc 17 0 50))
+  (error? ; invalid type
+    (make-time 'time-nonsense 17 0))
+  (error? ; invalid seconds
+    (make-time 'time-utc 0 #f))
+  (error? ; invalid nanoseconds
+    (make-time 'time-utc -1 17))
+  (error? ; invalid nanoseconds
+    (make-time 'time-utc #e1e9 17))
+  (error? ; invalid nanoseconds
+    (make-time 'time-utc #f 17))
+  (error? ; wrong number of arguments
+    (time?))
+  (error? ; wrong number of arguments
+    (time? #f 3))
+  (begin
+    (define $time-t1 (make-time 'time-utc (- #e1e9 1) #e1e9))
+    (and (time? $time-t1) (not (date? $time-t1))))
+  (error? ; wrong number of arguments
+    (time-type))
+  (error? ; wrong number of arguments
+    (time-type $time-t1 #t))
+  (error? ; not a time record
+    (time-type 17))
+  (error? ; wrong number of arguments
+    (time-second))
+  (error? ; wrong number of arguments
+    (time-second $time-t1 #t))
+  (error? ; not a time record
+    (time-second 17))
+  (error? ; wrong number of arguments
+    (time-nanosecond))
+  (error? ; wrong number of arguments
+    (time-nanosecond $time-t1 #t))
+  (error? ; not a time record
+    (time-nanosecond 17))
+  (error? ; wrong number of arguments
+    (set-time-type!))
+  (error? ; wrong number of arguments
+    (set-time-type! $time-t1))
+  (error? ; wrong number of arguments
+    (set-time-type! $time-t1 'time-utc 0))
+  (error? ; not a time record
+    (set-time-type! 'time-utc 'time-utc))
+  (error? ; invalid type
+    (set-time-type! $time-t1 'time-nonsense))
+  (error? ; wrong number of arguments
+    (set-time-second!))
+  (error? ; wrong number of arguments
+    (set-time-second! $time-t1))
+  (error? ; wrong number of arguments
+    (set-time-second! $time-t1 5000 0))
+  (error? ; not a time record
+    (set-time-second! 5000 5000))
+  (error? ; invalid second
+    (set-time-second! $time-t1 'time-utc))
+  (error? ; wrong number of arguments
+    (set-time-nanosecond!))
+  (error? ; wrong number of arguments
+    (set-time-nanosecond! $time-t1))
+  (error? ; wrong number of arguments
+    (set-time-nanosecond! $time-t1 5000 0))
+  (error? ; not a time record
+    (set-time-nanosecond! 5000 5000))
+  (error? ; invalid nanosecond
+    (set-time-nanosecond! $time-t1 -1))
+  (error? ; invalid nanosecond
+    (set-time-nanosecond! $time-t1 'time-utc))
+  (error? ; invalid nanosecond
+    (set-time-nanosecond! $time-t1 #e1e9))
+  (error?  ; wrong number of arguments
+    (current-time 'time-utc #t))
+  (error?  ; invalid type
+    (current-time 'time-nonsense))
+  (begin
+    (define $time-t2 (current-time 'time-utc))
+    (and (time? $time-t2) (not (date? $time-t2))))
+  (begin
+    (define $time-t3 (current-time 'time-monotonic))
+    (and (time? $time-t3) (not (date? $time-t3))))
+  (begin
+    (define $time-t4 (current-time 'time-duration))
+    (and (time? $time-t4) (not (date? $time-t4))))
+  (begin
+    (define $time-t5 (current-time 'time-process))
+    (and (time? $time-t5) (not (date? $time-t5))))
+  (begin
+    (define $time-t6 (current-time 'time-thread))
+    (and (time? $time-t6) (not (date? $time-t6))))
+  (begin
+    (define $time-t7 (current-time 'time-collector-cpu))
+    (and (time? $time-t7) (not (date? $time-t7))))
+  (begin
+    (define $time-t8 (current-time 'time-collector-real))
+    (and (time? $time-t8) (not (date? $time-t8))))
+  (eqv? (time-type $time-t1) 'time-utc)
+  (eqv? (time-type $time-t2) 'time-utc)
+  (eqv? (time-type $time-t3) 'time-monotonic)
+  (eqv? (time-type $time-t4) 'time-duration)
+  (eqv? (time-type $time-t5) 'time-process)
+  (eqv? (time-type $time-t6) 'time-thread)
+  (eqv? (time-type $time-t7) 'time-collector-cpu)
+  (eqv? (time-type $time-t8) 'time-collector-real)
+  (eqv? (time-second $time-t1) #e1e9)
+  (eqv? (time-nanosecond $time-t1) (- #e1e9 1))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t2))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t3))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t4))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t5))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t6))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t7))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t8))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t2))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t3))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t4))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t5))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t6))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t7))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t8))
+  (eqv?
+    (let ([sec (+ (time-second (current-time 'time-thread)) 3)]
+          [cnt 0]
+          [ans 0])
+      (define fib (lambda (x) (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2))))))
+      (let f ()
+        (when (< (time-second (current-time 'time-thread)) sec)
+          (for-each
+            (lambda (t)
+              (let ([n (time-nanosecond (current-time t))])
+                (unless (<= 0 n #e1e9)
+                  (errorf #f "(time-nanosecond (current-time '~s)) = ~s" t n))))
+            '(time-utc time-monotonic time-duration time-process time-thread))
+          (set! ans (+ ans (fib 20)))
+          (set! cnt (+ cnt 1))
+          (f)))
+      (/ ans cnt))
+    6765)
+  (begin
+    (set-time-type! $time-t1 'time-monotonic)
+    (eqv? (time-type $time-t1) 'time-monotonic))
+  (begin
+    (set-time-second! $time-t1 3)
+    (eqv? (time-second $time-t1) 3))
+  (begin
+    (set-time-nanosecond! $time-t1 3000)
+    (eqv? (time-nanosecond $time-t1) 3000))
+  (error? ; wrong number of arguments
+    (time=?))
+  (error? ; wrong number of arguments
+    (time=? $time-t1))
+  (error? ; wrong number of arguments
+    (time=? $time-t1 $time-t1 $time-t1))
+  (error? ; invalid argument
+    (time=? $time-t1 3))
+  (error? ; invalid argument
+    (time=? car $time-t1))
+  (error? ; different types
+    (time=? $time-t4 $time-t5))
+  (error? ; wrong number of arguments
+    (time?))
+  (error? ; wrong number of arguments
+    (time>? $time-t1))
+  (error? ; wrong number of arguments
+    (time>? $time-t1 $time-t1 $time-t1))
+  (error? ; invalid argument
+    (time>? $time-t1 3))
+  (error? ; invalid argument
+    (time>? car $time-t1))
+  (error? ; different types
+    (time>? $time-t4 $time-t5))
+  (error? ; wrong number of arguments
+    (time>=?))
+  (error? ; wrong number of arguments
+    (time>=? $time-t1))
+  (error? ; wrong number of arguments
+    (time>=? $time-t1 $time-t1 $time-t1))
+  (error? ; invalid argument
+    (time>=? $time-t1 3))
+  (error? ; invalid argument
+    (time>=? car $time-t1))
+  (error? ; different types
+    (time>=? $time-t4 $time-t5))
+  (time=? $time-t1 $time-t1)
+  (time<=? $time-t1 $time-t1)
+  (time>=? $time-t1 $time-t1)
+  (not (time? $time-t1 $time-t1))
+  (equal?
+    (let ([ta (make-time 'time-duration 200 #e1e19)]
+          [tb (make-time 'time-duration 300 #e1e20)]
+          [tc (make-time 'time-duration 300 #e1e20)]
+          [td (make-time 'time-duration 301 #e1e20)]
+          [te (make-time 'time-duration 400 #e1e21)])
+      (define-syntax foo
+        (syntax-rules ()
+          [(_ x ...)
+           (list
+             (let ([t x])
+               (list (time=? t x) ...
+                     (time>? t x) ...))
+             ...)]))
+      (foo ta tb tc td te))
+    '((#f #t #t #t #t
+       #t #t #t #t #t
+       #t #f #f #f #f
+       #t #f #f #f #f
+       #f #f #f #f #f)
+      (#f #f #f #t #t
+       #f #t #t #t #t
+       #f #t #t #f #f
+       #t #t #t #f #f
+       #t #f #f #f #f)
+      (#f #f #f #t #t
+       #f #t #t #t #t
+       #f #t #t #f #f
+       #t #t #t #f #f
+       #t #f #f #f #f)
+      (#f #f #f #f #t
+       #f #f #f #t #t
+       #f #f #f #t #f
+       #t #t #t #t #f
+       #t #t #t #f #f)
+      (#f #f #f #f #f
+       #f #f #f #f #t
+       #f #f #f #f #t
+       #t #t #t #t #t
+       #t #t #t #t #f)))
+  (error? (time-difference $time-t2 $time-t3))
+  (error? (add-duration $time-t3 $time-t2))
+  (error? (subtract-duration $time-t3 $time-t2))
+  (let ([t (make-time 'time-duration 1000000 -20)])
+    (and (time? t)
+         (not (date? t))
+         (eqv? (time-second t) -20)
+         (eqv? (time-nanosecond t) 1000000)))
+  (equal?
+    (let ([t1 (make-time 'time-process 999999999 7)]
+          [t2 (make-time 'time-duration 10 2)])
+      (let ([t3 (add-duration t1 t2)]
+            [t4 (subtract-duration t1 t2)])
+        (let ([t5 (time-difference t3 t1)]
+              [t6 (time-difference t1 t3)]
+              [t7 (time-difference t1 t4)]
+              [t8 (time-difference t4 t1)])
+          (list
+            (list (time-second t3) (time-nanosecond t3))
+            (list (time-second t4) (time-nanosecond t4))
+            (time=? t5 t2)
+            (list (time-second t6) (time-nanosecond t6))
+            (time=? t7 t2)
+            (list (time-second t8) (time-nanosecond t8))))))
+    '((10 9) (5 999999989) #t (-3 999999990) #t (-3 999999990)))
+  (error? (copy-time (current-date)))
+  (begin
+    (define $new-time-t2 (copy-time $time-t2))
+    (time? $new-time-t2))
+  (not (eq? $new-time-t2 $time-t2))
+  (time=? $new-time-t2 $time-t2)
+)
+
+(mat date
+  (error? ; wrong number of arguments
+    (make-date))
+  (error? ; wrong number of arguments
+    (make-date 0))
+  (error? ; wrong number of arguments
+    (make-date 0 0))
+  (error? ; wrong number of arguments
+    (make-date 0 0 0))
+  (error? ; wrong number of arguments
+    (make-date 0 0 0 0))
+  (error? ; wrong number of arguments
+    (make-date 0 0 0 0 1))
+  (error? ; wrong number of arguments
+    (make-date 0 0 0 0 1 1))
+  (error? ; wrong number of arguments
+    (make-date 0 0 0 0 1 1 2007 0 0))
+  (error? ; invalid nanosecond
+    (make-date -1 0 0 0 1 1 2007 0))
+  (error? ; invalid nanosecond
+    (make-date #e1e9 0 0 0 1 1 2007 0))
+  (error? ; invalid nanosecond
+    (make-date 'zero 0 0 0 1 1 2007 0))
+  (error? ; invalid second
+    (make-date 0 -1 0 0 1 1 2007 0))
+  (error? ; invalid second
+    (make-date 0 62 0 0 1 1 2007 0))
+  (error? ; invalid second
+    (make-date 0 "hello" 0 0 1 1 2007 0))
+  (error? ; invalid minute
+    (make-date 0 0 -1 0 1 1 2007 0))
+  (error? ; invalid minute
+    (make-date 0 0 60 0 1 1 2007 0))
+  (error? ; invalid minute
+    (make-date 0 0 "hello" 0 1 1 2007 0))
+  (error? ; invalid hour
+    (make-date 0 0 0 -1 1 1 2007 0))
+  (error? ; invalid hour
+    (make-date 0 0 0 24 1 1 2007 0))
+  (error? ; invalid hour
+    (make-date 0 0 0 "hello" 1 1 2007 0))
+  (error? ; invalid day
+    (make-date 0 0 0 0 0 1 2007 0))
+  (error? ; invalid day
+    (make-date 0 0 0 0 32 1 2007 0))
+  (error? ; invalid day
+    (make-date 0 0 0 0 31 11 2007 0))
+  (error? ; invalid day
+    (make-date 0 0 0 0 29 2 2007 0))
+  (error? ; invalid day
+    (make-date 0 0 0 0 "hello" 1 2007 0))
+  (error? ; invalid month
+    (make-date 0 0 0 0 1 0 2007 0))
+  (error? ; invalid month
+    (make-date 0 0 0 0 1 13 2007 0))
+  (error? ; invalid month
+    (make-date 0 0 0 0 1 'eleven 2007 0))
+  (error? ; invalid year
+    (make-date 0 0 0 0 1 1 'mmvii 0))
+  (error? ; invalid tz
+    (make-date 0 0 0 0 1 1 2007 (* -25 60 60)))
+  (error? ; invalid tz
+    (make-date 0 0 0 0 1 1 2007 (* 25 60 60)))
+  (error? ; invalid tz
+    (make-date 0 0 0 0 1 1 2007 'est))
+  (error? ; invalid tz
+    (make-date 0 0 0 0 1 1 2007 "est"))
+  (error? ; wrong number of arguments
+    (date?))
+  (error? ; wrong number of arguments
+    (date? #f 3))
+  (begin
+    (define $date-d1 (make-date 1 2 3 4 5 6 1970 8))
+    (and (date? $date-d1) (not (time? $date-d1))))
+  (error? ; wrong number of arguments
+    (date-nanosecond))
+  (error? ; wrong number of arguments
+    (date-nanosecond $date-d1 #t))
+  (error? ; not a date record
+    (date-nanosecond 17))
+  (error? ; not a date record
+    (date-nanosecond $time-t1))
+  (error? ; wrong number of arguments
+    (date-nanosecond))
+  (error? ; wrong number of arguments
+    (date-nanosecond $date-d1 #t))
+  (error? ; not a date record
+    (date-nanosecond 17))
+  (error? ; not a date record
+    (date-nanosecond $time-t1))
+  (error? ; wrong number of arguments
+    (date-second))
+  (error? ; wrong number of arguments
+    (date-second $date-d1 #t))
+  (error? ; not a date record
+    (date-second 17))
+  (error? ; not a date record
+    (date-second $time-t1))
+  (error? ; wrong number of arguments
+    (date-minute))
+  (error? ; wrong number of arguments
+    (date-minute $date-d1 #t))
+  (error? ; not a date record
+    (date-minute 17))
+  (error? ; not a date record
+    (date-minute $time-t1))
+  (error? ; wrong number of arguments
+    (date-hour))
+  (error? ; wrong number of arguments
+    (date-hour $date-d1 #t))
+  (error? ; not a date record
+    (date-hour 17))
+  (error? ; not a date record
+    (date-hour $time-t1))
+  (error? ; wrong number of arguments
+    (date-day))
+  (error? ; wrong number of arguments
+    (date-day $date-d1 #t))
+  (error? ; not a date record
+    (date-day 17))
+  (error? ; not a date record
+    (date-day $time-t1))
+  (error? ; wrong number of arguments
+    (date-month))
+  (error? ; wrong number of arguments
+    (date-month $date-d1 #t))
+  (error? ; not a date record
+    (date-month 17))
+  (error? ; not a date record
+    (date-month $time-t1))
+  (error? ; wrong number of arguments
+    (date-year))
+  (error? ; wrong number of arguments
+    (date-year $date-d1 #t))
+  (error? ; not a date record
+    (date-year 17))
+  (error? ; not a date record
+    (date-year $time-t1))
+  (error? ; wrong number of arguments
+    (date-week-day))
+  (error? ; wrong number of arguments
+    (date-week-day $date-d1 #t))
+  (error? ; not a date record
+    (date-week-day 17))
+  (error? ; not a date record
+    (date-week-day $time-t1))
+  (error? ; wrong number of arguments
+    (date-year-day))
+  (error? ; wrong number of arguments
+    (date-year-day $date-d1 #t))
+  (error? ; not a date record
+    (date-year-day 17))
+  (error? ; not a date record
+    (date-year-day $time-t1))
+  (error? ; wrong number of arguments
+    (date-dst?))
+  (error? ; wrong number of arguments
+    (date-dst? $date-d1 #t))
+  (error? ; not a date record
+    (date-dst? 17))
+  (error? ; not a date record
+    (date-dst? $time-t1))
+  (error? ; wrong number of arguments
+    (date-zone-offset))
+  (error? ; wrong number of arguments
+    (date-zone-offset $date-d1 #t))
+  (error? ; not a date record
+    (date-zone-offset 17))
+  (error? ; not a date record
+    (date-zone-offset $time-t1))
+  (error? ; wrong number of arguments
+    (date-zone-name))
+  (error? ; wrong number of arguments
+    (date-zone-name $date-d1 #t))
+  (error? ; not a date record
+    (date-zone-name 17))
+  (error? ; not a date record
+    (date-zone-name $time-t1))
+  (error?  ; wrong number of arguments
+    (current-date 0 #t))
+  (error?  ; invalid offset
+    (current-date (* -25 60 60)))
+  (error?  ; invalid offset
+    (current-date (* 25 60 60)))
+  (begin
+    (define $date-d2 (current-date))
+    (and (date? $date-d2) (not (time? $date-d2))))
+  (begin
+    (define $date-d3 (current-date (* -5 60 60)))
+    (and (date? $date-d3) (not (time? $date-d3))))
+  (begin
+    (define $date-d4 (current-date (* 10 60 60)))
+    (and (date? $date-d4) (not (time? $date-d4))))
+  (begin
+    (define $date-d5 (make-date 0 1 1 1 15 6 2016))
+    (and (date? $date-d5) (not (time? $date-d5))))
+  (date? (make-date 0 0 0 0 1 1 1970 -24))
+  (date? (make-date 999999999 59 59 23 31 12 2007 24))
+  (eqv? (date-nanosecond $date-d1) 1)
+  (eqv? (date-second $date-d1) 2)
+  (eqv? (date-minute $date-d1) 3)
+  (eqv? (date-hour $date-d1) 4)
+  (eqv? (date-day $date-d1) 5)
+  (eqv? (date-month $date-d1) 6)
+  (eqv? (date-year $date-d1) 1970)
+  (eqv? (date-zone-offset $date-d1) 8)
+  (boolean? (date-dst? $date-d5))
+  (fixnum? (date-zone-offset $date-d5))
+  (eqv? (date-zone-name $date-d1) #f)
+  (or (string? (date-zone-name $date-d2))
+      (not (date-zone-name $date-d2)))
+  (eqv? (date-zone-name $date-d3) #f)
+  (eqv? (date-zone-name $date-d4) #f)
+  (or (string? (date-zone-name $date-d5))
+      (not (date-zone-name $date-d5)))
+  (begin
+    (define (plausible-dst? d)
+      ;; Recognize a few time zone names and correlate with the DST field.
+      ;; Names like "EST" appear on Unix variants, while the long names
+      ;; show up on Windows.
+      (cond
+       [(member (date-zone-name d) '("EST" "CST" "MST" "PST"
+				     "Eastern Standard Time"
+				     "Central Standard Time"
+				     "Mountain Standard Time"
+				     "Pacific Standard Time"))
+        (eqv? (date-dst? d) #f)]
+       [(member (date-zone-name d) '("EDT" "CDT" "MDT" "PDT"
+				     "Eastern Daylight Time"
+				     "Central Daylight Time"
+				     "Mountain Daylight Time"
+				     "Pacific Daylight Time"))
+        (eqv? (date-dst? d) #t)]
+       [else #t]))
+    (plausible-dst? $date-d5))
+  (begin
+    (define $date-d6 (make-date 0 1 1 1 15 1 2016))
+    (plausible-dst? $date-d6))
+ ; check whether tz offsets are set according to DST, assuming that
+ ; DST always means a 1-hour shift
+  (let ([delta (time-second (time-difference (date->time-utc $date-d5)
+                                             (date->time-utc $date-d6)))]
+        [no-dst-delta (* 152 24 60 60)]; 152 days
+        [hour-delta (* 60 60)])
+    (cond
+     [(and (date-dst? $date-d5) (not (date-dst? $date-d6)))
+      ;; Northern-hemisphere DST reduces delta
+      (= delta (- no-dst-delta hour-delta))]
+     [(and (not (date-dst? $date-d5)) (date-dst? $date-d6))
+      ;; Southern-hemisphere DST increases delta
+      (= delta (+ no-dst-delta hour-delta))]
+     [else
+      ;; No DST or always DST
+      (= delta no-dst-delta)]))
+ ; check to make sure dst isn't screwing with our explicitly created dates
+ ; when we call mktime to fill in wday and yday
+  (let f ([mon 1])
+    (or (= mon 13)
+        (and (andmap
+               (lambda (day)
+                 (let ([d (make-date 5 6 7 8 day mon 2007 -18000)])
+                   (and (eqv? (date-nanosecond d) 5)
+                        (eqv? (date-second d) 6)
+                        (eqv? (date-minute d) 7)
+                        (eqv? (date-hour d) 8)
+                        (eqv? (date-day d) day)
+                        (eqv? (date-month d) mon)
+                        (eqv? (date-year d) 2007)
+                        (eqv? (date-zone-offset d) -18000))))
+               '(5 10 15 20 25))
+             (f (+ mon 1)))))
+  (eqv? (date-zone-offset $date-d3) (* -5 60 60))
+  (eqv? (date-zone-offset $date-d4) (* 10 60 60))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x 999999999))) (date-nanosecond $date-d2))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x 999999999))) (date-nanosecond $date-d3))
+  ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x 999999999))) (date-nanosecond $date-d4))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 61))) (date-second $date-d2))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 61))) (date-second $date-d3))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 61))) (date-second $date-d4))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 59))) (date-minute $date-d2))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 59))) (date-minute $date-d3))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 59))) (date-minute $date-d4))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 23))) (date-hour $date-d2))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 23))) (date-hour $date-d3))
+  ((lambda (x) (and (fixnum? x) (<= 0 x 23))) (date-hour $date-d4))
+  ((lambda (x) (and (fixnum? x) (<= 1 x 31))) (date-day $date-d2))
+  ((lambda (x) (and (fixnum? x) (<= 1 x 31))) (date-day $date-d3))
+  ((lambda (x) (and (fixnum? x) (<= 1 x 31))) (date-day $date-d4))
+  ((lambda (x) (and (fixnum? x) (<= 1 x 12))) (date-month $date-d2))
+  ((lambda (x) (and (fixnum? x) (<= 1 x 12))) (date-month $date-d3))
+  ((lambda (x) (and (fixnum? x) (<= 1 x 12))) (date-month $date-d4))
+  ((lambda (x) (and (fixnum? x) (<= 1900 x 2038))) (date-year $date-d2))
+  ((lambda (x) (and (fixnum? x) (<= 1900 x 2038))) (date-year $date-d3))
+  ((lambda (x) (and (fixnum? x) (<= 1900 x 2038))) (date-year $date-d4))
+  (let ([s (date-and-time)])
+    (and (fixnum? (read (open-input-string (substring s 8 10))))
+         (fixnum? (read (open-input-string (substring s 20 24))))))
+  (let ([d (current-date)])
+    (let ([s (date-and-time d)])
+      (and (= (read (open-input-string (substring s 8 10))) (date-day d))
+           (= (read (open-input-string (substring s 11 13))) (date-hour d))
+           (= (read (open-input-string (substring s 20 24))) (date-year d)))))
+)
+
+(mat conversions/sleep
+  (error? (date->time-utc (current-time)))
+  (error? (time-utc->date (current-date)))
+  (error? (sleep 20))
+  (time? (date->time-utc (current-date)))
+  (date? (time-utc->date (current-time 'time-utc)))
+  (let ([t (current-time 'time-utc)])
+    (sleep (make-time 'time-duration 0 1))
+    (timetime-utc (current-date))))
+  (let ([t (current-time)])
+    (and
+     (time=? (date->time-utc (time-utc->date t)) t)
+     (time=? (date->time-utc (time-utc->date t -86400)) t)
+     (time=? (date->time-utc (time-utc->date t 0)) t)
+     (time=? (date->time-utc (time-utc->date t 86400)) t)))
+)
+
+(mat time&date-printing
+  (equal? 
+    (with-output-to-string (lambda () (pretty-print (make-time 'time-duration 1 -1))))
+    "#\n")
+  (equal?
+    (with-output-to-string (lambda () (write (time-utc->date (make-time 'time-utc 708626501 1427137297) -14400))))
+    "#")
+)
diff --git a/mats/enum.ms b/mats/enum.ms
new file mode 100644
index 0000000..a3741ee
--- /dev/null
+++ b/mats/enum.ms
@@ -0,0 +1,152 @@
+;;; enum.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat enumeration
+  (equal? '(a b c) (enum-set->list (make-enumeration '(a b c))))
+  (equal? '(a b c) (enum-set->list (make-enumeration '(a b a c))))
+  (equal? '(a b c)
+          (enum-set->list
+           ((enum-set-constructor (make-enumeration '(a a b b c d)))
+            '(a b c))))
+  (equal? 
+   '(a b c d e f g h i j k l m n o p q r s t u v w x y z
+       aa bb cc dd ee ff gg hh ii jj kk ll mm
+       nn oo pp qq rr ss tt uu vv ww xx yy zz)
+   (enum-set->list
+    (make-enumeration
+     '(a b c d e f g h i j k l m n o p q r s t u v w x y z
+         aa bb cc dd ee ff gg hh ii jj kk ll mm
+         nn oo pp qq rr ss tt uu vv ww xx yy zz))))
+  (equal? '(d)
+          (let ([c (enum-set-constructor (make-enumeration '(a b c d e f)))])
+            (enum-set->list (enum-set-intersection (c '(a c d e))
+                                                   (c '(b d f))))))
+  (equal? '(a b c d e f)
+          (let ([c (enum-set-constructor (make-enumeration '(a b c d e f)))])
+            (enum-set->list (enum-set-union (c '(a c d e))
+                                            (c '(b d f))))))
+  (equal? '(a c e)
+          (let ([c (enum-set-constructor (make-enumeration '(a b c d e f)))])
+            (enum-set->list (enum-set-difference (c '(a c d e))
+                                                 (c '(b d f))))))
+  (equal? '(b f)
+          (let ([c (enum-set-constructor (make-enumeration '(a b c d e f)))])
+            (enum-set->list (enum-set-complement (c '(a c d e))))))
+  (equal? '(a b c d e f)
+          (let ([c (enum-set-constructor (make-enumeration '(a b c d e f)))])
+            (enum-set->list (enum-set-universe (c '(a c d e))))))
+  (equal? '(a c d e)
+          (let ([c (enum-set-constructor (make-enumeration '(a b c d e f)))])
+            (enum-set->list (enum-set-projection (c '(a c d e))
+                                                 (c '(b d f))))))
+  (equal? '(0 1 #f 5 #f)
+          (let ([e (make-enumeration '(a b c d e f))])
+            (map (enum-set-indexer e) '(a b g f h))))
+  (error? (enum-set-intersection (make-enumeration '(a b c d e f g))
+                                 (make-enumeration '(a b c d e f g))))
+  (error? (enum-set-intersection 1 1))
+  (equal? '(#f #t #f #t #t #t #f #f #f #f)
+          (let ([x ((enum-set-constructor (make-enumeration '(a b c d e f g)))
+                    '(b d e f))])
+            (map (lambda (y) (enum-set-member? y x)) '(a b c d e f g h i j))))
+  (equal? '(#t #f #t #f)
+          (let ([e1 (make-enumeration '(a b c d))]
+                [e2 (make-enumeration '(c d e f))])
+            (list (enum-set-subset? e1 e1)
+                  (enum-set-subset? e1 e2)
+                  (enum-set-subset? e2 e2)
+                  (enum-set-subset? e2 e1))))
+  (equal? '(#f #f #f #f #f)
+          (let ([c1 (enum-set-constructor (make-enumeration '(a b c d)))]
+                [c2 (enum-set-constructor (make-enumeration '(c d e f)))])
+            (list (enum-set-subset? (c1 '(c)) (c2 '(c d)))
+                  (enum-set-subset? (c1 '(a c)) (c2 '(c d)))
+                  (enum-set-subset? (c1 '(c d)) (c2 '(c d)))
+                  (enum-set=? (c1 '(c d)) (c2 '(c d)))
+                  (enum-set=? (c1 '(c)) (c2 '(c d))))))
+  (equal? '(#t #f #t #t #f)
+          (let ([c1 (enum-set-constructor (make-enumeration '(a b c d e f)))]
+                [c2 (enum-set-constructor (make-enumeration '(f e d c b a)))])
+            (list (enum-set-subset? (c1 '(c)) (c2 '(c d)))
+                  (enum-set-subset? (c1 '(a c)) (c2 '(c d)))
+                  (enum-set-subset? (c1 '(c d)) (c2 '(c d)))
+                  (enum-set=? (c1 '(c d)) (c2 '(c d)))
+                  (enum-set=? (c1 '(c)) (c2 '(c d))))))
+  (equal? 'a
+          (let ()
+            (define-enumeration foo (a b c) make-foo)
+            (foo a)))
+  (error? (let ()
+            (define-enumeration foo (a b c) make-foo)
+            (foo d)))
+  (equal? '(a b)
+          (let ()
+            (define-enumeration foo (a b c) make-foo)
+            (enum-set->list (make-foo a b))))
+  (error? (let ()
+            (define-enumeration foo (a b c) make-foo)
+            (make-foo a d)))
+  (error? (make-enumeration 3))
+  (error? (enum-set-universe 3))
+  (error? (enum-set-indexer 3))
+  (error? (let ([e (make-enumeration '(a b c))])
+            ((enum-set-indexer e) 1)))
+  (error? (enum-set->list 3))
+  (equal? '(a b)
+          (let ()
+            (define-enumeration foo (a b c) f)
+            (enum-set->list (enum-set-union (f a) (f b)))))
+  (error? (let ()
+            (define-enumeration foo (a b c) f)
+            (enum-set->list (enum-set-union (f a) 3))))
+  (error? (enum-set-union 4 (make-enumeration '(a b c))))
+  (error? (let ()
+            (define-enumeration foo (a b c) f)
+            (define-enumeration bar (a b c) g)
+            (enum-set-union (f a) (g b))))
+  (error? (enum-set-complement 3))
+  (error? (enum-set-projection 3 (make-enumeration '(a b))))
+  (error? (enum-set-projection (make-enumeration '(a b)) 4))
+  (equal? '(a b)
+          (enum-set->list
+           (enum-set-projection (make-enumeration '(a b))
+                                (make-enumeration '(a b)))))
+  (equal? '(a b)
+          (enum-set->list
+           (enum-set-projection (make-enumeration '(a b c))
+                                (make-enumeration '(a b)))))
+  (equal? '(a b)
+          (enum-set->list
+           (enum-set-projection (make-enumeration '(a b))
+                                (make-enumeration '(a b c)))))
+  (equal? #t (let () (define-enumeration foo () bar) #t))
+  (error? (let () (define-enumeration 3 () bar) #t))
+  (error? (let () (define-enumeration foo baz bar) #t))
+  (error? (let () (define-enumeration foo () 3) #t))
+  (error? (let () (define-enumeration foo (a 3) bar) #t))
+  (error? (let ()
+            (define-enumeration foo (a b) bar)
+            (foo 3)))
+  (error? (let ()
+            (define-enumeration foo (a b) bar)
+            (bar 3)))
+  (error? ; cannot extend sealed record
+    (make-record-type
+      (record-rtd (make-enumeration '(a b c)))
+      "foo" '()))
+
+  (equal? #t (enum-set? (make-enumeration '(a b c))))
+  (equal? #f (enum-set? 1))
+ )
diff --git a/mats/examples.ms b/mats/examples.ms
new file mode 100644
index 0000000..99535c6
--- /dev/null
+++ b/mats/examples.ms
@@ -0,0 +1,594 @@
+;;; examples.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; define *examples-directory* in Makefile
+(define-syntax examples-mat
+  (syntax-rules ()
+    [(_ name (file ...) expr ...)
+     (begin
+       (mat name
+         (begin
+           (parameterize ((source-directories (cons *examples-directory* (source-directories))))
+             (load (format "~a/~a.ss" *examples-directory* file))
+             ...)
+           #t)
+         expr ...)
+       (mat name
+         (begin
+           (parameterize ((source-directories (cons *examples-directory* (source-directories))))
+             (load (format "~a/~a.so" *examples-directory* file))
+             ...
+             #t))
+         expr ...))]))
+
+(define load-example
+   (case-lambda
+      [(str)
+       (load (format "~a/~a.ss" *examples-directory* str))
+       #t]
+      [(str eval)
+       (load (format "~a/~a.ss" *examples-directory* str) eval)
+       #t]))
+
+(define (example-file file) (format "~a/~a" *mats-dir* file))
+
+(define file=?
+   (lambda (fn1 fn2)
+      (let ([p1 (open-input-file fn1)] [p2 (open-input-file fn2)])
+         (let loop ()
+            (let ([c1 (read-char p1)] [c2 (read-char p2)])
+               (if (eof-object? c1)
+                   (begin
+                     (close-port p1)
+                     (close-port p2)
+                     (eof-object? c2))
+                   (and (not (eof-object? c2))
+                        (char=? c1 c2)
+                        (loop))))))))
+
+(examples-mat def-edit ("def" "edit")
+   (begin (def fact (lambda (x) (if (zero? x) 1 (* x (fact ( x 1))))))
+          (procedure? fact))
+   (equal? (ls-def) '(fact))
+   (let ([in (open-input-string "3 3 4 3 2 (ib 1 -) t")]
+         [out (open-output-string)])
+      (and (eqv? (parameterize ([current-input-port in]
+                                [current-output-port out])
+                    (ed-def fact))
+                 'fact)
+           (equal? (get-output-string out)
+"(def fact (lambda (...) (...)))
+edit> (lambda (x) (if (...) 1 (...)))
+edit> (if (zero? x) 1 (* x (...)))
+edit> (* x (fact (...)))
+edit> (fact (x 1))
+edit> (x 1)
+edit> (- x 1)
+edit> (def fact (lambda (...) (...)))
+edit> 
+")))
+   (eqv? (fact 30) 265252859812191058636308480000000)
+ )
+
+(examples-mat fact ("fact")
+   (eqv? (fact 30) 265252859812191058636308480000000)
+ )
+
+(examples-mat fatfib ("fatfib")
+   (eqv? (fatfib 10) 89)
+ )
+
+(examples-mat fib ("fib")
+   (begin (printf "***** expect trace of (fib 4):~%")
+          (eqv? (fib 4) 5))
+ )
+
+(examples-mat freq ("freq")
+   ;; freq.in and freq.out come from example in TSPL
+   (begin (delete-file "testfile.freq" #f) #t)
+   (begin (frequency (example-file "freq.in") "testfile.freq")
+          (file=? "testfile.freq" (example-file "freq.out")))
+ )
+
+;-------- freq.in: --------
+;Peter Piper picked a peck of pickled peppers;
+;A peck of pickled peppers Peter Piper picked.
+;If Peter Piper picked a peck of pickled peppers,
+;Where's the peck of pickled peppers Peter Piper picked?
+
+;-------- freq.out: --------
+;1       A
+;1       If
+;4       Peter
+;4       Piper
+;1       Where
+;2       a
+;4       of
+;4       peck
+;4       peppers
+;4       picked
+;4       pickled
+;1       s
+;1       the
+
+; "interpret" can't handle all Chez core forms
+;(mat interpret
+;   (and (eq? (getprop 'interpret '*type*) 'primitive)
+;        (begin (remprop 'interpret '*type*) #t))
+;   (load-example "interpret")
+;   (load-example "interpret" interpret)
+;   (load-example "fatfib" interpret)
+;   (eqv? (fatfib 4) 5)
+;   (begin (putprop 'interpret '*type* 'primitive) #t)
+; )
+
+(examples-mat m4 ("m4")
+   (begin (m4 "testfile.m4" (example-file "m4test.in"))
+          (file=? (example-file "m4test.out") "testfile.m4"))
+ )
+
+(examples-mat macro ("macro")
+   (begin (macro xxxxxx (lambda (x) `',x)) #t)
+   (equal? (xxxxxx 3) '(xxxxxx 3))
+ )
+
+(examples-mat matrix ("matrix")
+  ;; examples from TSPL2:
+  (equal? (mul 3 4) 12)
+  (equal? (mul 1/2 '#(#(1 2 3))) '#(#(1/2 1 3/2)))
+  (equal? (mul -2
+               '#(#(3 -2 -1)
+                  #(-3 0 -5)
+                  #(7 -1 -1))) '#(#(-6 4 2)
+                                  #(6 0 10)
+                                  #(-14 2 2)))
+  (equal? (mul '#(#(1 2 3))
+               '#(#(2 3)
+                  #(3 4)
+                  #(4 5))) '#(#(20 26)))
+  (equal? (mul '#(#(2 3 4)
+                  #(3 4 5))
+               '#(#(1) #(2) #(3))) '#(#(20) #(26)))
+  (equal? (mul '#(#(1 2 3)
+                  #(4 5 6))
+               '#(#(1 2 3 4)
+                  #(2 3 4 5)
+                  #(3 4 5 6))) '#(#(14 20 26 32)
+                                  #(32 47 62 77)))
+)
+
+(examples-mat object ("object")
+   (begin (define-object (summit x)
+             ([y 3])
+             ([getx (lambda () x)]
+              [sumxy (lambda () (+ x y))]
+              [setx (lambda (v) (set! x v))]))
+          (procedure? summit))
+   (begin (define a (summit 1)) (procedure? a))
+   (eq? (send-message a getx) 1)
+   (eq? (send-message a sumxy) 4)
+   (begin (send-message a setx 13)
+          (eq? (send-message a sumxy) 16))
+   ;; examples from TSPL:
+   (begin (define-object (kons kar kdr)
+             ([get-car (lambda () kar)]
+              [get-cdr (lambda () kdr)]
+              [set-car! (lambda (x) (set! kar x))]
+              [set-cdr! (lambda (x) (set! kdr x))]))
+          (procedure? kons))
+   (begin (define p (kons 'a 'b)) (procedure? p))
+   (eq? (send-message p get-car) 'a)
+   (eq? (send-message p get-cdr) 'b)
+   (begin (send-message p set-cdr! 'c)
+          (eq? (send-message p get-cdr) 'c))
+   (begin (define-object (kons kar kdr pwd)
+             ([get-car (lambda () kar)]
+              [get-cdr (lambda () kar)]
+              [set-car!
+                 (lambda (x p)
+                    (when (string=? p pwd)
+                        (set! kar x)))]
+              [set-cdr!
+                 (lambda (x p)
+                    (when (string=? p pwd)
+                        (set! kar x)))]))
+          (procedure? kons))
+   (begin (define p1 (kons 'a 'b "magnificent")) (procedure? p1))
+   (begin (send-message p1 set-car! 'c "magnificent")
+          (eq? (send-message p1 get-car) 'c))
+   (begin (send-message p1 set-car! 'd "please")
+          (eq? (send-message p1 get-car) 'c))
+   (begin (define p2 (kons 'x 'y "please")) (procedure? p2))
+   (begin (send-message p2 set-car! 'z "please")
+          (eq? (send-message p2 get-car) 'z))
+   (begin (define-object (kons kar kdr)
+             ([count 0])
+             ([get-car
+               (lambda ()
+                  (set! count (+ count 1))
+                  kar)]
+              [get-cdr
+               (lambda ()
+                  (set! count (+ count 1))
+                  kdr)]
+              [accesses
+               (lambda () count)]))
+          (procedure? kons))
+   (begin (define p (kons 'a 'b)) (procedure? p))
+   (eq? (send-message p get-car) 'a)
+   (eq? (send-message p get-cdr) 'b)
+   (eq? (send-message p accesses) '2)
+   (eq? (send-message p get-cdr) 'b)
+   (eq? (send-message p accesses) '3)
+ )
+
+(examples-mat power ("power")
+  (eqv? (power 1/2 3) 1/8)
+)
+
+(examples-mat rabbit ("rabbit")
+   (begin (printf "***** expect rabbit output:~%")
+          (rabbit 3)
+          (dispatch)
+          #t)
+ )
+
+(examples-mat rsa ("rsa")
+   (begin (printf "***** expect rsa output:~%")
+          (make-user bonzo)
+          (make-user bobo)
+          (make-user tiger)
+          (show-center)
+          #t)
+   (equal? (send "hi there" bonzo bobo) "hi there")
+   (equal? (send "hi there to you" bobo bonzo) "hi there to you")
+   (not (equal? (decrypt (encrypt "hi there" bonzo bobo) tiger)
+                "hi there"))
+ )
+
+(define stream->list
+   (lambda (s)
+      (if (procedure? s)
+          '()
+          (cons (car s) (stream->list (cdr s))))))
+
+(examples-mat scons ("scons")
+   (eqv? (stream-ref factlist 3) 6)
+   (equal? (stream->list factlist) '(1 1 2 6))
+   (eqv? (stream-ref factlist 10) 3628800)
+   (equal? (stream->list factlist)
+           '(1 1 2 6 24 120 720 5040 40320 362880 3628800))
+   (eqv? (stream-ref fiblist 3) 3)
+   (equal? (stream->list fiblist) '(1 1 2 3))
+   (eqv? (stream-ref fiblist 5) 8)
+   (equal? (stream->list fiblist) '(1 1 2 3 5 8))
+ )
+
+(examples-mat setof ("setof")
+   (equal? (set-of x (x in '(a b c))) '(a b c))
+   (equal? (set-of x (x in '(1 2 3 4)) (even? x)) '(2 4))
+   (equal? (set-of (cons x y) (x in '(1 2 3)) (y is (* x x)))
+           '((1 . 1) (2 . 4) (3 . 9)))
+   (equal? (set-of (cons x y) (x in '(a b)) (y in '(1 2)))
+           '((a . 1) (a . 2) (b . 1) (b . 2)))
+ )
+
+(examples-mat unify ("unify")
+   ;; examples from TSPL:
+   (eq? (unify 'x 'y) 'y)
+   (equal? (unify '(f x y) '(g x y)) "clash")
+   (equal? (unify '(f x (h)) '(f (h) y)) '(f (h) (h)))
+   (equal? (unify '(f (g x) y) '(f y x)) "cycle")
+   (equal? (unify '(f (g x) y) '(f y (g x))) '(f (g x) (g x)))
+ )
+
+(examples-mat fft ("fft")
+  (equal? (dft '(0 0 0 0)) '(0 0 0 0))
+  (equal? (dft '(2.0 2.0 2.0 2.0)) '(8.0 0.0-0.0i 0.0 0.0+0.0i))
+  (equal? (dft '(+2.i +2.i +2.i +2.i)) '(+0.0+8.0i 0.0+0.0i 0.0+0.0i 0.0+0.0i))
+)
+
+(examples-mat compat ("compat")
+   (eqv? (define! defined-with-define! (lambda () defined-with-define!))
+         'defined-with-define!)
+   (let ((p defined-with-define!))
+     (set! defined-with-define! 0)
+     (eqv? (p) 0))
+
+   (eqv? (defrec! defined-with-defrec! (lambda () defined-with-defrec!))
+         'defined-with-defrec!)
+   (let ((p defined-with-defrec!))
+     (set! defined-with-defrec! 0)
+     (eqv? (p) p))
+
+   (eqv? (begin0 1 2 3 4) 1)
+
+   (equal? (recur f ((ls '(a b c)) (new '()))
+             (if (null? ls) new (f (cdr ls) (cons (car ls) new))))
+           '(c b a))
+
+   (equal? (tree-copy '()) '())
+   (equal? (tree-copy 'a) 'a)
+   (equal? (tree-copy '(a)) '(a))
+   (equal? (tree-copy '(a (b c) . d)) '(a (b c) . d))
+   (let* ((p1 '((a . b) c)) (p2 (car p1)) (p3 (cdr p1)))
+       (let ((c1 (tree-copy p1)))
+           (not
+               (or (memq c1 (list p1 p2 p3))
+                   (memq (car c1) (list p1 p2 p3))
+                   (memq (cdr c1) (list p1 p2 p3))))))
+
+   (= *most-positive-short-integer*
+      *most-positive-fixnum*
+      (most-positive-fixnum))
+
+   (= *most-negative-short-integer*
+      *most-negative-fixnum*
+      (most-negative-fixnum))
+
+   (eof-object? *eof*)
+
+   (eq? short-integer? fixnum?)
+   (eq? big-integer? bignum?)
+   (eq? ratio? ratnum?)
+   (eq? float? flonum?)
+
+   (eq? bound? top-level-bound?)
+   (eq? global-value top-level-value)
+   (eq? set-global-value! set-top-level-value!)
+   (eq? define-global-value define-top-level-value)
+   (eq? symbol-value top-level-value)
+   (eq? set-symbol-value! set-top-level-value!)
+
+   (eq? put putprop)
+   (eq? get getprop)
+
+   (eq? copy-list list-copy)
+   (eq? copy-tree tree-copy)
+   (eq? copy-string string-copy)
+   (eq? copy-vector vector-copy)
+
+   (eq? intern string->symbol)
+   (eq? symbol-name symbol->string)
+   (eq? make-temp-symbol gensym)
+   (eq? temp-symbol? gensym?)
+   (eq? string->uninterned-symbol gensym)
+   (eq? uninterned-symbol? gensym?)
+
+   (eq? compile-eval compile)
+
+   (eq? closure? procedure?)
+
+   (eq? =? =)
+   (eq? ? >)
+   (eq? <=? <=)
+   (eq? >=? >=)
+
+   (eq? float exact->inexact)
+   (eq? rational inexact->exact)
+
+   (eq? char-equal? char=?)
+   (eq? char-less? charsymbol
+                              (string-append
+                               (symbol->string x)
+                               "!!!")))])
+        `'(,(test-function val))))
+    (equal? '(xyz!!!) (test-4 xyz)))
+  (let ()
+    (define-macro (test-4 val)
+      (let ([test-function (lambda (x)
+                             (string->symbol
+                              (string-append
+                               (symbol->string x)
+                               "!!!")))])
+        `'(,(test-function val))))
+    (equal? '(xyz!!!) (test-4 xyz))) 
+  (let ()
+    (define-macro test-5 (this . that)
+      `'(,this ,that))
+    (equal? '(x (y z)) (test-5 x y z)))
+  (let ()
+    (define-macro (test-5 this . that)
+      `'(,this ,that))
+    (equal? '(x (y z)) (test-5 x y z)))
+  (let ()
+    (define-macro test-6 (this . that)
+      `'(,this ,@that))
+    (equal? '(x y z) (test-6 x y z)))
+  (let ()
+    (define-macro (test-6 this . that)
+      `'(,this ,@that))
+    (equal? '(x y z) (test-6 x y z)))
+  (let ()
+    (defmacro test-1 (val)
+      `',val)
+    (equal? 'x (test-1 x)))
+  (let ()
+    (defmacro (test-1 val)
+      `',val)
+    (equal? 'x (test-1 x)))
+  (let ()
+    (defmacro test-2 (val)
+      `'(,val))
+    (equal? '(x) (test-2 x)))
+  (let ()
+    (defmacro (test-2 val)
+      `'(,val))
+    (equal? '(x) (test-2 x)))
+  (let ([xyz '(x y z)])
+    (defmacro test-3 (val)
+      `(,@val))
+    (equal? '(x y z) (test-3 xyz)))
+  (let ([xyz '(x y z)])
+    (defmacro (test-3 val)
+      `(,@val))
+    (equal? '(x y z) (test-3 xyz)))
+  (let ()
+    (defmacro test-4 (val)
+      (let ([test-function (lambda (x)
+                             (string->symbol
+                              (string-append
+                               (symbol->string x)
+                               "!!!")))])
+        `'(,(test-function val))))
+    (equal? '(xyz!!!) (test-4 xyz)))
+  (let ()
+    (defmacro (test-4 val)
+      (let ([test-function (lambda (x)
+                             (string->symbol
+                              (string-append
+                               (symbol->string x)
+                               "!!!")))])
+        `'(,(test-function val))))
+    (equal? '(xyz!!!) (test-4 xyz)))
+  (let ()
+    (defmacro test-5 (this . that)
+      `'(,this ,that))
+    (equal? '(x (y z)) (test-5 x y z)))
+  (let ()
+    (defmacro (test-5 this . that)
+      `'(,this ,that))
+    (equal? '(x (y z)) (test-5 x y z)))
+  (let ()
+    (defmacro test-6 (this . that)
+      `'(,this ,@that))
+    (equal? '(x y z) (test-6 x y z)))
+  (let ()
+    (defmacro (test-6 this . that)
+      `'(,this ,@that))
+    (equal? '(x y z) (test-6 x y z)))
+
+  (begin (define-struct! caramel x y z) (eqv? (caramel-x (caramel 1 2 3)) 1))
+)
+
+(examples-mat ez-grammar-test ("ez-grammar-test")
+  (equal?
+    (with-output-to-string ez-grammar-test)
+    "8 tests ran\n")
+)
diff --git a/mats/exceptions.ms b/mats/exceptions.ms
new file mode 100644
index 0000000..34a773e
--- /dev/null
+++ b/mats/exceptions.ms
@@ -0,0 +1,404 @@
+;;; exceptions.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat exceptions
+  (begin
+    (define ($$capture thunk)
+      (with-output-to-string
+        (lambda ()
+          (call/cc
+            (lambda (k)
+              (with-exception-handler
+                (lambda (x) (printf "default handler: ~s\n" x) (k))
+                (lambda () (printf "~s\n" (thunk)))))))))
+    (define-syntax $capture
+      (syntax-rules ()
+        [(_ e1 e2 ...) ($$capture (lambda () e1 e2 ...))]))
+    #t)
+  (equal?
+    ($capture 'hello)
+    "hello\n")
+  (begin
+    (define ($ex-test1) (raise 'oops) (printf "finished\n"))
+    (define ($ex-test2) (printf "handler returned: ~s\n" (raise-continuable 'oops)) 'done)
+    #t)
+  (equal?
+    ($capture (list ($ex-test1)))
+    "default handler: oops\n")
+  (equal?
+    ($capture
+      (list
+        (with-exception-handler
+          (lambda (arg) (printf "hello: ~s\n" arg))
+          $ex-test1)))
+    "hello: oops\ndefault handler: #\n")
+  (equal?
+    ($capture
+      (list
+        (with-exception-handler
+          (lambda (arg) (raise (list arg)))
+          $ex-test1)))
+    "default handler: (oops)\n")
+  (equal?
+    ($capture (list ($ex-test2)))
+    "default handler: oops\n")
+  (equal?
+    ($capture
+      (list
+        (with-exception-handler
+          (lambda (arg) (printf "hello: ~s\n" arg) 17)
+          $ex-test2)))
+    "hello: oops\nhandler returned: 17\n(done)\n")
+  (equal?
+    ($capture
+      (list
+        (with-exception-handler
+          (lambda (arg) (raise (list arg)))
+          $ex-test2)))
+    "default handler: (oops)\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (raise '()))))
+    "(empty)\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (raise '(a . b)))))
+    "((a . b))\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (raise 'oops))))
+    "default handler: oops\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (with-exception-handler
+            (lambda (x) (printf "just passing through...\n") (raise x))
+            (lambda () (raise '()))))))
+    "just passing through...\n(empty)\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (with-exception-handler
+            (lambda (x) (printf "just passing through...\n") (raise x))
+            (lambda () (raise '(a . b)))))))
+    "just passing through...\n((a . b))\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (with-exception-handler
+            (lambda (x) (printf "just passing through...\n") (raise x))
+            (lambda () (raise 'oops))))))
+    "just passing through...\ndefault handler: oops\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo]
+                    [else (raise 'hair)])
+          (with-exception-handler
+            (lambda (x) (printf "just passing through...\n") (raise x))
+            (lambda () (raise '(a . b)))))))
+    "just passing through...\n((a . b))\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo]
+                    [else (raise 'hair)])
+          (with-exception-handler
+            (lambda (x) (printf "just passing through...\n") (raise x))
+            (lambda () (raise 'oops))))))
+    "just passing through...\ndefault handler: hair\n")
+  (equal?
+    ($capture
+      (list
+        (call/cc
+          (lambda (k)
+            (with-exception-handler
+              (lambda (arg) (printf "outer handler: ~s\n" arg) (k 'fini))
+              (lambda ()
+                (guard (foo [(begin (printf "checking null\n") (null? foo)) 'empty]
+                            [(begin (printf "checking pair\n") (pair? foo)) foo])
+                  (dynamic-wind
+                    (lambda () (printf "in\n"))
+                    (lambda () (raise 'oops))
+                    (lambda () (printf "out\n"))))))))))
+    "in\nout\nchecking null\nchecking pair\nin\nouter handler: oops\nout\n(fini)\n")
+  (equal?
+    ($capture
+      (list
+        (guard (foo [(null? foo) 'empty]
+                    [(pair? foo) foo])
+          (with-exception-handler
+            (lambda (x) (printf "returning...\n"))
+            (lambda () (raise-continuable 'oops) 'continuing)))))
+    "returning...\n(continuing)\n")
+  (equal?
+    ($capture
+     ; test to make sure guard reraises with raise-continuable per r6rs errata
+      (list
+        (with-exception-handler
+          (lambda (x) (printf "returning...\n"))
+          (lambda ()
+            (guard (foo [(null? foo) 'empty]
+                        [(pair? foo) foo])
+              (raise-continuable 'oops)
+              'continuing)))))
+    "returning...\n(continuing)\n")
+)
+
+(mat assert
+  (equal?
+    (begin (assert #t) "yes")
+    "yes")
+  (equal?
+    (assert (memq 'a '(1 2 a 3 4)))
+    '(a 3 4))
+  (error? ; assertion failed
+    (assert (memq 'b '(1 2 a 3 4))))
+  (equal?
+    (begin (assert (< 3 4)) "yes")
+    "yes")
+  (equal?
+    (guard (c [#t "yes"])
+      (begin (assert #f) "no"))
+    "yes")
+  (equal?
+    (guard (c [#t "yes"])
+      (begin (assert (< 4 3)) "no"))
+    "yes")
+ ; make sure pattern variables and ellipses on RHS don't screw us up
+  (equal?
+    (guard (c [#t "oops"])
+      (let-syntax ([q (lambda (x) #t)])
+        (assert (q ...))
+        "okay"))
+    "okay")
+  (equal?
+    (guard (c [#t "oops"])
+      (let-syntax ([q (lambda (x) #f)])
+        (assert (q ...))
+        "okay"))
+    "oops")
+  (error? ; assertion failed
+    (let-syntax ([q (lambda (x) #f)])
+      (assert (q ...))
+      "okay"))
+  (equal?
+    (syntax-case '(a b c) ()
+      [(x ...)
+       (begin
+         (assert (andmap symbol? #'(x ...)))
+         #'((x . x) ...))])
+    '((a . a) (b . b) (c . c)))
+  (error? ; assertion failed
+    (syntax-case '(a b 3) ()
+      [(x ...)
+       (begin
+         (assert (andmap symbol? #'(x ...)))
+         #'((x . x) ...))]))
+)
+
+(mat exceptions-r6rs ; r6rs examples
+  (equal?
+    ($capture
+      (guard (con
+               ((error? con)
+                (if (message-condition? con)
+                    (display (condition-message con))
+                    (display "an error has occurred"))
+                'error)
+               ((violation? con)
+                (if (message-condition? con)
+                    (display (condition-message con))
+                    (display "the program has a bug"))
+                'violation))
+        (raise
+          (condition
+            (make-error)
+            (make-message-condition "I am an error")))))
+    "I am an errorerror\n")
+  (equal?
+    ($capture
+      (guard (con
+               ((error? con)
+                (if (message-condition? con)
+                    (display (condition-message con))
+                    (display "an error has occurred"))
+                'error))
+        (raise
+          (condition
+            (make-violation)
+            (make-message-condition "I am an error")))))
+    "default handler: #\n")
+  (equal?
+    ($capture
+      (with-exception-handler
+        (lambda (con)
+          (cond
+            ((not (warning? con))
+             (raise con))
+            ((message-condition? con)
+             (display (condition-message con)))
+            (else
+             (display "a warning has been issued")))
+          42)
+        (lambda ()
+          (+ (raise-continuable
+               (condition
+                 (make-warning)
+                 (make-message-condition
+                   "should be a number")))
+             23))))
+    "should be a number65\n")
+)
+
+(mat conditions-r6rs ; r6rs examples
+  (begin
+    (define-record-type ($co-&cond1 $co-make-cond1 $co-real-cond1?)
+      (parent &condition)
+      (fields (immutable x $co-real-cond1-x)))
+    (define $co-cond1?
+      (condition-predicate
+        (record-type-descriptor $co-&cond1)))
+    (define $co-cond1-x
+      (condition-accessor
+        (record-type-descriptor $co-&cond1)
+        $co-real-cond1-x))
+    (define $co-foo ($co-make-cond1 'foo))
+    #t)
+  (condition? $co-foo)
+  ($co-cond1? $co-foo)
+  (eq? ($co-cond1-x $co-foo) 'foo)
+  (begin
+    (define-record-type ($co-&cond2 $co-make-cond2 $co-real-cond2?)
+      (parent &condition)
+      (fields
+       (immutable y $co-real-cond2-y)))
+    (define $co-cond2?
+      (condition-predicate
+        (record-type-descriptor $co-&cond2)))
+    (define $co-cond2-y
+      (condition-accessor
+         (record-type-descriptor $co-&cond2)
+         $co-real-cond2-y))
+    (define $co-bar ($co-make-cond2 'bar))
+  #t)
+  (condition? (condition $co-foo $co-bar))
+  ($co-cond1? (condition $co-foo $co-bar))
+  ($co-cond2? (condition $co-foo $co-bar))
+  ($co-cond1? (condition $co-foo))
+  (list?
+    (memq
+      ($co-real-cond1? (condition $co-foo))
+      '(#t #f)))
+  (not ($co-real-cond1? (condition $co-foo $co-bar)))
+  (eq? ($co-cond1-x (condition $co-foo $co-bar)) 'foo)
+  (eq? ($co-cond2-y (condition $co-foo $co-bar)) 'bar)
+  (equal?
+    (simple-conditions (condition $co-foo $co-bar))
+    (list $co-foo $co-bar))
+  (equal?
+    (simple-conditions (condition $co-foo (condition $co-bar)))
+    (list $co-foo $co-bar))
+  (begin
+    (define-condition-type $co-&c &condition $co-make-c $co-c? (x $co-c-x))
+    (define-condition-type $co-&c1 $co-&c $co-make-c1 $co-c1? (a $co-c1-a))
+    (define-condition-type $co-&c2 $co-&c $co-make-c2 $co-c2? (b $co-c2-b))
+    (define $co-v1 ($co-make-c1 "V1" "a1"))
+    #t)
+  ($co-c? $co-v1)
+  ($co-c1? $co-v1)
+  (not ($co-c2? $co-v1))
+  (equal? ($co-c-x $co-v1) "V1")
+  (equal? ($co-c1-a $co-v1) "a1")
+  (begin
+    (define $co-v2 ($co-make-c2 "V2" "b2"))
+    (define $co-v3 (condition ($co-make-c1 "V3/1" "a3") ($co-make-c2 "V3/2" "b3")))
+    (define $co-v4 (condition $co-v1 $co-v2))
+    (define $co-v5 (condition $co-v2 $co-v3))
+    #t)
+  ($co-c? $co-v2)
+  (not ($co-c1? $co-v2))
+  ($co-c2? $co-v2)
+  (equal? ($co-c-x $co-v2) "V2")
+  (equal? ($co-c2-b $co-v2) "b2")
+  ($co-c? $co-v3)
+  ($co-c1? $co-v3)
+  ($co-c2? $co-v3)
+  (equal? ($co-c-x $co-v3) "V3/1")
+  (equal? ($co-c1-a $co-v3) "a3")
+  (equal? ($co-c2-b $co-v3) "b3")
+  ($co-c? $co-v4)
+  ($co-c1? $co-v4)
+  ($co-c2? $co-v4)
+  (equal? ($co-c-x $co-v4) "V1")
+  (equal? ($co-c1-a $co-v4) "a1")
+  (equal? ($co-c2-b $co-v4) "b2")
+  ($co-c? $co-v5)
+  ($co-c1? $co-v5)
+  ($co-c2? $co-v5)
+  (equal? ($co-c-x $co-v5) "V2")
+  (equal? ($co-c1-a $co-v5) "a3")
+  (equal? ($co-c2-b $co-v5) "b2")
+)
+
+(mat system-exceptions
+  (equal?
+    ($capture
+     ; from r6rs
+      (guard (con
+               ((error? con)
+                (display "error opening file")
+                #f))
+        (call-with-input-file "/probably/not/here" read)))
+    "error opening file#f\n")
+  (guard (c [else (and (assertion-violation? c)
+                       (not (implementation-restriction-violation? c)))])
+    (let ()
+      (define-record-type foo (fields x))
+      (foo-x 17)))
+)
+
+(mat exception-state
+  (#%$record? (current-exception-state))
+  (not (record? (current-exception-state)))
+  (eq?
+    (call/cc
+      (lambda (k)
+        (parameterize ([current-exception-state
+                        (create-exception-state
+                          (lambda (x)
+                            (if (eq? x 'oops)
+                                (raise 'rats)
+                                (k x))))])
+          (raise 'oops))))
+    'rats)
+)
diff --git a/mats/fl.ms b/mats/fl.ms
new file mode 100644
index 0000000..d953c8f
--- /dev/null
+++ b/mats/fl.ms
@@ -0,0 +1,1035 @@
+;;; fl.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat flonum->fixnum
+   (error? (flonum->fixnum))
+   (error? (flonum->fixnum 3.3 4.4))
+   (error? (flonum->fixnum 3))
+   (error? (flonum->fixnum 'a))
+   (error? (flonum->fixnum
+              (* (inexact (most-positive-fixnum)) 2.0)))
+   (error? (flonum->fixnum
+              (* (inexact (most-negative-fixnum)) 2.0)))
+   (eq? (+ (ash (most-positive-fixnum) -1) 1)
+        (flonum->fixnum (* (+ (ash (most-positive-fixnum) -1) 1) 1.0)))
+   (eq? (most-negative-fixnum)
+        (flonum->fixnum (* (most-negative-fixnum) 1.0)))
+   (eq? (flonum->fixnum 0.0) 0)
+   (eq? (flonum->fixnum 1.0) 1)
+   (eq? (flonum->fixnum +4.5) +4)
+   (eq? (flonum->fixnum +4.3) +4)
+   (eq? (flonum->fixnum +4.0) +4)
+   (eq? (flonum->fixnum +3.6) +3)
+   (eq? (flonum->fixnum +3.5) +3)
+   (eq? (flonum->fixnum +3.4) +3)
+   (eq? (flonum->fixnum +3.0) +3)
+   (eq? (flonum->fixnum +2.6) +2)
+   (eq? (flonum->fixnum +1.0) +1)
+   (eq? (flonum->fixnum +.5) 0)
+   (eq? (flonum->fixnum -.5) 0)
+   (eq? (flonum->fixnum -1.0) -1)
+   (eq? (flonum->fixnum -2.6) -2)
+   (eq? (flonum->fixnum -3.0) -3)
+   (eq? (flonum->fixnum -3.4) -3)
+   (eq? (flonum->fixnum -3.5) -3)
+   (eq? (flonum->fixnum -3.6) -3)
+   (eq? (flonum->fixnum -4.0) -4)
+   (eq? (flonum->fixnum -4.3) -4)
+   (eq? (flonum->fixnum -4.5) -4)
+
+   (test-cp0-expansion eq? '(+ (ash (most-positive-fixnum) -1) 1)
+        (flonum->fixnum (* (+ (ash (most-positive-fixnum) -1) 1) 1.0)))
+   (test-cp0-expansion eq? '(most-negative-fixnum)
+        (flonum->fixnum (* (most-negative-fixnum) 1.0)))
+   (test-cp0-expansion eq? '(flonum->fixnum 0.0) 0)
+   (test-cp0-expansion eq? '(flonum->fixnum 1.0) 1)
+   (test-cp0-expansion eq? '(flonum->fixnum +4.5) +4)
+   (test-cp0-expansion eq? '(flonum->fixnum +4.3) +4)
+   (test-cp0-expansion eq? '(flonum->fixnum +4.0) +4)
+   (test-cp0-expansion eq? '(flonum->fixnum +3.6) +3)
+   (test-cp0-expansion eq? '(flonum->fixnum +3.5) +3)
+   (test-cp0-expansion eq? '(flonum->fixnum +3.4) +3)
+   (test-cp0-expansion eq? '(flonum->fixnum +3.0) +3)
+   (test-cp0-expansion eq? '(flonum->fixnum +2.6) +2)
+   (test-cp0-expansion eq? '(flonum->fixnum +1.0) +1)
+   (test-cp0-expansion eq? '(flonum->fixnum +.5) 0)
+   (test-cp0-expansion eq? '(flonum->fixnum -.5) 0)
+   (test-cp0-expansion eq? '(flonum->fixnum -1.0) -1)
+   (test-cp0-expansion eq? '(flonum->fixnum -2.6) -2)
+   (test-cp0-expansion eq? '(flonum->fixnum -3.0) -3)
+   (test-cp0-expansion eq? '(flonum->fixnum -3.4) -3)
+   (test-cp0-expansion eq? '(flonum->fixnum -3.5) -3)
+   (test-cp0-expansion eq? '(flonum->fixnum -3.6) -3)
+   (test-cp0-expansion eq? '(flonum->fixnum -4.0) -4)
+   (test-cp0-expansion eq? '(flonum->fixnum -4.3) -4)
+   (test-cp0-expansion eq? '(flonum->fixnum -4.5) -4)
+)
+
+(mat fixnum->flonum
+   (error? (fixnum->flonum))
+   (error? (fixnum->flonum 3 4))
+   (error? (fixnum->flonum 3.4))
+   (error? (fixnum->flonum 'a))
+   (error? (fixnum->flonum (+ (most-positive-fixnum) 1)))
+   (= (fixnum->flonum (most-positive-fixnum))
+      (* (most-positive-fixnum) 1.0))
+   (= (fixnum->flonum 0) 0.0)
+   (= (fixnum->flonum 1) 1.0)
+   (test-cp0-expansion = '(fixnum->flonum (most-positive-fixnum))
+      (* (most-positive-fixnum) 1.0))
+   (test-cp0-expansion = '(fixnum->flonum 0) 0.0)
+   (test-cp0-expansion = '(fixnum->flonum 1) 1.0)
+   (test-cp0-expansion = '(fixnum->flonum -1) -1.0)
+   (test-cp0-expansion = '(fixnum->flonum -1) -1.0)
+)
+
+(mat fl=
+   (not (fl= 3.0 4.0))
+   (not (fl= 4.0 3.0))
+   (fl= 4.1 4.1)
+   (not (fl= -4.1 4.1))
+   (not (fl= 4.1 -4.1))
+   (not (fl= -4.272 -3.272))
+   (not (fl= -3.01e-10 -.01e-3))
+   (fl= -4e-4)
+   (fl= -4e-4 -4e-4)
+   (fl= -4e4 -4e4 -4e4)
+   (error? (fl=))
+   (error? (fl= (list 'a)))
+   (error? (fl= 'a 3.1))
+   (error? (fl= 3.1 'a))
+   (error? (fl= 3.0 3.0 3))
+   (error? (fl= 3.0 3.1 3))
+   (error? (fl= 3.5 3.5 7/2 4.5))
+   (error? (fl= 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl= 3.0 4.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl= 3.0 (error #f "oops") 4.0))
+   (guard (c [#t #t]) (fl= (error #f "oops") 3.0 4.0))
+   (guard (c [#t #t]) (not (fl= (error #f "oops"))))
+ )
+
+(mat fl<
+   (fl< 3.0 4.0)
+   (not (fl< 4.0 3.0))
+   (not (fl< 4.1 4.1))
+   (fl< -4.1 4.1)
+   (not (fl< 4.1 -4.1))
+   (fl< -4.272 -3.272)
+   (not (fl< -3.01e-10 -.01e-3))
+   (fl< -4e-4)
+   (not (fl< -4e-4 -4e-4))
+   (not (fl< -4e-4 -4e-4 -4e-4))
+   (error? (fl<))
+   (error? (fl< (list 'a)))
+   (error? (fl< 'a 3.1))
+   (error? (fl< 3.1 'a))
+   (error? (fl< 3.0 3.1 3))
+   (error? (fl< 3.0 3.0 3))
+   (error? (fl< 3.5 3.5 7/2 4.5))
+   (error? (fl< 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl< 4.0 3.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl< 4.0 (error #f "oops") 3.0))
+   (guard (c [#t #t]) (fl< (error #f "oops") 4.0 3.0))
+   (guard (c [#t #t]) (not (fl< (error #f "oops"))))
+ )
+
+(mat fl>
+   (not (fl> 3.0 4.0))
+   (fl> 4.0 3.0)
+   (not (fl> 4.1 4.1))
+   (not (fl> -4.1 4.1))
+   (fl> 4.1 -4.1)
+   (not (fl> -4.272 -3.272))
+   (fl> -3.01e-10 -.01e-3)
+   (fl> -4e-4)
+   (not (fl> -4e-4 -4e-4))
+   (not (fl> -4e-4 -4e-4 -4e-4))
+   (error? (fl>))
+   (error? (fl> (list 'a)))
+   (error? (fl> 'a 3.1))
+   (error? (fl> 3.1 'a))
+   (error? (fl> 3.1 3.0 3))
+   (error? (fl> 3.0 3.0 3))
+   (error? (fl> 3.5 3.5 7/2 4.5))
+   (error? (fl> 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl> 3.0 4.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl> 3.0 (error #f "oops") 4.0))
+   (guard (c [#t #t]) (fl> (error #f "oops") 3.0 4.0))
+   (guard (c [#t #t]) (not (fl> (error #f "oops"))))
+ )
+
+(mat fl<=
+   (fl<= 3.0 4.0)
+   (not (fl<= 4.0 3.0))
+   (fl<= 4.1 4.1)
+   (fl<= -4.1 4.1)
+   (not (fl<= 4.1 -4.1))
+   (fl<= -4.272 -3.272)
+   (not (fl<= -3.01e-10 -.01e-3))
+   (fl<= -4e-4)
+   (fl<= -4e-4 -4e-4)
+   (fl<= -4e-4 -4e-4 -4e-4)
+   (error? (fl<=))
+   (error? (fl<= (list 'a)))
+   (error? (fl<= 'a 3.1))
+   (error? (fl<= 3.1 'a))
+   (error? (fl<= 3.0 3.0 3))
+   (error? (fl<= 3.1 3.0 3))
+   (error? (fl<= 3.5 3.5 7/2 4.5))
+   (error? (fl<= 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl<= 4.0 3.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl<= 4.0 (error #f "oops") 3.0))
+   (guard (c [#t #t]) (fl<= (error #f "oops") 4.0 3.0))
+   (guard (c [#t #t]) (not (fl<= (error #f "oops"))))
+ )
+
+(mat fl>=
+   (not (fl>= 3.0 4.0))
+   (fl>= 4.0 3.0)
+   (fl>= 4.1 4.1)
+   (not (fl>= -4.1 4.1))
+   (fl>= 4.1 -4.1)
+   (not (fl>= -4.272 -3.272))
+   (fl>= -3.01e-10 -.01e-3)
+   (fl>= -4e-4)
+   (fl>= -4e-4 -4e-4)
+   (fl>= -4e-4 -4e-4 -4e-4)
+   (error? (fl>=))
+   (error? (fl>= (list 'a)))
+   (error? (fl>= 'a 3.1))
+   (error? (fl>= 3.1 'a))
+   (error? (fl>= 3.0 3.0 3))
+   (error? (fl>= 3.0 3.1 3))
+   (error? (fl>= 3.5 3.5 7/2 4.5))
+   (error? (fl>= 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl>= 3.0 4.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl>= 3.0 (error #f "oops") 4.0))
+   (guard (c [#t #t]) (fl>= (error #f "oops") 3.0 4.0))
+   (guard (c [#t #t]) (not (fl>= (error #f "oops"))))
+ )
+
+(mat fl=?
+   (not (fl=? 3.0 4.0))
+   (not (fl=? 4.0 3.0))
+   (fl=? 4.1 4.1)
+   (not (fl=? -4.1 4.1))
+   (not (fl=? 4.1 -4.1))
+   (not (fl=? -4.272 -3.272))
+   (not (fl=? -3.01e-10 -.01e-3))
+   (fl=? -4e-4 -4e-4)
+   (fl=? -4e4 -4e4 -4e4)
+   (error? (fl=?))
+   (error? (fl=? 3.4))
+   (error? (fl=? 'a 3.1))
+   (error? (fl=? 3.1 'a))
+   (error? (fl=? 3.0 3.0 3))
+   (error? (fl=? 3.0 3.1 3))
+   (error? (fl=? 3.5 3.5 7/2 4.5))
+   (error? (fl=? 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl=? 3.0 4.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl=? 3.0 (error #f "oops") 4.0))
+   (guard (c [#t #t]) (fl=? (error #f "oops") 3.0 4.0))
+   (guard (c [#t #t]) (not (fl=? (error #f "oops"))))
+ )
+
+(mat fl?
+   (not (fl>? 3.0 4.0))
+   (fl>? 4.0 3.0)
+   (not (fl>? 4.1 4.1))
+   (not (fl>? -4.1 4.1))
+   (fl>? 4.1 -4.1)
+   (not (fl>? -4.272 -3.272))
+   (fl>? -3.01e-10 -.01e-3)
+   (not (fl>? -4e-4 -4e-4))
+   (not (fl>? -4e-4 -4e-4 -4e-4))
+   (error? (fl>?))
+   (error? (fl>? 3.4))
+   (error? (fl>? 'a 3.1))
+   (error? (fl>? 3.1 'a))
+   (error? (fl>? 3.1 3.0 3))
+   (error? (fl>? 3.0 3.0 3))
+   (error? (fl>? 3.5 3.5 7/2 4.5))
+   (error? (fl>? 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl>? 3.0 4.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl>? 3.0 (error #f "oops") 4.0))
+   (guard (c [#t #t]) (fl>? (error #f "oops") 3.0 4.0))
+   (guard (c [#t #t]) (not (fl>? (error #f "oops"))))
+ )
+
+(mat fl<=?
+   (fl<=? 3.0 4.0)
+   (not (fl<=? 4.0 3.0))
+   (fl<=? 4.1 4.1)
+   (fl<=? -4.1 4.1)
+   (not (fl<=? 4.1 -4.1))
+   (fl<=? -4.272 -3.272)
+   (not (fl<=? -3.01e-10 -.01e-3))
+   (fl<=? -4e-4 -4e-4)
+   (fl<=? -4e-4 -4e-4 -4e-4)
+   (error? (fl<=?))
+   (error? (fl<=? 3.4))
+   (error? (fl<=? 'a 3.1))
+   (error? (fl<=? 3.1 'a))
+   (error? (fl<=? 3.0 3.0 3))
+   (error? (fl<=? 3.1 3.0 3))
+   (error? (fl<=? 3.5 3.5 7/2 4.5))
+   (error? (fl<=? 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl<=? 4.0 3.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl<=? 4.0 (error #f "oops") 3.0))
+   (guard (c [#t #t]) (fl<=? (error #f "oops") 4.0 3.0))
+   (guard (c [#t #t]) (not (fl<=? (error #f "oops"))))
+ )
+
+(mat fl>=?
+   (not (fl>=? 3.0 4.0))
+   (fl>=? 4.0 3.0)
+   (fl>=? 4.1 4.1)
+   (not (fl>=? -4.1 4.1))
+   (fl>=? 4.1 -4.1)
+   (not (fl>=? -4.272 -3.272))
+   (fl>=? -3.01e-10 -.01e-3)
+   (fl>=? -4e-4 -4e-4)
+   (fl>=? -4e-4 -4e-4 -4e-4)
+   (error? (fl>=?))
+   (error? (fl>=? 3.4))
+   (error? (fl>=? 'a 3.1))
+   (error? (fl>=? 3.1 'a))
+   (error? (fl>=? 3.0 3.0 3))
+   (error? (fl>=? 3.0 3.1 3))
+   (error? (fl>=? 3.5 3.5 7/2 4.5))
+   (error? (fl>=? 3.5 4.5 7/2 3.5))
+   (guard (c [#t #t]) (fl>=? 3.0 4.0 (error #f "oops")))
+   (guard (c [#t #t]) (fl>=? 3.0 (error #f "oops") 4.0))
+   (guard (c [#t #t]) (fl>=? (error #f "oops") 3.0 4.0))
+   (guard (c [#t #t]) (not (fl>=? (error #f "oops"))))
+ )
+
+(mat fl+
+   (eqv? (fl+) 0.0)
+   (eqv? (fl+ -3.0) -3.0)
+   (eqv? (fl+ -3.0 4.0) 1.0)
+   (eqv? (fl+ (inexact 1/3) (inexact 1/3))
+         (+ (inexact 1/3) (inexact 1/3)))
+   (eqv? (fl+ 3.25 4.375 5.625) (+ 3.25 4.375 5.625))
+   (error? (fl+ '(a . b)))
+   (error? (fl+ 2.0 1))
+   (error? (fl+ 1.0 -3.0 2/3))
+   (string=? (number->string (fl+)) "0.0")
+   (test-cp0-expansion eqv? '(fl+) 0.0)
+   (test-cp0-expansion eqv? '(fl+ -3.0) -3.0)
+   (test-cp0-expansion eqv? '(fl+ -3.0 4.0) 1.0)
+   (test-cp0-expansion eqv? 
+     '(fl+ (inexact 1/3) (inexact 1/3))
+     (+ (inexact 1/3) (inexact 1/3)))
+   (test-cp0-expansion eqv? '(fl+ 3.25 4.375 5.625) (+ 3.25 4.375 5.625))
+ )
+
+(mat fl-
+   (error? (fl-))
+   (eqv? (fl- -3.0) 3.0)
+   (eqv? (fl- -3.0 4.0) -7.0)
+   (eqv? (fl- (inexact 1/3) (inexact 1/7))
+         (- (inexact 1/3) (inexact 1/7)))
+   (eqv? (fl- 3.25 4.375 5.625) (- 3.25 4.375 5.625))
+   (error? (fl- '(a . b)))
+   (error? (fl- 2.0 1))
+   (error? (fl- 'a 'b))
+   (error? (fl- 'a 'b 'c))
+   (error? (fl- 1.0 -3.0 2/3))
+   (error? (fl- 1.0 'b 2.0))
+   (test-cp0-expansion eqv? '(fl- -3.0) 3.0)
+   (test-cp0-expansion eqv? '(fl- -3.0 4.0) -7.0)
+   (test-cp0-expansion eqv? 
+     '(fl- (inexact 1/3) (inexact 1/7))
+     (- (inexact 1/3) (inexact 1/7)))
+   (test-cp0-expansion eqv? '(fl- 3.25 4.375 5.625) (- 3.25 4.375 5.625))
+ )
+
+(mat fl*
+   (eqv? (fl*) 1.0)
+   (eqv? (fl* -3.0) -3.0)
+   (eqv? (fl* -3.0 4.0) -12.0)
+   (eqv? (fl* (inexact 1/3) (inexact 1/3))
+         (* (inexact 1/3) (inexact 1/3)))
+   (eqv? (fl* 3.25 4.375 5.625) (* 3.25 4.375 5.625))
+   (error? (fl* '(a . b)))
+   (error? (fl* 2.0 1))
+   (error? (fl* 1.0 -3.0 2/3))
+   (string=? (number->string (fl*)) "1.0")
+   (test-cp0-expansion eqv? '(fl*) 1.0)
+   (test-cp0-expansion eqv? '(fl* -3.0) -3.0)
+   (test-cp0-expansion eqv? '(fl* -3.0 4.0) -12.0)
+   (test-cp0-expansion eqv? 
+     '(fl* (inexact 1/3) (inexact 1/3))
+     (* (inexact 1/3) (inexact 1/3)))
+   (test-cp0-expansion eqv? '(fl* 3.25 4.375 5.625) (* 3.25 4.375 5.625))
+ )
+
+(mat fl/
+   (error? (fl/))
+   (eqv? (fl/ -3.0) (/ -3.0))
+   (eqv? (fl/ -3.0 4.0) -.75)
+   (eqv? (fl/ (inexact 1/3) (inexact 1/7))
+         (/ (inexact 1/3) (inexact 1/7)))
+   (eqv? (fl/ 3.25 4.375 5.625) (/ 3.25 4.375 5.625))
+   (error? (fl/ '(a . b)))
+   (error? (fl/ 2.0 1))
+   (error? (fl/ 1.0 -3.0 2/3))
+   (test-cp0-expansion eqv? '(fl/ -3.0) (/ -3.0))
+   (test-cp0-expansion eqv? '(fl/ -3.0 4.0) -.75)
+   (test-cp0-expansion eqv? 
+     '(fl/ (inexact 1/3) (inexact 1/7))
+     (/ (inexact 1/3) (inexact 1/7)))
+   (test-cp0-expansion eqv? '(fl/ 3.25 4.375 5.625) (/ 3.25 4.375 5.625))
+ )
+
+(mat flabs
+    (error? (flabs))
+    (error? (flabs 1 2))
+    (error? (flabs 'a))
+    (error? (flabs 1))
+    (error? (flabs -3/4))
+    (error? (flabs 3+4i))
+    (error? (flabs 3.3+4.5i))
+    (fl~= (flabs 1.83) 1.83)
+    (fl~= (flabs -0.093) 0.093)
+    (== (flabs -0.0) 0.0)
+    (== (flabs 0.0) 0.0)
+    (== (flabs +inf.0) +inf.0)
+    (== (flabs -inf.0) +inf.0)
+    (== (flabs +nan.0) +nan.0)
+    (eqv? (flabs 0.0) 0.0)
+    (eqv? (flabs -1.0) 1.0)
+    (eqv? (flabs 1.0) 1.0)
+ )
+
+(mat fllog
+    (error? (fllog))
+    (error? (fllog 3)) 
+    (error? (fllog 'a))
+    (error? (fllog 0))
+    (fl~= (fllog 1.0) 0.0)
+    (fl~= (fllog (exp 7.0)) 7.0) 
+    (fl~= (fllog (exp 10.2)) 10.2)
+    (fl~= (fllog 1e30) (inexact (log #e1e30)))
+    (fl~= (/ (log (expt 10 500)) (fllog 10.0)) 500.0)
+    (fl~= (log 3/4) (fllog .75))
+    (fl~= (fllog 10.0 10.0) 1.0)
+    (fl~= (fllog 50.0 50.0) 1.0)
+    (fl~= (fllog 1000.0 10.0) 3.0)
+   ; r6rs:
+    (== (fllog +inf.0) +inf.0)
+    (== (fllog 0.0) -inf.0)
+    (== (fllog -inf.0) +nan.0)
+ )
+
+(mat flexp
+    (error? (flexp))
+    (error? (flexp 3.0 4.0)) 
+    (error? (flexp 'a))
+    (error? (flexp 3))
+    (fl= (flexp 0.0) 1.0)
+    (~= (* (flexp 1.0) (flexp 1.0)) (flexp 2.0))
+    (fl~= (/ (flexp 24.2) (flexp 2.0)) (flexp 22.2))
+   ; r6rs:
+    (== (flexp +inf.0) +inf.0)
+    (== (flexp -inf.0) 0.0)
+ )
+
+(mat flsin
+    (and (> pi 3.14159265) (< pi 3.14159266))
+    (error? (flsin))
+    (error? (flsin 3.0 4.0)) 
+    (error? (flsin 'a))
+    (error? (flsin 3))
+    (fl~= (flsin (/ pi 6)) 0.5)
+ )
+
+(mat flcos
+    (error? (flcos))
+    (error? (flcos 3.0 4.0)) 
+    (error? (flcos 'a))
+    (error? (flcos 3))
+    (fl~= (flcos (/ pi 3)) 0.5)
+    (let ([x 3.3])
+       (let ([s (flsin x)] [c (flcos x)])
+          (~= (+ (* s s) (* c c)) 1.0)))
+ )
+
+(mat fltan
+    (error? (fltan))
+    (error? (fltan 3.0 4.0)) 
+    (error? (fltan 'a))
+    (error? (fltan 3))
+    (fl~= (fltan (/ pi 4)) 1.0)
+    (let ([x 4.4]) (~= (fltan x) (/ (flsin x) (flcos x))))
+ )
+
+(mat flasin
+    (error? (flasin))
+    (error? (flasin 3.0 4.0)) 
+    (error? (flasin 'a))
+    (error? (flasin 3))
+    (fl~= (flasin 1.0) (/ pi 2))
+    (let ([x 1.0]) (fl~= (flasin (flsin x)) x))
+    (let ([x 0.5]) (fl~= (flasin (flsin x)) x))
+ )
+
+(mat flacos
+    (error? (flacos))
+    (error? (flacos 3.0 4.0)) 
+    (error? (flacos 'a))
+    (error? (flacos 3))
+    (fl~= (flacos 0.5) (/ pi 3))
+    (let ([x 0.5]) (fl~= (flacos (flcos x)) x))
+ )
+
+(mat flatan
+    (error? (flatan))
+    (error? (flatan 3.0 4.0 5.0)) 
+    (error? (flatan 'a))
+    (error? (flatan 'a 3.0))
+    (error? (flatan 3.0 'a))
+    (error? (flatan 3 4))
+    (error? (flatan +i))
+    (error? (flatan -i))
+    (fl~= (flatan 1.0) (/ pi 4))
+    (fl~= (flatan 2.0 2.0) (/ pi 4))
+    (let ([x 0.5]) (fl~= (flatan (fltan x)) x))
+    (fl~= (flatan 10.0 -10.0) (angle -10+10i))
+    (fl~= (flatan 10.0 -10.0) (angle -10.0+10.0i))
+    (fl~= (flatan 10.0 -10.0) (flatan 10.0 -10.0))
+   ; r6rs:
+    (== (flatan -inf.0) -1.5707963267948965)
+    (== (flatan +inf.0) 1.5707963267948965)
+ )
+
+(mat flsqrt
+    (error? (flsqrt))
+    (error? (flsqrt 3.0 4.0)) 
+    (error? (flsqrt 'a))
+    (error? (flsqrt 3))
+    (== (flsqrt -1.0) (nan))
+    (~= (flsqrt 9.0) 3.0)
+    (~= (flsqrt #i1/4) #e1/2)
+    (~= (* (flsqrt 189.0) (flsqrt 189.0)) 189.0)
+    (fl~= (* (flsqrt 2.0) (flsqrt 2.0)) 2.0)
+    (~= (flsqrt 1e38) (sqrt #e1e38))
+   ; r6rs:
+    (== (flsqrt +inf.0) +inf.0)
+    (== (flsqrt -0.0) -0.0)
+ )
+
+(mat flexpt
+    (error? (flexpt))
+    (error? (flexpt 5.0))
+    (error? (flexpt 3.0 4.0 5.0))
+    (error? (flexpt 'a 3.0))
+    (error? (flexpt 3.0 'a))
+    (error? (flexpt 0.0 -1))
+    (error? (flexpt 0.0 +1i))
+    (fl~= (flexpt 10.0 -20.0) 1e-20)
+    (eqv? (flexpt 2.0 10.0) 1024.0)
+    (eqv? (flexpt 0.0 0.0) 1.0)
+    (eqv? (flexpt 0.0 2.0) 0.0)
+    (eqv? (flexpt 100.0 0.0) 1.0)
+    (eqv? (flexpt 2.0 -10.0) #i1/1024)
+    (eqv? (flexpt #i-1/2 #i5) #i-1/32)
+    (fl~= (flexpt 9.0 #i1/2) 3.0)
+    (fl~= (flexpt 3.0 3.0) 27.0)
+    (~= (flexpt -0.5 2.0) .25)
+    (~= (flexpt -0.5 -2.0) 4.0)
+    (~= (flexpt 3.0 2.5) (flsqrt (* 3.0 3.0 3.0 3.0 3.0)))
+    (fl= (flexpt 0.0 2.0) 0.0)
+    (fl= (flexpt 0.0 0.0) 1.0)
+    (fl= (flexpt 2.0 0.0) 1.0)
+    (fl~= (flexpt #i-2/3 #i-3) #i-27/8)
+    (fl= (flexpt 10.0 -1000.0) 0.0)
+    (fl= (flexpt .1 1000.0) 0.0)
+    (~= (flexpt #i11 #i1/2) (flsqrt #i11))
+    (fl~= (flexpt 1.5e-20 0.5) (flsqrt 1.5e-20))
+    (equal?
+      (let ([ls '(a b c)])
+        (let ([n (flexpt (begin (set! ls (append ls ls)) 2.0)
+                         (begin (set! ls (reverse ls)) 3.0))])
+          (cons n ls)))
+      '(8.0 c b a c b a))
+ )
+
+(mat fltruncate
+    (error? (fltruncate))
+    (error? (fltruncate 2.0 3.0))
+    (error? (fltruncate 'a))
+    (error? (fltruncate 3))
+    (error? (fltruncate 2+1.0i))
+    (error? (fltruncate 2+1i))
+    (eqv? (fltruncate 19.0) 19.0)
+    (eqv? (fltruncate #i2/3) 0.0)
+    (fl~= (fltruncate #i-2/3) 0.0)
+    (fl= (fltruncate #i17.3) 17.0)
+    (eqv? (fltruncate #i-17/2) -8.0)
+    (fl= (fltruncate 2.5) 2.0)
+   ; r6rs:
+    (== (fltruncate +nan.0) +nan.0)
+ )
+
+(mat flfloor
+    (error? (flfloor))
+    (error? (flfloor 2.0 3.0))
+    (error? (flfloor 'a))
+    (error? (flfloor 3))
+    (error? (flfloor 2+1.0i))
+    (error? (flfloor 2+1i))
+    (eqv? (flfloor 19.0) 19.0)
+    (eqv? (flfloor #i2/3) 0.0)
+    (eqv? (flfloor #i-2/3) -1.0)
+    (fl= (flfloor #i17.3) 17.0)
+    (eqv? (flfloor #i-17/2) -9.0)
+    (fl= (flfloor 2.5) 2.0)
+   ; r6rs:
+    (== (flfloor +inf.0) +inf.0)
+ )
+
+(mat flceiling
+    (error? (flceiling))
+    (error? (flceiling 2.0 3.0))
+    (error? (flceiling 'a))
+    (error? (flceiling 3))
+    (error? (flceiling 2+1.0i))
+    (eqv? (flceiling 19.0) 19.0)
+    (eqv? (flceiling #i2/3) 1.0)
+    (fl~= (flceiling #i-2/3) 0.0)
+    (fl= (flceiling #i17.3) 18.0)
+    (eqv? (flceiling #i-17/2) -8.0)
+    (fl= (flceiling 2.5) 3.0)
+   ; r6rs:
+    (== (flceiling -inf.0) -inf.0)
+ )
+
+(mat flround
+    (error? (flround))
+    (error? (flround 2.0 3))
+    (error? (flround 'a))
+    (error? (flround 2+1.0i))
+    (error? (flround 2+1i))
+    (error? (flround 19))
+    (error? (flround 2/3))
+    (fl= (flround 17.3) 17.0)
+    (fl= (flround 2.5) 2.0)
+    (fl= (flround 0.5000000000000000) 0.0)
+    (fl= (flround 0.5000000000000001) 1.0)
+ )
+
+(mat flinteger?
+    (error? (flinteger? 'a))
+    (error? (flinteger? "hi"))
+    (error? (flinteger? (cons 3 4)))
+    (error? (flinteger? 3.0+0.0i))
+    (error? (flinteger? 3.0+1.0i))
+    (flinteger? 3.0)
+    (flinteger? 23048230482304.0)
+    (not (flinteger? #i-3/4))
+    (flinteger? -1.0)
+    (flinteger? 0.0)
+    (flinteger? -12083.0)
+    (flinteger? 4.0)
+    (not (flinteger? 3.5))
+    (not (flinteger? 1.8e-10))
+    (flinteger? 1.8e10)
+    (flinteger? -3e5)
+    (not (flinteger? -1231.2344))
+ )
+
+(mat flnan?
+  (error? (flnan? 3))
+  (error? (flnan? 3/4))
+  (error? (flnan? 'hi))
+  (flnan? (nan))
+  (not (flnan? 5.0))
+  (not (flnan? +inf.0))
+  (not (flnan? -inf.0))
+)
+
+(mat flfinite?
+  (error? (flfinite? 3))
+  (error? (flfinite? 3/4))
+  (error? (flfinite? 'hi))
+  (not (flfinite? (nan)))
+  (flfinite? 5.0)
+  (not (flfinite? +inf.0))
+  (not (flfinite? -inf.0))
+ ; r6rs:
+  (not (flfinite? +inf.0))
+  (flfinite? 5.0)
+)
+
+(mat flinfinite?
+  (error? (flinfinite? 3))
+  (error? (flinfinite? 3/4))
+  (error? (flinfinite? 'hi))
+  (not (flinfinite? (nan)))
+  (not (flinfinite? 5.0))
+  (flinfinite? +inf.0)
+  (flinfinite? -inf.0)
+ ; r6rs:
+  (not (flinfinite? 5.0))
+  (flinfinite? +inf.0)
+)
+
+(mat flzero?
+    (error? (flzero?))
+    (error? (flzero? 0.0 1.0))
+    (error? (flzero? 'a))
+    (error? (flzero? 3))
+    (flzero? 0.0)
+    (flzero? #i0/5)
+    (not (flzero? 234.0))
+    (not (flzero? #i23423423/234241211))
+    (not (flzero? 23.4))
+    (not (flzero? -1734234.0))
+    (not (flzero? #i-2/3))
+    (not (flzero? -0.1))
+ )
+
+(mat flpositive?
+    (error? (flpositive?))
+    (error? (flpositive? 0.0 1.0))
+    (error? (flpositive? 'a))
+    (error? (flpositive? 3))
+    (error? (flpositive? 1+1.0i))
+    (error? (flpositive? 1+1i))
+    (not (flpositive? 0.0))
+    (not (flpositive? #i0/5))
+    (flpositive? 234.0)
+    (flpositive? #i23423423/234241211)
+    (flpositive? 23.4)
+    (not (flpositive? -1734234.0))
+    (not (flpositive? #i-2/3))
+    (not (flpositive? -0.1))
+ )
+
+(mat flnegative?
+    (error? (flnegative?))
+    (error? (flnegative? 0.0 1.0))
+    (error? (flnegative? 'a))
+    (error? (flnegative? 3))
+    (error? (flnegative? 1+1.0i))
+    (error? (flnegative? 1+1i))
+    (not (flnegative? 0.0))
+    (not (flnegative? #i0/5))
+    (not (flnegative? 234.0))
+    (not (flnegative? #i23423423/234241211))
+    (not (flnegative? 23.4))
+    (flnegative? -1734234.0)
+    (flnegative? #i-2/3)
+    (flnegative? -0.1)
+   ; r6rs:
+    (not (flnegative? -0.0))
+ )
+
+(mat flnonpositive?
+    (error? (flnonpositive?))
+    (error? (flnonpositive? 0.0 1.0))
+    (error? (flnonpositive? 'a))
+    (error? (flnonpositive? 3))
+    (error? (flnonpositive? 1+1.0i))
+    (error? (flnonpositive? 1+1i))
+    (flnonpositive? 0.0)
+    (flnonpositive? #i0/5)
+    (not (flnonpositive? 234.0))
+    (not (flnonpositive? #i23423423/234241211))
+    (not (flnonpositive? 23.4))
+    (flnonpositive? -1734234.0)
+    (flnonpositive? #i-2/3)
+    (flnonpositive? -0.1)
+ )
+
+(mat flnonnegative?
+    (error? (flnonnegative?))
+    (error? (flnonnegative? 0.0 1.0))
+    (error? (flnonnegative? 'a))
+    (error? (flnonnegative? 3))
+    (error? (flnonnegative? 1+1i))
+    (error? (flnonnegative? 1.0+1.0i))
+    (flnonnegative? 0.0)
+    (flnonnegative? #i0/5)
+    (flnonnegative? 234.0)
+    (flnonnegative? #i23423423/234241211)
+    (flnonnegative? 23.4)
+    (not (flnonnegative? -1734234.0))
+    (not (flnonnegative? #i-2/3))
+    (not (flnonnegative? -0.1))
+ )
+
+(mat fleven?
+    (error? (fleven?))
+    (error? (fleven? 0.0 1.0))
+    (error? (fleven? 'a))
+    (error? (fleven? 3))
+    (error? (fleven? 3.2))
+    (error? (fleven? 3.0+1.0i))
+    (error? (fleven? 1+1i))
+    (error? (fleven? +inf.0))
+    (error? (fleven? +nan.0))
+    (not (fleven? -3.0))
+    (fleven? 2.0)
+    (not (fleven? 1208312083280477.0))
+    (fleven? 1208312083280478.0)
+    (fleven? 4.0)
+    (not (fleven? 3.0))
+ )
+
+(mat flodd?
+    (error? (flodd?))
+    (error? (flodd? 0.0 1.0))
+    (error? (flodd? 'a))
+    (error? (flodd? 3))
+    (error? (flodd? 3.2))
+    (error? (flodd? 3.0+1.0i))
+    (error? (flodd? 3+1i))
+    (error? (flodd? +inf.0))
+    (error? (flodd? +nan.0))
+    (flodd? -3.0)
+    (not (flodd? 2.0))
+    (flodd? 1208312083280477.0)
+    (not (flodd? 1208312083280478.0))
+    (not (flodd? 4.0))
+    (flodd? 3.0)
+ )
+
+(mat flmin
+    (error? (flmin))
+    (error? (flmin 'a))
+    (error? (flmin 1.0 'a))
+    (error? (flmin 1.0 'a 2.0))
+    (error? (flmin 1.0 3 2.0))
+    (error? (flmin 1.0 2.0 3.0 'a))
+    (error? (flmin 1.0 2.0 3.0 0+1.0i))
+    (error? (flmin 1.0 2.0 3.0 +1i))
+    (eqv? (flmin -17.0) -17.0)
+    (eqv? (flmin 3.0 -3.0) -3.0)
+    (eqv? (flmin 3.2 1.0) 1.0)
+    (fl= (flmin 3.2 1.0) 1.0)
+    (fl= (flmin #i1/2 0.5) 0.5)
+    (fl= (flmin #i-1/2 0.5) -0.5)
+    (eqv? (flmin 3.0 5.0 1.0 4.0 6.0 2.0) 1.0)
+    (== (flmin 4.5 (nan)) (nan))
+    (== (flmin (nan) 4.5) (nan))
+    (== (flmin +inf.0 (nan)) (nan))
+    (== (flmin (nan) +inf.0) (nan))
+    (== (flmin -inf.0 (nan)) (nan))
+    (== (flmin (nan) -inf.0) (nan))
+    (== (flmin 3.0 4.5 (nan) 17.3 -1.5) (nan))
+    (fl= (flmin 3.0 4.5 +inf.0 17.3 -1.5) -1.5)
+    (fl= (flmin 3.0 4.5 -inf.0 17.3 -1.5) -inf.0)
+ )
+
+(mat flmax
+    (error? (flmax))
+    (error? (flmax 'a))
+    (error? (flmax 1.0 'a))
+    (error? (flmax 1.0 3))
+    (error? (flmax 1.0 'a 2.0))
+    (error? (flmax 1.0 2.0 3.0 'a))
+    (error? (flmax 1.0 2.0 3.0 0+1.0i))
+    (error? (flmax 1.0 2.0 3.0 +1i))
+    (eqv? (flmax 1.0) 1.0)
+    (eqv? (flmax 3.0 -3.0) 3.0)
+    (fl= (flmax 3.2 1.0) 3.2)
+    (fl= (flmax 3.2 1.0) 3.2)
+    (fl= (flmax #i1/2 0.5) 0.5)
+    (fl= (flmax #i1/2 -0.5) 0.5)
+    (eqv? (flmax 3.0 5.0 1.0 4.0 6.0 2.0) 6.0)
+    (== (flmax 4.5 (nan)) (nan))
+    (== (flmax (nan) 4.5) (nan))
+    (== (flmax +inf.0 (nan)) (nan))
+    (== (flmax (nan) +inf.0) (nan))
+    (== (flmax -inf.0 (nan)) (nan))
+    (== (flmax (nan) -inf.0) (nan))
+    (== (flmax 3.0 4.5 (nan) 17.3 -1.5) (nan))
+    (fl= (flmax 3.0 4.5 +inf.0 17.3 -1.5) +inf.0)
+    (fl= (flmax 3.0 4.5 -inf.0 17.3 -1.5) 17.3)
+ )
+
+(mat flnumerator
+    (error? (flnumerator))
+    (error? (flnumerator 3.0 4.0)) 
+    (error? (flnumerator 'a))
+    (error? (flnumerator 3))
+    (error? (flnumerator +1i))
+    (error? (flnumerator 2.2+1.1i))
+    (eqv? (flnumerator 3.25) 13.0)
+    (eqv? (flnumerator 9.0) 9.0)
+    (fl~= (let ([n (flnumerator #i2/3)] [d (fldenominator #i2/3)]) (/ n d)) #i2/3)
+    (fl~= (flnumerator #i-9/4) -9.0)
+    (== (flnumerator +nan.0) +nan.0)
+   ; r6rs:
+    (== (flnumerator +inf.0) +inf.0)
+    (== (flnumerator -inf.0) -inf.0)
+    (== (flnumerator 0.75) 3.0)
+ )
+
+(mat fldenominator
+    (error? (fldenominator))
+    (error? (fldenominator 3.0 4.0)) 
+    (error? (fldenominator 'a))
+    (error? (fldenominator 3))
+    (error? (fldenominator +1i))
+    (error? (fldenominator 2.2+1.1i))
+    (eqv? (fldenominator 3.25) 4.0)
+    (eqv? (fldenominator 9.0) 1.0)
+    (eqv? (fldenominator #i-9/4) 4.0)
+    (== (fldenominator +nan.0) +nan.0)
+   ; r6rs:
+    (== (fldenominator +inf.0) 1.0)
+    (== (fldenominator -inf.0) 1.0)
+    (== (fldenominator 0.75) 4.0)
+ )
+
+(mat fldiv-and-mod
+ ; fldiv-and-mod
+  (error? (fldiv-and-mod 17 3.0))
+  (error? (fldiv-and-mod 3.0 17))
+  (error? (fldiv-and-mod 'a 17.0))
+  (error? (fldiv-and-mod 17.0 '(a)))
+ ; fldiv
+  (error? (fldiv 17 3.0))
+  (error? (fldiv 3.0 17))
+  (error? (fldiv 'a 17.0))
+  (error? (fldiv 17.0 '(a)))
+ ; flmod
+  (error? (flmod 17 3.0))
+  (error? (flmod 3.0 17))
+  (error? (flmod 'a 17.0))
+  (error? (flmod 17.0 '(a)))
+ ; fldiv-and-mod
+  (begin
+    (define $d&m fldiv-and-mod)
+    (define ($dmpair x y) (call-with-values (lambda () ($d&m x y)) cons))
+    (define ($dmpairs x y)
+      (list ($dmpair x y) ($dmpair (- x) y) ($dmpair x (- y)) ($dmpair (- x) (- y))
+            ($dmpair y x) ($dmpair (- y) x) ($dmpair y (- x)) ($dmpair (- y) (- x))))
+    (define ($dmequal? x y)
+      (cond
+        [(pair? x)
+         (and (pair? y)
+              ($dmequal? (car x) (car y))
+              ($dmequal? (cdr x) (cdr y)))]
+        [(number? x)
+         (and (number? y)
+              (if (inexact? x)
+                  (and (inexact? y) (== x y))
+                  (and (exact? y) (= x y))))]
+        [else (eq? x y)]))
+    #t)
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (-1.0 . 7.75) (-0.0 . 3.5) (1.0 . 7.75)
+      (3.0 . 0.75) (-4.0 . 2.75) (-3.0 . 0.75) (4.0 . 2.75)))
+ ; fldiv with flmod
+  (begin
+    (set! $d&m (lambda (x y) (values (fldiv x y) (flmod x y))))
+    #t)
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (-1.0 . 7.75) (-0.0 . 3.5) (1.0 . 7.75)
+      (3.0 . 0.75) (-4.0 . 2.75) (-3.0 . 0.75) (4.0 . 2.75)))
+)
+
+(mat fldiv0-and-mod0
+ ; fldiv0-and-mod0
+  (error? (fldiv0-and-mod0 17 3.0))
+  (error? (fldiv0-and-mod0 3.0 17))
+  (error? (fldiv0-and-mod0 'a 17.0))
+  (error? (fldiv0-and-mod0 17.0 '(a)))
+ ; fldiv0
+  (error? (fldiv0 17 3.0))
+  (error? (fldiv0 3.0 17))
+  (error? (fldiv0 'a 17.0))
+  (error? (fldiv0 17.0 '(a)))
+ ; flmod0
+  (error? (flmod0 17 3.0))
+  (error? (flmod0 3.0 17))
+  (error? (flmod0 'a 17.0))
+  (error? (flmod0 17.0 '(a)))
+ ; fldiv0-and-mod0
+  (begin
+    (define $d&m fldiv0-and-mod0)
+    (define ($dmpair x y) (call-with-values (lambda () ($d&m x y)) cons))
+    (define ($dmpairs x y)
+      (list ($dmpair x y) ($dmpair (- x) y) ($dmpair x (- y)) ($dmpair (- x) (- y))
+            ($dmpair y x) ($dmpair (- y) x) ($dmpair y (- x)) ($dmpair (- y) (- x))))
+    #t)
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (0.0 . -3.5) (-0.0 . 3.5) (0.0 . -3.5)
+      (3.0 . 0.75) (-3.0 . -0.75) (-3.0 . 0.75) (3.0 . -0.75)))
+  ($dmequal?
+    ($dmpairs 10.0 4.0)
+    '((3.0 . -2.0) (-2.0 . -2.0) (-3.0 . -2.0) (2.0 . -2.0)
+      (0.0 . 4.0) (0.0 . -4.0) (-0.0 . 4.0) (0.0 . -4.0)))
+ ; fldiv0 with flmod0
+  (begin
+    (set! $d&m (lambda (x y) (values (fldiv0 x y) (flmod0 x y))))
+    #t)
+  ($dmequal?
+    ($dmpairs 0.0 3.5)
+    '((0.0 . 0.0) (-0.0 . 0.0) (-0.0 . 0.0) (0.0 . 0.0)
+      (+inf.0 . +nan.0) (-inf.0 . +nan.0) (-inf.0 . +nan.0) (+inf.0 . +nan.0)))
+  ($dmequal?
+    ($dmpairs 3.5 11.25)
+    '((0.0 . 3.5) (0.0 . -3.5) (-0.0 . 3.5) (0.0 . -3.5)
+      (3.0 . 0.75) (-3.0 . -0.75) (-3.0 . 0.75) (3.0 . -0.75)))
+  ($dmequal?
+    ($dmpairs 10.0 4.0)
+    '((3.0 . -2.0) (-2.0 . -2.0) (-3.0 . -2.0) (2.0 . -2.0)
+      (0.0 . 4.0) (0.0 . -4.0) (-0.0 . 4.0) (0.0 . -4.0)))
+)
diff --git a/mats/foreign.ms b/mats/foreign.ms
new file mode 100644
index 0000000..004bfb5
--- /dev/null
+++ b/mats/foreign.ms
@@ -0,0 +1,3201 @@
+;;; foreign.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-syntax machine-case
+  (lambda (x)
+    (syntax-case x ()
+      [(_ [(a ...) e ...] m ...)
+       (if (memq (machine-type) (datum (a ...)))
+           #'(begin (void) e ...)
+           #'(machine-case m ...))]
+      [(_ [else e ...]) #'(begin (void) e ...)]
+      [(_) #'(void)])))
+
+#;(define-syntax foreign-struct-mat
+ (syntax-rules ()
+   [(_ name n)
+    (mat name
+       (set! fs-size
+          ((foreign-procedure (format "s~a_size" n) () unsigned-32)))
+       (set! fs-align
+          ((foreign-procedure (format "s~a_align" n) () unsigned-32)))
+       (set! fs-get-s
+          (eval `(foreign-procedure ,(format "get_s~a" n) (char)
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-get-sp
+          (foreign-procedure (format "get_s~ap" n) (char)
+             foreign-pointer))
+       (set! fs-s_f1_s
+          (eval `(foreign-procedure ,(format "s~a_f1_s~a" n n)
+                    ((foreign-object ,fs-size ,fs-align)
+                     (foreign-object ,fs-size ,fs-align))
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-sp_f1_s
+          (eval `(foreign-procedure ,(format "s~ap_f1_s~a" n n)
+                    (foreign-pointer
+                     (foreign-object ,fs-size ,fs-align))
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-s_f1_sp
+          (eval `(foreign-procedure ,(format "s~a_f1_s~ap" n n)
+                    ((foreign-object ,fs-size ,fs-align)
+                     foreign-pointer)
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-sp_f1_sp
+          (eval `(foreign-procedure ,(format "s~ap_f1_s~ap" n n)
+                    (foreign-pointer
+                     foreign-pointer)
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-s_f2_s
+          (eval `(foreign-procedure ,(format "s~a_f2_s~a" n n)
+                    (integer-32
+                     (foreign-object ,fs-size ,fs-align)
+                     (foreign-object ,fs-size ,fs-align))
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-sp_f2_s
+          (eval `(foreign-procedure ,(format "s~ap_f2_s~a" n n)
+                    (integer-32
+                     foreign-pointer
+                     (foreign-object ,fs-size ,fs-align))
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-s_f2_sp
+          (eval `(foreign-procedure ,(format "s~a_f2_s~ap" n n)
+                    (integer-32
+                     (foreign-object ,fs-size ,fs-align)
+                     foreign-pointer)
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-sp_f2_sp
+          (eval `(foreign-procedure ,(format "s~ap_f2_s~ap" n n)
+                    (integer-32
+                     foreign-pointer
+                     foreign-pointer)
+                    (foreign-object ,fs-size ,fs-align))))
+       (set! fs-s_f3_s
+          (eval `(foreign-procedure ,(format "s~a_f3_s~a" n n)
+                    ((foreign-object ,fs-size ,fs-align)
+                     (foreign-object ,fs-size ,fs-align))
+                    boolean)))
+       (set! fs-sp_f3_s
+          (eval `(foreign-procedure ,(format "s~ap_f3_s~a" n n)
+                    (foreign-pointer
+                     (foreign-object ,fs-size ,fs-align))
+                    boolean)))
+       (set! fs-s_f3_sp
+          (eval `(foreign-procedure ,(format "s~a_f3_s~ap" n n)
+                    ((foreign-object ,fs-size ,fs-align)
+                     foreign-pointer)
+                    boolean)))
+       (set! fs-sp_f3_sp
+          (eval `(foreign-procedure ,(format "s~ap_f3_s~ap" n n)
+                    (foreign-pointer
+                     foreign-pointer)
+                    boolean)))
+
+       (set! fs-a (fs-get-s #\a))
+       (string? fs-a)
+       (set! fs-ap (fs-get-sp #\a))
+       (integer? fs-ap)
+       (set! fs-b (fs-get-s #\b))
+       (string? fs-b)
+       (set! fs-bp (fs-get-sp #\b))
+       (integer? fs-bp)
+
+
+       (fs-s_f3_s fs-a fs-a)
+       (fs-s_f3_s fs-a fs-ap)
+       (fs-s_f3_s fs-ap fs-a)
+       (fs-s_f3_s fs-ap fs-ap)
+       (fs-sp_f3_s fs-a fs-a)
+       (fs-sp_f3_s fs-a fs-ap)
+       (fs-sp_f3_s fs-ap fs-a)
+       (fs-sp_f3_s fs-ap fs-ap)
+       (fs-s_f3_sp fs-a fs-a)
+       (fs-s_f3_sp fs-a fs-ap)
+       (fs-s_f3_sp fs-ap fs-a)
+       (fs-s_f3_sp fs-ap fs-ap)
+       (fs-sp_f3_sp fs-a fs-a)
+       (fs-sp_f3_sp fs-a fs-ap)
+       (fs-sp_f3_sp fs-ap fs-a)
+       (fs-sp_f3_sp fs-ap fs-ap)
+
+       (not (fs-s_f3_s fs-a fs-b))
+       (not (fs-s_f3_s fs-a fs-bp))
+       (not (fs-s_f3_s fs-ap fs-b))
+       (not (fs-s_f3_s fs-ap fs-bp))
+       (not (fs-sp_f3_s fs-a fs-b))
+       (not (fs-sp_f3_s fs-a fs-bp))
+       (not (fs-sp_f3_s fs-ap fs-b))
+       (not (fs-sp_f3_s fs-ap fs-bp))
+       (not (fs-s_f3_sp fs-a fs-b))
+       (not (fs-s_f3_sp fs-a fs-bp))
+       (not (fs-s_f3_sp fs-ap fs-b))
+       (not (fs-s_f3_sp fs-ap fs-bp))
+       (not (fs-sp_f3_sp fs-a fs-b))
+       (not (fs-sp_f3_sp fs-a fs-bp))
+       (not (fs-sp_f3_sp fs-ap fs-b))
+       (not (fs-sp_f3_sp fs-ap fs-bp))
+
+       (fs-sp_f3_sp (fs-s_f1_s fs-ap fs-bp) (fs-sp_f1_s fs-a fs-bp))
+       (fs-sp_f3_sp (fs-s_f1_sp fs-ap fs-b) (fs-sp_f1_sp fs-a fs-b))
+
+       (fs-sp_f3_sp (fs-s_f2_s 1 fs-ap fs-bp) (fs-sp_f2_s 1 fs-a fs-bp))
+       (fs-sp_f3_sp (fs-s_f2_sp 1 fs-ap fs-b) (fs-sp_f2_sp 1 fs-a fs-b))
+      )]))
+
+(define-syntax auto-mat-ick
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name)
+       (let ((ls (let f ([ls (string->list (datum name))])
+                   (if (null? ls)
+                       '()
+                       (cons (car ls) (f (cddr ls)))))))
+         (with-syntax ([((p v) ...)
+                        (map (lambda (c)
+                               (case (syntax->datum c)
+                                 [(#\n) `(,(syntax integer-32)
+                                          ,(random 1000))]
+                                 [(#\s) `(,(syntax single-float)
+                                          ,(truncate (random 1000.0)))]
+                                 [(#\d) `(,(syntax double-float)
+                                          ,(truncate (random 1000.0)))]))
+                             ls)])
+           (syntax (= (let ([x (foreign-procedure name (p ...) double-float)])
+                        (x v ...))
+                      (+ v ...)))))))))
+
+(define foreign1.so (format "~a/foreign1.so" *mats-dir*))
+
+(machine-case
+  [(i3ob ti3ob a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx)
+   (mat load-shared-object
+      (file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "libc.so") #t)
+      (error? (load-shared-object 3))
+    )
+   ]
+  [(i3le ti3le a6le ta6le arm32le tarm32le ppc32le tppc32le)
+   (mat load-shared-object
+      (file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "libc.so.6") #t)
+      (error? (load-shared-object 3))
+    )
+   ]
+  [(i3fb ti3fb a6fb ta6fb)
+   (mat load-shared-object
+      (file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "libc.so.7") #t)
+      (error? (load-shared-object 3))
+    )
+   ]
+  [(i3nb ti3nb a6nb ta6nb)
+   (mat load-shared-object
+      (file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "libc.so") #t)
+      (error? (load-shared-object 3))
+    )
+   ]
+  [(i3nt ti3nt a6nt ta6nt)
+   (mat load-shared-object
+      (file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "msvcrt.dll") #t)
+      (begin (load-shared-object "kernel32.dll") #t)
+      (error? (load-shared-object 3))
+    )
+   ]
+  [(i3osx ti3osx a6osx ta6osx)
+   (mat load-shared-object
+      (file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "libc.dylib") #t)
+      #t
+      (error? (load-shared-object 3))
+    )
+   ]
+  [else
+   (mat foreign-procedure
+      (error? (foreign-procedure "foo" () scheme-object))
+      (begin (define (idint32 x)
+            (errorf 'idint32 "invalid foreign-procedure argument ~s" x))
+          (procedure? idint32))
+      (error? (idint32 #x80000000))
+      (error? (idint32 #x80000001))
+      (error? (idint32 #xffffffff))
+      (error? (idint32 #x8000000080000000))
+      (error? (idint32 #x-80000001))
+      (error? (idint32 #x-8000000080000000))
+      (error? (idint32 #f))
+      (error? (idint32 "hi"))
+      (begin (define (iduns32 x)
+            (errorf 'iduns32 "invalid foreign-procedure argument ~s" x))
+             (procedure? iduns32))
+         (error? (iduns32 #x100000000))
+      (error? (iduns32 #x8000000080000000))
+      (error? (iduns32 -1))
+      (error? (iduns32 #x-7fffffff))
+      (error? (iduns32 #x-80000000))
+      (error? (iduns32 #x-80000001))
+      (error? (iduns32 #x-8000000080000000))
+      (error? (iduns32 #f))
+      (error? (iduns32 "hi"))
+      (begin (define (idfix x)
+            (errorf 'idfix "invalid foreign-procedure argument ~s" x))
+             (procedure? idfix))
+      (error? (idfix (+ (most-positive-fixnum) 1)))
+      (error? (idfix (- (most-negative-fixnum) 1)))
+      (error? (errorf 'id "return value ~s is out of range" #x7fffffff))
+      (error? (errorf 'id "return value ~s is out of range" #x-80000000))
+      (error? (errorf 'id "invalid foreign-procedure argument ~s" 0))
+      (error? (errorf 'id "return value ~s is out of range" #x7fffffff))
+      (error? (errorf 'id "invalid foreign-procedure argument ~s" 'foo))
+      (error? (foreign-procedure 'abcde (integer-32) integer-32))
+      (error? (errorf 'float_id "invalid foreign-procedure argument ~s" 0))
+    )
+   ])
+
+(mat foreign-entry?
+   (foreign-entry? "id")
+   (foreign-entry? "idid")
+   (foreign-entry? "ididid")
+   (not (foreign-entry? "foo")))
+
+(mat foreign-procedure
+   (procedure? (foreign-procedure "idiptr" (scheme-object) scheme-object))
+   (error? (foreign-procedure "i do not exist" (scheme-object) scheme-object))
+   (error? (begin (foreign-procedure "i do not exist" () scheme-object) 'q))
+   (error? (if (foreign-procedure "i do not exist" () scheme-object) 'q 'q))
+   (error? (foreign-procedure 'foo () scheme-object))
+   (error? (begin (foreign-procedure 'foo () scheme-object) 'q))
+   (error? (if (foreign-procedure 'foo () scheme-object) 'q 'q))
+
+   (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) scheme-object) 'foo))
+
+   (parameterize ([current-eval interpret])
+       (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) scheme-object) 'foo)))
+
+   (not (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) void) 'foo)))
+
+   (begin (define idint32 (foreign-procedure "id" (integer-32) integer-32))
+          (procedure? idint32))
+   (eqv? (idint32 0) 0)
+   (eqv? (idint32 #x7fffffff) #x7fffffff)
+   (eqv? (idint32 -1) -1)
+   (eqv? (idint32 #x-7fffffff) #x-7fffffff)
+   (eqv? (idint32 #x-80000000) #x-80000000)
+   (eqv? (idint32 #x80000000) (+ #x-100000000 #x80000000))
+   (eqv? (idint32 #x80000001) (+ #x-100000000 #x80000001))
+   (eqv? (idint32 #xffffffff) (+ #x-100000000 #xffffffff))
+   (error? (idint32 #x100000000))
+   (error? (idint32 #x100000001))
+   (error? (idint32 #xfffffffffffffffffffffffffffff))
+   (error? (idint32 #x8000000080000000))
+   (error? (idint32 #x-80000001))
+   (error? (idint32 #x-8000000080000000))
+   (error? (idint32 #f))
+   (error? (idint32 "hi"))
+
+   (begin (define iduns32 (foreign-procedure "id" (unsigned-32) unsigned-32))
+          (procedure? iduns32))
+   (eqv? (iduns32 0) 0)
+   (eqv? (iduns32 #x7fffffff) #x7fffffff)
+   (eqv? (iduns32 #x80000000) #x80000000)
+   (eqv? (iduns32 #x80000001) #x80000001)
+   (eqv? (iduns32 #x88000000) #x88000000)
+   (eqv? (iduns32 #xffffffff) #xffffffff)
+   (error? (iduns32 #x100000000))
+   (error? (iduns32 #x8000000080000000))
+   (eqv? (iduns32 -1) (+ #x100000000 -1))
+   (eqv? (iduns32 #x-7fffffff) (+ #x100000000 #x-7fffffff))
+   (eqv? (iduns32 #x-80000000) (+ #x100000000 #x-80000000))
+   (error? (iduns32 #x-80000001))
+   (error? (iduns32 #x-ffffffff))
+   (error? (iduns32 #x-fffffffffffffffffffffffffffffffff))
+   (error? (iduns32 #x-80000001))
+   (error? (iduns32 #x-8000000080000000))
+   (error? (iduns32 #f))
+   (error? (iduns32 "hi"))
+
+   (eqv? #xffffffff ((foreign-procedure "id" (integer-32) unsigned-32) -1))
+   (eqv? -1 ((foreign-procedure "id" (unsigned-32) integer-32) #xffffffff))
+
+   (begin (define idfix (foreign-procedure "idiptr" (fixnum) fixnum))
+          (procedure? idfix))
+   (eqv? 0 (idfix 0))
+   (eqv? -1 (idfix -1))
+   (eqv? (quotient (most-positive-fixnum) 2)
+         (idfix (quotient (most-positive-fixnum) 2)))
+   (eqv? (quotient (most-negative-fixnum) 2)
+         (idfix (quotient (most-negative-fixnum) 2)))
+   (eqv? (most-positive-fixnum) (idfix (most-positive-fixnum)))
+   (eqv? (most-negative-fixnum) (idfix (most-negative-fixnum)))
+   (error? (idfix (+ (most-positive-fixnum) 1)))
+   (error? (idfix (- (most-negative-fixnum) 1)))
+
+; we've eliminated the return range checks---caveat emptor
+;   (error? ((foreign-procedure "id" (integer-32) fixnum) #x7fffffff))
+;   (error? ((foreign-procedure "id" (integer-32) fixnum) #x-80000000))
+;   (error? ((foreign-procedure "id" (integer-32) char) #x7fffffff))
+
+   (error? (foreign-procedure "id" (booleen) char))
+   (error? (foreign-procedure "id" (integer-32 integer-34) char))
+   (error? (foreign-procedure "id" () chare))
+   (error? (foreign-procedure "id" (void) char))
+
+   ((foreign-procedure "id" (boolean) boolean) #t)
+   (not ((foreign-procedure "id" (boolean) boolean) #f))
+   ((foreign-procedure "id" (boolean) boolean) 0)
+   (= 1 ((foreign-procedure "id" (boolean) integer-32) #t))
+   (= 1 ((foreign-procedure "id" (boolean) integer-32) 0))
+   (= 0 ((foreign-procedure "id" (boolean) integer-32) #f))
+   (not ((foreign-procedure "id" (integer-32) boolean) 0))
+   ((foreign-procedure "id" (integer-32) boolean) 1)
+
+   (char=? #\a ((foreign-procedure "id" (char) char) #\a))
+   (= 0 ((foreign-procedure "id" (char) integer-32) #\nul))
+   (char=? #\nul ((foreign-procedure "id" (integer-32) char) 0))
+   (eqv? ((foreign-procedure "id" (integer-32) char) -1) #\377)
+   (error? ((foreign-procedure "id" (char) void) 0))
+
+   (let ([s "now is the time for all good men"])
+      (string=? s ((foreign-procedure "idiptr" (string) string) s)))
+   (let ([s "now is the time for all good men"])
+      (not (eq? s ((foreign-procedure "idiptr" (string) string) s))))
+  ; assuming iptr is same size as char *:
+   (let ([id1 (foreign-procedure "idiptr" (string) string)]
+         [id2 (foreign-procedure "idiptr" (string) iptr)]
+         [id3 (foreign-procedure "idiptr" (iptr) string)])
+      (and (eq? (id1 #f) #f) (eq? (id2 #f) 0) (eq? (id3 0) #f)))
+   (let ()
+     (define $string->bytevector
+       (lambda (s)
+         (let ([n (string-length s)])
+           (let ([bv (make-bytevector (+ n 1))])
+             (do ([i 0 (fx+ i 1)])
+                 ((fx= i n))
+               (bytevector-u8-set! bv i (char->integer (string-ref s i))))
+             (bytevector-u8-set! bv n 0)
+             bv))))
+     (let ([s "now is the time for all good men"]
+           [r "                                "])
+       (let ([bv ($string->bytevector r)])
+         ((foreign-procedure (if (windows?) "windows_strcpy" "strcpy") (u8* string) void) bv s)
+         (= 0 ((foreign-procedure (if (windows?) "windows_strcmp" "strcmp") (u8* string) integer-32) bv s)))))
+   (error? ((foreign-procedure "id" (string) void) 'foo))
+
+   (= ((foreign-procedure "idid" (integer-32) integer-32) #xc7c7c7) #xc7c7c7)
+   (= ((foreign-procedure "ididid" (integer-32) integer-32) #x7c7c7c7c)
+      #x7c7c7c7c)
+
+   (= ((foreign-procedure "id" (unsigned-32) unsigned-32) #x80000000)
+      #x80000000)
+   (= ((foreign-procedure "id" (unsigned-32) integer-32) #x80000000)
+      #x-80000000)
+
+   (error? (foreign-procedure 'abcde (integer-32) integer-32))
+   (let ([template
+          (lambda (x)
+             (foreign-procedure x (char) boolean))])
+      (let ([id (template "id")]
+            [idid (template "idid")]
+            [ididid (template "ididid")])
+         (and (eqv? (id #\nul) #f)
+              (eqv? (idid #\001) #t)
+              (eqv? (idid #\a) #t))))
+
+   (= 0.0 ((foreign-procedure "float_id" (double-float) double-float) 0.0))
+   (= 1.1 ((foreign-procedure "float_id" (double-float) double-float) 1.1))
+   (error? ((foreign-procedure "float_id" (double-float) void) 0))
+
+   (let ([fid (foreign-procedure "float_id" (double-float) double-float)])
+     (let f ((n 10000))
+       (or (= n 0)
+           (let ([x (random 1.0)])
+             (and (eqv? x (fid x))
+                  (f (- n 1)))))))
+
+   (= (+ (*  1 29) (*  2 31) (*  3 37) (*  5 41) (*  7 43)
+         (* 11 47) (* 13 49) (* 17 53) (* 19 59) (* 23 61))
+      ((foreign-procedure "testten"
+          (integer-32 integer-32 integer-32 integer-32 integer-32
+           integer-32 integer-32 integer-32 integer-32 integer-32)
+          integer-32)
+       29 31 37 41 43 47 49 53 59 61))
+
+   (= (+ 1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8)
+      ((foreign-procedure "flsum8"
+          (double-float double-float double-float double-float
+           double-float double-float double-float double-float)
+          double-float)
+       1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8))
+
+   (= (+ 1 2 3 4 5 6.75 7 8.5)
+      ((foreign-procedure "sparcfltest"
+          (integer-32 integer-32 integer-32 integer-32
+           integer-32 double-float integer-32 double-float)
+          double-float)
+       1 2 3 4 5 6.75 7 8.5))
+
+   (= (+ 1 2 3.3)
+      ((foreign-procedure "mipsfltest1"
+          (integer-32 integer-32 double-float)
+          double-float)
+       1 2 3.3))
+
+   (= (+ 1 2.2 3.3)
+      ((foreign-procedure "mipsfltest2"
+          (integer-32 double-float double-float)
+          double-float)
+       1 2.2 3.3))
+
+   (= (+ 1 2.25 3 4.5 5 6.75 7 8.25 9.5 10.75 11.25 12.5 13.75 14.25 15.5
+       16.75 17.25 18.75 19.25)
+      ((foreign-procedure "ppcfltest"
+          (integer-32 double-float integer-32 double-float integer-32
+           double-float integer-32 double-float double-float double-float
+           double-float double-float double-float double-float double-float
+           double-float double-float double-float double-float)
+          double-float)
+       1 2.25 3 4.5 5 6.75 7 8.25 9.5 10.75 11.25 12.5 13.75 14.25 15.5
+       16.75 17.25 18.75 19.25))
+
+   (= (+ 1 2.25 3 4.5 5
+         (expt 2 36) 6.75 7 8.25
+         (expt 2 39) 75
+         9.5 10.75 11.25 12.5
+         13.75 14.25 15.5
+         20 16.75 21 (expt 2 37) 18.75 22
+         19.25)
+      ((foreign-procedure "ppcfltest2"
+         (integer-32 double-float integer-32 double-float integer-32
+          integer-64 double-float integer-32 double-float
+          ; next integer should be stack-allocated with the PPC ABI
+          integer-64 integer-32
+          ; but next four floats should still get registers
+          double-float double-float double-float double-float
+          ; and remaining floags and ints should go on the stack
+          double-float single-float double-float
+          integer-32 double-float integer-32 integer-64 double-float integer-32
+          double-float)
+         double-float)
+        1 2.25 3 4.5 5
+        (expt 2 36) 6.75 7 8.25
+        (expt 2 39) 75
+        9.5 10.75 11.25 12.5
+        13.75 14.25 15.5
+        20 16.75 21 (expt 2 37) 18.75 22
+        19.25))
+
+   ((foreign-procedure "chk_data" () boolean))
+   ((foreign-procedure "chk_bss" () boolean))
+   ((foreign-procedure "chk_malloc" () boolean))
+
+   (begin
+     (define $fp-tlv (foreign-procedure "(cs)s_tlv" (ptr) ptr))
+     (define $fp-stlv! (foreign-procedure "(cs)s_stlv" (ptr ptr) void))
+     #t)
+
+   (equal?
+     (let ()
+       (define-syntax list-in-order
+         (syntax-rules ()
+           [(_) '()]
+           [(_ e . rest) (let ([t e]) (cons t (list-in-order . rest)))]))
+       (list-in-order
+         ($fp-tlv 'cons)
+         ($fp-stlv! '$fp-spam 'yum)
+         ($fp-tlv '$fp-spam)
+         (top-level-value '$fp-spam)))
+     `(,cons ,(void) yum yum))
+
+   (equal?
+     (let ()
+       (define-syntax list-in-order
+         (syntax-rules ()
+           [(_) '()]
+           [(_ e . rest) (let ([t e]) (cons t (list-in-order . rest)))]))
+       (parameterize ([interaction-environment (copy-environment (scheme-environment))])
+         (list-in-order
+           (define-top-level-value 'foo 17)
+           ($fp-tlv 'foo)
+           ($fp-stlv! 'bar 55)
+           ($fp-tlv 'bar)
+           (top-level-value 'bar))))
+     `(,(void) 17 ,(void) 55 55))
+
+  (equal?
+    (parameterize ([interaction-environment (copy-environment (scheme-environment))])
+     ; should have no effect
+      ($fp-stlv! cons 3)
+      (list
+        (#%$tc-field 'disable-count (#%$tc))
+        cons
+        ($fp-tlv 'cons)))
+    `(0 ,cons ,cons))
+
+  (equal?
+    (parameterize ([interaction-environment (copy-environment (scheme-environment))])
+     ; should have no effect
+      ($fp-stlv! 'let 3)
+      (list
+        (#%$tc-field 'disable-count (#%$tc))
+        (eval '(let ((x 23)) x))))
+    '(0 23))
+
+  (equal?
+    (let ([x ($fp-tlv '$fp-i-am-not-bound)])
+      (list (#%$tc-field 'disable-count (#%$tc)) x))
+    `(0 ,(#%$unbound-object)))
+
+  (equal?
+    (let ([x ($fp-tlv 'let)])
+      (list (#%$tc-field 'disable-count (#%$tc)) x))
+    `(0 ,(#%$unbound-object)))
+
+  (equal? ((foreign-procedure "(cs)s_test_schlib" () void)) (void))
+
+  (begin
+    (define $siv (foreign-procedure "(cs)Sinteger_value" (ptr) void))
+    (define $si32v (foreign-procedure "(cs)Sinteger32_value" (ptr) void))
+    (define $si64v (foreign-procedure "(cs)Sinteger64_value" (ptr) void))
+    (define ($check p n)
+      (or (= (optimize-level) 3)
+          (guard (c [(and (assertion-violation? c)
+                          (irritants-condition? c)
+                          (equal? (condition-irritants c) (list n)))
+                     #t])
+            (p n)
+            #f)))
+    #t)
+
+ ; make sure no errors for in-range inputs
+  (begin
+    ($si32v (- (expt 2 32) 1))
+    ($si32v (- (expt 2 31)))
+    ($si64v (- (expt 2 64) 1))
+    ($si64v (- (expt 2 63)))
+    (if (< (fixnum-width) 32)
+        (begin ; assume 32-bit words
+          ($siv (- (expt 2 32) 1))
+          ($siv (- (expt 2 31))))
+        (begin ; assume 64-bit words
+          ($siv (- (expt 2 64) 1))
+          ($siv (- (expt 2 63)))))
+    #t)
+
+ ; check barely out-of-range inputs
+  ($check $si32v (expt 2 32))
+  ($check $si32v (- -1 (expt 2 31)))
+  ($check $si64v (expt 2 64))
+  ($check $si64v (- -1 (expt 2 63)))
+  ($check $siv (expt 2 (if (< (fixnum-width) 32) 32 64)))
+  ($check $siv (- -1 (expt 2 (if (< (fixnum-width) 32) 31 63))))
+
+ ; check further out-of-range inputs
+  ($check $si32v (expt 2 36))
+  ($check $si32v (- -1 (expt 2 35)))
+  ($check $si64v (expt 2 68))
+  ($check $si64v (- -1 (expt 2 67)))
+  ($check $siv (expt 2 (if (< (fixnum-width) 32) 36 68)))
+  ($check $siv (- -1 (expt 2 (if (< (fixnum-width) 32) 35 67))))
+  ($check $si32v (expt 2 100))
+  ($check $si32v (- -1 (expt 2 100)))
+  ($check $si64v (expt 2 100))
+  ($check $si64v (- -1 (expt 2 100)))
+  ($check $siv (expt 2 100))
+  ($check $siv (- -1 (expt 2 100)))
+)
+
+(mat foreign-sizeof
+  (equal?
+    (list
+      (foreign-sizeof 'integer-8)
+      (foreign-sizeof 'unsigned-8)
+      (foreign-sizeof 'integer-16)
+      (foreign-sizeof 'unsigned-16)
+      (foreign-sizeof 'integer-24)
+      (foreign-sizeof 'unsigned-24)
+      (foreign-sizeof 'integer-32)
+      (foreign-sizeof 'unsigned-32)
+      (foreign-sizeof 'integer-40)
+      (foreign-sizeof 'unsigned-40)
+      (foreign-sizeof 'integer-48)
+      (foreign-sizeof 'unsigned-48)
+      (foreign-sizeof 'integer-56)
+      (foreign-sizeof 'unsigned-56)
+      (foreign-sizeof 'integer-64)
+      (foreign-sizeof 'unsigned-64)
+      (foreign-sizeof 'single-float)
+      (foreign-sizeof 'double-float))
+    '(1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 4 8))
+  ((foreign-procedure "check_types" (int int int int int int int int int) boolean)
+   (foreign-sizeof 'char)
+   (foreign-sizeof 'wchar)
+   (foreign-sizeof 'short)
+   (foreign-sizeof 'int)
+   (foreign-sizeof 'long)
+   (foreign-sizeof 'long-long)
+   (foreign-sizeof 'float)
+   (foreign-sizeof 'double)
+   (foreign-sizeof 'void*))
+  (equal? (foreign-sizeof 'unsigned) (foreign-sizeof 'int))
+  (equal? (foreign-sizeof 'unsigned-int) (foreign-sizeof 'int))
+  (equal? (foreign-sizeof 'unsigned-short) (foreign-sizeof 'short))
+  (equal? (foreign-sizeof 'unsigned-long) (foreign-sizeof 'long))
+  (equal? (foreign-sizeof 'unsigned-long-long) (foreign-sizeof 'long-long))
+  (equal? (foreign-sizeof 'boolean) (foreign-sizeof 'int))
+  (equal? (foreign-sizeof 'fixnum) (foreign-sizeof 'iptr))
+  (equal? (foreign-sizeof 'scheme-object) (foreign-sizeof 'void*))
+  (equal? (foreign-sizeof 'ptr) (foreign-sizeof 'void*))
+  (equal? (foreign-sizeof 'iptr) (foreign-sizeof 'void*))
+  (equal? (foreign-sizeof 'uptr) (foreign-sizeof 'void*))
+  (error? (foreign-sizeof))
+  (error? (foreign-sizeof 'int 'int))
+  (error? (foreign-sizeof 'i-am-not-a-type))
+  (error? (foreign-sizeof '1))
+)
+
+(mat foreign-bytevectors
+ ; test u8*, u16*, u32*
+  (begin
+    (define u8*->u8* (foreign-procedure "u8_star_to_u8_star" (u8*) u8*))
+    (define u16*->u16* (foreign-procedure "u16_star_to_u16_star" (u16*) u16*))
+    (define u32*->u32* (foreign-procedure "u32_star_to_u32_star" (u32*) u32*))
+    #t)
+  (equal? (u8*->u8* #vu8(1 2 3 4 0)) #vu8(2 3 4))
+  (equal? (u16*->u16* #vu8(1 2 3 4 5 6 7 8 0 0)) #vu8(3 4 5 6 7 8))
+  (equal? (u32*->u32* #vu8(1 2 3 4 5 6 7 8 9 10 11 12 0 0 0 0)) #vu8(5 6 7 8 9 10 11 12))
+
+  (eq? (u8*->u8* #vu8(1 0)) #vu8())
+  (eq? (u16*->u16* #vu8(1 2 0 0)) #vu8())
+  (eq? (u32*->u32* #vu8(1 2 3 4 0 0 0 0)) #vu8())
+
+  (eq? (u8*->u8* #f) #f)
+  (eq? (u16*->u16* #f) #f)
+  (eq? (u32*->u32* #f) #f)
+
+  (error? (u8*->u8* "hello"))
+  (error? (u16*->u16* "hello"))
+  (error? (u32*->u32* "hello"))
+  (error? (u8*->u8* 0))
+  (error? (u16*->u16* 0))
+  (error? (u32*->u32* 0))
+
+  (begin
+    (define call-u8* (foreign-procedure "call_u8_star" (ptr u8*) u8*))
+    (define call-u16* (foreign-procedure "call_u16_star" (ptr u16*) u16*))
+    (define call-u32* (foreign-procedure "call_u32_star" (ptr u32*) u32*))
+    (define $bytevector-map
+      (lambda (p bv)
+        (u8-list->bytevector (map p (bytevector->u8-list bv)))))
+    #t)
+  (equal?
+    (call-u8* (foreign-callable
+                (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x))
+                (u8*) u8*)
+      #vu8(1 2 3 4 5 255 0 ))
+    '#vu8(103 104 105))
+  (equal?
+    (call-u16* (foreign-callable
+                 (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x))
+                 (u16*) u16*)
+      #vu8(1 2 3 4 5 6 255 255 0 0))
+    '#vu8(105 106))
+  (equal?
+    (call-u32* (foreign-callable
+                 (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x))
+                 (u32*) u32*)
+      #vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 255 255 255 255 0 0 0 0))
+    '#vu8(109 110 111 112 113 114 115 116 117 118 119 120))
+  (error?
+    (let ([frotz (foreign-callable
+                   (lambda (x) (list x (bytevector-length x)))
+                   (u8*) u8*)])
+      (call-u8* frotz #vu8(1 2 3 4 5 0))))
+  (error?
+    (call-u16* (foreign-callable
+                 (lambda (x) (list x (bytevector-length x)))
+                 (u16*) u16*)
+      #vu8(1 2 3 4 5 6 0 0)))
+  (error?
+    (call-u32* (foreign-callable
+                 (lambda (x) (list x (bytevector-length x)))
+                 (u32*) u32*)
+      #vu8(1 2 3 4 5 6 7 8 0 0 0 0)))
+  (error?
+    (call-u8* (foreign-callable
+                (lambda (x) (list x (bytevector-length x)))
+                (u8*) u8*)
+      '#(1 2 3 4 5 0)))
+  (error?
+    (call-u16* (foreign-callable
+                 (lambda (x) (list x (bytevector-length x)))
+                 (u16*) u16*)
+      '#(1 2 3 4 5 6 0 0)))
+  (error?
+    (call-u32* (foreign-callable
+                 (lambda (x) (list x (bytevector-length x)))
+                 (u32*) u32*)
+      '#(1 2 3 4 5 6 7 8 0 0 0 0)))
+)
+
+(mat foreign-strings
+ ; test utf-8, utf-16le, utf-16be, utf-32le, utf-32be, string, wstring
+  (begin
+    (define utf-8->utf-8 (foreign-procedure "u8_star_to_u8_star" (utf-8) utf-8))
+    (define utf-16le->utf-16le (foreign-procedure "u16_star_to_u16_star" (utf-16le) utf-16le))
+    (define utf-16be->utf-16be (foreign-procedure "u16_star_to_u16_star" (utf-16be) utf-16be))
+    (define utf-32le->utf-32le (foreign-procedure "u32_star_to_u32_star" (utf-32le) utf-32le))
+    (define utf-32be->utf-32be (foreign-procedure "u32_star_to_u32_star" (utf-32be) utf-32be))
+    (define string->string (foreign-procedure "char_star_to_char_star" (string) string))
+    (define wstring->wstring (foreign-procedure "wchar_star_to_wchar_star" (wstring) wstring))
+    #t)
+  (equal? (utf-8->utf-8 "hello") "ello")
+  (equal? (utf-16le->utf-16le "hello") "ello")
+  (equal? (utf-16be->utf-16be "hello") "ello")
+  (equal? (utf-32le->utf-32le "hello") "ello")
+  (equal? (utf-32be->utf-32be "hello") "ello")
+  (equal? (string->string "hello") "ello")
+  (equal? (wstring->wstring "hello") "ello")
+
+  (eq? (utf-8->utf-8 "h") "")
+  (eq? (utf-16le->utf-16le "h") "")
+  (eq? (utf-16be->utf-16be "h") "")
+  (eq? (utf-32le->utf-32le "h") "")
+  (eq? (utf-32be->utf-32be "h") "")
+  (eq? (string->string "h") "")
+  (eq? (wstring->wstring "h") "")
+
+  (eq? (utf-8->utf-8 #f) #f)
+  (eq? (utf-16le->utf-16le #f) #f)
+  (eq? (utf-16be->utf-16be #f) #f)
+  (eq? (utf-32le->utf-32le #f) #f)
+  (eq? (utf-32be->utf-32be #f) #f)
+  (eq? (string->string #f) #f)
+  (eq? (wstring->wstring #f) #f)
+
+  (error? (utf-8->utf-8 #vu8(1 2 3 4 0 0 0 0)))
+  (error? (utf-16le->utf-16le #vu8(1 2 3 4 0 0 0 0)))
+  (error? (utf-16be->utf-16be #vu8(1 2 3 4 0 0 0 0)))
+  (error? (utf-32le->utf-32le #vu8(1 2 3 4 0 0 0 0)))
+  (error? (utf-32be->utf-32be #vu8(1 2 3 4 0 0 0 0)))
+  (error? (string->string #vu8(1 2 3 4 0 0 0 0)))
+  (error? (wstring->wstring #vu8(1 2 3 4 0 0 0 0)))
+
+  (error? (utf-8->utf-8 0))
+  (error? (utf-16le->utf-16le 0))
+  (error? (utf-16be->utf-16be 0))
+  (error? (utf-32le->utf-32le 0))
+  (error? (utf-32be->utf-32be 0))
+  (error? (string->string 0))
+  (error? (wstring->wstring 0))
+
+  (begin
+    (define call-utf-8 (foreign-procedure "call_u8_star" (ptr utf-8) utf-8))
+    (define call-utf-16le (foreign-procedure "call_u16_star" (ptr utf-16le) utf-16le))
+    (define call-utf-16be (foreign-procedure "call_u16_star" (ptr utf-16be) utf-16be))
+    (define call-utf-32le (foreign-procedure "call_u32_star" (ptr utf-32le) utf-32le))
+    (define call-utf-32be (foreign-procedure "call_u32_star" (ptr utf-32be) utf-32be))
+    (define call-string (foreign-procedure "call_string" (ptr string) string))
+    (define call-wstring (foreign-procedure "call_wstring" (ptr wstring) wstring))
+    #t)
+  (equal?
+    (call-utf-8 (foreign-callable
+                  (lambda (x) (string-append x "$q"))
+                  (utf-8) utf-8)
+      "hello")
+    "llo$q")
+  (equal?
+    (call-utf-16le (foreign-callable
+                     (lambda (x) (string-append x "$q"))
+                     (utf-16le) utf-16le)
+      "hello")
+    "llo$q")
+  (equal?
+    (call-utf-16be (foreign-callable
+                     (lambda (x) (string-append x "$q"))
+                     (utf-16be) utf-16be)
+      "hello")
+    "llo$q")
+  (equal?
+    (call-utf-32le (foreign-callable
+                     (lambda (x) (string-append x "$q"))
+                     (utf-32le) utf-32le)
+      "hello")
+    "llo$q")
+  (equal?
+    (call-utf-32be (foreign-callable
+                     (lambda (x) (string-append x "$q"))
+                     (utf-32be) utf-32be)
+      "hello")
+    "llo$q")
+  (equal?
+    (call-string (foreign-callable
+                   (lambda (x) (string-append x "$q"))
+                   (string) string)
+      "hello")
+    "llo$q")
+  (equal?
+    (call-wstring (foreign-callable
+                    (lambda (x) (string-append x "$q"))
+                    (wstring) wstring)
+      "hello")
+    "llo$q")
+  (error?
+    (call-utf-8 (foreign-callable
+                  (lambda (x) (list x (string-length x)))
+                  (utf-8) utf-8)
+      "hello"))
+  (error?
+    (call-utf-16le (foreign-callable
+                     (lambda (x) (list x (string-length x)))
+                     (utf-16le) utf-16le)
+      "hello"))
+  (error?
+    (call-utf-16be (foreign-callable
+                     (lambda (x) (list x (string-length x)))
+                     (utf-16be) utf-16be)
+      "hello"))
+  (error?
+    (call-utf-32le (foreign-callable
+                     (lambda (x) (list x (string-length x)))
+                     (utf-32le) utf-32le)
+      "hello"))
+  (error?
+    (call-utf-32be (foreign-callable
+                     (lambda (x) (list x (string-length x)))
+                     (utf-32be) utf-32be)
+      "hello"))
+  (error?
+    (call-string (foreign-callable
+                   (lambda (x) (list x (string-length x)))
+                   (string) string)
+      "hello"))
+  (error?
+    (call-wstring (foreign-callable
+                    (lambda (x) (list x (string-length x)))
+                    (wstring) wstring)
+      "hello"))
+)
+
+(mat foreign-fixed-types
+ ; test {integer,unsigned}-8, {single,double}-float
+  (begin
+    (define i8-to-i8 (foreign-procedure "i8_to_i8" (integer-8 int) integer-8))
+    (define u8-to-u8 (foreign-procedure "u8_to_u8" (unsigned-8 int) unsigned-8))
+    (define i16-to-i16 (foreign-procedure "i16_to_i16" (integer-16 int) integer-16))
+    (define u16-to-u16 (foreign-procedure "u16_to_u16" (unsigned-16 int) unsigned-16))
+    (define i24-to-i24 (foreign-procedure "i32_to_i32" (integer-24 int) integer-24))
+    (define u24-to-u24 (foreign-procedure "u32_to_u32" (unsigned-24 int) unsigned-24))
+    (define i32-to-i32 (foreign-procedure "i32_to_i32" (integer-32 int) integer-32))
+    (define u32-to-u32 (foreign-procedure "u32_to_u32" (unsigned-32 int) unsigned-32))
+    (define i40-to-i40 (foreign-procedure "i64_to_i64" (integer-40 int) integer-40))
+    (define u40-to-u40 (foreign-procedure "u64_to_u64" (unsigned-40 int) unsigned-40))
+    (define i48-to-i48 (foreign-procedure "i64_to_i64" (integer-48 int) integer-48))
+    (define u48-to-u48 (foreign-procedure "u64_to_u64" (unsigned-48 int) unsigned-48))
+    (define i56-to-i56 (foreign-procedure "i64_to_i64" (integer-56 int) integer-56))
+    (define u56-to-u56 (foreign-procedure "u64_to_u64" (unsigned-56 int) unsigned-56))
+    (define i64-to-i64 (foreign-procedure "i64_to_i64" (integer-64 int) integer-64))
+    (define u64-to-u64 (foreign-procedure "u64_to_u64" (unsigned-64 int) unsigned-64))
+    (define sf-to-sf (foreign-procedure "sf_to_sf" (single-float) single-float))
+    (define df-to-df (foreign-procedure "df_to_df" (double-float) double-float))
+    (define $test-int-to-int
+      (lambda (fp size signed?)
+        (define n10000 (expt 256 size))
+        (define nffff (- n10000 1))
+        (define nfffe (- nffff 1))
+        (define n8000 (ash n10000 -1))
+        (define n8001 (+ n8000 1))
+        (define n7fff (- n8000 1))
+        (define n7ffe (- n7fff 1))
+        (define n100 (expt 16 size))
+        (define n101 (+ n100 1))
+        (define nff (- n100 1))
+        (define nfe (- nff 1))
+        (define n80 (ash n100 -1))
+        (define n81 (+ n80 1))
+        (define n7f (- n80 1))
+        (define n7e (- n7f 1))
+        (define (expect x k)
+          (if signed?
+              (if (<= (- n8000) x nffff)
+                  (mod0 (+ x k) n10000)
+                  'err)
+              (if (<= (- n8000) x nffff)
+                  (mod (+ x k) n10000)
+                  'err)))
+        (define (check x)
+          (define (do-one x k)
+            (let ([a (expect x k)])
+              (if (eq? a 'err)
+                  (or (= (optimize-level) 3)
+                      (guard (c [#t (display-condition c) (newline) #t])
+                        (fp x k)
+                        (printf "no error for x = ~x, k = ~d\n" x k)
+                        #f))
+                  (or (eqv? (fp x k) a)
+                      (begin
+                        (printf "incorrect answer ~x should be ~x for x = ~x, k = ~d\n" (fp x k) a x k)
+                        #f)))))
+          (list
+            (do-one x 1)
+            (do-one x -1)
+            (do-one (- x) 1)
+            (do-one (- x) -1)))
+        (andmap
+          (lambda (x) (and (list? x) (= (length x) 4) (andmap (lambda (x) (eq? x #t)) x)))
+          (list
+            (check n10000)
+            (check nffff)
+            (check nfffe)
+            (check n8001)
+            (check n8000)
+            (check n7fff)
+            (check n7ffe)
+            (check n101)
+            (check n100)
+            (check nff)
+            (check nfe)
+            (check n81)
+            (check n80)
+            (check n7f)
+            (check n7e)
+            (check 73)
+            (check 5)
+            (check 1)
+            (check 0)))))
+    #t)
+  ($test-int-to-int i8-to-i8 1 #t)
+  ($test-int-to-int u8-to-u8 1 #f)
+  ($test-int-to-int i16-to-i16 2 #t)
+  ($test-int-to-int u16-to-u16 2 #f)
+  ($test-int-to-int i24-to-i24 3 #t)
+  ($test-int-to-int u24-to-u24 3 #f)
+  ($test-int-to-int i32-to-i32 4 #t)
+  ($test-int-to-int u32-to-u32 4 #f)
+  ($test-int-to-int i40-to-i40 5 #t)
+  ($test-int-to-int u40-to-u40 5 #f)
+  ($test-int-to-int i48-to-i48 6 #t)
+  ($test-int-to-int u48-to-u48 6 #f)
+  ($test-int-to-int i56-to-i56 7 #t)
+  ($test-int-to-int u56-to-u56 7 #f)
+  ($test-int-to-int i64-to-i64 8 #t)
+  ($test-int-to-int u64-to-u64 8 #f)
+  (eqv? (sf-to-sf 73.5) 74.5)
+  (eqv? (df-to-df 73.5) 74.5)
+
+  (error? (i8-to-i8 'qqq 0))
+  (error? (u8-to-u8 'qqq 0))
+  (error? (i16-to-i16 'qqq 0))
+  (error? (u16-to-u16 'qqq 0))
+  (error? (i24-to-i24 'qqq 0))
+  (error? (u24-to-u24 'qqq 0))
+  (error? (i32-to-i32 'qqq 0))
+  (error? (u32-to-u32 'qqq 0))
+  (error? (i64-to-i64 'qqq 0))
+  (error? (u64-to-u64 'qqq 0))
+  (error? (i8-to-i8 0 "oops"))
+  (error? (u8-to-u8 0 "oops"))
+  (error? (i16-to-i16 0 "oops"))
+  (error? (u16-to-u16 0 "oops"))
+  (error? (i32-to-i32 0 "oops"))
+  (error? (u32-to-u32 0 "oops"))
+  (error? (i64-to-i64 0 "oops"))
+  (error? (u64-to-u64 0 "oops"))
+
+  (error? (sf-to-sf 'qqq))
+  (error? (df-to-df 'qqq))
+
+  (begin
+    (define call-i8 (foreign-procedure "call_i8" (ptr integer-8 int int) integer-8))
+    (define call-u8 (foreign-procedure "call_u8" (ptr unsigned-8 int int) unsigned-8))
+    (define call-i16 (foreign-procedure "call_i16" (ptr integer-16 int int) integer-16))
+    (define call-u16 (foreign-procedure "call_u16" (ptr unsigned-16 int int) unsigned-16))
+    (define call-i24 (foreign-procedure "call_i32" (ptr integer-24 int int) integer-24))
+    (define call-u24 (foreign-procedure "call_u32" (ptr unsigned-24 int int) unsigned-24))
+    (define call-i32 (foreign-procedure "call_i32" (ptr integer-32 int int) integer-32))
+    (define call-u32 (foreign-procedure "call_u32" (ptr unsigned-32 int int) unsigned-32))
+    (define call-i40 (foreign-procedure "call_i64" (ptr integer-40 int int) integer-40))
+    (define call-u40 (foreign-procedure "call_u64" (ptr unsigned-40 int int) unsigned-40))
+    (define call-i48 (foreign-procedure "call_i64" (ptr integer-48 int int) integer-48))
+    (define call-u48 (foreign-procedure "call_u64" (ptr unsigned-48 int int) unsigned-48))
+    (define call-i56 (foreign-procedure "call_i64" (ptr integer-56 int int) integer-56))
+    (define call-u56 (foreign-procedure "call_u64" (ptr unsigned-56 int int) unsigned-56))
+    (define call-i64 (foreign-procedure "call_i64" (ptr integer-64 int int) integer-64))
+    (define call-u64 (foreign-procedure "call_u64" (ptr unsigned-64 int int) unsigned-64))
+    (define call-sf (foreign-procedure "call_sf" (ptr single-float int int) single-float))
+    (define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float))
+    (define ($test-call-int signed? size call-int make-fc)
+      (define n10000 (expt 256 size))
+      (define nffff (- n10000 1))
+      (define nfffe (- nffff 1))
+      (define n8000 (ash n10000 -1))
+      (define n8001 (+ n8000 1))
+      (define n7fff (- n8000 1))
+      (define n7ffe (- n7fff 1))
+      (define n100 (expt 16 size))
+      (define n101 (+ n100 1))
+      (define nff (- n100 1))
+      (define nfe (- nff 1))
+      (define n80 (ash n100 -1))
+      (define n81 (+ n80 1))
+      (define n7f (- n80 1))
+      (define n7e (- n7f 1))
+      (define (expect x m k)
+        (if signed?
+            (if (<= (- n8000) x nffff)
+                (mod0 (+ x m k) n10000)
+                'err)
+            (if (<= (- n8000) x nffff)
+                (mod (+ x m k) n10000)
+                'err)))
+      (define fc (make-fc values))
+      (define fp (lambda (x m k) (call-int fc x m k)))
+      (define (check x)
+        (define (do-one x m k)
+          (let ([a (expect x m k)])
+            (if (eq? a 'err)
+                (or (= (optimize-level) 3)
+                    (guard (c [#t (display-condition c) (newline) #t]) (fp x m k)))
+                (eqv? (fp x m k) a))))
+        (list
+          (do-one x 0 0)
+          (do-one x 5 7)
+          (do-one x -5 7)
+          (do-one x 5 -7)
+          (do-one x -5 -7)
+          (do-one (- x) 0 0)
+          (do-one (- x) 5 7)
+          (do-one (- x) -5 7)
+          (do-one (- x) 5 -7)
+          (do-one (- x) -5 -7)))
+      (andmap
+        (lambda (x) (and (list? x) (= (length x) 10) (andmap (lambda (x) (eq? x #t)) x)))
+        (list
+          (check n10000)
+          (check nffff)
+          (check nfffe)
+          (check n8001)
+          (check n8000)
+          (check n7fff)
+          (check n7ffe)
+          (check n101)
+          (check n100)
+          (check nff)
+          (check nfe)
+          (check n81)
+          (check n80)
+          (check n7f)
+          (check n7e)
+          (check 73)
+          (check 5)
+          (check 1)
+          (check 0))))
+    #t)
+  ($test-call-int #t (foreign-sizeof 'integer-8) call-i8
+    (lambda (p) (foreign-callable p (integer-8) integer-8)))
+  ($test-call-int #t (foreign-sizeof 'integer-16) call-i16
+    (lambda (p) (foreign-callable p (integer-16) integer-16)))
+  ($test-call-int #t (foreign-sizeof 'integer-24) call-i24
+    (lambda (p) (foreign-callable p (integer-24) integer-24)))
+  ($test-call-int #t (foreign-sizeof 'integer-32) call-i32
+    (lambda (p) (foreign-callable p (integer-32) integer-32)))
+  ($test-call-int #t (foreign-sizeof 'integer-40) call-i40
+    (lambda (p) (foreign-callable p (integer-40) integer-40)))
+  ($test-call-int #t (foreign-sizeof 'integer-48) call-i48
+    (lambda (p) (foreign-callable p (integer-48) integer-48)))
+  ($test-call-int #t (foreign-sizeof 'integer-56) call-i56
+    (lambda (p) (foreign-callable p (integer-56) integer-56)))
+  ($test-call-int #t (foreign-sizeof 'integer-64) call-i64
+     (lambda (p) (foreign-callable p (integer-64) integer-64)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-8) call-u8
+    (lambda (p) (foreign-callable p (unsigned-8) unsigned-8)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-16) call-u16
+    (lambda (p) (foreign-callable p (unsigned-16) unsigned-16)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-24) call-u24
+    (lambda (p) (foreign-callable p (unsigned-24) unsigned-24)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-32) call-u32
+    (lambda (p) (foreign-callable p (unsigned-32) unsigned-32)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-40) call-u40
+    (lambda (p) (foreign-callable p (unsigned-40) unsigned-40)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-48) call-u48
+    (lambda (p) (foreign-callable p (unsigned-48) unsigned-48)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-56) call-u56
+    (lambda (p) (foreign-callable p (unsigned-56) unsigned-56)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-64) call-u64
+    (lambda (p) (foreign-callable p (unsigned-64) unsigned-64)))
+  (equal?
+    (call-sf
+      (foreign-callable
+        (lambda (x) (+ x 5))
+        (single-float) single-float)
+      73.25 7 23)
+    108.25)
+  (equal?
+    (call-df
+      (foreign-callable
+        (lambda (x) (+ x 5))
+        (double-float) double-float)
+      73.25 7 23)
+    108.25)
+
+  (error?
+    (call-i8
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (integer-8) integer-8)
+      73 0 0))
+  (error?
+    (call-u8
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (unsigned-8) unsigned-8)
+      73 0 0))
+  (error?
+    (call-i16
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (integer-16) integer-16)
+      73 0 0))
+  (error?
+    (call-u16
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (unsigned-16) unsigned-16)
+      73 0 0))
+  (error?
+    (call-i32
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (integer-32) integer-32)
+      73 0 0))
+  (error?
+    (call-u32
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (unsigned-32) unsigned-32)
+      73 0 0))
+  (error?
+    (call-i64
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (integer-64) integer-64)
+      73 0 0))
+  (error?
+    (call-u64
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (unsigned-64) unsigned-64)
+      73 0 0))
+  (error?
+    (call-sf
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (single-float) single-float)
+      73.25 0 0))
+  (error?
+    (call-df
+      (foreign-callable
+        (lambda (x) '(- x 7))
+        (double-float) double-float)
+      73.25 0 0))
+
+  (begin
+    (define u32xu32->u64
+      (foreign-procedure "u32xu32_to_u64" (unsigned-32 unsigned-32)
+        unsigned-64))
+    (define i32xu32->i64
+      (foreign-procedure "i32xu32_to_i64" (integer-32 unsigned-32)
+        integer-64))
+    (define call-i32xu32->i64
+      (foreign-procedure "call_i32xu32_to_i64"
+        (ptr integer-32 unsigned-32 int)
+        integer-64))
+    (define fc-i32xu32->i64
+      (foreign-callable i32xu32->i64
+        (integer-32 unsigned-32)
+        integer-64))
+    #t)
+
+  (eqv? (u32xu32->u64 #xFFFFFFFF #xFFFFFFFF) #xFFFFFFFFFFFFFFFF)
+  (eqv? (u32xu32->u64 #xFF3FFFFF #xFFFFF0FF) #xFF3FFFFFFFFFF0FF)
+  (eqv? (u32xu32->u64 #xFFFFFFFF #xF0000000) #xFFFFFFFFF0000000)
+
+  (eqv? (i32xu32->i64 #x0 #x5) #x5)
+  (eqv? (i32xu32->i64 #x7 #x5) #x700000005)
+  (eqv? (i32xu32->i64 #xFFFFFFFF #xFFFFFFFF) #x-1)
+  (eqv? (fixnum? (i32xu32->i64 #xFFFFFFFF #xFFFFFFFF)) #t)
+  (eqv? (i32xu32->i64 #xFFFFFFFF #xFFFFFFFE) #x-2)
+  (eqv? (i32xu32->i64 #xFFFFFFFF #x00000000) #x-100000000)
+  (eqv? (i32xu32->i64 #xFFFFFFFE #x00000000) #x-200000000)
+  (eqv? (i32xu32->i64 #xFFFFFFFF #x00000001) #x-FFFFFFFF)
+  (eqv? (i32xu32->i64 #x0 #xFFFFFFFF) #xFFFFFFFF)
+  (eqv? (i32xu32->i64 #x7FFFFFFF #xFFFFFFFF) #x7FFFFFFFFFFFFFFF)
+  (eqv? (i32xu32->i64 #x80000000 #x00000000) #x-8000000000000000)
+
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x0 #x5 #x13) #x18)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x7 #x5 7) #x70000000C)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #xFFFFFFFF -3) #x-4)
+  (eqv? (fixnum? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #xFFFFFFFF 0)) #t)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #xFFFFFFFE -1) #x-3)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #x00000000 0) #x-100000000)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFE #x00000000 0) #x-200000000)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #x00000001 0) #x-FFFFFFFF)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x0 #xFFFFFFFF 0) #xFFFFFFFF)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x7FFFFFFF #xFFFFFFFF 0) #x7FFFFFFFFFFFFFFF)
+  (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x80000000 #x00000000 0) #x-8000000000000000)
+
+ ; check for 64-bit alignment issues
+  (begin
+    (define ufoo64a
+      (foreign-procedure "ufoo64a" (unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64)
+        unsigned-64))
+    (define ufoo64b
+      (foreign-procedure "ufoo64b" (integer-32 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64)
+        unsigned-64))
+    (define test-ufoo
+      (lambda (foo x a b c d e f g)
+        (eqv? (foo x a b c d e f g)
+              (mod (+ x (- a b) (- c d) (- e f) g) (expt 2 64)))))
+    #t)
+  (test-ufoo (lambda (x a b c d e f g) (+ x (ufoo64a a b c d e f g)))
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #x0700000000000080)
+  (test-ufoo ufoo64b
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #x0700000000000080)
+  (test-ufoo (lambda (x a b c d e f g) (+ x (ufoo64a a b c d e f g)))
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #xC700000000000080)
+  (test-ufoo ufoo64b
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #xC700000000000080)
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (cons (random (expt 2 32))
+                    (map random (make-list 7 (expt 2 64))))])
+      (unless (apply test-ufoo
+                (lambda (x a b c d e f g)
+                  (+ x (ufoo64a a b c d e f g)))
+                ls)
+        (pretty-print ls)
+        (errorf #f "failed for ufoo64a on ~s" ls))
+      (unless (apply test-ufoo ufoo64b ls)
+        (pretty-print ls)
+        (errorf #f "failed for ufoo64b on ~s" ls))))
+  (begin
+    (define ifoo64a
+      (foreign-procedure "ifoo64a" (integer-64 integer-64 integer-64 integer-64 integer-64 integer-64 integer-64)
+        integer-64))
+    (define ifoo64b
+      (foreign-procedure "ifoo64b" (integer-32 integer-64 integer-64 integer-64 integer-64 integer-64 integer-64 integer-64)
+        integer-64))
+    (define test-ifoo
+      (lambda (foo x a b c d e f g)
+        (eqv? (foo x a b c d e f g)
+              (mod0 (+ x (- a b) (- c d) (- e f) g) (expt 2 64)))))
+    #t)
+  (test-ifoo (lambda (x a b c d e f g) (+ x (ifoo64a a b c d e f g)))
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #x0700000000000080)
+  (test-ifoo ifoo64b
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #x0700000000000080)
+  (test-ifoo (lambda (x a b c d e f g) (+ x (ifoo64a a b c d e f g)))
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #xC700000000000080)
+  (test-ifoo ifoo64b
+    #x0000000010000000
+    #x0000000120000000
+    #x0000002003000000
+    #x0000030000400000
+    #x0000400000050000
+    #x0005000000006000
+    #x0060000000000700
+    #xC700000000000080)
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([ls (cons (- (random (expt 2 32)) (expt 2 31))
+                    (map (lambda (n) (- (random n) (expt 2 31))) (make-list 7 (expt 2 64))))])
+      (unless (apply test-ifoo
+                (lambda (x a b c d e f g)
+                  (+ x (ifoo64a a b c d e f g)))
+                ls)
+        (pretty-print ls)
+        (errorf #f "failed for ifoo64a on ~s" ls))
+      (unless (apply test-ifoo ifoo64b ls)
+        (pretty-print ls)
+        (errorf #f "failed for ifoo64b on ~s" ls))))
+)
+
+(mat foreign-C-types
+ ; test void*, int, unsigned, float, etc.
+  (begin
+    (define int-to-int (foreign-procedure "int_to_int" (int int) int))
+    (define unsigned-to-unsigned (foreign-procedure "unsigned_to_unsigned" (unsigned int) unsigned))
+    (define unsigned-int-to-unsigned-int (foreign-procedure "unsigned_to_unsigned" (unsigned-int int) unsigned-int))
+    (define char-to-char (foreign-procedure "char_to_char" (char) char))
+    (define wchar-to-wchar (foreign-procedure "wchar_to_wchar" (wchar) wchar))
+    (define short-to-short (foreign-procedure "short_to_short" (short int) short))
+    (define unsigned-short-to-unsigned-short (foreign-procedure "unsigned_short_to_unsigned_short" (unsigned-short int) unsigned-short))
+    (define long-to-long (foreign-procedure "long_to_long" (long int) long))
+    (define unsigned-long-to-unsigned-long (foreign-procedure "unsigned_long_to_unsigned_long" (unsigned-long int) unsigned-long))
+    (define long-long-to-long-long (foreign-procedure "long_long_to_long_long" (long-long int) long-long))
+    (define unsigned-long-long-to-unsigned-long-long (foreign-procedure "unsigned_long_long_to_unsigned_long_long" (unsigned-long-long int) unsigned-long-long))
+    (define float-to-float (foreign-procedure "float_to_float" (float) float))
+    (define double-to-double (foreign-procedure "double_to_double" (double) double))
+    (define iptr-to-iptr (foreign-procedure "iptr_to_iptr" (iptr int) iptr))
+    (define uptr-to-uptr (foreign-procedure "uptr_to_uptr" (uptr int) uptr))
+    (define void*-to-void* (foreign-procedure "uptr_to_uptr" (void* int) void*))
+    #t)
+  ($test-int-to-int int-to-int (foreign-sizeof 'int) #t)
+  ($test-int-to-int unsigned-to-unsigned (foreign-sizeof 'unsigned) #f)
+  ($test-int-to-int unsigned-int-to-unsigned-int (foreign-sizeof 'unsigned-int) #f)
+  ($test-int-to-int short-to-short (foreign-sizeof 'short) #t)
+  ($test-int-to-int unsigned-short-to-unsigned-short (foreign-sizeof 'unsigned-short) #f)
+  ($test-int-to-int long-to-long (foreign-sizeof 'long) #t)
+  ($test-int-to-int unsigned-long-to-unsigned-long (foreign-sizeof 'unsigned-long) #f)
+  ($test-int-to-int long-long-to-long-long (foreign-sizeof 'long-long) #t)
+  ($test-int-to-int unsigned-long-long-to-unsigned-long-long (foreign-sizeof 'unsigned-long-long) #f)
+  ($test-int-to-int iptr-to-iptr (foreign-sizeof 'iptr) #t)
+  ($test-int-to-int uptr-to-uptr (foreign-sizeof 'uptr) #f)
+  ($test-int-to-int void*-to-void* (foreign-sizeof 'void*) #f)
+
+  (eqv? (char-to-char #\a) #\A)
+  (eqv? (wchar-to-wchar #\x3bb) #\x39b)
+  (eqv? (float-to-float 73.5) 74.5)
+  (eqv? (double-to-double 73.5) 74.5)
+
+  (error? (int-to-int 'qqq 0))
+  (error? (unsigned-to-unsigned 'qqq 0))
+  (error? (unsigned-int-to-unsigned-int 'qqq 0))
+  (error? (unsigned-short-to-unsigned-short 'qqq 0))
+  (error? (short-to-short 'qqq 0))
+  (error? (long-to-long 'qqq 0))
+  (error? (unsigned-long-to-unsigned-long 'qqq 0))
+  (error? (long-long-to-long-long 'qqq 0))
+  (error? (unsigned-long-long-to-unsigned-long-long 'qqq 0))
+  (error? (iptr-to-iptr 'qqq 0))
+  (error? (uptr-to-uptr 'qqq 0))
+  (error? (void*-to-void* 'qqq 0))
+  (error? (int-to-int 0 "oops"))
+  (error? (unsigned-to-unsigned 0 "oops"))
+  (error? (unsigned-int-to-unsigned-int 0 "oops"))
+  (error? (unsigned-short-to-unsigned-short 0 "oops"))
+  (error? (short-to-short 0 "oops"))
+  (error? (long-to-long 0 "oops"))
+  (error? (unsigned-long-to-unsigned-long 0 "oops"))
+  (error? (long-long-to-long-long 0 "oops"))
+  (error? (unsigned-long-long-to-unsigned-long-long 0 "oops"))
+  (error? (iptr-to-iptr 0 "oops"))
+  (error? (uptr-to-uptr 0 "oops"))
+  (error? (void*-to-void* 0 "oops"))
+
+  (error? (char-to-char 73))
+  (error? (char-to-char #\x100))
+  (error? (wchar-to-wchar 73))
+  (or (= (optimize-level) 3)
+      (if (eq? (foreign-sizeof 'wchar) 16)
+          (guard? (c [#t]) (wchar-to-char #\x10000) #f)
+          #t))
+  (error? (float-to-float 'qqq.5))
+  (error? (double-to-double 'qqq.5))
+
+  (begin
+    (define call-int (foreign-procedure "call_int" (ptr int int int) int))
+    (define call-unsigned (foreign-procedure "call_unsigned" (ptr unsigned int int) unsigned))
+    (define call-unsigned-int (foreign-procedure "call_unsigned" (ptr unsigned-int int int) unsigned-int))
+    (define call-char (foreign-procedure "call_char" (ptr char int int) char))
+    (define call-wchar (foreign-procedure "call_wchar" (ptr wchar int int) wchar))
+    (define call-short (foreign-procedure "call_short" (ptr short int int) short))
+    (define call-unsigned-short (foreign-procedure "call_unsigned_short" (ptr unsigned-short int int) unsigned-short))
+    (define call-long (foreign-procedure "call_long" (ptr long int int) long))
+    (define call-unsigned-long (foreign-procedure "call_unsigned_long" (ptr unsigned-long int int) unsigned-long))
+    (define call-long-long (foreign-procedure "call_long_long" (ptr long-long int int) long-long))
+    (define call-unsigned-long-long (foreign-procedure "call_unsigned_long_long" (ptr unsigned-long-long int int) unsigned-long-long))
+    (define call-float (foreign-procedure "call_float" (ptr float int int) float))
+    (define call-double (foreign-procedure "call_double" (ptr double int int) double))
+    (define call-iptr (foreign-procedure "call_iptr" (ptr iptr int int) iptr))
+    (define call-uptr (foreign-procedure "call_uptr" (ptr uptr int int) uptr))
+    (define call-void* (foreign-procedure "call_uptr" (ptr void* int int) void*))
+    #t)
+  ($test-call-int #t (foreign-sizeof 'int) call-int
+    (lambda (p) (foreign-callable p (int) int)))
+  ($test-call-int #f (foreign-sizeof 'unsigned) call-unsigned
+    (lambda (p) (foreign-callable p (unsigned) unsigned)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-int) call-unsigned-int
+    (lambda (p) (foreign-callable p (unsigned-int) unsigned-int)))
+  ($test-call-int #t (foreign-sizeof 'short) call-short
+    (lambda (p) (foreign-callable p (short) short)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-short) call-unsigned-short
+    (lambda (p) (foreign-callable p (unsigned-short) unsigned-short)))
+  ($test-call-int #t (foreign-sizeof 'long) call-long
+    (lambda (p) (foreign-callable p (long) long)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-long) call-unsigned-long
+    (lambda (p) (foreign-callable p (unsigned-long) unsigned-long)))
+  ($test-call-int #t (foreign-sizeof 'long-long) call-long-long
+    (lambda (p) (foreign-callable p (long-long) long-long)))
+  ($test-call-int #f (foreign-sizeof 'unsigned-long-long) call-unsigned-long-long
+    (lambda (p) (foreign-callable p (unsigned-long-long) unsigned-long-long)))
+  ($test-call-int #t (foreign-sizeof 'iptr) call-iptr
+    (lambda (p) (foreign-callable p (iptr) iptr)))
+  ($test-call-int #f (foreign-sizeof 'uptr) call-uptr
+    (lambda (p) (foreign-callable p (uptr) uptr)))
+  ($test-call-int #f (foreign-sizeof 'void*) call-void*
+    (lambda (p) (foreign-callable p (void*) void*)))
+  (equal?
+    (call-char
+      (foreign-callable
+        (lambda (x) (integer->char (+ (char->integer x) 5)))
+        (char) char)
+      #\a 7 11)
+    #\x)
+  (equal?
+    (call-wchar
+      (foreign-callable
+        (lambda (x) (integer->char (+ (char->integer x) 5)))
+        (wchar) wchar)
+      #\x3bb 7 11)
+    #\x3d2)
+  (equal?
+    (call-float
+      (foreign-callable
+        (lambda (x) (+ x 5))
+        (float) single-float)
+      73.25 7 23)
+    108.25)
+  (equal?
+    (call-double
+      (foreign-callable
+        (lambda (x) (+ x 5))
+        (double) double-float)
+      73.25 7 23)
+    108.25)
+
+  (error?
+    (call-int
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (int) int)
+      73 0 0))
+  (error?
+    (call-unsigned
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (unsigned) unsigned)
+      73 0 0))
+  (error?
+    (call-unsigned-int
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (unsigned-int) unsigned-int)
+      73 0 0))
+  (error?
+    (call-char
+      (foreign-callable
+        (lambda (x) (list x))
+        (char) char)
+      #\a 0 0))
+  (error?
+    (call-wchar
+      (foreign-callable
+        (lambda (x) (list x))
+        (wchar) wchar)
+      #\a 0 0))
+  (error?
+    (call-short
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (short) short)
+      73 0 0))
+  (error?
+    (call-unsigned-short
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (unsigned-short) unsigned-short)
+      73 0 0))
+  (error?
+    (call-long
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (long) long)
+      73 0 0))
+  (error?
+    (call-unsigned-long
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (unsigned-long) unsigned-long)
+      73 0 0))
+  (error?
+    (call-long-long
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (long-long) long-long)
+      73 0 0))
+  (error?
+    (call-unsigned-long-long
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (unsigned-long-long) unsigned-long-long)
+      73 0 0))
+  (error?
+    (call-float
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (float) float)
+      73.25 0 0))
+  (error?
+    (call-double
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (double) double)
+      73.25 0 0))
+  (error?
+    (call-iptr
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (iptr) iptr)
+      73 0 0))
+  (error?
+    (call-uptr
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (uptr) uptr)
+      73 0 0))
+  (error?
+    (call-void*
+      (foreign-callable
+        (lambda (x) (list x (+ x 1)))
+        (void*) void*)
+      73 0 0))
+)
+
+(mat foreign-ftype
+  (begin
+    (define-ftype A (struct [x double] [y wchar]))
+    (define-ftype B (struct [x (array 10 A)] [y A]))
+    (define B->*int (foreign-procedure "uptr_to_uptr" ((* B) int) (* int)))
+    (define B->A (foreign-procedure "uptr_to_uptr" ((* B) int) (* A)))
+    (define B->uptr (foreign-procedure "uptr_to_uptr" ((* B) int) uptr))
+    (define uptr->A (foreign-procedure "uptr_to_uptr" (uptr int) (* A)))
+    (define b ((foreign-procedure (if (windows?) "windows_malloc" "malloc") (ssize_t) (* B)) (ftype-sizeof B)))
+    #t)
+  (eqv?
+    (ftype-pointer-address (uptr->A (ftype-pointer-address (ftype-&ref B (y) b)) 0))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (eqv?
+    (ftype-pointer-address (uptr->A (ftype-pointer-address b) (* 10 (ftype-sizeof A))))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (eqv?
+    (B->uptr b (* 10 (ftype-sizeof A)))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (eqv?
+    (ftype-pointer-address (B->A b (* 10 (ftype-sizeof A))))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (begin
+    (define uptr->uptr (foreign-callable values (uptr) uptr))
+    (define uptr->A (foreign-callable (lambda (a) (make-ftype-pointer A a)) (uptr) (* A)))
+    (define B->uptr (foreign-callable ftype-pointer-address ((* B)) uptr))
+    (define B->A (foreign-callable (lambda (b) (ftype-&ref B (y) b)) ((* B)) (* A)))
+    (define call-B->A (foreign-procedure "call_uptr" (ptr (* B) int int) (* A)))
+    #t)
+  (eqv?
+    (ftype-pointer-address (call-B->A uptr->uptr b (* 5 (ftype-sizeof A)) (* 5 (ftype-sizeof A))))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (eqv?
+    (ftype-pointer-address (call-B->A uptr->A b (* 5 (ftype-sizeof A)) (* 5 (ftype-sizeof A))))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (eqv?
+    (ftype-pointer-address (call-B->A B->uptr b (* 5 (ftype-sizeof A)) (* 5 (ftype-sizeof A))))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (eqv?
+    (ftype-pointer-address (call-B->A B->A b 0 0))
+    (ftype-pointer-address (ftype-&ref B (y) b)))
+  (begin
+    ((foreign-procedure (if (windows?) "windows_free" "free") ((* B)) void) b)
+    (set! b #f)
+    #t)
+  (error? ; unrecognized foreign-procedure argument ftype name
+    (foreign-procedure "foo" ((* broken)) void))
+  (error? ; invalid foreign-procedure argument type specifier
+    (foreign-procedure "foo" ((+ * -)) void))
+  (error? ; invalid foreign-procedure argument type specifier
+    (foreign-procedure "foo" ((* * *)) void))
+  (error? ; invalid foreign-procedure argument type specifier
+    (foreign-procedure "foo" ((struct [a int])) void))
+  (error? ; invalid foreign-procedure argument type specifier
+    (foreign-procedure "foo" (hag) void))
+  (error? ; unrecognized foreign-procedure return ftype name
+    (foreign-procedure "foo" () (* broken)))
+  (error? ; invalid foreign-procedure return type specifier
+    (foreign-procedure "foo" () (+ * -)))
+  (error? ; invalid foreign-procedure return type specifier
+    (foreign-procedure "foo" () (* * *)))
+  (error? ; invalid foreign-procedure argument type specifier
+    (foreign-procedure "foo" () ((struct [a int]))))
+  (error? ; invalid foreign-procedure return type specifier
+    (foreign-procedure "foo" () hag))
+  (error? ; invalid (non-base) ... ftype
+    (foreign-procedure "foo" (A) void))
+  (error? ; invalid (non-base) ... ftype
+    (foreign-procedure "foo" () A))
+  (begin
+    (meta-cond
+      [(eq? (native-endianness) 'little)
+       (define-ftype swap-fixnum (endian big fixnum))]
+      [(eq? (native-endianness) 'big)
+       (define-ftype swap-fixnum (endian little fixnum))])
+    #t)
+  (error? ; invalid (swapped) ... ftype
+    (foreign-procedure "foo" (swap-fixnum) void))
+  (error? ; invalid (swapped) ... ftype
+    (foreign-procedure "foo" () swap-fixnum))
+  (error? ; invalid syntax
+    (define-ftype foo (function "wtf" () void) +))
+  (error? ; invalid convention
+    (define-ftype foo (function "wtf" () void)))
+  (error? ; invalid argument type void
+    (define-ftype foo (function (void) int)))
+  (equal?
+    (let ()
+      (define-ftype foo (function (int) void))
+      (list (ftype-pointer? (make-ftype-pointer foo 0))
+            (ftype-pointer? foo (make-ftype-pointer double 0))
+            (ftype-pointer? foo (make-ftype-pointer foo 0))))
+    '(#t #f #t))
+  (error? ; non-function ftype with "memcpy" address
+    (define $fp-bvcopy (make-ftype-pointer double "memcpy")))
+  (error? ; unrecognized ftype
+    (define $fp-bvcopy (make-ftype-pointer spam "memcpy")))
+  (error? ; invalid syntax 
+    (define $fp-bvcopy (make-ftype-pointer (struct [x int]) "memcpy")))
+  (error? ; invalid function-ftype result type specifier u8
+    (let ()
+      (define-ftype foo (function (u8* u8* size_t) u8))
+      (define $fp-bvcopy (make-ftype-pointer foo "memcpy"))))
+  (error? ; invalid function-ftype argument type specifier u8
+    (let ()
+      (define-ftype foo (function (u8* u8 size_t) u8*))
+      (define $fp-bvcopy (make-ftype-pointer foo "memcpy"))))
+  (begin
+    (define-ftype memcpy_t (function (u8* u8* size_t) u8*))
+    (define $fp-bvcopy (ftype-ref memcpy_t () (make-ftype-pointer memcpy_t "memcpy")))
+    #t)
+  (let ([bv1 (string->utf8 "hello")] [bv2 (make-bytevector 5)])
+    ($fp-bvcopy bv2 bv1 5)
+    (and (bytevector=? bv1 bv2) (bytevector=? bv1 (string->utf8 "hello"))))
+  (begin
+    (define-ftype bvcopy-t (function (u8* u8* size_t) u8*))
+    (define $fp-bvcopy (ftype-ref bvcopy-t () (make-ftype-pointer bvcopy-t "memcpy")))
+    #t)
+  (let ([bv1 (string->utf8 "hello")] [bv2 (make-bytevector 5)])
+    ($fp-bvcopy bv2 bv1 5)
+    (and (bytevector=? bv1 bv2) (bytevector=? bv1 (string->utf8 "hello"))))
+  ;; No longer an error since make-ftype-pointer also serves to make foreign-pointers
+  #;(error? ; "memcpy" is not a procedure
+      (make-ftype-pointer memcpy_t "memcpy"))
+  (error? ; unrecognized ftype
+    (make-ftype-pointer spam +))
+  (error? ; non-function ftype
+    (make-ftype-pointer double +))
+  (error? ; invalid syntax
+    (make-ftype-pointer (struct [x int]) +))
+  (eqv?
+    (let ()
+      (define-ftype foo (function (int int) double))
+      (define code
+        (make-ftype-pointer foo
+          (lambda (x y) (inexact (+ x y)))))
+      (let ([code-object (foreign-callable-code-object (ftype-pointer-address code))])
+        (dynamic-wind
+          (lambda () (lock-object code-object))
+          (lambda ()
+            (define f (ftype-ref foo () code))
+            (f 3 4))
+          (lambda () (unlock-object code-object)))))
+    7.0)
+  (eqv?
+    (let ()
+      (define-ftype foo (function (int int) double))
+      (define code
+        (make-ftype-pointer foo
+          (lambda (x y) (inexact (+ x y)))))
+      (define f (ftype-ref foo () code))
+      (let ([x (f 8 4)])
+        (unlock-object (foreign-callable-code-object (ftype-pointer-address code)))
+        x))
+    12.0)
+  (eqv?
+    (let ()
+      (define-ftype foo (function (void* void*) ptrdiff_t))
+      (define code (make-ftype-pointer foo -))
+      (let ([code-object (foreign-callable-code-object (ftype-pointer-address code))])
+        (dynamic-wind
+          (lambda () (lock-object code-object))
+          (lambda () ((ftype-ref foo () code) 17 (* (most-positive-fixnum) 2)))
+          (lambda () (unlock-object code-object)))))
+    (- 17 (* (most-positive-fixnum) 2)))
+  (eqv?
+    (let ()
+      (define-ftype foo (function (void* void*) ptrdiff_t))
+      (define code (make-ftype-pointer foo -))
+      (let ([x ((ftype-ref foo () code) 19 (* (most-positive-fixnum) 2))])
+        (unlock-object (foreign-callable-code-object (ftype-pointer-address code)))
+        x))
+    (- 19 (* (most-positive-fixnum) 2)))
+  (eqv?
+    (let ()
+      (define-ftype foo (function (int int) size_t))
+      (define code (make-ftype-pointer foo -))
+      (let ([code-object (foreign-callable-code-object (ftype-pointer-address code))])
+        (dynamic-wind
+          (lambda () (lock-object code))
+          (lambda () ((ftype-ref foo () code) 17 32))
+          (lambda () (unlock-object code)))))
+    (- (expt 2 (* (ftype-sizeof size_t) 8)) 15))
+  (eqv?
+    (let ()
+      (define-ftype foo (function (int int) size_t))
+      (define code (make-ftype-pointer foo -))
+      (let ([x ((ftype-ref foo () code) 17 32)])
+        (unlock-object (foreign-callable-code-object (ftype-pointer-address code)))
+        x))
+    (- (expt 2 (* (ftype-sizeof size_t) 8)) 15))
+
+  (error? ; not a string
+    (foreign-entry #e1e6))
+
+  (error? ; no entry for "i am not defined"
+    (foreign-entry "i am not defined"))
+
+  (begin
+    (define-ftype F (function (size_t) int))
+    (define malloc-fptr1 (make-ftype-pointer F (if (windows?) "windows_malloc" "malloc")))
+    (define malloc-fptr2 (make-ftype-pointer F (foreign-entry (if (windows?) "windows_malloc" "malloc"))))
+    #t)
+
+  (equal?
+    (foreign-address-name (ftype-pointer-address malloc-fptr1))
+    (if (windows?) "windows_malloc" "malloc"))
+
+  (equal?
+    (foreign-address-name (ftype-pointer-address malloc-fptr2))
+    (if (windows?) "windows_malloc" "malloc"))
+
+  (eqv?
+    (ftype-pointer-address malloc-fptr1)
+    (ftype-pointer-address malloc-fptr2))
+
+  (procedure?
+    (ftype-ref F () malloc-fptr1))
+
+  (begin
+    (define-ftype SF (struct [i int] [f (* F)]))
+    (define sf (make-ftype-pointer SF (foreign-alloc (ftype-sizeof SF))))
+    (ftype-set! SF (i) sf 10)
+    (ftype-set! SF (f) sf malloc-fptr2)
+    #t)
+
+  (ftype-pointer? F (ftype-ref SF (f) sf))
+
+  (procedure? (ftype-ref SF (f *) sf))
+
+  (error?
+    (begin
+      (define-ftype A (struct [x double] [y wchar]))
+      (define-ftype B (struct [x (array 10 A)] [y A]))
+      ; see if defns above mess up defn below
+      (define-ftype
+        [A (function ((* B)) (* B))]
+        [B (struct [x A])])))
+
+  (begin
+    (define-ftype A (struct [x double] [y wchar]))
+    (define-ftype B (struct [x (array 10 A)] [y A]))
+    ; see if defns above mess up defn below
+    (define-ftype
+      [A (function ((* B)) (* B))]
+      [B (struct [x (* A)])])
+    (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+    (define a (ftype-ref A () (make-ftype-pointer A "idiptr")))
+    #t)
+  (eqv? (ftype-pointer-address (a b)) (ftype-pointer-address b))
+
+  (begin
+    (define-ftype
+      [A (function ((* B)) (* B))]
+      [B (struct [x (* A)])])
+    (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+    (define a (ftype-ref A () (make-ftype-pointer A "idiptr")))
+    #t)
+  (eqv? (ftype-pointer-address (a b)) (ftype-pointer-address b))
+
+  (begin
+    (define-ftype
+      [B (struct [x (* A)])]
+      [A (function ((* B)) (* B))])
+    (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+    (define a (ftype-ref A () (make-ftype-pointer A "idiptr")))
+    #t)
+  (eqv? (ftype-pointer-address (a b)) (ftype-pointer-address b))
+
+  (begin
+    (define-ftype A (function ((* A)) (* A)))
+    (define a (make-ftype-pointer A "idiptr"))
+    #t)
+  (eqv? (ftype-pointer-address ((ftype-ref A () a) a)) (ftype-pointer-address a))
+
+  (begin 
+    (define-ftype A (struct [x uptr] [y uptr]))
+    (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (define ff-init-lock (foreign-procedure "init_lock" ((* uptr)) void))
+    (define ff-spinlock (foreign-procedure "spinlock" ((* uptr)) void))
+    (define ff-unlock (foreign-procedure "unlock" ((* uptr)) void))
+    (define ff-locked-incr (foreign-procedure "locked_incr" ((* uptr)) boolean))
+    (define ff-locked-decr (foreign-procedure "locked_decr" ((* uptr)) boolean))
+    #t)
+  (eq? (ff-init-lock (ftype-&ref A (x) a)) (void))
+  (ftype-lock! A (x) a)
+  (not (ftype-lock! A (x) a))
+  (eq? (ftype-unlock! A (x) a) (void))
+  (eq? (ff-spinlock (ftype-&ref A (x) a)) (void))
+  (not (ftype-lock! A (x) a))
+  (eq? (ff-unlock (ftype-&ref A (x) a)) (void))
+  (ftype-lock! A (x) a)
+  (eq? (ff-unlock (ftype-&ref A (x) a)) (void))
+  (eq? (ff-spinlock (ftype-&ref A (x) a)) (void))
+  (not (ftype-lock! A (x) a))
+  (eq? (ff-unlock (ftype-&ref A (x) a)) (void))
+  (eq? (ftype-set! A (y) a 1) (void))
+  (not (ff-locked-incr (ftype-&ref A (y) a)))
+  (eqv? (ftype-ref A (y) a) 2)
+  (not (ff-locked-decr (ftype-&ref A (y) a)))
+  (ff-locked-decr (ftype-&ref A (y) a))
+  (eqv? (ftype-ref A (y) a) 0)
+  (not (ff-locked-decr (ftype-&ref A (y) a)))
+  (ff-locked-incr (ftype-&ref A (y) a))
+)
+
+(mat foreign-anonymous
+  (eqv?
+    (let ([addr ((foreign-procedure "idiptr_addr" () iptr))])
+      (define idiptr (foreign-procedure addr (scheme-object) scheme-object))
+      (idiptr 'friggle))
+    'friggle)
+)
+
+(machine-case
+  [(i3nt ti3nt)
+   (mat i3nt-stdcall
+     (let ()
+        (define (win32:number-32-ptr->number n32ptr)
+          (+ (fx+ (char->integer (string-ref n32ptr 0))
+               (fxsll (char->integer (string-ref n32ptr 1)) 8)
+               (fxsll (char->integer (string-ref n32ptr 2)) 16))
+            (* (char->integer (string-ref n32ptr 3)) #x1000000)))
+        (define (win32:GetVolumeSerialNumber root)
+          (define f-proc
+            (foreign-procedure __stdcall "GetVolumeInformationA"
+              (string string unsigned-32 string string string string unsigned-32)
+              boolean))
+          (let ([vol-sid (make-string 4)]
+                [max-filename-len (make-string 4)]
+                [sys-flags (make-string 4)])
+            (and (f-proc root #f 0 vol-sid max-filename-len sys-flags #f 0)
+                 (win32:number-32-ptr->number vol-sid))))
+        (number? (win32:GetVolumeSerialNumber "C:\\"))))])
+
+(mat single-float
+  (= (let ((x (foreign-procedure "sxstos" (single-float single-float)
+                single-float)))
+       (x 3.0 5.0))
+     15)
+  (let ((args '(1.25 2.25 3.25 4.25 5.25 6.25 7.25 8.25 9.25 10.25 11.25 12.25)))
+    (= (apply + args)
+       (apply
+         (foreign-procedure "singlesum12"
+           (single-float single-float single-float single-float
+            single-float single-float single-float single-float
+            single-float single-float single-float single-float)
+           single-float)
+         args)))
+ )
+
+(mat auto-mat-icks
+  (auto-mat-ick "d1d2")
+  (auto-mat-ick "s1s2")
+  (auto-mat-ick "s1d1")
+  (auto-mat-ick "d1s1")
+  (auto-mat-ick "n1n2n3n4")
+  (auto-mat-ick "d1n1d2")
+  (auto-mat-ick "d1n1n2")
+  (auto-mat-ick "s1n1n2")
+  (auto-mat-ick "n1n2n3d1")
+  (auto-mat-ick "n1n2n3s1")
+  (auto-mat-ick "n1n2d1")
+  (auto-mat-ick "n1d1")
+  (auto-mat-ick "s1s2s3s4")
+  (auto-mat-ick "s1n1s2n2")
+  (auto-mat-ick "d1s1s2")
+  (auto-mat-ick "s1s2d1")
+  (auto-mat-ick "n1s1n2s2")
+  (auto-mat-ick "n1s1n2n3")
+  (auto-mat-ick "n1n2s1n3")
+  (auto-mat-ick "d1d2s1s2")
+  (auto-mat-ick "d1d2n1n2")
+  (auto-mat-ick "s1d1s2s3")
+ )
+
+(mat foreign-callable
+  (error? ; spam is not a procedure
+    (foreign-callable 'spam () void))
+  (error? ; spam is not a procedure
+    (begin (foreign-callable 'spam () void) 'q))
+  (error? ; spam is not a procedure
+    (if (foreign-callable 'spam () void) 'q 'p))
+  (equal?
+    (let ()
+      (define Sinvoke2
+        (foreign-procedure "Sinvoke2"
+          (scheme-object scheme-object iptr)
+          scheme-object))
+      (define Fcons
+        (foreign-callable
+          (lambda (x y)
+            (collect)
+            (let ([ls (map (lambda (x) (make-vector 200 x)) (make-list 100))])
+              (collect)
+              (collect)
+              (collect)
+              (collect)
+              (collect)
+              (cons (length ls) (cons x y))))
+          (scheme-object iptr)
+          scheme-object))
+      (define (go) (Sinvoke2 Fcons 4 5))
+      (define initial-result (go))
+      (let loop ([i 100])
+        (if (zero? i)
+            initial-result
+            (and (equal? initial-result (go))
+                 (loop (sub1 i))))))
+    '(100 4 . 5))
+  (eqv?
+    (let ()
+      (define Sinvoke2
+        (foreign-procedure "Sinvoke2"
+          (scheme-object scheme-object iptr)
+          scheme-object))
+      (define fxFsum
+        (foreign-callable
+          (lambda (x y)
+            (if (fx= x 0)
+                y
+                (fx+ x (Sinvoke2 fxFsum (fx- x 1) y))))
+          (scheme-object iptr)
+          scheme-object))
+      (define (fxgosum n) (Sinvoke2 fxFsum n 0))
+      (fxgosum 20))
+    210)
+  (eqv?
+    (let ()
+      (define Sinvoke2
+        (foreign-procedure "Sinvoke2"
+          (scheme-object scheme-object iptr)
+          scheme-object))
+      (define Fsum
+        (foreign-callable
+          (lambda (x y)
+            (if (= x 0)
+                y
+                (+ x (Sinvoke2 Fsum (- x 1) y))))
+          (scheme-object iptr)
+          scheme-object))
+      (define (gosum n) (Sinvoke2 Fsum n (most-positive-fixnum)))
+      (gosum 20))
+    (+ (most-positive-fixnum) 210))
+  (let ()
+    (define Fargtest
+      (foreign-callable
+        (lambda (bool char fixnum double single string)
+          (list string single double fixnum char bool))
+        (boolean char fixnum double-float single-float string)
+        scheme-object))
+    (define Sargtest
+      (foreign-procedure "Sargtest"
+        (iptr boolean char fixnum double-float single-float string)
+        scheme-object))
+    (define args1 (list #t #\Q 12345 3.1415 2.0 "hit me"))
+    (define args2 (list #f #\newline -51293 3.1415 2.5 ""))
+    (define args3 (list #f #\newline -51293 3.1415 2.5 #f))
+    (let ()
+      (define addr
+        (begin
+          (lock-object Fargtest)
+          (foreign-callable-entry-point Fargtest)))
+      (dynamic-wind
+        void
+        (lambda ()
+          (collect (collect-maximum-generation))
+          (collect (collect-maximum-generation))
+          (and
+            (equal? (apply Sargtest addr args1) (reverse args1))
+            (equal? (apply Sargtest addr args2) (reverse args2))
+            (equal? (apply Sargtest addr args3) (reverse args3))))
+        (lambda () (unlock-object Fargtest)))))
+  (let ()
+    (define Fargtest2
+      (foreign-callable
+        (lambda (x1 x2 x3 x4 x5 x6)
+          (list x6 x5 x4 x3 x2 x1))
+        (short int char double short char)
+        scheme-object))
+    (define Sargtest2
+      (foreign-procedure "Sargtest2"
+        (iptr short int char double short char)
+        scheme-object))
+    (define args1 (list 32123 #xc7c7c7 #\% 3.1415 -32768 #\!))
+    (define args2 (list 17 #x-987654 #\P -521.125 -1955 #\Q))
+    (define args3 (list -7500 #x987654 #\? +inf.0 3210 #\7))
+    (let ()
+      (define addr
+        (begin
+          (lock-object Fargtest2)
+          (foreign-callable-entry-point Fargtest2)))
+      (dynamic-wind
+        void
+        (lambda ()
+          (collect (collect-maximum-generation))
+          (collect (collect-maximum-generation))
+          (and
+            (equal? (apply Sargtest2 addr args1) (reverse args1))
+            (equal? (apply Sargtest2 addr args2) (reverse args2))
+            (equal? (apply Sargtest2 addr args3) (reverse args3))))
+        (lambda () (unlock-object Fargtest2)))))
+  (let ()
+    (define Frvtest_int32
+      (foreign-callable
+        (lambda (x) (* x x))
+        (scheme-object)
+        integer-32))
+    (define Srvtest_int32
+      (foreign-procedure "Srvtest_int32"
+        (scheme-object scheme-object)
+        integer-32))
+    (and
+      (eqv? (Srvtest_int32 Frvtest_int32 16) 256)
+      (eqv? (Srvtest_int32 Frvtest_int32 #x8000) #x40000000)))
+  (let ()
+    (define Frvtest_uns32
+      (foreign-callable
+        (lambda (x) (- (* x x) 1))
+        (scheme-object)
+        unsigned-32))
+    (define Srvtest_uns32
+      (foreign-procedure "Srvtest_uns32"
+        (scheme-object scheme-object)
+        unsigned-32))
+    (and
+      (eqv? (Srvtest_uns32 Frvtest_uns32 16) 255)
+      (eqv? (Srvtest_uns32 Frvtest_uns32 #x10000) #xffffffff)))
+  (let ()
+    (define Frvtest_single
+      (foreign-callable
+        (lambda (x) (* x x))
+        (scheme-object)
+        single-float))
+    (define Srvtest_single
+      (foreign-procedure "Srvtest_single"
+        (scheme-object scheme-object)
+        single-float))
+    (eqv? (Srvtest_single Frvtest_single 16.0) 256.0))
+  (let ()
+    (define Frvtest_double
+      (foreign-callable
+        (lambda (x) (* x x))
+        (scheme-object)
+        double-float))
+    (define Srvtest_double
+      (foreign-procedure "Srvtest_double"
+        (scheme-object scheme-object)
+        double-float))
+    (eqv? (Srvtest_double Frvtest_double 16.0) 256.0))
+  (let ()
+    (define Frvtest_char
+      (foreign-callable
+        (lambda (x) (string-ref x 3))
+        (scheme-object)
+        char))
+    (define Srvtest_char
+      (foreign-procedure "Srvtest_char"
+        (scheme-object scheme-object)
+        char))
+    (eqv? (Srvtest_char Frvtest_char "abcdefg") #\d))
+  (let ()
+    (define Frvtest_boolean
+      (foreign-callable
+        (lambda (x) (equal? x "abcdefg"))
+        (scheme-object)
+        boolean))
+    (define Srvtest_boolean
+      (foreign-procedure "Srvtest_int32"
+        (scheme-object scheme-object)
+        boolean))
+    (and
+      (eqv? (Srvtest_boolean Frvtest_boolean "abcdefg") #t)
+      (eqv? (Srvtest_boolean Frvtest_boolean "gfedcba") #f)))
+  (let ()
+    (define Frvtest_fixnum
+      (foreign-callable
+        (lambda (x) (* x x))
+        (scheme-object)
+        fixnum))
+    (define Srvtest_fixnum
+      (foreign-procedure "Srvtest_int32"
+        (scheme-object scheme-object)
+        fixnum))
+    (eqv? (Srvtest_fixnum Frvtest_fixnum 16) 256))
+  (let ()
+    (define Frvtest_fixnum
+      (foreign-callable
+        (lambda (x) (* x x))
+        (scheme-object)
+        void))
+    (define Srvtest_fixnum
+      (foreign-procedure "Srvtest_int32"
+        (scheme-object scheme-object)
+        void))
+    (eqv? (Srvtest_fixnum Frvtest_fixnum 16) (void)))
+  #;(error? (foreign-callable values (scheme-object) foreign-pointer))
+  #;(error? (foreign-callable values (scheme-object) (foreign-object 16 4)))
+  #;(error? (foreign-callable values (foreign-pointer) void))
+  #;(error? (foreign-callable values ((foreign-object 16 4)) void))
+  (equal?
+    (let ([x 5])
+      (define call-twice (foreign-procedure "call_twice" (void* int int) void))
+      (let ([co (foreign-callable (lambda (y) (set! x (+ x y))) (int) void)])
+        (lock-object co)
+        (call-twice (foreign-callable-entry-point co) 7 31)
+        (unlock-object co))
+      x)
+    43)
+  (equal?
+    (let ()
+     ; foreign_callable example adapted from foreign.stex
+      (define cb-init
+        (foreign-procedure "cb_init" () void))
+      (define register-callback
+        (foreign-procedure "register_callback" (char iptr) void))
+      (define event-loop
+        (foreign-procedure "event_loop" (string) void))
+
+      (define callback
+        (lambda (p)
+          (let ([code (foreign-callable p (char) void)])
+            (lock-object code)
+            (foreign-callable-entry-point code))))
+      (let ()
+        (define ouch
+          (callback
+            (lambda (c)
+              (printf "Ouch! Hit by '~c'~%" c))))
+        (define rats
+          (callback
+            (lambda (c)
+              (printf "Rats! Received '~c'~%" c))))
+  
+        (cb-init)
+        (register-callback #\a ouch)
+        (register-callback #\c rats)
+        (register-callback #\e ouch)
+  
+        (parameterize ([current-output-port (open-output-string)])
+          (event-loop "abcde")
+          (get-output-string (current-output-port)))))
+    (format "Ouch! Hit by 'a'~%Rats! Received 'c'~%Ouch! Hit by 'e'~%"))
+   ; make sure foreign-procedure's code-object is properly locked when
+   ; calling back into Scheme
+   (begin
+     (define call-collect (lambda () (collect) (collect (collect-maximum-generation))))
+     (define code (foreign-callable call-collect () void))
+     (collect)
+     #t)
+   ; this form needs to be after the preceding form and not part of it, so that when
+   ; we lock code we don't also lock the code object created by foreign-procedure
+   (begin
+     (lock-object code)
+     ((foreign-procedure (foreign-callable-entry-point code) () scheme-object))
+     (unlock-object code)
+     #t)
+
+  (not (locked-object?
+         (let ()
+           (define cb (foreign-callable (lambda (i) i) (int) int))
+           (define unlock-callback (foreign-procedure "unlock_callback" (void*) void))
+           (lock-object cb)
+           (unlock-callback (foreign-callable-entry-point cb))
+           cb)))
+  (not (locked-object?
+         (let ()
+           (define cb (foreign-callable (lambda (i) i) (int) int))
+           (define unlock-callback (foreign-procedure "unlock_callback" (void*) void))
+           (lock-object cb)
+           (collect)
+           (unlock-callback (foreign-callable-entry-point cb))
+           cb)))
+  (equal?
+    (let ()
+      (define cb (foreign-callable (lambda (i) (+ i 10)) (int) int))
+      (define call-and-unlock (foreign-procedure "call_and_unlock" (void* int) int))
+      (lock-object cb)
+      (let ([ans (call-and-unlock (foreign-callable-entry-point cb) 5)])
+        (list (locked-object? cb) ans)))
+    '(#f 15))
+  (equal?
+    (let ()
+      (define cb (foreign-callable (lambda (i) (+ i 10)) (int) int))
+      (define call-and-unlock (foreign-procedure "call_and_unlock" (void* int) int))
+      (lock-object cb)
+      (collect)
+      (let ([ans (call-and-unlock (foreign-callable-entry-point cb) 3)])
+        (list (locked-object? cb) ans)))
+    '(#f 13))
+  (begin
+    (define $stack-depth 8000)
+    (define $base-value 37)
+    #t)
+  (eqv? ; make sure foreign-callable does it's overflow checks
+    (let ()
+      (define-ftype foo (function (fixnum fixnum) fixnum))
+      (define f (lambda (n m) (if (fx= n 0) m (g (fx- n 1) (fx+ m 1)))))
+      (define fptr (make-ftype-pointer foo f))
+      (define g (ftype-ref foo () fptr))
+      (let ([v (f $stack-depth $base-value)])
+        (unlock-object
+          (foreign-callable-code-object
+            (ftype-pointer-address fptr)))
+        v))
+    (+ $stack-depth $base-value))
+  (begin
+    (define $with-exit-proc
+      ; if you change this, consider changing the definition of with-exit-proc
+      ; in foreign.stex
+      (lambda (p)
+        (define th (lambda () (call/cc p)))
+        (define-ftype ->ptr (function () ptr))
+        (let ([fptr (make-ftype-pointer ->ptr th)])
+          (let ([v ((ftype-ref ->ptr () fptr))])
+            (unlock-object
+              (foreign-callable-code-object
+                (ftype-pointer-address fptr)))
+            v))))
+    #t)
+  (eqv? ; make sure we can jump out of a deep nest of C/Scheme calls
+    (let ()
+      (define *k*)
+      (define-ftype foo (function (fixnum fixnum) fixnum))
+      (define f (lambda (n m) (if (fx= n 0) (*k* m) (g (fx- n 1) (fx+ m 1)))))
+      (define fptr (make-ftype-pointer foo f))
+      (define g (ftype-ref foo () fptr))
+      (let ([v ($with-exit-proc
+                 (lambda (k)
+                   (set! *k* k)
+                   (f $stack-depth $base-value)))])
+        (unlock-object
+          (foreign-callable-code-object
+            (ftype-pointer-address fptr)))
+        v))
+    (+ $stack-depth $base-value))
+  (eqv? ; make sure we can jump out a few frames at a time
+    (let ()
+      (define-ftype foo (function (fixnum fixnum ptr) fixnum))
+      (define f
+        (lambda (n m k)
+          (if (fx= n 0)
+              (k m)
+              (if (fx= (fxmodulo n 10) 0)
+                  (k (call/cc
+                       (lambda (k)
+                         (g (fx- n 1) (fx+ m 1) k))))
+                  (g (fx- n 1) (fx+ m 1) k)))))
+      (define fptr (make-ftype-pointer foo f))
+      (define g (ftype-ref foo () fptr))
+      (let ([v ($with-exit-proc
+                 (lambda (k)
+                   (f $stack-depth $base-value k)))])
+        (unlock-object
+          (foreign-callable-code-object
+            (ftype-pointer-address fptr)))
+        v))
+    (+ $stack-depth $base-value))
+  (or (= (optimize-level) 3)
+      ; make sure we can jump out a few frames at a time, returning from
+      ; each with an invalid number of values, just for fun
+      (eqv?
+        ($with-exit-proc
+          (lambda (ignore)
+            (define *m*)
+            (define *k*)
+            (define-ftype foo (function (fixnum fixnum) fixnum))
+            (define f
+              (lambda (n m)
+                (if (fx= n 0)
+                    (begin (set! *m* m) (values))
+                    (if (fx= (fxmodulo n 10) 0)
+                        (begin
+                          (set! *m*
+                            (call/cc
+                              (lambda (k)
+                                (fluid-let ([*k* k])
+                                  (g (fx- n 1) (fx+ m 1))))))
+                          (values))
+                        (g (fx- n 1) (fx+ m 1))))))
+            (define fptr (make-ftype-pointer foo f))
+            (define g (ftype-ref foo () fptr))
+            (with-exception-handler
+              (lambda (c) (*k* *m*))
+              (lambda ()
+                (call/cc
+                  (lambda (k)
+                    (fluid-let ([*k* k]) (f $stack-depth $base-value))))))
+            (unlock-object
+              (foreign-callable-code-object
+                (ftype-pointer-address fptr)))
+            *m*))
+        (+ $stack-depth $base-value)))
+  (or (= (optimize-level) 3)
+      ; similarly, but with a ptr return value so the values error is signaled
+      ; by S_call_help rather than the foreign-procedure wrapper
+      (eqv?
+        ($with-exit-proc
+          (lambda (ignore)
+            (define *m*)
+            (define *k*)
+            (define-ftype foo (function (fixnum fixnum) ptr))
+            (define f
+              (lambda (n m)
+                (if (fx= n 0)
+                    (begin (set! *m* m) (values))
+                    (if (fx= (fxmodulo n 10) 0)
+                        (begin
+                          (set! *m*
+                            (call/cc
+                              (lambda (k)
+                                (fluid-let ([*k* k])
+                                  (g (fx- n 1) (fx+ m 1))))))
+                          (values))
+                        (g (fx- n 1) (fx+ m 1))))))
+            (define fptr (make-ftype-pointer foo f))
+            (define g (ftype-ref foo () fptr))
+            (with-exception-handler
+              (lambda (c) (*k* *m*))
+              (lambda ()
+                (call/cc
+                  (lambda (k)
+                    (fluid-let ([*k* k]) (f $stack-depth $base-value))))))
+            (unlock-object
+              (foreign-callable-code-object
+                (ftype-pointer-address fptr)))
+            *m*))
+        (+ $stack-depth $base-value)))
+  (or (= (optimize-level) 3)
+      ; make sure we can jump out a few frames at a time, returning from
+      ; each with an fasl-reading error, just for fun
+      (eqv?
+        (let ()
+          (define *m*)
+          (define *k*)
+          (define ip (open-file-input-port (format "~a/mat.ss" *mats-dir*)))
+          (define-ftype foo (function (fixnum fixnum) fixnum))
+          (define f
+            (lambda (n m)
+              (if (fx= n 0)
+                  (begin (set! *m* m) (fasl-read ip))
+                  (if (fx= (fxmodulo n 10) 0)
+                      (begin
+                        (set! *m*
+                          (call/cc
+                            (lambda (k)
+                              (fluid-let ([*k* k])
+                                (g (fx- n 1) (fx+ m 1))))))
+                        (fasl-read ip))
+                      (g (fx- n 1) (fx+ m 1))))))
+          (define fptr (make-ftype-pointer foo f))
+          (define g (ftype-ref foo () fptr))
+          ; position "fasl" file at eof to make sure fasl-read isn't tripped up
+          ; by something that appears almost valid
+          (get-bytevector-all ip)
+          (with-exception-handler
+            (lambda (c) (*k* *m*))
+            (lambda ()
+              ($with-exit-proc
+                (lambda (k)
+                  (fluid-let ([*k* k]) (f $stack-depth $base-value))))))
+          (unlock-object
+            (foreign-callable-code-object
+              (ftype-pointer-address fptr)))
+          *m*)
+        (+ $stack-depth $base-value)))
+  ;; Make sure that a callable is suitably locked, and that it's
+  ;; unlocked when the C stack is popped by an escape
+  (equal?
+    (let ()
+      (define Sinvoke2
+        (foreign-procedure "Sinvoke2"
+          (scheme-object scheme-object iptr)
+          scheme-object))
+      (define Fcons
+        (foreign-callable
+          (lambda (k y)
+            ;; Escape with locked, which should be #t
+            ;; because a callable is locked while it's
+            ;; called:
+            (k (locked-object? Fcons)))
+          (scheme-object iptr)
+          scheme-object))
+      (list
+       ;; Call and normal callable return:
+       (let ([v (Sinvoke2 Fcons (lambda (x) x) 5)])
+         (list v (locked-object? Fcons)))
+       ;; Escape from callable:
+       (let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))])
+         (list v (locked-object? Fcons)))))
+    '((#t #f) (#t #f)))
+
+  ;; Make sure the code pointer for a call into a
+  ;; foreign procedure is correctly saved for locking
+  ;; when entering a callback as a callable:
+  (equal?
+   (let ()
+     (define v 0)
+     (define call_many_times (foreign-procedure "call_many_times" (void*) void))
+     (define work
+       (lambda (n)
+         ;; This loop needs to be non-allocating, but
+         ;; causes varying numbers of ticks
+         ;; to be used up.
+         (let loop ([n (bitwise-and n #xFFFF)])
+           (unless (zero? n)
+             (set! v (add1 v))
+             (loop (bitwise-arithmetic-shift-right n 1))))))
+     (define handler (foreign-callable work (long) void))
+     (lock-object handler)
+     (call_many_times (foreign-callable-entry-point handler))
+     (unlock-object handler)
+     v)
+   14995143)
+
+  (equal?
+   (let ()
+     (define v 0)
+     (define call_many_times_bv (foreign-procedure "call_many_times_bv" (void*) void))
+     (define work
+       (lambda (bv)
+         (set! v (+ v (bytevector-u8-ref bv 0)))
+         ;; Varying work, as above:
+         (let loop ([n (bitwise-and (bytevector-u8-ref bv 1) #xFFFF)])
+           (unless (zero? n)
+             (set! v (add1 v))
+             (loop (bitwise-arithmetic-shift-right n 1))))))
+     (define handlers (list (foreign-callable work (u8*) void)
+                            (foreign-callable work (u16*) void)
+                            (foreign-callable work (u32*) void)))
+     (map lock-object handlers)
+     (for-each (lambda (handler)
+                 (call_many_times_bv (foreign-callable-entry-point handler)))
+               handlers)
+     (map unlock-object handlers)
+     v)
+   103500000)
+
+  ;; regression test related to saving registers that hold allocated
+  ;; callable argument
+  (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)]
+         [result #f]
+         [cb (foreign-callable
+              (lambda (i s1 s2 s3 s4 i2 s6 s7 i3)
+                (set! result
+                      (and (eqv? i 0)
+                           (equal? (string->utf8 "this") s1)
+                           (equal? (string->utf8 "is") s2)
+                           (equal? (string->utf8 "working") s3)
+                           (equal? (string->utf8 "just") s4)
+                           (eqv? i2 1)
+                           (equal? (string->utf8 "fine") s6)
+                           (equal? (string->utf8 "or does it?") s7)
+                           (eqv? i3 2))))
+              (int u8* u8* u8* u8* int u8* u8* int)
+              void)])
+    (lock-object cb)
+    (call-with-many-args (foreign-callable-entry-point cb))
+    (unlock-object cb)
+    result)
+
+)
+
+(machine-case
+  [(i3nt ti3nt)
+   (mat i3nt-stdcall-foreign-callable
+     (equal?
+       (let ()
+         (define Sinvoke2
+           (foreign-procedure "Sinvoke2_stdcall"
+             (scheme-object scheme-object iptr)
+             scheme-object))
+         (define Fcons
+           (foreign-callable __stdcall
+             (lambda (x y)
+               (collect)
+               (let ([ls (make-list 20000 #\z)])
+                 (collect)
+                 (collect)
+                 (collect)
+                 (collect)
+                 (collect)
+                 (cons (length ls) (cons x y))))
+             (scheme-object iptr)
+             scheme-object))
+         (define (go) (Sinvoke2 Fcons 4 5))
+         (go))
+       '(20000 4 . 5))
+     (eqv?
+       (let ()
+         (define Sinvoke2
+           (foreign-procedure "Sinvoke2_stdcall"
+             (scheme-object scheme-object iptr)
+             scheme-object))
+         (define fxFsum
+           (foreign-callable __stdcall
+             (lambda (x y)
+               (if (fx= x 0)
+                   y
+                   (fx+ x (Sinvoke2 fxFsum (fx- x 1) y))))
+             (scheme-object iptr)
+             scheme-object))
+         (define (fxgosum n) (Sinvoke2 fxFsum n 0))
+         (fxgosum 20))
+       210)
+     (eqv?
+       (let ()
+         (define Sinvoke2
+           (foreign-procedure "Sinvoke2_stdcall"
+             (scheme-object scheme-object iptr)
+             scheme-object))
+         (define Fsum
+           (foreign-callable __stdcall
+             (lambda (x y)
+               (if (= x 0)
+                   y
+                   (+ x (Sinvoke2 Fsum (- x 1) y))))
+             (scheme-object iptr)
+             scheme-object))
+         (define (gosum n) (Sinvoke2 Fsum n (most-positive-fixnum)))
+         (gosum 20))
+       536871121))
+   (mat i3nt-com
+     (eqv?
+       (let ()
+         (define com-instance ((foreign-procedure "get_com_instance" () iptr)))
+         ((foreign-procedure __com 0 (iptr int) int) com-instance 3)
+         ((foreign-procedure __com 4 (iptr int) int) com-instance 17))
+       37))])
+
+(mat die-gracefully-without-stderr
+  (let-values ([(to-stdin from-stdout from-stderr pid)
+                (open-process-ports (format "~a -q" (patch-exec-path *scheme*))
+                  (buffer-mode block)
+                  (native-transcoder))])
+    (fprintf to-stdin "(error #f \"oops 1\")\n")
+    (flush-output-port to-stdin)
+    (let ([s1 (get-line from-stderr)])
+      (close-port from-stderr)
+      (fprintf to-stdin "(error #f \"oops 2\")\n") ; this message should disappear
+      (flush-output-port to-stdin)
+      (fprintf to-stdin "(+ 17 44)\n")
+      (flush-output-port to-stdin)
+      (let ([s2 (get-line from-stdout)])
+        (fprintf to-stdin "(reset-handler abort)\n")
+        (fprintf to-stdin "(reset-handler)\n")
+        (flush-output-port to-stdin)
+        (let ([s3 (get-line from-stdout)])
+          (close-port from-stdout)
+          (fprintf to-stdin "'hello\n") ; should cause exception, then abort (via reset)
+          (flush-output-port to-stdin)
+          (let ([pid^ (machine-case
+                        [(i3nt ti3nt a6nt ta6nt) pid]
+                        [else ((foreign-procedure "waitpid" (int (* int) int) int) pid (make-ftype-pointer int 0) 0)])])
+            (and
+              (equal? s1 "Exception: oops 1")
+              (equal? s2 "61")
+              (equal? s3 "#")
+              (eqv? pid^ pid)))))))
+)
+
+;; varargs ABI not supported for arm32le (yet)
+(unless (memq (machine-type) '(arm32le tarm32le))
+  (mat varargs
+    (begin
+      (define load-libc
+        (machine-case
+          [(i3ob ti3ob a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx i3nb ti3nb a6nb ta6nb)
+           '(load-shared-object "libc.so")]
+          [(i3le ti3le a6le ta6le arm32le tarm32le ppc32le tppc32le)
+           '(load-shared-object "libc.so.6")]
+          [(i3fb ti3fb a6fb ta6fb)
+           '(load-shared-object "libc.so.7")]
+          [(i3nt ti3nt a6nt ta6nt)
+           '(load-shared-object "msvcrt.dll")]
+          [(i3osx ti3osx a6osx ta6osx)
+           '(load-shared-object "libc.dylib")]
+          [else (error 'load-libc "unrecognized machine type ~s" (machine-type))]))
+      #t)
+    (equal?
+      (with-input-from-string
+        (separate-eval
+          `(begin
+             ,load-libc
+             (define f (foreign-procedure "printf" (string double) int))
+             (f "(%g)" 3.5)
+             (void)))
+        read)
+      '(3.5))
+    (equal?
+      (with-input-from-string
+        (separate-eval
+          `(begin
+             ,load-libc
+             (define f (foreign-procedure "printf" (string double double double double double double) int))
+             (f "(%g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5)
+             (void)))
+        read)
+      '(3.5 2.5 -1.5 6.75 8.25 -9.5))
+    (equal?
+      (with-input-from-string
+        (separate-eval
+          `(begin
+             ,load-libc
+             (define f (foreign-procedure "printf" (string double double double double double double double double) int))
+             (f "(%g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5)
+             (void)))
+        read)
+      '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5))
+    (equal?
+      (with-input-from-string
+        (separate-eval
+          `(begin
+             ,load-libc
+             (define f (foreign-procedure "printf" (string double double double double double double double double double double) int))
+             (f "(%g %g %g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5)
+             (void)))
+        read)
+      '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5))))
+
+(mat structs
+  (begin
+    (define-ftype i8 integer-8)
+    (define-ftype u8 unsigned-8)
+    (define-ftype u16 unsigned-16)
+    (define-ftype i64 integer-64)
+    (define-syntax check*
+      (syntax-rules ()
+        [(_ (conv ...) T s [vi ...] [T-ref ...] [T-set! ...])
+         (let ()
+           (define-ftype callback (function conv ... ((& T)) double))
+           (define-ftype callback-two (function conv ... ((& T) (& T)) double))
+           (define-ftype pre-int-callback (function conv ... (int (& T)) double))
+           (define-ftype pre-double-callback (function conv ... (double (& T)) double))
+           (define-ftype callback-r (function conv ... () (& T)))
+           (define get (foreign-procedure conv ... (format "f4_get~a" s)
+                                          () (& T)))
+           (define sum (foreign-procedure conv ... (format "f4_sum~a" s)
+                                          ((& T)) double))
+           (define sum_two (foreign-procedure conv ... (format "f4_sum_two~a" s)
+                                              ((& T) (& T)) double))
+           (define sum_pre_int (foreign-procedure conv ... (format "f4_sum_pre_int~a" s)
+                                                  (int (& T)) double))
+           (define sum_pre_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int~a" s)
+                                                      (int int (& T)) double))
+           (define sum_pre_int_int_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int_int_int~a" s)
+                                                              (int int int int (& T)) double))
+           (define sum_pre_int_int_int_int_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int_int_int_int_int~a" s)
+                                                                      (int int int int int int (& T)) double))
+           (define sum_post_int (foreign-procedure conv ... (format "f4_sum~a_post_int" s)
+                                                   ((& T) int) double))
+           (define sum_pre_double (foreign-procedure conv ... (format "f4_sum_pre_double~a" s)
+                                                     (double (& T)) double))
+           (define sum_pre_double_double (foreign-procedure conv ... (format "f4_sum_pre_double_double~a" s)
+                                                            (double double (& T)) double))
+           (define sum_pre_double_double_double_double (foreign-procedure conv ... (format "f4_sum_pre_double_double_double_double~a" s)
+                                                                          (double double double double (& T)) double))
+           (define sum_pre_double_double_double_double_double_double_double_double
+             (foreign-procedure conv ... (format "f4_sum_pre_double_double_double_double_double_double_double_double~a" s)
+                                (double double double double double double double double (& T)) double))
+           (define sum_post_double (foreign-procedure conv ... (format "f4_sum~a_post_double" s)
+                                                      ((& T) double) double))
+           (define cb_send (foreign-procedure conv ... (format "f4_cb_send~a" s)
+                                              ((* callback)) double))
+           (define cb_send_two (foreign-procedure conv ... (format "f4_cb_send_two~a" s)
+                                                  ((* callback-two)) double))
+           (define cb_send_pre_int (foreign-procedure conv ... (format "f4_cb_send_pre_int~a" s)
+                                                      ((* pre-int-callback)) double))
+           (define cb_send_pre_double (foreign-procedure conv ... (format "f4_cb_send_pre_double~a" s)
+                                                         ((* pre-double-callback)) double))
+           (define sum_cb (foreign-procedure conv ... (format "f4_sum_cb~a" s)
+                                             ((* callback-r)) double))
+           (define-syntax with-callback
+             (syntax-rules ()
+               [(_ ([id rhs])
+                   body)
+                (let ([id rhs])
+                  (let ([v body])
+                    (unlock-object
+                     (foreign-callable-code-object
+                      (ftype-pointer-address id)))
+                    v))]))
+           (and (let ([v (make-ftype-pointer T (malloc_at_boundary (ftype-sizeof T)))])
+                  (get v)
+                  (and (= (T-ref v) vi)
+                       ...
+                       (begin
+                         (free_at_boundary (ftype-pointer-address v))
+                         #t)))
+                (let ([a (make-ftype-pointer T (malloc_at_boundary (ftype-sizeof T)))])
+                  (T-set! a) ...
+                  (and (= (+ vi ...) (sum a))
+                       (= (+ vi ... vi ...) (sum_two a a))
+                       (= (+ 8 vi ...) (sum_pre_int 8 a))
+                       (= (+ 8 9 vi ...) (sum_pre_int_int 8 9 a))
+                       (= (+ 8 9 10 11 vi ...) (sum_pre_int_int_int_int 8 9 10 11 a))
+                       (= (+ 8 9 10 11 12 13 vi ...) (sum_pre_int_int_int_int_int_int 8 9 10 11 12 13 a))
+                       (= (+ 8 vi ...) (sum_post_int a 8))
+                       (= (+ 8.25 vi ...) (sum_pre_double 8.25 a))
+                       (= (+ 8.25 9.25 vi ...) (sum_pre_double_double 8.25 9.25 a))
+                       (= (+ 8.25 9.25 10.25 11.25 vi ...) (sum_pre_double_double_double_double 8.25 9.25 10.25 11.25 a))
+                       (= (+ 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 vi ...)
+                          (sum_pre_double_double_double_double_double_double_double_double
+                           8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 a))
+                       (= (+ 8.25 vi ...) (sum_post_double a 8.25))
+                       (= (+ 1.0 vi ...) (with-callback ([cb (make-ftype-pointer
+                                                              callback
+                                                              (lambda (r)
+                                                                (exact->inexact (+ (T-ref r) ...))))])
+                                           (cb_send cb)))
+                       (= (+ 1.0 vi ... vi ...) (with-callback ([cb (make-ftype-pointer
+                                                                     callback-two
+                                                                     (lambda (r1 r2)
+                                                                       (exact->inexact (+ (T-ref r1) ...
+                                                                                          (T-ref r2) ...))))])
+                                                  (cb_send_two cb)))
+                       (= (+ 1.0 8 vi ...) (with-callback ([cb (make-ftype-pointer
+                                                                pre-int-callback
+                                                                (lambda (v r)
+                                                                  (exact->inexact (+ v (T-ref r) ...))))])
+                                             (cb_send_pre_int cb)))
+                       (= (+ 1.0 8.25 vi ...) (with-callback ([cb (make-ftype-pointer
+                                                                   pre-double-callback
+                                                                   (lambda (v r)
+                                                                     (exact->inexact (+ v (T-ref r) ...))))])
+                                                (cb_send_pre_double cb)))
+                       (= (+ vi ...) (with-callback ([cb (make-ftype-pointer
+                                                          callback-r
+                                                          (lambda (r)
+                                                            (T-set! r) ...))])
+                                       (sum_cb cb)))
+                       (begin
+                         (free_at_boundary (ftype-pointer-address a))
+                         #t)))))]))
+    (define-syntax check*t
+      (syntax-rules ()
+        [(_ arg ...)
+         (and (check* () arg ...)
+              (check* (__collect_safe) arg ...))]))
+    (define-syntax check-n
+      (syntax-rules ()
+        [(_ [ni ti vi] ...)
+         (let ()
+           (define-ftype T (struct [ni ti] ...))
+           (define s (apply string-append
+                            "_struct"
+                            (let loop ([l '(ti ...)])
+                              (cond
+                               [(null? l) '()]
+                               [else (cons (format "_~a" (car l))
+                                           (loop (cdr l)))]))))
+           (check*t T s
+                    [vi ...]
+                    [(lambda (a) (ftype-ref T (ni) a)) ...]
+                    [(lambda (a) (ftype-set! T (ni) a vi)) ...]))]))
+    (define-syntax check
+      (syntax-rules ()
+        [(_ t1 v1)
+         (check*t t1 (format "_~a" 't1)
+                  [v1]
+                  [(lambda (a) (ftype-ref t1 () a))]
+                  [(lambda (a) (ftype-set! t1 () a v1))])]))
+    (define-syntax check-union
+      (syntax-rules ()
+        [(_ [n0 t0 v0] [ni ti vi] ...)
+         (let ()
+           (define-ftype T (union [n0 t0] [ni ti] ...))
+           (define s (apply string-append
+                            "_union"
+                            (let loop ([l '(t0 ti ...)])
+                              (cond
+                               [(null? l) '()]
+                               [else (cons (format "_~a" (car l))
+                                           (loop (cdr l)))]))))
+           (check*t T s
+                    [v0]
+                    [(lambda (a) (ftype-ref T (n0) a))]
+                    [(lambda (a) (ftype-set! T (n0) a v0))]))]))
+    (define-syntax check-1
+      (syntax-rules ()
+        [(_ t1 v1)
+         (check-n [x t1 v1])]))
+    (define-syntax check-2
+      (syntax-rules ()
+        [(_ t1 t2 v1 v2)
+         (check-n [x t1 v1] [y t2 v2])]))
+    (define-syntax check-2-set
+      (syntax-rules ()
+        [(_ t x)
+         (and
+          (check-2 t i8 (+ 1 x) 10)
+          (check-2 t short (+ 2 x) 20)
+          (check-2 t long (+ 3 x) 30)
+          (check-2 t i64 (+ 5 x) 50)
+          (check-2 short t 6 (+ 60 x))
+          (check-2 long t 7 (+ 70 x))
+          (check-2 i64 t 9 (+ 90 x))
+          (check-2 i8 t 10 (+ 100 x)))]))
+    (define-syntax check-3
+      (syntax-rules ()
+        [(_ t1 t2 t3 v1 v2 v3)
+         (check-n [x t1 v1] [y t2 v2] [z t3 v3])]))
+    (define-syntax check-3-set
+      (syntax-rules ()
+        [(_ t x)
+         (and
+          (check-3 t i8 int (+ 1 x) 10 100)
+          (check-3 t short int (+ 2 x) 20 200)
+          (check-3 t long int (+ 3 x) 30 300)
+          (check-3 t i64 int (+ 5 x) 50 500)
+          (check-3 short t int 6 (+ 60 x) 600)
+          (check-3 long t int 7 (+ 70 x) 700)
+          (check-3 i64 t int 9 (+ 90 x) 900)
+          (check-3 i8 t int 10 (+ 100 x) 1000))]))
+    (define malloc_at_boundary (foreign-procedure "malloc_at_boundary"
+                                                  (int) uptr))
+    (define free_at_boundary (foreign-procedure "free_at_boundary"
+                                                (uptr) void))
+    #t)
+  (check i8 -11)
+  (check u8 129)
+  (check short -22)
+  (check u16 33022)
+  (check long 33)
+  (check int 44)
+  (check i64 49)
+  (check float 55.0)
+  (check double 66.0)
+  (check-1 i8 -12)
+  (check-1 u8 212)
+  (check-1 short -23)
+  (check-1 u16 33023)
+  (check-1 long 34)
+  (check-1 int 45)
+  (check-1 i64 48)
+  (check-1 float 56.0)
+  (check-1 double 67.0)
+  (check-2-set int 0)
+  (check-2-set float 0.5)
+  (check-2-set double 0.25)
+  (check-2 int int 4 40)
+  (check-2 float float 4.5 40.5)
+  (check-2 double double 4.25 40.25)
+  (check-3-set int 0)
+  (check-3-set float 0.5)
+  (check-3-set double 0.25)
+  (check-3 i8 i8 i8 4 38 127)
+  (check-3 short short short 4 39 399)
+  (check-3 int int int 4 40 400)
+  (check-3 float float float 4.5 40.5 400.5)
+  (check-3 double double double 4.25 40.25 400.25)
+  (check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5])
+  (check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5] [r i8 6] [s i8 7])
+  (check-union [x i8 -17])
+  (check-union [x u8 217])
+  (check-union [x short -27])
+  (check-union [x u16 33027])
+  (check-union [x long 37])
+  (check-union [x int 47])
+  (check-union [x i64 49])
+  (check-union [x float 57.0])
+  (check-union [x double 77.0])
+  (check-union [x i8 18] [y int 0])
+  (check-union [x short 28] [y int 0])
+  (check-union [x long 38] [y int 0])
+  (check-union [x int 48] [y int 0])
+  (check-union [x i64 43] [y int 0])
+  (check-union [x float 58.0] [y int 0])
+  (check-union [x double 68.0] [y int 0])
+
+  ;; Check that `__collect_safe` saves argument and result floating-point registers
+  ;; while activating and deactivating a thread
+  (let ()
+    (define-ftype T (struct [d double] [i integer-8] [n int]))
+    (define sum_pre_double_double_double_double_double_double_double_double
+      (foreign-procedure __collect_safe
+                         "f4_sum_pre_double_double_double_double_double_double_double_double_struct_double_i8_int"
+                         (double double double double double double double double (& T))
+                         double))
+    (let* ([p (foreign-alloc (ftype-sizeof T))]
+           [a (make-ftype-pointer T p)])
+      (ftype-set! T (d) a 1.25)
+      (ftype-set! T (i) a 10)
+      (ftype-set! T (n) a 100)
+      (let loop ([i 1000000])
+        (cond
+         [(zero? i) (foreign-free p) #t]
+         [else
+          (let ([v (sum_pre_double_double_double_double_double_double_double_double 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 a)])
+            (and (= 205.25 v)
+                 (loop (sub1 i))))]))))
+  (let ()
+    (define-ftype T (struct [d double] [i integer-8] [n int]))
+    (define-ftype callback (function __collect_safe ((& T)) double))
+    (define cb_send (foreign-procedure __collect_safe
+                                       "f4_cb_send_struct_double_i8_int"
+                                       ((* callback)) double))
+    (let ([cb (make-ftype-pointer
+               callback
+               (lambda (r)
+                 (+ (ftype-ref T (d) r)
+                    (ftype-ref T (i) r)
+                    (ftype-ref T (n) r))))])
+      (let loop ([i 1000000])
+        (cond
+         [(zero? i)
+          (unlock-object
+           (foreign-callable-code-object
+            (ftype-pointer-address cb)))
+          #t]
+         [else
+          (let ([v (cb_send cb)])
+            (and (= v 112.25)
+                 (loop (sub1 i))))]))))
+  )
+
+(mat collect-safe
+  (error? (foreign-procedure __collect_safe "unknown" (utf-8) void))
+  (error? (foreign-procedure __collect_safe "unknown" (utf-16be) void))
+  (error? (foreign-procedure __collect_safe "unknown" (utf-16le) void))
+  (error? (foreign-procedure __collect_safe "unknown" (utf-32be) void))
+  (error? (foreign-procedure __collect_safe "unknown" (utf-32le) void))
+  (error? (foreign-procedure __collect_safe "unknown" (string) void))
+  (error? (foreign-procedure __collect_safe "unknown" (wstring) void))
+  (error? (foreign-callable __collect_safe (lambda () #f) () utf-8))
+  (error? (foreign-callable __collect_safe (lambda () #f) () utf-16le))
+  (error? (foreign-callable __collect_safe (lambda () #f) () utf-16be))
+  (error? (foreign-callable __collect_safe (lambda () #f) () utf-32le))
+  (error? (foreign-callable __collect_safe (lambda () #f) () utf-32be))
+  (error? (foreign-callable __collect_safe (lambda () #f) () string))
+  (error? (foreign-callable __collect_safe (lambda () #f) () wstring))
+  (begin
+    (define-ftype thread-callback-T (function __collect_safe (double) double))
+    (define (call-with-thread-callback cb-proc proc)
+      (let* ([exception #f]
+             [callback (make-ftype-pointer thread-callback-T
+                         (lambda (arg)
+                           ;; Don't let an exception reset this tread.
+                           (guard [c (else (set! exception c) 0.0)]
+                             (cb-proc arg))))]
+             [r (proc callback)])
+        (unlock-object
+         (foreign-callable-code-object
+          (ftype-pointer-address callback)))
+        (when exception (raise exception))
+        r))
+    (define (call-in-unknown-thread-1 proc arg n-times)
+      ;; Baseline implementation that uses the current thread
+      (let loop ([i 0] [arg arg])
+        (cond
+         [(= i n-times) arg]
+         [else (loop (fx+ i 1) (proc arg))])))
+    (define call-in-unknown-thread-2
+      ;; Call in the current thread, but through the foreign procedure
+      (if (and (threaded?)
+               (foreign-entry? "call_in_unknown_thread"))
+          (let ([call (foreign-procedure "call_in_unknown_thread"
+                                         ((* thread-callback-T) double int boolean boolean)
+                                         double)])
+            (lambda (proc arg n-times)
+              (call-with-thread-callback
+               proc
+               (lambda (callback) (call callback arg n-times #f #t)))))
+          call-in-unknown-thread-1))
+    (define call-in-unknown-thread-3
+      ;; Call in a truly unknown thread:
+      (if (and (threaded?)
+               (foreign-entry? "call_in_unknown_thread"))
+          (let ([call (foreign-procedure "call_in_unknown_thread"
+                                         ((* thread-callback-T) double int boolean boolean)
+                                         double)])
+            (lambda (proc arg n-times)
+              (call-with-thread-callback
+               proc
+               (lambda (callback) (call callback arg n-times #t #t)))))
+          call-in-unknown-thread-1))
+    (define call-in-unknown-thread-4
+      ;; In an truly unknown thread, but also using `__collect_safe` to
+      ;; deactivate the current thread instead of using `Sdeactivate_thread`
+      ;; within the foreign function:
+      (if (and (threaded?)
+               (foreign-entry? "call_in_unknown_thread"))
+          (let ([call (foreign-procedure __collect_safe "call_in_unknown_thread"
+                                         ((* thread-callback-T) double int boolean boolean)
+                                         double)])
+            (lambda (proc arg n-times)
+              (call-with-thread-callback
+               proc
+               (lambda (callback) (call callback arg n-times #t #f)))))
+          call-in-unknown-thread-1))
+    #t)
+  ;; These tests will pass only if `collect` can run, where `collect`
+  ;; can run only if a single thread is active
+  (equal? (call-in-unknown-thread-1 (lambda (n) (collect 0) (+ n 1.0)) 3.5 1)
+          4.5)
+  (equal? (call-in-unknown-thread-2 (lambda (n) (collect 0) (+ n 1.0)) 3.5 2)
+          5.5)
+  (equal? (call-in-unknown-thread-3 (lambda (n) (collect 0) (+ n 1.0)) 3.5 3)
+          6.5)
+  (equal? (call-in-unknown-thread-4 (lambda (n) (collect 0) (+ n 1.0)) 3.5 4)
+          7.5)
+  (equal? (let loop ([n 10.0])
+            (call-in-unknown-thread-4
+             (lambda (n)
+               (cond
+                [(zero? n) (collect) 0.5]
+                [else (+ 1.0 (loop (- n 1.0)))]))
+             n
+             1))
+          10.5)
+  ;; Try to crash a `__collect_safe` foreign-procedure call by moving the
+  ;; return address out from under the foreign procedure. This attempt
+  ;; should fail, because deactivating a thread first locks the
+  ;; current code object.
+  (or (not (threaded?))
+      (let ([m (make-mutex)]
+            [exception #f]
+            [done? #f]
+            [ok? #t])
+        (fork-thread (lambda ()
+                       ;; Don't let an exception reset this thread.
+                       (guard [c (else (set! exception c))]
+                         (let loop ([i 10])
+                           (unless (zero? i)
+                             (let ([spin (eval '(foreign-procedure __collect_safe "spin_a_while" (int unsigned unsigned) unsigned))])
+                               (spin 100000000 0 1))
+                             (loop (sub1 i)))))
+                       (mutex-acquire m)
+                       (set! done? #t)
+                       (mutex-release m)))
+        (let loop ()
+          (mutex-acquire m)
+          (let ([done? done?])
+            (mutex-release m)
+            (unless done?
+              (let loop ([i 10])
+                (unless (zero? i)
+                  (eval '(foreign-procedure "spin_a_while" () void))
+                  (loop (sub1 i))))
+              (loop))))
+        (when exception (raise exception))
+        ok?))
+)
+
+(machine-case
+  [(i3nt ti3nt)
+   (mat i3nt-stdcall-collect-safe
+     (equal?
+       (let ()
+         (define sum (foreign-procedure __collect_safe __stdcall "_sum_stdcall@8" (int int) int))
+	 (sum 3 7))
+        10)
+     (equal?
+      (let ()
+        (define Sinvoke2
+          (foreign-procedure __collect_safe "Sinvoke2_stdcall"
+            (scheme-object scheme-object iptr)
+            scheme-object))
+        (define Fcons
+          (foreign-callable __collect_safe __stdcall
+            (lambda (x y) (cons x y))
+            (scheme-object iptr)
+            scheme-object))
+        (Sinvoke2 Fcons 41 51))
+      '(41 . 51)))
+    (mat i3nt-com-thread
+     (eqv?
+       (let ()
+         (define com-instance ((foreign-procedure "get_com_instance" () iptr)))
+         ((foreign-procedure __collect_safe __com 0 (iptr int) int) com-instance 3)
+         ((foreign-procedure __collect_safe __com 4 (iptr int) int) com-instance 17))
+       37))])
diff --git a/mats/foreign1.c b/mats/foreign1.c
new file mode 100644
index 0000000..c4ac079
--- /dev/null
+++ b/mats/foreign1.c
@@ -0,0 +1,72 @@
+/* foreign1.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#ifdef _WIN32
+#  define SCHEME_IMPORT
+#  include "scheme.h"
+#  undef EXPORT
+#  define EXPORT extern __declspec (dllexport)
+#else
+#include "scheme.h"
+#endif
+
+EXPORT int id(int x) {
+   return x;
+}
+
+EXPORT int idid(int x) {
+    return id(id(x));
+}
+
+EXPORT int ididid(int x) {
+    return idid(id(x));
+}
+
+EXPORT unsigned int iduns(unsigned int x) {
+   return x;
+}
+
+EXPORT iptr idiptr(iptr x) {
+   return x;
+}
+
+EXPORT iptr idiptr_addr(void) {
+   return (iptr)&idiptr;
+}
+
+EXPORT double float_id(double x) {
+   return x;
+}
+
+#ifdef _WIN32
+#include 
+
+EXPORT int windows_strcpy(char *dst, char *src) {
+  return strcpy(dst, src);
+}
+
+EXPORT int windows_strcmp(char *dst, char *src) {
+  return strcmp(dst, src);
+}
+
+EXPORT void *windows_malloc(long n) {
+  return malloc(n);
+}
+
+EXPORT void windows_free(void *x) {
+  free(x);
+}
+#endif
diff --git a/mats/foreign2.c b/mats/foreign2.c
new file mode 100644
index 0000000..872a1a4
--- /dev/null
+++ b/mats/foreign2.c
@@ -0,0 +1,464 @@
+/* foreign2.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include 
+#include 
+
+#ifdef _WIN32
+#  define SCHEME_IMPORT
+#  include "scheme.h"
+#  undef EXPORT
+#  define EXPORT extern __declspec (dllexport)
+#else
+#include "scheme.h"
+#endif
+
+EXPORT int testten(int x0,int x1,int x2,int x3,int x4,int x5,int x6,int x7,int x8,int x9) {
+   return  1 * x0 +
+           2 * x1 +
+           3 * x2 +
+           5 * x3 +
+           7 * x4 +
+          11 * x5 +
+          13 * x6 +
+          17 * x7 +
+          19 * x8 +
+          23 * x9;
+}
+
+EXPORT double flsum8(double x1,double x2,double x3,double x4,double x5,double x6,double x7,double x8) {
+    return (x1+x2+x3+x4+x5+x6+x7+x8);
+}
+
+EXPORT double sparcfltest(int x1,int x2,int x3,int x4,int x5,double x6,int x7,double x8) {
+    return (x1+x2+x3+x4+x5+x6+x7+x8);
+}
+
+EXPORT double mipsfltest1(int x1,int x2,double x3) {
+    return (x1+x2+x3);
+}
+
+EXPORT double mipsfltest2(int x1,double x2,double x3) {
+    return (x1+x2+x3);
+}
+
+EXPORT double ppcfltest(int x1,double x2,int x3,double x4,int x5,double x6,int x7,double x8,double x9,double x10,double x11,double x12,double x13,double x14,double x15,double x16,double x17,double x18,double x19) {
+    return x1+x2+x3+x4+x5+x6+x7+x8+x9+x10+x11+x12+x13+x14+x15+x16+x17+x18+x19;
+}
+
+EXPORT double ppcfltest2(int x1, double x2, int x3, double x4, int x5, long long x5_5, double x6, int x7, double x8, long long x8_5, int x8_75, double x9, double x10, double x11, double x12, double x13, float x14, double x15, int x15_5, double x16, int x16_5, long long x17, double x18, int x18_5, double x19) {
+    return x1+x2+x3+x4+x5+x6+x7+x8+x9+x10+x11+x12+x13+x14+x15+x16+x17+x18+x19 + x5_5 + x8_5 + x8_75 + x15_5 + x16_5 + x18_5;
+}
+
+typedef char i8;
+typedef unsigned char u8;
+typedef short i16;
+typedef unsigned short u16;
+typedef int i32;
+typedef unsigned int u32;
+#ifdef _WIN32
+typedef __int64 i64;
+typedef unsigned __int64 u64;
+typedef __int64 LONGLONG;
+typedef unsigned __int64 UNSIGNED_LONGLONG;
+#else
+typedef long long i64;
+typedef unsigned long long u64;
+typedef long long LONGLONG;
+typedef unsigned long long UNSIGNED_LONGLONG;
+#endif
+typedef float single_float;
+typedef double double_float;
+
+EXPORT int check_types(int Bchar, int Bwchar, int Bshort, int Bint, int Blong, int Blonglong, int Bfloat, int Bdouble, int Bvoid_star) {
+  int succ = 1;
+  if (sizeof(i8) != 1) {
+    fprintf(stderr,"sizeof(i8) [%ld] != 1\n", (long)sizeof(i8));
+    succ = 0;
+  }
+  if (sizeof(u8) != 1) {
+    fprintf(stderr,"sizeof(u8) [%ld] != 1\n", (long)sizeof(u8));
+    succ = 0;
+  }
+  if (sizeof(i16) != 2) {
+    fprintf(stderr,"sizeof(i16) [%ld] != 2\n", (long)sizeof(i16));
+    succ = 0;
+  }
+  if (sizeof(u16) != 2) {
+    fprintf(stderr,"sizeof(u16) [%ld] != 2\n", (long)sizeof(u16));
+    succ = 0;
+  }
+  if (sizeof(i32) != 4) {
+    fprintf(stderr,"sizeof(i32) [%ld] != 4\n", (long)sizeof(i32));
+    succ = 0;
+  }
+  if (sizeof(u32) != 4) {
+    fprintf(stderr,"sizeof(u32) [%ld] != 4\n", (long)sizeof(u32));
+    succ = 0;
+  }
+  if (sizeof(i64) != 8) {
+    fprintf(stderr,"sizeof(i64) [%ld] != 8\n", (long)sizeof(i64));
+    succ = 0;
+  }
+  if (sizeof(u64) != 8) {
+    fprintf(stderr,"sizeof(u64) [%ld] != 8\n", (long)sizeof(u64));
+    succ = 0;
+  }
+  if (sizeof(single_float) != 4) {
+    fprintf(stderr,"sizeof(single_float) [%ld] != 4\n", (long)sizeof(single_float));
+    succ = 0;
+  }
+  if (sizeof(double_float) != 8) {
+    fprintf(stderr,"sizeof(double_float) [%ld] != 8\n", (long)sizeof(double_float));
+    succ = 0;
+  }
+  if (sizeof(char) != Bchar) {
+    fprintf(stderr,"sizeof(char) [%ld] != %ld\n", (long)sizeof(char), (long)Bchar);
+    succ = 0;
+  }
+  if (sizeof(wchar_t) != Bwchar) {
+    fprintf(stderr,"sizeof(wchar_t) [%ld] != %ld\n", (long)sizeof(wchar_t), (long)Bwchar);
+    succ = 0;
+  }
+  if (sizeof(short) != Bshort) {
+    fprintf(stderr,"sizeof(short) [%ld] != %ld\n", (long)sizeof(short), (long)Bshort);
+    succ = 0;
+  }
+  if (sizeof(int) != Bint) {
+    fprintf(stderr,"sizeof(int) [%ld] != %ld\n", (long)sizeof(int), (long)Bint);
+    succ = 0;
+  }
+  if (sizeof(long) != Blong) {
+    fprintf(stderr,"sizeof(long) [%ld] != %ld\n", (long)sizeof(long), (long)Blong);
+    succ = 0;
+  }
+  if (sizeof(long long) != Blonglong) {
+    fprintf(stderr,"sizeof(long long) [%ld] != %ld\n", (long)sizeof(long long), (long)Blong);
+    succ = 0;
+  }
+  if (sizeof(float) != Bfloat) {
+    fprintf(stderr,"sizeof(float) [%ld] != %ld\n", (long)sizeof(float), (long)Bfloat);
+    succ = 0;
+  }
+  if (sizeof(double) != Bdouble) {
+    fprintf(stderr,"sizeof(double) [%ld] != %ld\n", (long)sizeof(double), (long)Bdouble);
+    succ = 0;
+  }
+  if (sizeof(void *) != Bvoid_star) {
+    fprintf(stderr,"sizeof(void *) [%ld] != %ld\n", (long)sizeof(void *), (long)Bvoid_star);
+    succ = 0;
+  }
+  return succ;
+}
+
+EXPORT i8 i8_to_i8(i8 x, int k) {
+  return x + k;
+}
+
+EXPORT u8 u8_to_u8(u8 x, int k) {
+  return x + k;
+}
+
+EXPORT i8 call_i8(ptr code, i8 x, int m, int k) {
+  return (*((i8 (*) (i8))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT u8 call_u8(ptr code, u8 x, int m, int k) {
+  return (*((u8 (*) (u8))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT i16 i16_to_i16(i16 x, int k) {
+  return x + k;
+}
+
+EXPORT u16 u16_to_u16(u16 x, int k) {
+  return x + k;
+}
+
+EXPORT i16 call_i16(ptr code, i16 x, int m, int k) {
+  return (*((i16 (*) (i16))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT u16 call_u16(ptr code, u16 x, int m, int k) {
+  return (*((u16 (*) (u16))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT i32 i32_to_i32(i32 x, int k) {
+  return x + k;
+}
+
+EXPORT u32 u32_to_u32(u32 x, int k) {
+  return x + k;
+}
+
+EXPORT i32 call_i32(ptr code, i32 x, int m, int k) {
+  return (*((i32 (*) (i32))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT u32 call_u32(ptr code, u32 x, int m, int k) {
+  return (*((u32 (*) (u32))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT i64 i64_to_i64(u64 x, int k) {
+  return x + k;
+}
+
+EXPORT u64 u64_to_u64(u64 x, int k) {
+  return x + k;
+}
+
+EXPORT i64 call_i64(ptr code, i64 x, int m, int k) {
+  return (*((i64 (*) (i64))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT u64 call_u64(ptr code, u64 x, int m, int k) {
+  return (*((u64 (*) (u64))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT single_float sf_to_sf(single_float x) {
+  return x + 1;
+}
+
+EXPORT single_float call_sf(ptr code, single_float x, int m, int k) {
+  return (*((single_float (*) (single_float))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT double_float df_to_df(double_float x) {
+  return x + 1;
+}
+
+EXPORT double_float call_df(ptr code, double_float x, int m, int k) {
+  return (*((double_float (*) (double_float))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT u8 *u8_star_to_u8_star(u8 *s) {
+  return s == (u8 *)0 ? (u8 *)0 : s + 1;
+}
+
+EXPORT u8 *call_u8_star(ptr code, u8 *s) {
+  return (*((u8 *(*) (u8 *))Sforeign_callable_entry_point(code)))(s + 1) + 1;
+}
+
+EXPORT u16 *u16_star_to_u16_star(u16 *s) {
+  return s == (u16 *)0 ? (u16 *)0 : s + 1;
+}
+
+EXPORT u16 *call_u16_star(ptr code, u16 *s) {
+  return (*((u16 *(*) (u16 *))Sforeign_callable_entry_point(code)))(s + 1) + 1;
+}
+
+EXPORT u32 *u32_star_to_u32_star(u32 *s) {
+  return s == (u32 *)0 ? (u32 *)0 : s + 1;
+}
+
+EXPORT u32 *call_u32_star(ptr code, u32 *s) {
+  return (*((u32 *(*) (u32 *))Sforeign_callable_entry_point(code)))(s + 1) + 1;
+}
+
+EXPORT char *char_star_to_char_star(char *s) {
+  return s == (char *)0 ? (char *)0 : s + 1;
+}
+
+EXPORT char *call_string(ptr code, char *s) {
+  return (*((char *(*) (char *))Sforeign_callable_entry_point(code)))(s + 1) + 1;
+}
+
+EXPORT wchar_t *wchar_star_to_wchar_star(wchar_t *s) {
+  return s == (wchar_t *)0 ? (wchar_t *)0 : s + 1;
+}
+
+EXPORT wchar_t *call_wstring(ptr code, wchar_t *s) {
+  return (*((wchar_t *(*) (wchar_t *))Sforeign_callable_entry_point(code)))(s + 1) + 1;
+}
+
+EXPORT char char_to_char(char x) {
+  return x - 0x20;
+}
+
+EXPORT char call_char(ptr code, char x, int m, int k) {
+  return (*((char (*) (char))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT wchar_t wchar_to_wchar(wchar_t x) {
+  return x - 0x20;
+}
+
+EXPORT wchar_t call_wchar(ptr code, wchar_t x, int m, int k) {
+  return (*((wchar_t (*) (wchar_t))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT short short_to_short(short x, int k) {
+  return x + k;
+}
+
+EXPORT unsigned short unsigned_short_to_unsigned_short(unsigned short x, int k) {
+  return x + k;
+}
+
+EXPORT short call_short(ptr code, short x, int m, int k) {
+  return (*((short (*) (short))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT unsigned short call_unsigned_short(ptr code, unsigned short x, int m, int k) {
+  return (*((unsigned short (*) (unsigned short))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT int int_to_int(int x, int k) {
+  return x + k;
+}
+
+EXPORT unsigned unsigned_to_unsigned(int x, int k) {
+  return x + k;
+}
+
+EXPORT int call_int(ptr code, int x, int m, int k) {
+  return (*((int (*) (int))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT unsigned call_unsigned(ptr code, unsigned x, int m, int k) {
+  return (*((unsigned (*) (unsigned))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT long long_to_long(long x, int k) {
+  return x + k;
+}
+
+EXPORT unsigned long unsigned_long_to_unsigned_long(unsigned long x, int k) {
+  return x + k;
+}
+
+EXPORT long call_long(ptr code, long x, int m, int k) {
+  return (*((long (*) (long))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT unsigned long call_unsigned_long(ptr code, unsigned long x, int m, int k) {
+  return (*((unsigned long (*) (unsigned long))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT LONGLONG long_long_to_long_long(LONGLONG x, int k) {
+  return x + k;
+}
+
+EXPORT UNSIGNED_LONGLONG unsigned_long_long_to_unsigned_long_long(UNSIGNED_LONGLONG x, int k) {
+  return x + k;
+}
+
+EXPORT LONGLONG call_long_long(ptr code, LONGLONG x, int m, int k) {
+  return (*((LONGLONG (*) (LONGLONG))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT UNSIGNED_LONGLONG call_unsigned_long_long(ptr code, UNSIGNED_LONGLONG x, int m, int k) {
+  return (*((UNSIGNED_LONGLONG (*) (UNSIGNED_LONGLONG))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT iptr iptr_to_iptr(iptr x, int k) {
+  return x + k;
+}
+
+EXPORT iptr uptr_to_uptr(uptr x, int k) {
+  return x + k;
+}
+
+EXPORT iptr call_iptr(ptr code, iptr x, int m, int k) {
+  return (*((iptr (*) (iptr))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT iptr call_uptr(ptr code, uptr x, int m, int k) {
+  return (*((uptr (*) (uptr))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT float float_to_float(float x) {
+  return x + 1;
+}
+
+EXPORT float call_float(ptr code, float x, int m, int k) {
+  return (*((float (*) (float))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT double double_to_double(double x) {
+  return x + 1;
+}
+
+EXPORT double call_double(ptr code, double x, int m, int k) {
+  return (*((double (*) (double))Sforeign_callable_entry_point(code)))(x + m) + k;
+}
+
+EXPORT u64 u32xu32_to_u64(u32 x, u32 y) {
+  return (u64)x << 32 | (u64)y;
+}
+
+EXPORT i64 i32xu32_to_i64(i32 x, u32 y) {
+  return (i64)((u64)x << 32 | (u64)y);
+}
+
+EXPORT i64 call_i32xu32_to_i64(ptr code, i32 x, u32 y, int k) {
+  i64 q = (*((i64 (*) (i32, u32))Sforeign_callable_entry_point(code)))(x, y);
+  return q + k;
+}
+
+EXPORT u64 ufoo64a(u64 a, u64 b, u64 c, u64 d, u64 e, u64 f, u64 g) {
+  return (a - b) + (c - d) + (e - f) + g;
+}
+
+EXPORT u64 ufoo64b(u32 x, u64 a, u64 b, u64 c, u64 d, u64 e, u64 f, u64 g) {
+  return (u64)x + (a - b) + (c - d) + (e - f) + g;
+}
+
+EXPORT i64 ifoo64a(i64 a, i64 b, i64 c, i64 d, i64 e, i64 f, i64 g) {
+  return (a - b) + (c - d) + (e - f) + g;
+}
+
+EXPORT i64 ifoo64b(i32 x, i64 a, i64 b, i64 c, i64 d, i64 e, i64 f, i64 g) {
+  return (i64)x + (a - b) + (c - d) + (e - f) + g;
+}
+
+EXPORT void call_many_times(void (*f)(iptr))
+{
+  int x;
+  iptr a = 1, b = 3, c = 5, d = 7;
+  iptr e = 1, g = 3, h = 5, i = 7;
+  iptr j = 1, k = 3, l = 5, m = 7;
+  iptr big = (((iptr)1) << ((8 * sizeof(iptr)) - 2));
+
+  /* The intent of the loop is to convince the C compiler to store
+     something in the same register used for CP (so, compile with
+     optimization). */
+  for (x = 0; x < 1000000; x++) {
+    f(big|(a+e+j));
+    a = b; b = c; c = d; d = e;
+    e = g; g = h; h = i; i = j;
+    j = k+2; k = l+2; l = m+2; m = m+2;
+  }
+}
+
+EXPORT void call_many_times_bv(void (*f)(char *s))
+{
+  /* make this sensible as u8*, u16*, and u32* */
+  char buf[8] = { 1, 2, 3, 4, 0, 0, 0, 0 };
+  int x;
+
+  for (x = 0; x < 1000000; x++) {
+    buf[0] = (x & 63) + 1;
+    f(buf);
+  }
+}
+
+typedef void (*many_arg_callback_t)(int i, const char* s1, const char* s2, const char* s3,
+                                    const char* s4, int i2, const char* s6, const char* s7, int i3);
+EXPORT void call_with_many_args(many_arg_callback_t callback)
+{
+    callback(0, "this", "is", "working", "just", 1, "fine", "or does it?", 2);
+}
diff --git a/mats/foreign3.c b/mats/foreign3.c
new file mode 100644
index 0000000..31e7f99
--- /dev/null
+++ b/mats/foreign3.c
@@ -0,0 +1,281 @@
+/* foreign3.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include 
+#include 
+
+#ifndef WIN32
+#include 
+#endif
+
+#ifdef _WIN32
+#  define SCHEME_IMPORT
+#  include "scheme.h"
+#  undef EXPORT
+#  define EXPORT extern __declspec (dllexport)
+#else
+#include "scheme.h"
+#endif
+
+EXPORT int chk_data(void) {
+    static char c[10]="ABCDEFGH";
+
+    return('A' == c[0] && 'B' == c[1] && 'C' == c[2] && 'D' == c[3] &&
+           'E' == c[4] && 'F' == c[5] && 'G' == c[6] && 'H' == c[7]);
+}
+
+EXPORT int chk_bss(void) {
+    static int j[2000];
+    int i;
+
+    for (i=0; i<2000; i++) if (j[i] != 0) break;
+
+    return i == 2000;
+}
+
+EXPORT int chk_malloc(void) {
+    int *j, i;
+
+    j = (int *)malloc(2000 * sizeof(int));
+
+    for (i=0; i<2000; i++) j[i] = 0;
+
+    for (i=0; i<2000; i++) if (j[i] != 0) break;
+
+    free(j);
+
+    return i == 2000;
+}
+
+EXPORT float sxstos(float x, float y) {
+    return x * y;
+}
+
+EXPORT float singlesum12(float x1, float x2, float x3, float x4,
+                         float x5, float x6, float x7, float x8,
+                         float x9, float x10, float x11, float x12) {
+    return x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12;
+}
+
+/* these are taken from SYSTEM V Application Binary Interface
+ * MIPS Processor Supplement, 1991
+ * page 3-21
+ */   
+
+EXPORT double d1d2(double d1, double d2) {
+    return d1 + d2;
+}
+EXPORT double s1s2(float s1, float s2) {
+    return s1 + s2;
+}
+EXPORT double s1d1(float s1, double d1) {
+    return s1 + d1;
+}
+EXPORT double d1s1(double d1, float s1) {
+    return d1 + s1;
+}
+EXPORT double n1n2n3n4(int n1, int n2, int n3, int n4) {
+    return (double)(n1 + n2 + n3 + n4);
+}
+EXPORT double d1n1d2(double d1, int n1, double d2) {
+    return d1 + n1 + d2;
+}
+EXPORT double d1n1n2(double d1, int n1, int n2) {
+    return d1 + n1 + n2;
+}
+EXPORT double s1n1n2(float s1, int n1, int n2) {
+    return s1 + n1 + n2;
+}
+EXPORT double n1n2n3d1(int n1, int n2, int n3, double d1) {
+    return n1 + n2 + n3 + d1;
+}
+EXPORT double n1n2n3s1(int n1, int n2, int n3, float s1) {
+    return n1 + n2 + n3 + s1;
+}
+EXPORT double n1n2d1(int n1, int n2, double d1) {
+    return n1 + n2 + d1;
+}
+EXPORT double n1d1(int n1, double d1) {
+    return n1 + d1;
+}
+EXPORT double s1s2s3s4(float s1, float s2, float s3, float s4) {
+    return s1 + s2 + s3 + s4;
+}
+EXPORT double s1n1s2n2(float s1, int n1, float s2, int n2) {
+    return s1 + n1 + s2 + n2;
+}
+EXPORT double d1s1s2(double d1, float s1, float s2) {
+    return d1 + s1 + s2;
+}
+EXPORT double s1s2d1(float s1, float s2, double d1) {
+    return s1 + s2 + d1;
+}
+EXPORT double n1s1n2s2(int n1, float s1, int n2, float s2) {
+    return n1 + s1 + n2 + s2;
+}
+EXPORT double n1s1n2n3(int n1, float s1, int n2, int n3) {
+    return n1 + s1 + n2 + n3;
+}
+EXPORT double n1n2s1n3(int n1, int n2, float s1, int n3) {
+    return n1 + n2 + s1 + n3;
+}
+
+/* a few more for good measure */
+EXPORT double d1d2s1s2(double d1, double d2, float s1, float s2) {
+    return d1 + d2 + s1 + s2;
+}
+EXPORT double d1d2n1n2(double d1, double d2, int n1, int n2) {
+    return d1 + d2 + n1 + n2;
+}
+EXPORT double s1d1s2s3(float s1, double d1, float s2, float s3) {
+    return s1 + d1 + s2 + s3;
+}
+
+/* support for testing foreign-callable */
+EXPORT ptr Sinvoke2(ptr code, ptr x1, iptr x2) {
+    return (*((ptr (*)(ptr, iptr))Sforeign_callable_entry_point(code)))(x1, x2);
+}
+
+EXPORT ptr Sargtest(iptr f, int x1, int x2, iptr x3, double x4, float x5, char *x6) {
+    return (*((ptr (*)(int, int, iptr, double, float, char *))f))(x1, x2, x3, x4, x5, x6);
+}
+
+EXPORT ptr Sargtest2(iptr f, short x1, int x2, char x3, double x4, short x5, char x6) {
+    return (*((ptr (*)(short, int, char, double, short, char))f))(x1, x2, x3, x4, x5, x6);
+}
+
+EXPORT int Srvtest_int32(ptr code, ptr x1) {
+    return (*((int (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
+}
+
+EXPORT unsigned Srvtest_uns32(ptr code, ptr x1) {
+    return (*((unsigned (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
+}
+
+EXPORT float Srvtest_single(ptr code, ptr x1) {
+    return (*((float (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
+}
+
+EXPORT double Srvtest_double(ptr code, ptr x1) {
+    return (*((double (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
+}
+
+EXPORT char Srvtest_char(ptr code, ptr x1) {
+    return (*((char (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
+}
+
+#ifdef WIN32
+EXPORT int __stdcall sum_stdcall(int a, int b) {
+    return a + b;
+}
+
+EXPORT ptr Sinvoke2_stdcall(ptr code, ptr x1, iptr x2) {
+    return (*((ptr (__stdcall *)(ptr, iptr))Sforeign_callable_entry_point(code)))(x1, x2);
+}
+
+typedef int (__stdcall *comfunc) (void *, int);
+typedef struct { comfunc *vtable; int data; } com_instance_t;
+
+static comfunc com_vtable[2];
+static com_instance_t com_instance;
+
+extern int __stdcall com_method0(void *inst, int val) {
+  return ((com_instance_t *)inst)->data = val;
+}
+
+extern int __stdcall com_method1(void *inst, int val) {
+  return val * 2 + ((com_instance_t *)inst)->data;
+}
+
+EXPORT com_instance_t *get_com_instance(void) {
+  com_instance.vtable = com_vtable;
+  com_vtable[0] = com_method0;
+  com_vtable[1] = com_method1;
+  com_instance.data = -31;
+  return &com_instance;
+}
+#endif /* WIN32 */
+
+/* foreign_callable example adapted from foreign.stex */
+typedef void (*CB)(char);
+
+static CB callbacks[256];
+
+EXPORT void cb_init(void) {
+   int i;
+
+   for (i = 0; i < 256; i += 1)
+       callbacks[i] = (CB)0;
+}
+
+EXPORT void register_callback(char c, iptr cb) {
+    callbacks[(int)c] = (CB)cb;
+}
+
+EXPORT void event_loop(char *s) {
+    char buf[10];
+    CB f; char c;
+
+  /* create a local copy, since s points into an unlocked Scheme string */
+    strncpy(buf, s, 9);
+    buf[9] = '0';
+    s = buf;
+    for (;;) {
+        c = *s++;
+        if (c == 0) break;
+        f = callbacks[(int)c];
+        if (f != (CB)0) f(c);
+    }
+}
+
+EXPORT void call_twice(void (*foo)(int), int x, int y) {
+  foo(x);
+  foo(y);
+}
+
+EXPORT void unlock_callback(int (* f)(int)) {
+  Sunlock_object(Sforeign_callable_code_object(f));
+}
+
+EXPORT int call_and_unlock(int (* f)(int), int arg) {
+  int ans = f(arg);
+  Sunlock_object(Sforeign_callable_code_object(f));
+  return ans;
+}
+
+EXPORT void init_lock (uptr *u) {
+  INITLOCK(u);
+}
+
+EXPORT void spinlock (uptr *u) {
+  SPINLOCK(u);
+}
+
+EXPORT void unlock (uptr *u) {
+  UNLOCK(u);
+}
+
+EXPORT int locked_incr (uptr *u) {
+  int ret;
+  LOCKED_INCR(u, ret);
+  return ret;
+}
+
+EXPORT int locked_decr (uptr *u) {
+  int ret;
+  LOCKED_DECR(u, ret);
+  return ret;
+}
diff --git a/mats/foreign4.c b/mats/foreign4.c
new file mode 100644
index 0000000..ca7d4ea
--- /dev/null
+++ b/mats/foreign4.c
@@ -0,0 +1,397 @@
+/* foreign4.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include 
+#include 
+
+#if defined(_REENTRANT) || defined(_WIN32)
+# ifdef _WIN32
+#  include 
+#  define SCHEME_IMPORT
+#  include "scheme.h"
+# else
+#  include 
+#  include "scheme.h"
+# endif
+# undef EXPORT
+#endif
+
+typedef signed char i8;
+typedef unsigned char u8;
+typedef unsigned short u16;
+#ifdef _WIN32
+typedef __int64 i64;
+# define EXPORT extern __declspec (dllexport)
+#else
+typedef long long i64;
+# define EXPORT
+#endif
+
+/* To help make sure that argument and result handling doesn't
+   read or write too far, try to provide functions that allocate
+   a structure at the end of a memory page (where the next page is
+   likely to be unmapped) */
+
+#if defined(__linux__) || (defined(__APPLE__) && defined(__MACH__))
+
+# include 
+# include 
+# include 
+# include 
+
+EXPORT void *malloc_at_boundary(int sz)
+{
+  intptr_t alloc_size = getpagesize();
+  char *p;
+  p = mmap(NULL, 2 * alloc_size, PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0);
+  mprotect(p + alloc_size, alloc_size, PROT_NONE);
+  return p + alloc_size - sz;
+}
+
+EXPORT void free_at_boundary(void *p)
+{
+  intptr_t alloc_size = getpagesize();
+  munmap((void *)(((intptr_t)p) & ~(alloc_size-1)), 2 * alloc_size);
+}
+
+#elif defined(_WIN32)
+
+EXPORT void *malloc_at_boundary(int sz)
+{
+  SYSTEM_INFO si;
+  char *p;
+  DWORD dummy;
+  GetSystemInfo(&si);
+  p = VirtualAlloc(NULL, 2 * si.dwPageSize, MEM_COMMIT | MEM_RESERVE, PAGE_READWRITE);
+  VirtualProtect(p + si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &dummy);
+  return p + si.dwPageSize - sz;
+}
+
+EXPORT void free_at_boundary(void *p)
+{
+  SYSTEM_INFO si;
+  GetSystemInfo(&si);
+  VirtualFree((void *)(((intptr_t)p) & ~(si.dwPageSize-1)), 0, MEM_RELEASE);
+}
+
+#else
+
+EXPORT void *malloc_at_boundary(int sz)
+{
+  return malloc(sz);
+}
+ 
+EXPORT void free_at_boundary(void *p)
+{
+  free(p);
+}
+
+#endif
+
+#if defined(_REENTRANT) || defined(_WIN32)
+
+typedef struct in_thread_args_t {
+  double (*proc)(double arg);
+  double arg;
+  int n_times;
+} in_thread_args_t;
+
+void *in_thread(void *_proc_and_arg)
+{
+  in_thread_args_t *proc_and_arg = _proc_and_arg;
+  int i;
+
+  for (i = 0; i < proc_and_arg->n_times; i++) {
+    proc_and_arg->arg = proc_and_arg->proc(proc_and_arg->arg);
+  }
+
+  return NULL;
+}
+
+#if defined(_WIN32)
+# define os_thread_t unsigned
+# define os_thread_create(addr, proc, arg) (((*(addr)) = _beginthread(proc, 0, arg)) == -1)
+# define os_thread_join(t) WaitForSingleObject((HANDLE)(intptr_t)(t), INFINITE)
+#else
+# define os_thread_t pthread_t
+# define os_thread_create(addr, proc, arg) pthread_create(addr, NULL, in_thread, proc_and_arg)
+# define os_thread_join(t) pthread_join(t, NULL)
+#endif
+
+#ifdef FEATURE_PTHREADS
+EXPORT double call_in_unknown_thread(double (*proc)(double arg), double arg, int n_times,
+                                     int do_fork, int do_deactivate) {
+  os_thread_t t;
+  in_thread_args_t *proc_and_arg = malloc(sizeof(in_thread_args_t));
+
+  proc_and_arg->proc = proc;
+  proc_and_arg->arg = arg;
+  proc_and_arg->n_times = n_times;
+
+  if (do_fork) {
+    if (do_deactivate) Sdeactivate_thread();
+    if (!os_thread_create(&t, in_thread, proc_and_arg)) {
+      os_thread_join(t);
+    }
+    if (do_deactivate) Sactivate_thread();
+  } else {
+    in_thread(proc_and_arg);
+  }
+
+  arg = proc_and_arg->arg;
+  free(proc_and_arg);
+
+  return arg;
+}
+#endif /* FEATURE_PTHREADS */
+#endif
+
+EXPORT unsigned spin_a_while(int amt, unsigned a, unsigned b)
+{
+  int i;
+
+  /* A loop that the compiler is unlikely to optimize away */
+  for (i = 0; i < amt; i++) {
+    a = a + b;
+    b = b + a;
+  }
+
+  return a;
+}
+
+#define GEN(ts, init, sum)                                              \
+  EXPORT ts f4_get_ ## ts () {                                          \
+    ts r = init;                                                        \
+    return r;                                                           \
+  }                                                                     \
+  EXPORT double f4_sum_ ## ts (ts v) {                                  \
+    return sum(v);                                                      \
+  }                                                                     \
+  EXPORT double f4_sum_two_ ## ts (ts v1, ts v2) {                      \
+    return sum(v1) + sum(v2);                                           \
+  }                                                                     \
+  EXPORT double f4_sum_pre_double_ ## ts (double v0, ts v) {            \
+    return v0 + sum(v);                                                 \
+  }                                                                     \
+  EXPORT double f4_sum_pre_double_double_ ## ts (double v0, double v1, ts v) { \
+    return v0 + v1 + sum(v);                                            \
+  }                                                                     \
+  EXPORT double f4_sum_pre_double_double_double_double_ ## ts (double v0, double v1, double v2, double v3, ts v) { \
+    return v0 + v1 + v2 + v3 + sum(v);                                  \
+  }                                                                     \
+  EXPORT double f4_sum_pre_double_double_double_double_double_double_double_double_ ## ts \
+  (double v0, double v1, double v2, double v3, double v4, double v5, double v6, double v7, ts v) { \
+    return v0 + v1 + v2 + v3 + v4 + v5 + v6 + v7 + sum(v);              \
+  }                                                                     \
+  EXPORT double f4_sum_ ## ts ## _post_double (ts v, double v0) {       \
+    return v0 + sum(v);                                                 \
+  }                                                                     \
+  EXPORT double f4_sum_pre_int_ ## ts (int v0, ts v) {                  \
+    return (double)v0 + sum(v);                                         \
+  }                                                                     \
+  EXPORT double f4_sum_pre_int_int_ ## ts (int v0, int v1, ts v) {      \
+    return (double)v0 + (double)v1 + sum(v);                            \
+  }                                                                     \
+  EXPORT double f4_sum_pre_int_int_int_int_ ## ts (int v0, int v1, int v2, int v3, ts v) { \
+    return (double)v0 + (double)v1 + (double)v2 + (double)v3 + sum(v);  \
+  }                                                                     \
+  EXPORT double f4_sum_pre_int_int_int_int_int_int_ ## ts (int v0, int v1, int v2, int v3, int v4, int v5, ts v) { \
+    return (double)v0 + (double)v1 + (double)v2 + (double)v3 + (double)v4 + (double)v5 + sum(v); \
+  }                                                                     \
+  EXPORT double f4_sum_ ## ts ## _post_int (ts v, int v0) {             \
+    return (double)v0 + sum(v);                                         \
+  }                                                                     \
+  EXPORT double f4_cb_send_ ## ts (double (*cb)(ts)) {                  \
+    ts r = init;                                                        \
+    return cb(r) + 1.0;							\
+  }                                                                     \
+  EXPORT double f4_cb_send_two_ ## ts (double (*cb)(ts, ts)) {          \
+    ts r1 = init;                                                       \
+    ts r2 = init;                                                       \
+    return cb(r1, r2) + 1.0;                                            \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_int_ ## ts (double (*cb)(int, ts)) {     \
+    ts r = init;                                                        \
+    return cb(8, r) + 1.0;                                              \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_int_int_ ## ts (double (*cb)(int, int, ts)) { \
+    ts r = init;                                                        \
+    return cb(8, 9, r) + 1.0;                                           \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_int_int_int_int_ ## ts (double (*cb)(int, int, int, int, ts)) { \
+    ts r = init;                                                        \
+    return cb(8, 9, 10, 11, r) + 1.0;                                   \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_int_int_int_int_int_int_ ## ts (double (*cb)(int, int, int, int, int, int, ts)) { \
+    ts r = init;                                                        \
+    return cb(8, 9, 10, 11, 12, 13, r) + 1.0;                           \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_double_ ## ts (double (*cb)(double, ts)) { \
+    ts r = init;                                                        \
+    return cb(8.25, r) + 1.0;                                           \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_double_double_ ## ts (double (*cb)(double, double, ts)) { \
+    ts r = init;                                                        \
+    return cb(8.25, 9.25, r) + 1.0;                                     \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_double_double_double_double_ ## ts (double (*cb)(double, double, double, double, ts)) { \
+    ts r = init;                                                        \
+    return cb(8.25, 9.25, 10.25, 11.25, r) + 1.0;                       \
+  }                                                                     \
+  EXPORT double f4_cb_send_pre_double_double_double_double_double_double_double_double_ ## ts \
+  (double (*cb)(double, double, double, double, double, double, double, double, ts)) { \
+    ts r = init;                                                        \
+    return cb(8.25, 9.25, 10.25, 11.25, 12.25, 13.25, 14.25, 15.25, r) + 1.0; \
+  }                                                                     \
+  EXPORT double f4_sum_cb_ ## ts (ts (*cb)()) {                         \
+    ts v = cb();                                                        \
+    return sum(v);                                                      \
+  }
+
+#define TO_DOUBLE(x) ((double)(x))
+GEN(i8, -11, TO_DOUBLE)
+GEN(u8, 129, TO_DOUBLE)
+GEN(short, -22, TO_DOUBLE)
+GEN(u16, 33022, TO_DOUBLE)
+GEN(long, 33, TO_DOUBLE)
+GEN(int, 44, TO_DOUBLE)
+GEN(i64, 49, TO_DOUBLE)
+GEN(float, 55.0, TO_DOUBLE)
+GEN(double, 66.0, TO_DOUBLE)
+
+/* Some ABIs treat a struct containing a single field different that
+   just the field */
+#define GEN_1(t1, v1)                                                   \
+  typedef struct struct_ ## t1 { t1 x; } struct_ ## t1;                 \
+  static double _f4_sum_struct_ ## t1 (struct_ ## t1 v) {               \
+    return (double)v.x;                                                 \
+  }                                                                     \
+  static struct_ ## t1 init_struct_ ## t1 = { v1 };                     \
+  GEN(struct_ ## t1, init_struct_ ## t1, _f4_sum_struct_ ## t1)
+
+GEN_1(i8, -12)
+GEN_1(u8, 212)
+GEN_1(short, -23)
+GEN_1(u16, 33023)
+GEN_1(long, 34)
+GEN_1(int, 45)
+GEN_1(i64, 48)
+GEN_1(float, 56.0)
+GEN_1(double, 67.0)
+
+#define GEN_2(t1, t2, v1, v2)                                           \
+  typedef struct struct_ ## t1 ## _ ## t2 { t1 x; t2 y; } struct_ ## t1 ## _ ## t2; \
+  static double _f4_sum_struct_ ## t1 ## _ ## t2 (struct_ ## t1 ## _ ## t2 v) { \
+    return (double)v.x + (double)v.y;                                   \
+  }                                                                     \
+  static struct_ ## t1 ## _ ## t2 init_struct_ ## t1 ## _ ## t2 = { v1, v2 }; \
+  GEN(struct_ ## t1 ## _ ## t2, init_struct_ ## t1 ## _ ## t2, _f4_sum_struct_ ## t1 ## _ ## t2)
+
+#define GEN_2_SET(t, x)                         \
+  GEN_2(t, i8, 1+x, 10)                         \
+  GEN_2(t, short, 2+x, 20)                      \
+  GEN_2(t, long, 3+x, 30)                       \
+  GEN_2(t, i64, 5+x, 50)                        \
+  GEN_2(short, t, 6, 60+x)                      \
+  GEN_2(long, t, 7, 70+x)                       \
+  GEN_2(i64, t, 9, 90+x)                        \
+  GEN_2(i8, t, 10, 100+x)
+
+GEN_2_SET(int, 0)
+GEN_2_SET(float, 0.5)
+GEN_2_SET(double, 0.25)
+
+GEN_2(int, int, 4, 40)
+GEN_2(float, float, 4.5, 40.5)
+GEN_2(double, double, 4.25, 40.25)
+
+#define GEN_3(t1, t2, t3, v1, v2, v3)                                   \
+  typedef struct struct_ ## t1 ## _ ## t2 ## _ ## t3 { t1 x; t2 y; t3 z; } struct_ ## t1 ## _ ## t2 ## _ ## t3; \
+  static double _f4_sum_struct_ ## t1 ## _ ## t2 ## _ ## t3 (struct_ ## t1 ## _ ## t2 ## _ ## t3 v) { \
+    return (double)v.x + (double)v.y + (double)v.z;                     \
+  }                                                                     \
+  static struct_ ## t1 ## _ ## t2 ## _ ## t3 init_struct_ ## t1 ## _ ## t2 ## _ ## t3 = { v1, v2, v3 }; \
+  GEN(struct_ ## t1 ## _ ## t2 ## _ ## t3, init_struct_ ## t1 ## _ ## t2 ## _ ## t3, _f4_sum_struct_ ## t1 ## _ ## t2 ## _ ## t3)
+
+#define GEN_3_SET(t, x)                           \
+  GEN_3(t, i8, int, 1+x, 10, 100)                 \
+  GEN_3(t, short, int, 2+x, 20, 200)              \
+  GEN_3(t, long, int, 3+x, 30, 300)               \
+  GEN_3(t, i64, int, 5+x, 50, 500)                \
+  GEN_3(short, t, int, 6, 60+x, 600)              \
+  GEN_3(long, t, int, 7, 70+x, 700)               \
+  GEN_3(i64, t, int, 9, 90+x, 900)                \
+  GEN_3(i8, t, int, 10, 100+x, 1000)
+
+GEN_3_SET(int, 0)
+GEN_3_SET(float, 0.5)
+GEN_3_SET(double, 0.25)
+
+GEN_3(i8, i8, i8, 4, 38, 127)
+GEN_3(short, short, short, 4, 39, 399)
+GEN_3(int, int, int, 4, 40, 400)
+GEN_3(float, float, float, 4.5, 40.5, 400.5)
+GEN_3(double, double, double, 4.25, 40.25, 400.25)
+
+typedef struct struct_i8_i8_i8_i8_i8 { i8 x, y, z, w, q; } struct_i8_i8_i8_i8_i8;
+static double _f4_sum_struct_i8_i8_i8_i8_i8 (struct_i8_i8_i8_i8_i8 v) {
+  return (double)v.x + (double)v.y + (double)v.z + (double)v.w + (double)v.q;
+}
+static struct struct_i8_i8_i8_i8_i8 init_struct_i8_i8_i8_i8_i8 = { 1, 2, 3, 4, 5 };
+GEN(struct_i8_i8_i8_i8_i8, init_struct_i8_i8_i8_i8_i8, _f4_sum_struct_i8_i8_i8_i8_i8)
+
+typedef struct struct_i8_i8_i8_i8_i8_i8_i8 { i8 x, y, z, w, q, r, s; } struct_i8_i8_i8_i8_i8_i8_i8;
+static double _f4_sum_struct_i8_i8_i8_i8_i8_i8_i8 (struct struct_i8_i8_i8_i8_i8_i8_i8 v) {
+  return (double)v.x + (double)v.y + (double)v.z + (double)v.w + (double)v.q + (double)v.r + (double)v.s;
+}
+static struct struct_i8_i8_i8_i8_i8_i8_i8 init_struct_i8_i8_i8_i8_i8_i8_i8 = { 1, 2, 3, 4, 5, 6, 7 };
+GEN(struct_i8_i8_i8_i8_i8_i8_i8, init_struct_i8_i8_i8_i8_i8_i8_i8, _f4_sum_struct_i8_i8_i8_i8_i8_i8_i8)
+
+/* Some ABIs treat a union containing a single field different that
+   just the field */
+#define GEN_U1(t1, v1)                                                \
+  typedef union union_ ## t1 { t1 x; } union_ ## t1;                  \
+  static double _f4_sum_union_ ## t1 (union_ ## t1 v) {               \
+    return (double)v.x;                                               \
+  }                                                                   \
+  static union_ ## t1 init_union_ ## t1 = { v1 };                     \
+  GEN(union_ ## t1, init_union_ ## t1, _f4_sum_union_ ## t1)
+
+GEN_U1(i8, -17)
+GEN_U1(u8, 217)
+GEN_U1(short, -27)
+GEN_U1(u16, 33027)
+GEN_U1(long, 37)
+GEN_U1(int, 47)
+GEN_U1(i64, 49)
+GEN_U1(float, 57.0)
+GEN_U1(double, 77.0)
+
+#define GEN_U2(t1, t2, v1)                                              \
+  typedef union union_ ## t1 ## _ ## t2 { t1 x; t2 y; } union_ ## t1 ## _ ## t2; \
+  static double _f4_sum_union_ ## t1 ## _ ## t2 (union_ ## t1 ## _ ## t2 v) { \
+    return (double)v.x;                                                 \
+  }                                                                     \
+  static union_ ## t1 ## _ ## t2 init_union_ ## t1 ## _ ## t2 = { v1 }; \
+  GEN(union_ ## t1 ## _ ## t2, init_union_ ## t1 ## _ ## t2, _f4_sum_union_ ## t1 ## _ ## t2)
+
+GEN_U2(i8, int, 18)
+GEN_U2(short, int, 28)
+GEN_U2(long, int, 38)
+GEN_U2(int, int, 48)
+GEN_U2(i64, int, 43)
+GEN_U2(float, int, 58.0)
+GEN_U2(double, int, 68.0)
diff --git a/mats/format.ms b/mats/format.ms
new file mode 100644
index 0000000..b0e4762
--- /dev/null
+++ b/mats/format.ms
@@ -0,0 +1,1726 @@
+;;; format.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+; need some for printf and fprintf
+; need some when string is not known at compile time
+; need some when number of args is not known at compile time, e.g.,
+;    (apply format "hi ~s" args)
+; construct testing mechanism that gives us all of these from a
+; single set of directives
+; need some tabulate tests
+
+(mat format-errors
+  (error? (format "hi ~s"))
+  (error? (format "hi ~s" 'a 'b))
+  (error? (format "hi ~"))
+  (error? (format "hi ~23"))
+  (error? (format "hi ~23@"))
+  (error? (format "hi ~@"))
+  (error? (format 7 "hi ~@"))
+  (error? (format "~@%"))
+  (error? (format "~@c%"))
+  (error? (format "~c" 3))
+  (error? (format "~@~"))
+  (error? (format "~@@s"))
+  (error? (format "~@3"))
+  (error? (format "~q"))
+  (error? (format "~,,,-3:d" (expt 2 100)))
+  (error? (format "~,,-3,3e" -3.14159))
+  (error? (printf 'hello "there"))
+  (error? (fprintf 'not-a-port "~a ~s" 17 34))
+  (error? (format 'not-a-string-port-or-boolean "~a ~s" 17 34))
+  (error? (format "bad~\rdirective"))
+  (error? (printf "~a~:*"))
+)
+
+(mat format-continuation ; like slib tests, but with \r\n for DOS
+  (equal? (format "abc~\r\n    123") "abc123")
+  (equal? (format "abc~\r\n   ") "abc")
+  (equal? (format "abc~:\r\n   def") "abc   def")
+  (equal? (format "abc~@\r\n   def") "abc\ndef")
+)
+
+(mat format-plain
+  (equal? (format "") "")
+  (equal? (format "a") "a")
+  (equal? (format "ab") "ab")
+  (equal? (format "ab~%cd") "ab\ncd")
+  (equal? (format "ab\ncd") "ab\ncd")
+  (equal? (format "a\nb\ncc\nddd\neeee") "a\nb\ncc\nddd\neeee")
+  (equal? (format "a~&b~%cc~&ddd~%eeee") "a\nb\ncc\nddd\neeee")
+  (equal? (format "a\nb\ncc\nddd\neeee\n") "a\nb\ncc\nddd\neeee\n")
+  (equal? (format "a~%b~&cc~%ddd~&eeee\n") "a\nb\ncc\nddd\neeee\n")
+  (equal? (format "\na\nb\ncc\nddd\neeee") "\na\nb\ncc\nddd\neeee")
+  (equal? (format "~%a~&b~%cc~&ddd~%eeee") "\na\nb\ncc\nddd\neeee")
+  (equal? (format "\na\nb\ncc\nddd\neeee\n") "\na\nb\ncc\nddd\neeee\n")
+  (equal? (format "~%a~%b~&cc~%ddd~&eeee\n") "\na\nb\ncc\nddd\neeee\n")
+)
+
+(mat format-object
+  (equal? (format "hi ~s" "a") "hi \"a\"")
+  (equal? (format "hi ~10s" "a") "hi \"a\"       ")
+  (equal? (format "hi ~10@s" "a") "hi        \"a\"")
+  (equal? (format "~10,3,2,'$@s" 345) "$$$$$$$$345")
+  (equal? (format "~10,3,2,'$@s" 3456) "$$$$$$$$3456")
+  (equal? (format "~10,3,2,'$@s" 34567) "$$$$$34567")
+  (equal? (format "~10,3,2,'$@s" 345678) "$$$$$345678")
+  (equal? (format "~10,3,2,'$@s" 3456789) "$$$$$3456789")
+  (equal? (format "~10,3,2,'$@s" 34567890) "$$34567890")
+  (equal? (format "~10,3,2,'$@s" 345678901) "$$345678901")
+  (equal? (format "~10,3,2,'$@s" 3456789012) "$$3456789012")
+  (equal? (format "~7,,4,a~3%~10,3,,'#@s" "hello" 345)
+          "hello    \n\n\n#########345")
+  (equal? (format "~:s" '#{g0 ymnnefx976kvhp9-a}) "g0")
+  (equal? (format "~s" '#{g0 ymnnefx976kvhp9-a}) "#{g0 ymnnefx976kvhp9-a}")
+  (equal? (format "~,,2@s" 345678901) "  345678901")
+  (equal? (format "~,,2s" 345678901) "345678901  ")
+)
+
+(mat format-char
+  (equal? (format "~c" #\a) "a")
+  (equal? (format "~c" #\space) " ")
+  (equal? (format "~:c" #\a) "a")
+  (equal? (format "~:c" #\space) "")
+  (equal? (format "~:c" #\034) "^\\")
+  (equal? (format "~:c" #\003) "^C")
+  (equal? (format "~@c" #\a) "#\\a")
+  (equal? (format "~@c" #\space) "#\\space")
+  (equal? (format "~:@c" #\a) "a")
+  (equal? (format "~:@c" #\space) "")
+  (equal? (format "~:@c" #\034) "^\\")
+  (equal? (format "~:@c" #\003) "^C")
+  (equal? (format "~@:c" #\a) "a")
+  (equal? (format "~@:c" #\space) "")
+  (equal? (format "~@:c" #\034) "^\\")
+  (equal? (format "~@:c" #\003) "^C")
+)
+
+(mat format-plural
+  (error? (format "abc~:p" 1))
+  (error? (format "abc~:p"))
+  (error? (format "abc~:@p"))
+  (error? (format "abc~:p~s" 2))
+  (error? (format "abc~:@p~s" 2))
+  (equal? (format "~s abc~:p" 1) "1 abc")
+  (equal? (format "~s abc~:p" 2) "2 abcs")
+  (equal? (format "~s abc~:p" 1.0) "1.0 abcs")
+  (equal? (format "~s abc~:p" 'one) "one abcs")
+  (equal? (format "abc~p" 1) "abc")
+  (equal? (format "abc~p" 2) "abcs")
+  (equal? (format "abc~p" 'kumquat) "abcs")
+  (equal? (format "abc~@p" 1) "abcy")
+  (equal? (format "abc~@p" 'kumquat) "abcies")
+  (equal? (format "~s~@:p" 1) "1y")
+  (equal? (format "~s~@:p" 2) "2ies")
+)
+
+(mat format-convert-case
+  (error? (format "~23:(abc)"))
+  (error? (format "~,:(abc)"))
+  (error? (format "~(abc"#|)|#))
+  (error? (format "~:(abc)"))
+  (error? (format #|(|#"abc~)"))
+  (error? (format "~(~r ~(~a~)~) ~:@(~a)" 1621 "piNK" "bLuE"))
+  (equal? (format "~(AbC 123A DEF g~)") "abc 123a def g")
+  (equal? (format "~:(AbC 123A DEF g~)") "Abc 123a Def G")
+  (equal? (format "~@(AbC 123A DEF g~)") "Abc 123a def g")
+  (equal? (format "~:@(AbC 123A DEF g~)") "ABC 123A DEF G")
+  (equal? (format "~@:(AbC 123A DEF g~)") "ABC 123A DEF G")
+  (equal? (format "~@:(~r ~a~) ~a" 1621 "piNK" "bLuE")
+          "SIXTEEN HUNDRED TWENTY-ONE PINK bLuE")
+  (equal? (format "~:@(~r ~a~) ~a" 1621 "piNK" "bLuE")
+          "SIXTEEN HUNDRED TWENTY-ONE PINK bLuE")
+  (equal? (format "~@(~r ~a~) ~a" 1621 "piNK" "bLuE")
+          "Sixteen hundred twenty-one pink bLuE")
+  (equal? (format "~:(~r ~a~) ~a" 1621 "piNK" "bLuE")
+          "Sixteen Hundred Twenty-One Pink bLuE")
+  (equal? (format "~(~r ~a~) ~a" 1621 "piNK" "bLuE")
+          "sixteen hundred twenty-one pink bLuE")
+  (equal? (format "~(~r ~(~a~)~) ~a" 1621 "piNK" "bLuE")
+          "sixteen hundred twenty-one pink bLuE")
+  (equal? (format "~(~r ~(~a~)~) ~:@(~a~)" 1621 "piNK" "bLuE")
+          "sixteen hundred twenty-one pink BLUE")
+
+ ; cltl2 tests
+  (equal? (format "~@R ~(~@R~)" 14 14) "XIV xiv")
+  (begin
+    (define $f (lambda (n) (format "~@(~R~) error~:P detected." n)))
+    (procedure? $f))
+  (equal? ($f 0) "Zero errors detected.")
+  (equal? ($f 1) "One error detected.")
+  (equal? ($f 23) "Twenty-three errors detected.")
+)
+
+(mat format-indirect
+  (error? (format "~?" 3))
+  (error? (format "~@?" 3))
+  (error? (format "~?" "abc"))
+  (error? (format "~?" "~a" 4))
+  (error? (format "~?" "~a" '()))
+;  (error? (format "~@?" "abc" '())) ; too many args
+  (error? (format "~@?" "~(abc"#|)|#))
+  (error? (format "~@?" "~:?"))
+  (equal? (format "==> ~? <==" "~a" '(5)) "==> 5 <==")
+  (equal? (format "<~@?>" "abc") "")
+  (equal? (format "~:(<~@?>~)" "abc") "")
+  (equal? (format "<~@?>" "~:@(abc~)") "")
+  (equal? (format "<~@?>" "~r ~a" 101 "dalmations")
+          "")
+  (equal? (format "<~?~a>" "~r ~a" '(101 "dalmations") "!!!")
+          "")
+  (equal? (format "<~?>" "[~?]" '("(~?)" ("~a" (3)))) "<[(3)]>")
+  (equal? (format "<~@?>" "[~@?]" "(~@?)" "~a" 3) "<[(3)]>")
+  (error? (format "<~@?>" "[~@?]" "(~@?)" "~a"))
+;  (error? (format "<~@?>" "[~@?]" "(~@?)" "~a" 3 4)) ; too many args
+;  (error? (format "<~?>" "[~?]" '("(~?)" ("~a" (3 4))))) ; too many args
+;  (error? (format "<~?>" "[~?]" '("(~?)" ("~a" (3) 4)))) ; too many args
+
+ ; cltl2 tests
+  (equal? (format "~? ~d" "<~a ~d>" '("Foo" 5) 7) " 7")
+
+ ; cltl2 doesn't want us to complain about too many arguments
+  (equal? (format "~? ~d" "<~a ~d>" '("Foo" 5 14) 7) " 7")
+
+  (equal? (format "~@? ~D" "<~A ~D>" "Foo" 5 7) " 7")
+  (equal? (format "~@? ~D" "<~A ~D>" "Foo" 5 14 7) " 14")
+
+  (begin
+    (define (format-error ctl-index ctl-string string . args)
+      (format "~?~%~v@tv~%~3@t\"~a\"~%"
+        string args (+ ctl-index 3) ctl-string))
+    (procedure? format-error))
+  (equal? (format-error 16 "The item is a ~[Foo~;Bar~;Loser~]."
+            "ERROR: The argument to the format ~s command must be a number."
+            "~[")
+          "ERROR: The argument to the format \"~[\" command must be a number.\n                   v\n   \"The item is a ~[Foo~;Bar~;Loser~].\"\n")
+)
+
+(mat format-conditional/at
+  (error? (format "~@[abc~;def~]"))
+  (error? (format "~@[abc]"))
+  (error? (format #|(|# "~@[abc~)"))
+  (equal? (format "<~@[[in ~s]~]>" #f) "<>")
+  (equal? (format "<~@[[in ~s]~]>" 'foo) "<[in foo]>")
+;  (error? (format "<~@[[hey!]~]>" 'foo)) ; too many args
+  (equal? (format "<~@[~]> ~s" #t) "<> #t")
+  (error? (format "<~@[~]> ~s" #f))
+)
+
+(mat format-conditional/colon
+  (error? (format "~:[abc~:;def~]"))
+  (error? (format "~:[abc]"))
+  (error? (format #|(|# "~:[abc~)"))
+  (equal? (format "<~:[abc~;def~]>" #f) "")
+  (equal? (format "<~:[abc~;def~]>" #t) "")
+  (error? (format "<~:[abc~;def~;ghi~]>"))
+  (equal? (format "<~:[abc~;~a~]>" #f) "")
+  (equal? (format "<~:[abc~;~a~]>" #t 'yow!) "")
+  (equal? (format "<~:[abc~;~:*~a~]>" #t) "<#t>")
+  (error? (format "<~:[abc~;~a~]>" #t))
+  (error? (format "<~:[abc~]>" #f))
+)
+
+(mat format-conditional
+  (error? (format "~[abc~:;def~;ghi~]"))
+  (error? (format "~[abc]"))
+  (error? (format #|(|# "~[abc~)"))
+  (equal? (format "<~[abc~;def~]>" 0) "")
+  (equal? (format "<~[abc~;def~]>" 1) "")
+  (equal? (format "<~[abc~;def~]>" -15) "<>")
+  (equal? (format "<~[abc~;def~:;ghi~]>" 0) "")
+  (equal? (format "<~[abc~;def~:;ghi~]>" 1) "")
+  (equal? (format "<~[abc~;def~:;ghi~]>" 2) "")
+  (equal? (format "<~[abc~;def~:;ghi~]>" 'huh?) "")
+  (equal? (format "+++~[~s~;~r ~s~]---" 52) "+++---")
+;  (error? (format "+++~[~s~;~r ~s~]---" 52 23)) ; too many args
+;  (error? (format "+++~[~s~;~@r~s~]---" 52 23 '*)) ; too many args
+  (equal? (format "+++~[~s~;~r ~s~]---" 0 23) "+++23---")
+  (error? (format "+++~[~s~;~r ~s~]---" 0))
+  (equal? (format "+++~[~s~;~@r~s~]---" 1 23 '*) "+++XXIII*---")
+  (error? (format "+++~[~s~;~@r~s~]---" 1 23))
+  (equal? (format "+++~[~]---" 1) "+++---")
+)
+
+(mat format-tabulate
+  (error? (format "~-7t***"))
+  (error? (format "~8,'xt"))
+  (error? (format "~8,-3t"))
+  (error? (format "~8,5,4t"))
+  (error? (format "~-7@t***"))
+  (error? (format "~8,'x@t"))
+  (error? (format "~8,-3@t"))
+  (error? (format "~8,5,4@t"))
+  (equal? (format "~t***") " ***")
+  (equal? (format "x~t***") "x ***")
+  (equal? (format "~,3t***") " ***")
+  (equal? (format "xxxx~,3t***") "xxxx   ***")
+  (equal? (format "xxxx~1,3t***") "xxxx   ***")
+  (equal? (format "~0t***") " ***")
+  (equal? (format "~1t***") " ***")
+  (equal? (format "~2t***") "  ***")
+  (equal? (format "~7t***") "       ***")
+  (equal? (format "~0,0t***") "***")
+  (equal? (format "~1,0t***") " ***")
+  (equal? (format "~2,0t***") "  ***")
+  (equal? (format "~7,0t***") "       ***")
+  (equal? (format "~0,8t***") "        ***")
+  (equal? (format "~1,8t***") " ***")
+  (equal? (format "~2,8t***") "  ***")
+  (equal? (format "~7,8t***") "       ***")
+  (equal? (format "~8,8t***") "        ***")
+  (equal? (format "~9,8t***") "         ***")
+  (equal? (format "x~0t***") "x ***")
+  (equal? (format "x~1t***") "x ***")
+  (equal? (format "x~2t***") "x ***")
+  (equal? (format "x~7t***") "x      ***")
+  (equal? (format "x~0,0t***") "x***")
+  (equal? (format "x~1,0t***") "x***")
+  (equal? (format "x~2,0t***") "x ***")
+  (equal? (format "x~7,0t***") "x      ***")
+  (equal? (format "x~0,8t***") "x       ***")
+  (equal? (format "x~1,8t***") "x        ***")
+  (equal? (format "x~2,8t***") "x ***")
+  (equal? (format "x~7,8t***") "x      ***")
+  (equal? (format "x~8,8t***") "x       ***")
+  (equal? (format "x~9,8t***") "x        ***")
+  (equal? (format "xxx~7,0@tyyy") "xxx       yyy")
+  (equal? (format "xxx~7,1@tyyy") "xxx       yyy")
+  (equal? (format "xxx~7,8@tyyy") "xxx             yyy")
+)
+
+(mat format-justify
+  (equal? (format "~") "") ; not checking to make sure ~^ is at front of segment
+  (equal? (format "~") "abc")
+  (equal? (format "~:@") "abc")
+  (equal? (format "~,,1,'*:@") "*abc*")
+  (equal? (format "~10") "       abc")
+  (equal? (format "~10:") "       abc")
+  (equal? (format "~10@") "abc       ")
+  (equal? (format "~10:@") "    abc   ")
+  (equal? (format "~,8") "     abc")
+  (equal? (format "~,8") "abc    def   ghi")
+  (equal? (format "~7,8") "abc   def   ghi")
+  (equal? (format "~7,8:") "  abc  def  ghi")
+  (equal? (format "~7,8@") "abc  def  ghi  ")
+  (equal? (format "~7,8:@") "  abc def  ghi ")
+  (equal? (format "~&~7,8:@~&~&") "  abc def  ghi \n")
+  (equal? (format "~7,8,5,'*") "abc*******def*******ghi")
+  (equal? (format "~5,8,4,'*:@")
+          "*****abc*****def*****ghi*****")
+  (equal? (format "~1,8,4,'*:@")
+          "****abc****def****ghi****")
+  (equal? (format "~,,4,'*:@")
+          "****abc****def****ghi****")
+  (equal? (format "~7,8,5,'*<~%~,10:;abc~;def~;ghi~>")
+          "\nabc*******def*******ghi")
+  (equal? (format "~7,8,5,'*<~&~,10:;abc~;def~;ghi~>")
+          "abc*******def*******ghi")
+  (equal? (format "~7,8,5,'*<~%~,25:;abc~;def~;ghi~>")
+          "abc*******def*******ghi")
+  (equal? (format "~7,8,5,'*<~%~2,25:;abc~;def~;ghi~>")
+          "abc*******def*******ghi")
+  (equal? (format "~7,8,5,'*<~%~3,25:;abc~;def~;ghi~>")
+          "\nabc*******def*******ghi")
+  (equal? (format "~7,8,5,'*<~%~:;abc~;def~;ghi~>")
+          "abc*******def*******ghi")
+  (equal? (format "~72,,,'-<~%~:;abc~;def~;ghi~>")
+          "abc--------------------------------def-------------------------------ghi")
+  (equal? (format "~73,,,'-<~%~:;abc~;def~;ghi~>")
+          "\nabc--------------------------------def--------------------------------ghi")
+  (equal? (format "~73,,,'-:@<~%~:;abc~;def~;ghi~>")
+          "\n----------------abc----------------def----------------ghi----------------")
+  (equal? (format "~10<~^~a~;~^~a~>" "abc" "def") "abc    def")
+  (equal? (format "~10<~^~a~;~^~a~>" "abc") "       abc")
+  (equal? (format "~10<~^~a~;~^~a~>") "          ")
+  (equal? (format "~10<~^~a~,9:;~a~;~a~>" "\n" "1" "2") "\n1        2")
+  (equal? (format "~10<~^~a~,9:;~a~;~a~>") "          ")
+  (equal? (format "~10<~^~a~,9:;~a~;~^~a~>" "\n" "1" "2") "\n1        2")
+  (equal? (format "~10<~^~a~,9:;~a~;~^~a~;~a~>" "\n" "1" "2" "3")
+          "\n1    2   3")
+  (error? (format "~10<~^~a~,9:;~a~;~^~a~;~a~>" "\n" "1" "2"))
+  (equal? (format "~10<~^~a~,9:;~a~;~^~a~;~a~>" "\n" "1") "\n         1")
+  (error? (format "~10<~^~a~,9:;~a~;~^~a~;~a~>" "\n"))
+  (equal? (format "~10<~^~a~,9:;~a~;~^~a~;~a~>") "          ")
+  (error? (format "~10<~^~a~,9:;~a~;~a~:^~;~a~>" "\n"))
+  (error? (format "~10<~^~a~,9:;~a~;~^~^~a~;~a~>" "\n"))
+  (error? (format "~10<~^~a~,9:;~a~;~a~@^~;~a~>" "\n" "1"))
+  (error? (format "~10<~(abc~>def~)"))
+  (equal? (format "~10<~@:(abc~)~;~@(def~)~>") "ABC    Def")
+  (equal? (format "~(~10<~a~;~x~>~)" "PiEs" 221) "pies    dd")
+  (equal? (format "~13<~s~;~s~;~s~>" 3.4 4.5 5.6) "3.4  4.5  5.6")
+  (equal? (format "~16<~f~;~e~;~g~>" 3.4 4.5 5.6) "3.4  4.5e+0  5.6")
+
+ ; test nested ~<...~>
+  (equal? (format "~20g~>") "abc          de   fg")
+
+ ; from cltl2:
+  (equal? (format "~10") "foo    bar")
+  (equal? (format "~10:") "  foo  bar")
+  (equal? (format "~10") "    foobar")
+  (equal? (format "~10:") "    foobar")
+  (equal? (format "~10:@") "  foo bar ")
+  (equal? (format "~10@") "foobar    ")
+  (equal? (format "~10:@") "  foobar  ")
+  (equal? (format "~%;; ~{~<~%;; ~1:; ~s~>~^,~}.~%" '(a b c))
+          "\n;;  a, b, c.\n")
+  (equal? (format "~%;; ~{~<~%;; ~1:; ~s~>~^,~}.~%"
+            '(list-procedure stack $system-environment $active-threads
+              #{source yqrk281einmw7sg-a} $c-info placeholder
+              make-record-type join-subst trace-let set-top-level-value!
+              integer? error result make-resolved-interface
+              single->double word eleven clear-input-port reverse!
+              eighteen zero write-radix-commas? symbol-value exact->inexact
+              subst! type $apply-procedure loop/p write-radix-sign?))
+          "\n;;  list-procedure, stack, $system-environment, $active-threads,\n;;  #{source yqrk281einmw7sg-a}, $c-info, placeholder, make-record-type,\n;;  join-subst, trace-let, set-top-level-value!, integer?, error,\n;;  result, make-resolved-interface, single->double, word, eleven,\n;;  clear-input-port, reverse!, eighteen, zero, write-radix-commas?,\n;;  symbol-value, exact->inexact, subst!, type, $apply-procedure,\n;;  loop/p, write-radix-sign?.\n")
+  (equal? (format "~%;; ~{~<~%;; ~1,50:; ~s~>~^,~}.~%"
+            '(list-procedure stack $system-environment $active-threads
+              #{source yqrk281einmw7sg-a} $c-info placeholder
+              make-record-type join-subst trace-let set-top-level-value!
+              integer? error result make-resolved-interface
+              single->double word eleven clear-input-port reverse!
+              eighteen zero write-radix-commas? symbol-value exact->inexact
+              subst! type $apply-procedure loop/p write-radix-sign?))
+          "\n;;  list-procedure, stack, $system-environment,\n;;  $active-threads, #{source yqrk281einmw7sg-a},\n;;  $c-info, placeholder, make-record-type,\n;;  join-subst, trace-let, set-top-level-value!,\n;;  integer?, error, result,\n;;  make-resolved-interface, single->double, word,\n;;  eleven, clear-input-port, reverse!, eighteen,\n;;  zero, write-radix-commas?, symbol-value,\n;;  exact->inexact, subst!, type,\n;;  $apply-procedure, loop/p, write-radix-sign?.\n")
+  (equal? (format "~&;; ~{~<~%~&;; ~1:; ~s~>~^,~}.~&"
+            '(list-procedure stack $system-environment $active-threads
+              #{source yqrk281einmw7sg-a} $c-info placeholder
+              make-record-type join-subst trace-let set-top-level-value!
+              integer? error result make-resolved-interface
+              single->double word eleven clear-input-port reverse!
+              eighteen zero write-radix-commas? symbol-value exact->inexact
+              subst! type $apply-procedure loop/p write-radix-sign?))
+          ";;  list-procedure, stack, $system-environment, $active-threads,\n;;  #{source yqrk281einmw7sg-a}, $c-info, placeholder, make-record-type,\n;;  join-subst, trace-let, set-top-level-value!, integer?, error,\n;;  result, make-resolved-interface, single->double, word, eleven,\n;;  clear-input-port, reverse!, eighteen, zero, write-radix-commas?,\n;;  symbol-value, exact->inexact, subst!, type, $apply-procedure,\n;;  loop/p, write-radix-sign?.\n")
+  (equal? (format "~15<~s~;~^~s~;~^~s~>" 'foo) "            foo")
+  (equal? (format "~15<~s~;~^~s~;~^~s~>" 'foo 'bar) "foo         bar")
+  (equal? (format "~15<~s~;~^~s~;~^~s~>" 'foo 'bar 'baz) "foo   bar   baz")
+)
+
+(mat format-iterate
+  (error? (format "~{abc~:~}")) ; ~ directive has no : flag
+  (error? (format "~{abc~;~}")) ; misplaced directive "~;"
+
+ ; ~{...}
+  (error? (format "~{|~s~}")) ; too few args
+;  (error? (format "~{|~s~}" '() "$")) ; too many args
+  (equal? (format "~{|~s~}" '()) "")
+  (equal? (format "~a~{|~s~}~a" "^" '(a b c) "$") "^|a|b|c$")
+  (equal? (format "~a~{|~s~:}~a" "^" '(a b c) "$") "^|a|b|c$")
+  (equal? (format "~a~{abc~:}~a" "^" '() "$") "^abc$")
+  (equal? (format "~a~2{|~s~:}~a" "^" '(a b c) "$") "^|a|b$")
+  (error? (format "~a~2{|~s~:}~a" "^" '() "$")) ; too few args
+  (equal? (format "+~{<~s~^~s>~}+~{<~s~^~s>~}+" '(a b c d) '(a b c))
+          "++~}+~{<~s~^~s>~}+" '(a b c d) '(a b c))
+          "++~}+~{<~s~:^~s>~}+" '(a b c d) '(a b c))) ; too few args
+  (equal? (format "~a~{~}~a"
+            "^"
+            "+~{<~s~^~s>~}+"
+            '((a b c d) (a b c) () (a))
+            "$")
+          "^+++~}+"
+            '((a b c d) (a b c) () (a))
+            "$")) ; too few args for "+~{<~s~s>~}+"
+
+ ; ~:{...}
+  (error? (format "~:{|~s~}")) ; too few args
+;  (error? (format "~:{|~s~}" '() "$")) ; too many args
+  (equal? (format "~:{|~s~}" '()) "")
+  (equal? (format "~a~:{|~s~}~a" "^" '((a) (b) (c)) "$") "^|a|b|c$")
+  (equal? (format "~a~:{|~s~:}~a" "^" '((a) (b) (c)) "$") "^|a|b|c$")
+  (equal? (format "~a~:{abc~:}~a" "^" '() "$") "^abc$")
+  (equal? (format "~a~2:{|~s~:}~a" "^" '((a) (b) (c)) "$") "^|a|b$")
+  (equal? (format "~:{<~s~^~s>~:}" '((a b) (c) (e f))) "")
+  (equal? (format "~:{<~s~:^~s>~:}" '((a b) (c d) (e f))) "" '() "$") "^$")
+  (error? (format "~a~:{~}~a" "^" "<~s~:^~s>" '(a b) "$")) ; a is not a pair
+  (equal? (format "~a~:{~}~a" "^" "<~s~^~s>" '((a b)) "$") "^$")
+  (equal? (format "~a~:{~}~a" "^" "<~s~:^~s>" '((a b)) "$") "^" '((a b c)) "$")) ; too many args for "<~s~^~s>"
+
+  (equal? (format "~a~:{~}~a" "^" "<~s~^~s>" '((a b) (c)) "$") "^" '((a b) (c) (d e)) "$")) ; too few args for "<~s~:^~s>" 
+  (equal? (format "~a~:{~}~a" "^" "<~s~:^~s>" '((a b) (c d)) "$") "^~}" 'a 'b 'c 'd) "")
+  (equal? (format "~@{<~s~^~s>~}" 'a 'b 'c 'd 'e) "~}" 'a 'b 'c 'd) "")
+  (error? (format "~@{<~s~:^~s>~}" 'a 'b 'c 'd 'e)) ; too few args
+
+ ; ~@:{...}
+  (equal? (format "~@:{|~s~}") "")
+  (equal? (format "~@:{|~s~}" '(a) '(b) '(c)) "|a|b|c")
+  (equal? (format "~@:{|~s~:}" '(a) '(b) '(c)) "|a|b|c")
+  (equal? (format "~@:{abc~:}") "abc")
+  (equal? (format "~2@:{|~s~:}~s" '(a) '(b) '(c)) "|a|b(c)")
+  (equal? (format "~@:{<~s~^~s>~:}" '(a b) '(c) '(e f)) "")
+  (equal? (format "~@:{<~s~:^~s>~:}" '(a b) '(c d) '(e f)) "" '(a b) '(c d) '(e f)) "~}." '(a 1 b 2 c 3))
+          "Pairs:   .")
+  (equal? (format "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3)))
+          "Pairs:   .")
+  (equal? (format "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3)
+          "Pairs:   .")
+  (equal? (format "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3))
+          "Pairs:   .")
+
+  (equal? (format "~1{~:}" "a ~b c" '(5)) "a 101 c")
+  (equal? (format "~1{~:}" "a ~b c" '(5))
+          (apply format "a ~b c" '(5)))
+
+ ; ~^ tests from cltl2
+  (equal? (format "~:{/~s~^ ...~}"
+                  '((hot dog) (hamburger) (ice cream) (french fries)))
+          "/hot .../hamburger/ice .../french ...")
+  (equal? (format "~:{/~s~:^ ...~}"
+                  '((hot dog) (hamburger) (ice cream) (french fries)))
+          "/hot .../hamburger .../ice .../french")
+ ; this one appears not to be supported by cltl text, but it's one of
+ ; the examples
+  (equal? (format "~:{/~s~#:^ ...~}"
+                  '((hot dog) (hamburger) (ice cream) (french fries)))
+          "/hot .../hamburger")
+ ; was all screwed up in cltl2, and didn't illustrate ~^ within
+ ; ~[...~] as advertised:
+  ; (begin (define tellstr "~@{~@[~R~]~^ ~A.~}") (string? tellstr))
+  ; (equal? (format tellstr 23) "Twenty-three.")
+  ; (equal? (format tellstr #f "losers") "losers.")
+  ; (equal? (format tellstr 23 "losers") "Twenty-three losers.")
+ ; probably meant something more like this:
+  (begin (define tellstr "~@{~@[~R~^ ~]~A~}.") (string? tellstr))
+  (equal? (format tellstr 23) "twenty-three.")
+  (equal? (format tellstr #f "losers") "losers.")
+  (equal? (format tellstr 23 "losers") "twenty-three losers.")
+)
+
+(mat format-goto
+  (error? (format "~*"))
+  (error? (format "~s ~*" 0))
+  (equal? (format "~*~s" 0 1) "1")
+;  (error? (format "~0*~s" 0 1)) ; too many args
+  (error? (format "~2*~s" 0 1))
+  (error? (format "~3*~s" 0 1))
+  (error? (format "~-3*~s" 0 1))
+;  (error? (format "~s ~:*" 0)) ; too many args
+  (equal? (format "~s~:*~s" 0) "00")
+  (error? (format "~s~2:*~s" 0))
+  (error? (format "~s~0:*~s" 0))
+  (error? (format "~s~:@*~s" 0))
+  (error? (format "~s~@:*~s" 0))
+  (error? (format "~:*"))
+  (error? (format "~:* ~s" 0))
+  (equal? (format "~@*") "")
+;  (error? (format "~s~@*" 0)) ; too many args
+;  (error? (format "~@*" 0)) ; too many args
+  (equal? (format "~s~:*~s~s~s~2:*~s~3*~s~@*~s~s~1@*~s~5@*~s" 'a 'b 'c 'd 'e 'f)
+          "aabcbfabbf")
+  (equal? (format "~s~?~:*~s~s" '< "~s~s~:*~s~*~s" '(a b c d) '>)
+          "")
+  (equal? (format "~s~@?~:*~s~s" '< "~s~s~:*~s~*~s" 'a 'b 'c 'd '>)
+          "")
+)
+
+(mat format-radix
+  (equal? (format "~d" 3) "3")
+  (equal? (format "~3d" 1) "  1")
+  (equal? (format "~:d" 12345) "12,345")
+  (equal? (format "~:@d" 12345) "+12,345")
+  (equal? (format "~@:d" 12345) "+12,345")
+  (equal? (format "~:d" -12345) "-12,345")
+  (equal? (format "~:@d" -12345) "-12,345")
+  (equal? (format "~@:d" -12345) "-12,345")
+  (equal? (format "~:b" #b10110110101) "10,110,110,101")
+  (equal? (format "~20,'q,'%,4:@b" #b10110110101) "qqqqqq+101%1011%0101")
+  (equal? (format "~,,' ,4b" #xface) "1111101011001110") ; cltl2 example: "1111 1010 1100 1110"
+  (equal? (format "~,,' ,4:b" #xface) "1111 1010 1100 1110")
+  (equal? (format "~19,,' ,4:b" #x1ce) "        1 1100 1110") ; cltl2 example: "0000 0001 1100 1110"
+  (equal? (format "~x" #x1ce) "1CE")
+  (equal? (format "#o~:o" #o1234567076543210) "#o1,234,567,076,543,210")
+  (equal? (format "~36r" 35) "Z")
+  (equal? (format "~36,10r and ~26r" #36rzeus #26rapollo)
+          "      ZEUS and APOLLO")
+  (equal? (format "~,10r" -1234567) "  -1234567")
+  (equal? (format "~3,20,'*,'|,2:@r" #3r20202020) "********+20|20|20|20")
+  (equal? (format "~10d" '(a 10 c)) "  (a 10 c)")
+  (equal? (format "~10x" '(10 11 12)) "   (A B C)")
+  (equal? (format "~36,10,'*r" '(10 20 30)) "***(A K U)")
+)
+
+(mat format-roman
+  (equal? (format "~@r ~@r ~@r" 1999 -1999 4000) "MCMXCIX -1999 4000")
+  (equal? (format "~@r ~@r ~@r" 3999 3998 347) "MMMCMXCIX MMMCMXCVIII CCCXLVII")
+  (equal? (format "~@r" 2599) "MMDXCIX")
+  (equal? (format "~@r" 4736) "4736")
+  (equal? (format "~@r" 1782) "MDCCLXXXII")
+  (equal? (format "~@r" 2251) "MMCCLI")
+  (equal? (format "~@r" 1009) "MIX")
+  (equal? (format "~@r" 544) "DXLIV")
+  (equal? (format "~@r" 7) "VII")
+  (equal? (format "~@r" 5) "V")
+)
+
+(mat format-old-roman
+  (equal? (format "~@:r ~@:r ~@:r" 1999 -1999 5000)
+          "MDCCCCLXXXXVIIII -1999 5000")
+  (equal? (format "~@:r ~@:r ~@:r" 4999 4998 347)
+          "MMMMDCCCCLXXXXVIIII MMMMDCCCCLXXXXVIII CCCXXXXVII")
+  (equal? (format "~@:r" 2599) "MMDLXXXXVIIII")
+  (equal? (format "~@:r" 4736) "MMMMDCCXXXVI")
+  (equal? (format "~@:r" 1782) "MDCCLXXXII")
+  (equal? (format "~@:r" 2251) "MMCCLI")
+  (equal? (format "~@:r" 1009) "MVIIII")
+  (equal? (format "~@:r" 544) "DXXXXIIII")
+  (equal? (format "~@:r" 7) "VII")
+  (equal? (format "~@:r" 5) "V")
+)
+
+(mat format-cardinal
+  (equal? (format "~r" 1000000000) "1,000,000,000")
+  (equal? (format "~r" 1000000001) "1,000,000,001")
+  (equal? (format "~r" -2) "minus two")
+  (equal? (format "~r" -1023) "minus one thousand twenty-three")
+  (equal? (format "~r" 999999999) "nine hundred ninety-nine million nine hundred ninety-nine thousand nine hundred ninety-nine")
+  (equal? (format "~r" -954321098) "minus nine hundred fifty-four million three hundred twenty-one thousand ninety-eight")
+  (equal? (format "~r" 2599) "two thousand five hundred ninety-nine")
+  (equal? (format "~r" 4736) "four thousand seven hundred thirty-six")
+  (equal? (format "~r" -4730) "minus four thousand seven hundred thirty")
+  (equal? (format "~r" -4719) "minus four thousand seven hundred nineteen")
+  (equal? (format "~r" 1782) "seventeen hundred eighty-two")
+  (equal? (format "~r" 2251) "two thousand two hundred fifty-one")
+  (equal? (format "~r" 1009) "one thousand nine")
+  (equal? (format "~r" 544) "five hundred forty-four")
+  (equal? (format "~r ~r ~r ~r ~r ~r ~r ~r ~r ~r" 0 1 2 3 4 5 6 7 8 9)
+          "zero one two three four five six seven eight nine")
+  (equal? (format "~r ~r ~r ~r ~r ~r ~r ~r ~r ~r" 10 11 12 13 14 15 16 17 18 19)
+          "ten eleven twelve thirteen fourteen fifteen sixteen seventeen eighteen nineteen")
+)
+
+(mat format-ordinal
+  (equal? (format "~:r" 1000000000) "1,000,000,000th")
+  (equal? (format "~:r" -1000000001) "-1,000,000,001st")
+  (equal? (format "~:r" -1000000002) "-1,000,000,002nd")
+  (equal? (format "~:r"   1000000003)   "1,000,000,003rd")
+  (equal? (format "~:r" 300000000004) "300,000,000,004th")
+  (equal? (format "~:r" 700000000008) "700,000,000,008th")
+  (equal? (format "~:r" 800000000010) "800,000,000,010th")
+  (equal? (format "~:r" 800000000011) "800,000,000,011th")
+  (equal? (format "~:r" 800000000012) "800,000,000,012th")
+  (equal? (format "~:r" 800000000013) "800,000,000,013th")
+  (equal? (format "~:r" 800000000019) "800,000,000,019th")
+  (equal? (format "~:r" 800000000021) "800,000,000,021st")
+  (equal? (format "~:r" 800000000073) "800,000,000,073rd")
+  (equal? (format "~:r" -2) "minus second")
+  (equal? (format "~:r" -1023) "minus one thousand twenty-third")
+  (equal? (format "~:r" 999999999) "nine hundred ninety-nine million nine hundred ninety-nine thousand nine hundred ninety-ninth")
+  (equal? (format "~:r" 999000000) "nine hundred ninety-nine millionth")
+  (equal? (format "~:r" -999000000) "minus nine hundred ninety-nine millionth")
+  (equal? (format "~:r" 912304000) "nine hundred twelve million three hundred four thousandth")
+  (equal? (format "~:r" 912004000) "nine hundred twelve million four thousandth")
+  (equal? (format "~:r" -312001900) "minus three hundred twelve million nineteen hundredth")
+  (equal? (format "~:r" 2599) "two thousand five hundred ninety-ninth")
+  (equal? (format "~:r" 4736) "four thousand seven hundred thirty-sixth")
+  (equal? (format "~:r" -4730) "minus four thousand seven hundred thirtieth")
+  (equal? (format "~:r" -4716) "minus four thousand seven hundred sixteenth")
+  (equal? (format "~:r" 1782) "seventeen hundred eighty-second")
+  (equal? (format "~:r" 2251) "two thousand two hundred fifty-first")
+  (equal? (format "~:r" 1009) "one thousand ninth")
+  (equal? (format "~:r" 544) "five hundred forty-fourth")
+  (equal? (format "~:r ~:r ~:r ~:r ~:r ~:r ~:r ~:r ~:r ~:r" 0 1 2 3 4 5 6 7 8 9)
+          "zeroth first second third fourth fifth sixth seventh eighth ninth")
+  (equal? (format "~:r ~:r ~:r ~:r ~:r ~:r ~:r ~:r ~:r ~:r" 10 11 12 13 14 15 16 17 18 19)
+          "tenth eleventh twelfth thirteenth fourteenth fifteenth sixteenth seventeenth eighteenth nineteenth")
+)
+
+(mat format-fixed1
+  (equal? (format "~8,3f" 0.0) "   0.000")
+  (equal? (format "~8,3f" -0.0) "  -0.000")
+  (equal? (format "~8,3f" 1234567.89) "1234567.890")
+  (equal? (format "~8,3f" 123456.789) "123456.789")
+  (equal? (format "~8,3f" 1.23456) "   1.235")
+  (equal? (format "~8,3f" 1.23456789) "   1.235")
+  (equal? (format "~8,3f" 321.23456789) " 321.235")
+  (equal? (format "~8,3f" 4321.23456789) "4321.235")
+  (equal? (format "~8,3,-2,,'zf" 0.0) "zzz0.000")
+  (equal? (format "~8,3,-2,,'zf" -0.0) "zz-0.000")
+  (equal? (format "~8,3,-2,,'0f" 4321.23456789) "0043.212")
+  (equal? (format "~8,3f" 54321.23456789) "54321.235")
+  (equal? (format "~8,3f" -1.23456789) "  -1.235")
+  (equal? (format "~8,3@f" 0.0) "  +0.000")
+  (equal? (format "~8,3@f" -0.0) "  -0.000")
+  (equal? (format "~8,3@f" 1.23456789) "  +1.235")
+  (equal? (format "~8,3f" .0023456789) "   0.002")
+  (equal? (format "~8,3f" .002) "   0.002")
+  (equal? (format "~8,3@f" 123456789) "+123456789.000")
+  (equal? (format "~8,3@f" 123456789123456789) "+12345678912345678#.###")
+  (equal? (format "~8,3f" 12345678912345678) "12345678912345678.###")
+  (equal? (format "~8,3f" 1234567891234567) "1234567891234567.0##")
+  (equal? (format "~8,3f" 12345678912345) "12345678912345.000")
+  (equal? (format "~8,3f" 1e23) "9999999999999999#######.###")
+  (equal? (format "~8,3,23f" 0.0) "   0.000")
+  (equal? (format "~8,3,23f" -0.0) "  -0.000")
+  (equal? (format "~8,3,23f" 1.0) "10000000000000000#######.###")
+  (equal? (format "~8,3f" 1e-23) "   0.000")
+  (equal? (format "~8,3,-23f" 0.0) "   0.000")
+  (equal? (format "~8,3,-23f" -0.0) "  -0.000")
+  (equal? (format "~8,3,-23f" 1.0) "   0.000")
+  (equal? (format "~8,3f" 1e-7) "   0.000")
+  (equal? (format "~8,3f" 9e-7) "   0.000")
+  (equal? (format "~8,3f" 1e-6) "   0.000")
+  (equal? (format "~8,3f" 1e-5) "   0.000")
+  (equal? (format "~8,3f" 1e-4) "   0.000")
+  (equal? (format "~8,3f" 1e-3) "   0.001")
+  (equal? (format "~8,3f" 1e-2) "   0.010")
+  (equal? (format "~8,3f" 1e-1) "   0.100")
+)
+
+(mat format-fixed2
+  (equal? (format "~10,3,2f" 3.14159)   "   314.159")
+  (equal? (format "~10,3,-1f" 3.14159)  "     0.314")
+  (equal? (format "~6,3,-1f" 3.14159)   " 0.314")
+  (equal? (format "~5,3,-1f" 3.14159)   "0.314")
+  (equal? (format "~4,3,-1f" 3.14159)   ".314")
+  (equal? (format "~3,3,-1f" 3.14159)   ".314")
+  (equal? (format "~10,3,2f" -3.14159)  "  -314.159")
+  (equal? (format "~10,3,-1f" -3.14159) "    -0.314")
+  (equal? (format "~6,3,-1f" -3.14159)  "-0.314")
+  (equal? (format "~5,3,-1f" -3.14159)  "-.314")
+  (equal? (format "~3,3,-1f" -3.14159)  "-.314")
+  (equal? (format "~6,3,-1@f" 3.14159)  "+0.314")
+  (equal? (format "~5,3,-1@f" 3.14159)  "+.314")
+  (equal? (format "~,3,-1@f" 3.14159)   "+0.314")
+  (equal? (format "~,3,-8f" 3.14159)    "0.000")
+  (equal? (format "~4,3,-8f" 3.14159)   ".000")
+)
+
+(mat format-fixed3
+  (equal? (format "~10,,2f" 3.14159)  "   314.159")
+  (equal? (format "~10,,-1f" 3.14159) "  0.314159")
+  (equal? (format "~8,,-1f" 3.14159)  "0.314159")
+  (equal? (format "~7,,-1f" 3.14159)  ".314159")
+  (equal? (format "~6,,-1f" 3.14159)  ".31416")
+  (equal? (format "~5,,-1f" 3.14159)  ".3142")
+  (equal? (format "~4,,-1f" 3.14159)  ".314")
+  (equal? (format "~3,,-1f" 3.14159)  ".31")
+  (equal? (format "~2,,-1f" 3.14159)  ".3")
+  (equal? (format "~1f" .314159)      ".3")
+  (equal? (format "~1,,-1f" 3.14159)  ".3")
+  (equal? (format "~0,,-1f" 3.14159)  ".3")
+
+  (equal? (format "~0,,5f" 3.14159)  "314159.")
+
+  (equal? (format "~5f" -231.2) "-231.")
+  (equal? (format "~5f" 231.2)  "231.2")
+  (equal? (format "~5f" -23.12) "-23.1")
+  (equal? (format "~5f" 23.12)  "23.12")
+  (equal? (format "~5f" -23.1)  "-23.1")
+  (equal? (format "~5f" -231)   "-231.")
+  (equal? (format "~5f" -2.31)  "-2.31")
+  (equal? (format "~5f" -2310)  "-2310.")
+  (equal? (format "~5f" 1e23)   "9999999999999999#######.")
+
+  (equal? (format "~5,,1f" -231.2) "-2312.")
+  (equal? (format "~5,,1f" 231.2)  "2312.")
+  (equal? (format "~5,,1f" -23.12) "-231.")
+  (equal? (format "~5,,1f" 23.12)  "231.2")
+  (equal? (format "~5,,1f" -23.1)  "-231.")
+  (equal? (format "~5,,1f" -231)   "-2310.")
+  (equal? (format "~5,,1f" -2.31)  "-23.1")
+  (equal? (format "~5,,1f" -2310)  "-23100.")
+  (equal? (format "~5,,1f" 1e23)   "9999999999999999########.")
+
+  (equal? (format "~5,,-1f" -231.2) "-23.1")
+  (equal? (format "~5,,-1f" 231.2)  "23.12")
+  (equal? (format "~5,,-1f" -23.12) "-2.31")
+  (equal? (format "~5,,-1f" 23.12)  "2.312")
+  (equal? (format "~5,,-1f" -23.1)  "-2.31")
+  (equal? (format "~5,,-1f" -231)   "-23.1")
+  (equal? (format "~5,,-1f" -2.31)  "-.231")
+  (equal? (format "~5,,-1f" -2310)  "-231.")
+  (equal? (format "~5,,-1f" 1e23)   "9999999999999999######.")
+
+  (equal? (format "~,,1f" 3.14159) "31.4159")
+  (equal? (format "~,,5f" 3.14159) "314159.0")
+  (equal? (format "~,,10f" 3.14159) "31415900000.0")
+  (equal? (format "~,,-1f" 3.14159) "0.314159")
+  (equal? (format "~,,-2f" 3.14159) "0.0314159")
+)
+
+(mat format-fixed4
+  (equal? (format "~8f" 0.0) "     0.0")
+  (equal? (format "~8f" -0.0) "    -0.0")
+  (equal? (format "~8@f" 0.0) "    +0.0")
+  (equal? (format "~8@f" -0.0) "    -0.0")
+  (equal? (format "~8f" 1234567.89) "1234568.")
+  (equal? (format "~8f" 123456.789) "123456.8")
+  (equal? (format "~8f" 1.23456) " 1.23456")
+  (equal? (format "~8f" 1.23456789) "1.234568")
+  (equal? (format "~8f" 321.23456789) "321.2346")
+  (equal? (format "~8f" 4321.23456789) "4321.235")
+  (equal? (format "~8f" 54321.23456789) "54321.23")
+  (equal? (format "~8f" -1.23456789) "-1.23457")
+  (equal? (format "~8@f" 1.23456789) "+1.23457")
+  (equal? (format "~8f" .0023456789) ".0023457")
+  (equal? (format "~8f" .002) "   0.002")
+  (equal? (format "~8@f" 123456789) "+123456789.")
+  (equal? (format "~8@f" 123456789123456789) "+12345678912345678#.")
+  (equal? (format "~8f" 12345678912345678) "12345678912345678.")
+  (equal? (format "~8f" 1234567891234567) "1234567891234567.")
+  (equal? (format "~8f" 12345678912345) "12345678912345.")
+  (equal? (format "~8f" 1e23) "9999999999999999#######.")
+  (equal? (format "~8f" 1e-23) "     0.0")
+  (equal? (format "~8f" 1e-8)  "     0.0")
+  (equal? (format "~8f" 1e-7)  ".0000001")
+  (equal? (format "~8f" 9e-7)  ".0000009")
+  (equal? (format "~8f" 1e-6)  "0.000001")
+  (equal? (format "~7f" 9e-7)  ".000001")
+  (equal? (format "~7f" 1e-6)  ".000001")
+  (equal? (format "~6f" 9e-9)  "   0.0")
+  (equal? (format "~6f" 9e-7)  "   0.0")
+  (equal? (format "~6f" 1e-6)  "   0.0")
+  (equal? (format "~6f" 1e-5)  ".00001")
+
+  (equal? (format "~6f" 1.0)      "   1.0")
+  (equal? (format "~6f" 10.0)     "  10.0")
+  (equal? (format "~6f" 100.0)    " 100.0")
+  (equal? (format "~6f" 1e3)      "1000.0")
+  (equal? (format "~6f" 123.0)    " 123.0")
+  (equal? (format "~6f" 1234.0)   "1234.0")
+  (equal? (format "~6f" 12345.0)  "12345.")
+  (equal? (format "~6f" 123456.0) "123456.")
+  (equal? (format "~6f" 10000.0)  "10000.")
+  (equal? (format "~6,,1f" 1e3)   "10000.")
+  (equal? (format "~5,,1f" 1e3)   "10000.")
+  (equal? (format "~7f" -1.0)      "   -1.0")
+  (equal? (format "~7f" -10.0)     "  -10.0")
+  (equal? (format "~7f" -100.0)    " -100.0")
+  (equal? (format "~7f" -1e3)      "-1000.0")
+  (equal? (format "~7f" -123.0)    " -123.0")
+  (equal? (format "~7f" -1234.0)   "-1234.0")
+  (equal? (format "~7f" -12345.0)  "-12345.")
+  (equal? (format "~7f" -123456.0) "-123456.")
+  (equal? (format "~7f" -10000.0)  "-10000.")
+  (equal? (format "~7,,1f" -1e3)   "-10000.")
+  (equal? (format "~6,,1f" -1e3)   "-10000.")
+)
+
+(mat format-fixed5
+  (equal? (format "~f" 0.0) "0.0")
+  (equal? (format "~f" -0.0) "-0.0")
+  (equal? (format "~@f" 0.0) "+0.0")
+  (equal? (format "~@f" -0.0) "-0.0")
+  (equal? (format "~f" 1234567.89) "1234567.89")
+  (equal? (format "~f" 123456.789) "123456.789")
+  (equal? (format "~f" 1.23456) "1.23456")
+  (equal? (format "~f" 1.23456789) "1.23456789")
+  (equal? (format "~f" 321.23456789) "321.23456789")
+  (equal? (format "~f" 4321.23456789) "4321.23456789")
+  (equal? (format "~f" 54321.23456789) "54321.23456789")
+  (equal? (format "~f" -1.23456789) "-1.23456789")
+  (equal? (format "~@f" 1.23456789) "+1.23456789")
+  (equal? (format "~f" .0023456789) "0.0023456789")
+  (equal? (format "~f" .002) "0.002")
+  (equal? (format "~@f" 123456789) "+123456789.0")
+  (equal? (format "~@f" 123456789123456789) "+12345678912345678#.#")
+  (equal? (format "~f" 12345678912345678) "12345678912345678.#")
+  (equal? (format "~f" 1234567891234567) "1234567891234567.0")
+  (equal? (format "~f" 12345678912345) "12345678912345.0")
+  (equal? (format "~f" 1e23) "9999999999999999#######.#")
+  (equal? (format "~f" 1e-23) "0.00000000000000000000001")
+  (equal? (format "~f" 1e-7) "0.0000001")
+  (equal? (format "~f" 9e-7) "0.0000009")
+  (equal? (format "~f" 1e-6) "0.000001")
+)
+
+(mat format-fixed6
+  (equal? (format "~2,1@f" 0.003) "+.0")
+  (equal? (format "~2@f" 0.003) "+.0")
+  (equal? (format "~2@f" 1.34) "+1.")
+  (equal? (format "~2,1@f" 1.34) "+1.3")
+  (equal? (format "~2,2@f" 1.34) "+1.34")
+  (equal? (format "~0f" 1e23) "9999999999999999#######.")
+  (equal? (format "~0f" 1e-23) ".0")
+  (equal? (format "~0f" -1e-23) "-.0")
+  (equal? (format "~0f" 0.0) "0.")
+  (equal? (format "~0f" -0.0) "-0.")
+)
+
+(mat format-fixed7
+  (equal? (format "~2,1,,'*@f" 0.0) "**")
+  (equal? (format "~2,1,,'*@f" -0.0) "**")
+  (equal? (format "~2,1,,'*@f" 0.003) "**")
+  (equal? (format "~2,,,'*,@f" 0.003) "**")
+  (equal? (format "~4,2,,'*@f" 1.34) "****")
+  (equal? (format "~2,1,4,'q,'p@f" 0.0) "qq")
+  (equal? (format "~2,1,4,'q,'p@f" -0.0) "qq")
+  (equal? (format "~2,1,4,'q,'p@f" 1.34) "qq")
+  (equal? (format "~10,1,4,'q,'p@f" 0.0) "pppppp+0.0")
+  (equal? (format "~10,1,4,'q,'p@f" -0.0) "pppppp-0.0")
+  (equal? (format "~10,1,4,'q,'p@f" 1.34) "pp+13400.0")
+  (equal? (format "~10,1,-4,'q,'p@f" 1.34) "pppppp+0.0")
+  (equal? (format "~10,5,-4,'q,'p@f" 1.34) "pp+0.00013")
+  (equal? (format "~10,6,-4,'q,'p@f" 1.34) "p+0.000134")
+  (equal? (format "~10,6,-4,'q,'p@f" 0.0) "p+0.000000")
+  (equal? (format "~10,6,-4,'q,'p@f" -0.0) "p-0.000000")
+  (equal? (format "~2,2,,'q,'p@f" 1.34) "qq")
+  (equal? (format "~10,2,,'q,'p@f" 1.34) "ppppp+1.34")
+  (equal? (format "~0,,,'*f" 1e23) "")
+  (equal? (format "~0,,,'*f" 1e-23) "")
+  (equal? (format "~0,,,'*f" -1e-23) "")
+)
+
+(mat format-fixed8
+  (let () ; example adapted from cltl2
+    (define (foo x)
+      (format "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F"
+        x x x x x x))
+    (and (equal? (foo 3.14159)  "  3.14| 31.42|  3.14|3.1416|3.14|3.14159")
+         (equal? (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159")
+         (equal? (foo 100.0)    "100.00|******|100.00| 100.0|100.00|100.0")
+         (equal? (foo 1234.0)   "1234.00|******|??????|1234.0|1234.00|1234.0")
+         (equal? (foo 0.006)    "  0.01|  0.06|  0.01| 0.006|0.01|0.006")
+         (equal? (foo 0.0)      "  0.00|  0.00|  0.00|   0.0|0.00|0.0")
+         (equal? (foo -0.0)     " -0.00| -0.00| -0.00|  -0.0|-0.00|-0.0")))
+)
+
+(mat format-exp1
+  (equal? (format "~10,5,,2e" 0.0)        " 0.0000e+0")
+  (equal? (format "~10,5,,2e" -0.0)       "-0.0000e+0")
+  (equal? (format "~9,5,,2e" 0.0)         "0.0000e+0")
+  (equal? (format "~9,5,,2e" -0.0)        "-.0000e+0")
+  (equal? (format "~10,5,,2e" 3.14159)    "31.4159e-1")
+  (equal? (format "~10,0e" 3.4e-200)      "   3.e-200")
+  (equal? (format "~10,3,2,0e" 123456789) " 0.123e+09")
+  (equal? (format "~9,3,2,0e" 123456789)  "0.123e+09")
+  (equal? (format "~8,3,2,0e" 0.0)        ".000e+00")
+  (equal? (format "~8,3,2,0e" -0.0)       "-.000e+00")
+  (equal? (format "~8,3,2,0e" 123456789)  ".123e+09")
+  (equal? (format "~7,3,2,0e" 123456789)  ".123e+09")
+  (equal? (format "~3,3,2,0e" 123456789)  ".123e+09")
+)
+
+(mat format-exp2
+  (equal? (format "~10e" 0.0)      "    0.0e+0")
+  (equal? (format "~10e" -0.0)     "   -0.0e+0")
+  (equal? (format "~10e" 3.4)      "    3.4e+0")
+  (equal? (format "~10e" 3.4e10)   "   3.4e+10")
+  (equal? (format "~10e" 3.4e-10)  "   3.4e-10")
+  (equal? (format "~10e" 3.4e-200) "  3.4e-200")
+
+  (equal? (format "~10,,,2e" 0.0)       "    0.0e+0")
+  (equal? (format "~10,,,2e" -0.0)      "   -0.0e+0")
+  (equal? (format "~10,,,2e" 3.4e-200)  " 34.0e-201")
+  (equal? (format "~10,,,3e" 3.4e-200)  "340.0e-202")
+  (equal? (format "~10,,,-2e" 0.0)      "    0.0e+0")
+  (equal? (format "~10,,,-2e" -0.0)     "   -0.0e+0")
+  (equal? (format "~10,,,-2e" 3.4e-200) "0.003e-197")
+
+  (equal? (format "~10@e" 3.6e99) "  +3.6e+99")
+  (equal? (format "~9@e" 3.6e99)  " +3.6e+99")
+  (equal? (format "~8@e" 3.6e99)  "+3.6e+99")
+  (equal? (format "~7@e" 3.6e99)  "+4.e+99")
+  (equal? (format "~6@e" 3.6e99)  "+4.e+99")
+  (equal? (format "~5@e" 3.6e99)  "+4.e+99")
+  (equal? (format "~0@e" 3.6e99)  "+4.e+99")
+
+  (equal? (format "~9@e" 0.0)  "  +0.0e+0")
+  (equal? (format "~7@e" 0.0)  "+0.0e+0")
+  (equal? (format "~6@e" 0.0)  "+0.e+0")
+  (equal? (format "~0@e" 0.0)  "+0.e+0")
+  (equal? (format "~9@e" -0.0) "  -0.0e+0")
+  (equal? (format "~7@e" -0.0) "-0.0e+0")
+  (equal? (format "~6@e" -0.0) "-0.e+0")
+  (equal? (format "~0@e" -0.0) "-0.e+0")
+
+  (equal? (format "~9,,,0@e" 0.0)  "  +0.0e+0")
+  (equal? (format "~7,,,0@e" 0.0)  "+0.0e+0")
+  (equal? (format "~6,,,0@e" 0.0)  "+.0e+0")
+  (equal? (format "~0,,,0@e" 0.0)  "+.0e+0")
+  (equal? (format "~9,,,0@e" -0.0) "  -0.0e+0")
+  (equal? (format "~7,,,0@e" -0.0) "-0.0e+0")
+  (equal? (format "~6,,,0@e" -0.0) "-.0e+0")
+  (equal? (format "~0,,,0@e" -0.0) "-.0e+0")
+
+  (equal? (format "~10e" 9.999e9) "  9.999e+9")
+  (equal? (format "~9e" 9.999e9)  " 9.999e+9")
+  (equal? (format "~8e" 9.999e9)  "9.999e+9")
+  (equal? (format "~7e" 9.999e9)  "1.0e+10")
+  (equal? (format "~6e" 9.999e9)  "1.e+10")
+  (equal? (format "~5e" 9.999e9)  "1.e+10")
+  (equal? (format "~0e" 9.999e9)  "1.e+10")
+
+  (equal? (format "~10e" 9.999e-10) " 9.999e-10")
+  (equal? (format "~9e" 9.999e-10)  "9.999e-10")
+  (equal? (format "~8e" 9.999e-10)  "  1.0e-9")
+  (equal? (format "~7e" 9.999e-10)  " 1.0e-9")
+  (equal? (format "~6e" 9.999e-10)  "1.0e-9")
+  (equal? (format "~5e" 9.999e-10)  "1.e-9")
+  (equal? (format "~2e" 9.999e-10)  "1.e-9")
+
+  (equal? (format "~10e" 1e23)      "   1.0e+23")
+)
+
+(mat format-exp3
+  (equal? (format "~e" 0.0) "0.0e+0")
+  (equal? (format "~e" -0.0) "-0.0e+0")
+  (equal? (format "~e" 1e23) "1.0e+23")
+  (equal? (format "~e" .000345) "3.45e-4")
+  (equal? (format "~e" 345) "3.45e+2")
+  (equal? (format "~e" 345e20) "3.45e+22")
+  (equal? (format "~,,3,e" 0.0) "0.0e+000")
+  (equal? (format "~,,3,e" -0.0) "-0.0e+000")
+  (equal? (format "~,,3,e" 1e23) "1.0e+023")
+  (equal? (format "~,,3,3e" 0.0) "0.0e+000")
+  (equal? (format "~,,3,3e" -0.0) "-0.0e+000")
+  (equal? (format "~,,3,3e" 1e23) "100.0e+021")
+  (equal? (format "~,,,3e" 0.0) "0.0e+0")
+  (equal? (format "~,,,3e" -0.0) "-0.0e+0")
+  (equal? (format "~,,,3e" 1e23) "100.0e+21")
+  (equal? (format "~,,,3e" 3.14159) "314.159e-2")
+  (equal? (format "~,,2,3e" 3.14159) "314.159e-02")
+  (equal? (format "~,,2,3@e" 3.14159) "+314.159e-02")
+  (equal? (format "~,,,-3e" 0.0) "0.0e+0")
+  (equal? (format "~,,,-3e" -0.0) "-0.0e+0")
+  (equal? (format "~,,,-3e" -3.14159) "-0.000314159e+4")
+  (equal? (format "~0e" 0.0) "0.e+0")
+  (equal? (format "~0e" -0.0) "-0.e+0")
+  (equal? (format "~0,,,0e" 0.0) ".0e+0")
+  (equal? (format "~0,,,0e" -0.0) "-.0e+0")
+  (equal? (format "~,,1,,'*e" 3e20) "3.0e+20") ; can't fill with oc; no w
+  (equal? (format "~,2,1,,'*e" 3e20) "3.00e+20") ; can't fill with oc; no w
+  (equal? (format "~10,2,1,,'*e" 3e20) "**********") ; no room for exponent
+  (equal? (format "~10,,1,,'*e" 3e20) "**********") ; no room for exponent
+  (equal? (format "~10,2,,-2,'*e" 3e20) "**********") ; d to small for given k
+  (equal? (format "~,2,,-2,'*e" 3e20) "0.003e+23") ; can't fill with oc; no w
+)
+
+(mat format-exp4
+  (let () ; example adapted from cltl2
+    (define (foo x)
+      (format "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E"
+        x x x x))
+    (and (equal? (foo 3.14159)  "  3.14e+0| 31.42$-01|+.003e+03|  3.14e+0")
+         (equal? (foo -3.14159) " -3.14e+0|-31.42$-01|-.003e+03| -3.14e+0")
+         (equal? (foo 1100.0)   "  1.10e+3| 11.00$+02|+.001e+06|  1.10e+3")
+         (equal? (foo 1.1E13)   "*********| 11.00$+12|+.001e+16| 1.10e+13")
+         (equal? (foo 1.1E120)  "*********|??????????|%%%%%%%%%|1.10e+120")
+         (equal? (foo 1.1E1200) "   +inf.0|    +inf.0|   +inf.0|   +inf.0")   ; cltl2 assumes L (128-bit?) floats
+         (equal? (foo 0.0)      "  0.00e+0|  0.00$+00|+.000e+00|  0.00e+0")
+         (equal? (foo -0.0)     " -0.00e+0| -0.00$+00|-.000e+00| -0.00e+0")))
+  (let () ; like above but without d parameters
+    (define (foo x)
+      (format "~9,,1,,'*E|~10,,2,2,'?,,'$E|~9,,2,-2,'%@E|~9E"
+        x x x x))
+    (and (equal? (foo 3.14159)  "3.1416e+0|31.416$-01|+.003e+03|3.1416e+0")
+         (equal? (foo -3.14159) "-3.142e+0|-31.42$-01|-.003e+03|-3.142e+0")
+         (equal? (foo 1100.0)   "   1.1e+3|  11.0$+02|+.001e+06|   1.1e+3")
+         (equal? (foo 1.1E13)   "*********|  11.0$+12|+.001e+16|  1.1e+13")
+         (equal? (foo 1.1E120)  "*********|??????????|%%%%%%%%%| 1.1e+120")
+         (equal? (foo 1.1E1200) "   +inf.0|    +inf.0|   +inf.0|   +inf.0")   ; cltl2 assumes L (128-bit?) floats
+         (equal? (foo 0.0)      "   0.0e+0|   0.0$+00| +0.0e+00|   0.0e+0")
+         (equal? (foo -0.0)     "  -0.0e+0|  -0.0$+00| -0.0e+00|  -0.0e+0")))
+  (equal? ; example adapted from cltl2
+    (with-output-to-string
+      (lambda ()
+        (do ([k -5 (fx+ k 1)])
+            ((fx= k 8))
+          (printf
+            (format "Scale factor ~2d: |~~13,6,2,~de|~~%" k k)
+            3.14159))))
+    (format "Scale factor -5: | 0.000003e+06|~@
+             Scale factor -4: | 0.000031e+05|~@
+             Scale factor -3: | 0.000314e+04|~@
+             Scale factor -2: | 0.003142e+03|~@
+             Scale factor -1: | 0.031416e+02|~@
+             Scale factor  0: | 0.314159e+01|~@
+             Scale factor  1: | 3.141590e+00|~@
+             Scale factor  2: | 31.41590e-01|~@
+             Scale factor  3: | 314.1590e-02|~@
+             Scale factor  4: | 3141.590e-03|~@
+             Scale factor  5: | 31415.90e-04|~@
+             Scale factor  6: | 314159.0e-05|~@
+             Scale factor  7: | 3141590.e-06|\n"))
+)
+
+(mat format-general
+  (equal? (format "~g" 0.0) "0.")
+  (equal? (format "~g" -0.0) "-0.")
+  (equal? (format "~10g" 0.0) "    0.    ")
+  (equal? (format "~10g" -0.0) "   -0.    ")
+  (let () ; example adapted from cltl2
+    (define (foo x)
+      (format "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G"
+          x x x x))
+    (and (equal? (foo 0.0314159) "  3.14e-2|314.2$-04|0.314e-01|  3.14e-2")
+         (equal? (foo 0.314159)  "  0.31   |0.314    |0.314    | 0.31    ")
+         (equal? (foo 3.14159)   "   3.1   | 3.14    | 3.14    |  3.1    ")
+         (equal? (foo 31.4159)   "   31.   | 31.4    | 31.4    |  31.    ")
+         (equal? (foo 314.159)   "  3.14e+2| 314.    | 314.    |  3.14e+2")
+         (equal? (foo 3141.59)   "  3.14e+3|314.2$+01|0.314e+04|  3.14e+3")
+         (equal? (foo 3141.59L0) "  3.14e+3|314.2$+01|0.314e+04|  3.14e+3")
+         (equal? (foo 3.14E12)   "*********|314.0$+10|0.314e+13| 3.14e+12")
+         (equal? (foo 3.14L120)  "*********|?????????|%%%%%%%%%|3.14e+120")
+         (equal? (foo 3.14L1200) "   +inf.0|   +inf.0|   +inf.0|   +inf.0")))
+  (equal?
+    (list (format "~,3g" .9999) (format "~,3g" .999) (format "~,3g" 1.0))
+    '("1.00" "0.999" "1.00"))
+
+)
+
+(mat format-dollar
+  (equal? (format "~$" 0.0) "0.00")
+  (equal? (format "~$" -0.0) "-0.00")
+  (equal? (format "~$" 3.4) "3.40")
+  (equal? (format "~$" 23.99) "23.99")
+  (equal? (format "~$" -12345.67830) "-12345.68")
+  (equal? (format "~$" .153) "0.15")
+  (equal? (format "~$" -.01) "-0.01")
+  (equal? (format "~$" .0159) "0.02")
+  (equal? (format "~3$" 0.0) "0.000")
+  (equal? (format "~3$" -0.0) "-0.000")
+  (equal? (format "~3$" 3.4) "3.400")
+  (equal? (format "~3$" 23.99) "23.990")
+  (equal? (format "~3$" -12345.67830) "-12345.678")
+  (equal? (format "~3$" .153) "0.153")
+  (equal? (format "~3$" -.01) "-0.010")
+  (equal? (format "~3$" .0159) "0.016")
+  (equal? (format "~1,2$" 0.0) "00.0")
+  (equal? (format "~1,2$" -0.0) "-00.0")
+  (equal? (format "~1,2$" 3.4) "03.4")
+  (equal? (format "~1,2$" 23.99) "24.0")
+  (equal? (format "~1,2$" 12345.678) "12345.7")
+  (equal? (format "~1,2$" .153) "00.2")
+  (equal? (format "~1,2$" -.01) "-00.0")
+  (equal? (format "~1,2$" .0159) "00.0")
+  (equal? (format "~1,2$" .0159) "00.0")
+  (equal? (format "~1,2,7$" 0.0) "   00.0")
+  (equal? (format "~1,2,7$" -0.0) "  -00.0")
+  (equal? (format "~1,2,7$" 3.4) "   03.4")
+  (equal? (format "~1,2,7$" 23.99) "   24.0")
+  (equal? (format "~1,2,7$" -12345.678) "-12345.7")
+  (equal? (format "~1,2,7$" .153) "   00.2")
+  (equal? (format "~1,2,7$" -.01) "  -00.0")
+  (equal? (format "~1,2,7$" .0159) "   00.0")
+  (equal? (format "~1,2,7$" .0159) "   00.0")
+  (equal? (format "~1,2,7,'0$" 0.0) "00000.0")
+  (equal? (format "~1,2,7,'0$" -0.0) "00-00.0")
+  (equal? (format "~1,2,7,'0$" 3.4) "00003.4")
+  (equal? (format "~1,2,7,'0$" 23.99) "00024.0")
+  (equal? (format "~1,2,7,'0$" -12345.678) "-12345.7")
+  (equal? (format "~1,2,7,'0$" .153) "00000.2")
+  (equal? (format "~1,2,7,'0$" -.01) "00-00.0")
+  (equal? (format "~1,2,7,'0$" .0159) "00000.0")
+  (equal? (format "~1,2,7,'0$" .0159) "00000.0")
+  (equal? (format "~1,2,7,'0:$" 0.0) "00000.0")
+  (equal? (format "~1,2,7,'0:$" -0.0) "-0000.0")
+  (equal? (format "~1,2,7,'0:$" 3.4) "00003.4")
+  (equal? (format "~1,2,7,'0:$" 23.99) "00024.0")
+  (equal? (format "~1,2,7,'0:$" -12345.678) "-12345.7")
+  (equal? (format "~1,2,7,'0:$" .153) "00000.2")
+  (equal? (format "~1,2,7,'0:$" -.01) "-0000.0")
+  (equal? (format "~1,2,7,'0:$" .0159) "00000.0")
+  (equal? (format "~1,2,7,'0:$" .0159) "00000.0")
+  (equal? (format "~1,2,7,'0@:$" 0.0) "+0000.0")
+  (equal? (format "~1,2,7,'0@:$" -0.0) "-0000.0")
+  (equal? (format "~1,2,7,'0@:$" 3.4) "+0003.4")
+  (equal? (format "~1,2,7,'0@:$" 23.99) "+0024.0")
+  (equal? (format "~1,2,7,'0@:$" -12345.678) "-12345.7")
+  (equal? (format "~1,2,7,'0@:$" .153) "+0000.2")
+  (equal? (format "~1,2,7,'0@:$" -.01) "-0000.0")
+  (equal? (format "~1,2,7,'0@:$" .0159) "+0000.0")
+  (equal? (format "~1,2,7,'0@:$" .0159) "+0000.0")
+  (equal? (format "~1,,7,'*@:$" 0.0) "+***0.0")
+  (equal? (format "~1,,7,'*@:$" -0.0) "-***0.0")
+  (equal? (format "~1,,7,'*@:$" 3.4) "+***3.4")
+  (equal? (format "~,2,7,'*@$" 23.99) "*+23.99")
+  (equal? (format "~1,,7,@$" -12345.678) "-12345.7")
+  (equal? (format "~1,2,,'*@:$" .153) "+00.2")
+  (equal? (format "~,,10,'*$" -.01) "*****-0.01")
+  (equal? (format "~1,,,'*@:$" .0159) "+0.0")
+  (equal? (format "~,2,7,'*@:$" 0.0) "+*00.00")
+  (equal? (format "~,2,7,'*@:$" -0.0) "-*00.00")
+  (equal? (format "~,2,7,'*@:$" .0159) "+*00.02")
+
+ ; check to see if exact inputs are accepted
+  (equal? (format "~1,2,7,'0@:$" #e23.99) "+0024.0")
+  (equal? (format "~$" #e3.4) "3.40")
+  (equal? (format "~$" 1/3) "0.33")
+
+ ; check to see if nonreal inputs are rejected
+  (error? (format "~$" 'a))
+  (error? (format "~$" 1.0+3.0i))
+  (error? (format "~$" 1+3i))
+)
+
+(mat format-cltl2 ; misc cltl2 tests
+  (equal? (format "foo") "foo")
+  (begin (define fmt-x 5) #t)
+  (equal? (format "The answer is ~D." fmt-x) "The answer is 5.")
+  (equal? (format "The answer is ~3D." fmt-x) "The answer is   5.")
+  (equal? (format "The answer is ~3,'0D." fmt-x) "The answer is 005.")
+  (equal? (format "The answer is ~:D." (expt 47 fmt-x))
+          "The answer is 229,345,007.")
+  (begin (define fmt-y "elephant") #t)
+  (equal? (format "Look at the ~A!" fmt-y) "Look at the elephant!")
+  (equal? (format "Type ~:C to ~A." #\004 "delete all your files")
+          "Type ^D to delete all your files.")
+  (begin (define fmt-n 3) #t)
+  (equal? (format "~D item~:P found." fmt-n) "3 items found.")
+  (equal? (format "~R dog~:[s are~; is~] here." fmt-n (= fmt-n 1))
+          "three dogs are here.")
+  (equal? (format "~R dog~:*~[s are~; is~:;s are~] here." fmt-n)
+          "three dogs are here.")
+  (equal? (format "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." fmt-n)
+          "Here are three puppies.")
+  (begin (define fmt-n 1) #t)
+  (equal? (format "~D item~:P found." fmt-n) "1 item found.")
+  (equal? (format "~R dog~:[s are~; is~] here." fmt-n (= fmt-n 1))
+          "one dog is here.")
+  (equal? (format "~R dog~:*~[s are~; is~:;s are~] here." fmt-n)
+          "one dog is here.")
+  (equal? (format "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." fmt-n)
+          "Here is one puppy.")
+  (begin (define fmt-n 0) #t)
+  (equal? (format "~D item~:P found." fmt-n) "0 items found.")
+  (equal? (format "~R dog~:[s are~; is~] here." fmt-n (= fmt-n 1))
+          "zero dogs are here.")
+  (equal? (format "~R dog~:*~[s are~; is~:;s are~] here." fmt-n)
+          "zero dogs are here.")
+  (equal? (format "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." fmt-n)
+          "Here are zero puppies.")
+)
+
+; format-slib* tests are adapted from:
+
+;; "formatst.scm" SLIB FORMAT Version 3.0 conformance test
+; Written by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
+;
+; This code is in the public domain.
+
+(mat format-slib1
+  (equal? (format "abc") "abc")
+  (equal? (format "~a" 10) "10")
+  (equal? (format "~a" -1.2) "-1.2")
+  (equal? (format "~a" 'a) "a")
+  (equal? (format "~a" #t) "#t")
+  (equal? (format "~a" #f) "#f")
+  (equal? (format "~a" "abc") "abc")
+  (equal? (format "~a" '#(1 2 3)) "#(1 2 3)")         ; ans was "#(1 2 3)"
+  (equal? (format "~a" '()) "()")
+  (equal? (format "~a" '(a)) "(a)")
+  (equal? (format "~a" '(a b)) "(a b)")
+  (equal? (format "~a" '(a (b c) d)) "(a (b c) d)")
+  (equal? (format "~a" '(a . b)) "(a . b)")
+)
+
+(mat format-slib2
+  (equal? (format "~a ~a" 10 20) "10 20")
+  (equal? (format "~a abc ~a def" 10 20) "10 abc 20 def")
+)
+
+(mat format-slib3
+  (equal? (format "~d" 100) "100")
+  (equal? (format "~x" 100) "64")
+  (equal? (format "~o" 100) "144")
+  (equal? (format "~b" 100) "1100100")
+  (equal? (format "~@d" 100) "+100")
+  (equal? (format "~@d" -100) "-100")
+  (equal? (format "~@x" 100) "+64")
+  (equal? (format "~@o" 100) "+144")
+  (equal? (format "~@b" 100) "+1100100")
+  (equal? (format "~10d" 100) "       100")
+  (equal? (format "~:d" 123) "123")
+  (equal? (format "~:d" 1234) "1,234")
+  (equal? (format "~:d" 12345) "12,345")
+  (equal? (format "~:d" 123456) "123,456")
+  (equal? (format "~:d" 12345678) "12,345,678")
+  (equal? (format "~:d" -123) "-123")
+  (equal? (format "~:d" -1234) "-1,234")
+  (equal? (format "~:d" -12345) "-12,345")
+  (equal? (format "~:d" -123456) "-123,456")
+  (equal? (format "~:d" -12345678) "-12,345,678")
+  (equal? (format "~10:d" 1234) "     1,234")
+  (equal? (format "~10:d" -1234) "    -1,234")
+  (equal? (format "~10,'*d" 100) "*******100")
+  (equal? (format "~10,,'|:d" 12345678) "12|345|678")
+  (equal? (format "~10,,,2:d" 12345678) "12,34,56,78")
+  (equal? (format "~14,'*,'|,4:@d" 12345678) "****+1234|5678")
+)
+
+(mat format-slib4 ; ~r tests
+  (equal? (format "~10r" 100) "100")
+  (equal? (format "~2r" 100) "1100100")
+  (equal? (format "~8r" 100) "144")
+  (equal? (format "~16r" 100) "64")
+  (equal? (format "~16,10,'*r" 100) "********64")
+
+  (equal? (format "~@r" 4) "IV")
+  (equal? (format "~@r" 19) "XIX")
+  (equal? (format "~@r" 50) "L")
+  (equal? (format "~@r" 100) "C")
+  (equal? (format "~@r" 1000) "M")
+  (equal? (format "~@r" 99) "XCIX")
+  (equal? (format "~@r" 1994) "MCMXCIV")
+
+  ; old roman numeral test
+  (equal? (format "~:@r" 4) "IIII")
+  (equal? (format "~:@r" 5) "V")
+  (equal? (format "~:@r" 10) "X")
+  (equal? (format "~:@r" 9) "VIIII")
+
+  ; cardinal/ordinal English number test
+  (equal? (format "~r" 4) "four")
+  (equal? (format "~r" 10) "ten")
+  (equal? (format "~r" 19) "nineteen")
+  (equal? (format "~r" 1984) "nineteen hundred eighty-four") ; ans was "one thousand, nine hundred eighty-four")
+  (equal? (format "~:r" -1984) "minus nineteen hundred eighty-fourth") ; ans was "minus one thousand, nine hundred eighty-fourth")
+)
+
+(mat format-slib5 ; character tests
+  (equal? (format "~c" #\a) "a")
+  (equal? (format "~@c" #\a) "#\\a")
+  (equal? (format "~@c" (integer->char 32)) "#\\space")
+  (equal? (format "~@c" (integer->char 0)) "#\\nul")
+;  (equal? (format "~@c" (integer->char 27)) "#\\esc")
+;  (equal? (format "~@c" (integer->char 127)) "#\\del")
+;  (equal? (format "~@c" (integer->char 128)) "#\\200")
+;  (equal? (format "~@c" (integer->char 255)) "#\\377")
+;  (equal? (format "~65c") "A")
+;  (equal? (format "~7@c") "#\\bel")
+  (equal? (format "~:c" #\a) "a")
+  (equal? (format "~:c" (integer->char 1)) "^A")
+  (equal? (format "~:c" (integer->char 27)) "")
+;  (equal? (format "~7:c") "^G")
+;  (equal? (format "~:c" (integer->char 128)) "#\\200")
+;  (equal? (format "~:c" (integer->char 127)) "#\\177")
+;  (equal? (format "~:c" (integer->char 255)) "#\\377")
+)
+
+(mat format-slib6 ; plural test
+  (equal? (format "test~p" 1) "test")
+  (equal? (format "test~p" 2) "tests")
+  (equal? (format "test~p" 0) "tests")
+  (equal? (format "tr~@p" 1) "try")
+  (equal? (format "tr~@p" 2) "tries")
+  (equal? (format "tr~@p" 0) "tries")
+  (equal? (format "~a test~:p" 10) "10 tests")
+  (equal? (format "~a test~:p" 1) "1 test")
+)
+
+(mat format-slib-slib7 ; tilde tests
+  (equal? (format "~~~~") "~~")
+  (equal? (format "~3~") "~~~")
+)
+
+(mat format-slib8 ; whitespace character test
+  (equal? (format "~%") "\n")
+  (equal? (format "~3%") "\n\n\n")
+
+  (equal? (format "~&") "")
+  (equal? (format "abc~&") "abc\n")
+  (equal? (format "abc~&def") "abc\ndef")
+  (equal? (format "~3&") "\n\n")
+  (equal? (format "abc~3&") "abc\n\n\n") ; ans was "abc\n\n\n"
+; not yet  (equal? (format "~_~_~_") "   ")
+; not yet  (equal? (format "~3_") "   ")
+)
+
+(mat format-slib9 ; tabulate test
+ ; removed leading ~0& from control strings in following
+  (equal? (format "~3t") "   ")
+  (equal? (format "~10t") "          ") ; ans was ""
+  (equal? (format "1234567890~,8tABC")  "1234567890       ABC")
+  (equal? (format "1234567890~0,8tABC") "1234567890      ABC")
+  (equal? (format "1234567890~1,8tABC") "1234567890       ABC")
+  (equal? (format "1234567890~2,8tABC") "1234567890        ABC") ; ans was "1234567890ABC"
+  (equal? (format "1234567890~3,8tABC") "1234567890 ABC")
+  (equal? (format "1234567890~4,8tABC") "1234567890  ABC")
+  (equal? (format "1234567890~5,8tABC") "1234567890   ABC")
+  (equal? (format "1234567890~6,8tABC") "1234567890    ABC")
+  (equal? (format "1234567890~7,8tABC") "1234567890     ABC")
+  (equal? (format "1234567890~8,8tABC") "1234567890      ABC")
+  (equal? (format "1234567890~9,8tABC") "1234567890       ABC")
+  (equal? (format "1234567890~10,8tABC") "1234567890        ABC") ; ans was "1234567890ABC"
+  (equal? (format "1234567890~11,8tABC") "1234567890 ABC")
+  (equal? (format "12345~,8tABCDE~,8tXYZ") "12345    ABCDE   XYZ")
+  (equal? (format "~,8t+++~,8t===") " +++     ===") ; ans was "     +++     ==="
+;  (equal? (format "ABC~,8,'.tDEF") "ABC......DEF")
+  (equal? (format "~3,8@tABC") "        ABC")
+  (equal? (format "1234~3,8@tABC") "1234    ABC")
+  (equal? (format "12~3,8@tABC~3,8@tDEF") "12      ABC     DEF")
+)
+
+(mat format-slib10 ; indirection test
+  (equal? (format "~a ~? ~a" 10 "~a ~a" '(20 30) 40) "10 20 30 40")
+  (equal? (format "~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40")
+)
+
+(mat format-slib11
+  (equal? (format "~10a" "abc") "abc       ")
+  (equal? (format "~10@a" "abc") "       abc")
+  (equal? (format "~10a" "0123456789abc") "0123456789abc")
+  (equal? (format "~10@a" "0123456789abc") "0123456789abc")
+)
+
+(mat format-slib12 ; pad character test
+  (equal? (format "~10,,,'*a" "abc") "abc*******")
+  (equal? (format "~10,,,'Xa" "abc") "abcXXXXXXX")
+  ; bad test (equal? (format "~10,,,42a" "abc") "abc*******")
+  (equal? (format "~10,,,'*@a" "abc") "*******abc")
+  (equal? (format "~10,,3,'*a" "abc") "abc*******")
+  (equal? (format "~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length
+  (equal? (format "~10,,3,'*@a" "0123456789abc") "***0123456789abc")
+)
+
+(mat format-slib13 ; colinc, minpad padding test
+  (equal? (format "~10,8,0,'*a" 123)  "123********")
+  (equal? (format "~10,9,0,'*a" 123)  "123*********")
+  (equal? (format "~10,10,0,'*a" 123) "123**********")
+  (equal? (format "~10,11,0,'*a" 123) "123***********")
+  (equal? (format "~8,1,0,'*a" 123) "123*****")
+  (equal? (format "~8,2,0,'*a" 123) "123******")
+  (equal? (format "~8,3,0,'*a" 123) "123******")
+  (equal? (format "~8,4,0,'*a" 123) "123********")
+  (equal? (format "~8,5,0,'*a" 123) "123*****")
+  (equal? (format "~8,1,3,'*a" 123) "123*****")
+  (equal? (format "~8,1,5,'*a" 123) "123*****")
+  (equal? (format "~8,1,6,'*a" 123) "123******")
+  (equal? (format "~8,1,9,'*a" 123) "123*********")
+)
+
+(mat format-slib14 ; slashify test
+  (equal? (format "~s" "abc") "\"abc\"")
+  (equal? (format "~s" "abc \\ abc") "\"abc \\\\ abc\"")
+  (equal? (format "~a" "abc \\ abc") "abc \\ abc")
+  (equal? (format "~s" "abc \" abc") "\"abc \\\" abc\"")
+  (equal? (format "~a" "abc \" abc") "abc \" abc")
+  (equal? (format "~s" #\space) "#\\space")
+  (equal? (format "~s" #\newline) "#\\newline")
+  (equal? (format "~s" #\tab) "#\\tab")                 ; ans was "#\\ht"
+  (equal? (format "~s" #\a) "#\\a")
+  (equal? (format "~a" '(a "b" c)) "(a b c)")            ; ans was "(a \"b\" c)"
+)
+
+(mat format-slib15 ; continuation line test
+  (equal? (format "abc~\n    123") "abc123")
+  (equal? (format "abc~\n   ") "abc")
+  (equal? (format "abc~:\n   def") "abc   def")
+  (equal? (format "abc~@\n   def") "abc\ndef")
+)
+
+(mat format-slib16 ; string case conversion
+  (equal? (format "~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz")
+  (equal? (format "~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz")
+  (equal? (format "~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz")
+  (equal? (format "~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz")
+  (equal? (format "~:@(~a~)" '(a b c)) "(A B C)")
+  (equal? (format "~:@(~x~)" 255) "FF")
+  (equal? (format "~:@(~p~)" 2) "S")
+;  (test `("~:@(~a~)" ,display) (string-upcase (format:iobj->str display)))
+  (equal? (format "~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world")
+)
+
+(mat format-slib17 ; variable parameter
+  (equal? (format "~va" 10 "abc") "abc       ")
+ ; changed 42 to #\* below
+  (equal? (format "~v,,,va" 10 #\* "abc") "abc*******")
+)
+
+(mat format-slib18 ; number of remaining arguments as parameter
+  (equal? (format "~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1")
+)
+
+(mat format-slib19 ; argument jumping
+  (equal? (format "~a ~* ~a" 10 20 30) "10  30")
+  (equal? (format "~a ~2* ~a" 10 20 30 40) "10  40")
+  (equal? (format "~a ~:* ~a" 10) "10  10")
+  (equal? (format "~a ~a ~2:* ~a ~a" 10 20) "10 20  10 20")
+  (equal? (format "~a ~a ~@* ~a ~a" 10 20) "10 20  10 20")
+  (equal? (format "~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20  50 60")
+)
+
+(mat format-slib20 ; conditionals
+  (equal? (format "~[abc~;xyz~]" 0) "abc")
+  (equal? (format "~[abc~;xyz~]" 1) "xyz")
+  (equal? (format "~[abc~;xyz~:;456~]" 99) "456")
+  (equal? (format "~0[abc~;xyz~:;456~]") "abc")
+  (equal? (format "~1[abc~;xyz~:;456~] ~a" 100) "xyz 100")
+  (equal? (format "~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg")
+  (equal? (format "~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10")
+  (equal? (format "~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20)
+          "10 and 20")
+  (equal? (format "~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30)
+          "10, 20 and 30")
+  (equal? (format "~:[hello~;world~] ~a" #t 10) "world 10")
+  (equal? (format "~:[hello~;world~] ~a" #f 10) "hello 10")
+  (equal? (format "~@[~a tests~]" #f) "")
+  (equal? (format "~@[~a tests~]" 10) "10 tests")
+  (equal? (format "~@[~a test~:p~] ~a" 10 'done) "10 tests done")
+  (equal? (format "~@[~a test~:p~] ~a" 1 'done) "1 test done")
+  (equal? (format "~@[~a test~:p~] ~a" 0 'done) "0 tests done")
+  (equal? (format "~@[~a test~:p~] ~a" #f 'done) " done")
+  (equal? (format "~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5")
+  (equal? (format "~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc")   ; nested conditionals (irrghh)
+  (equal? (format "~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz")
+  (equal? (format "~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6")
+
+ ; cltl2 tests
+  (begin
+    (define foo "Items:~#[ none~; ~S~; ~S and ~S~
+                 ~:;~@{~#[~; and~] ~S~^,~}~].")
+    (string? foo))
+  (equal? (format foo) "Items: none.")
+  (equal? (format foo 'foo) "Items: foo.")
+  (equal? (format foo 'foo 'bar) "Items: foo and bar.")
+  (equal? (format foo 'foo 'bar 'baz) "Items: foo, bar, and baz.")
+  (equal? (format foo 'foo 'bar 'baz 'quux) "Items: foo, bar, baz, and quux.")
+)
+
+(mat format-slib21 ; iteration
+  (equal? (format "~{ ~a ~}" '(a b c)) " a  b  c ")
+  (equal? (format "~{ ~a ~}" '()) "")
+  (equal? (format "~{ ~a ~5,,,'*a~}" '(a b c d)) " a b**** c d****")
+  (equal? (format "~{ ~a,~a ~}" '(a 1 b 2 c 3)) " a,1  b,2  c,3 ")
+  (equal? (format "~2{ ~a,~a ~}" '(a 1 b 2 c 3)) " a,1  b,2 ")
+  (equal? (format "~3{~a ~} ~a" '(a b c d e) 100) "a b c  100")
+  (equal? (format "~0{~a ~} ~a" '(a b c d e) 100) " 100")
+ ; replaced (c d e f) with (c d) below
+  (equal? (format "~:{ ~a,~a ~}" '((a b) (c d) (g h))) " a,b  c,d  g,h ")
+ ; replaced (c d e f) with (c d) below
+  (equal? (format "~2:{ ~a,~a ~}" '((a b) (c d) (g h))) " a,b  c,d ")
+  (equal? (format "~@{ ~a,~a ~}" 'a 1 'b 2 'c 3) " a,1  b,2  c,3 ")
+  (equal? (format "~2@{ ~a,~a ~} <~a|~a>" 'a 1 'b 2 'c 3) " a,1  b,2  ")
+  (equal? (format "~:@{ ~a,~a ~}" '(a 1) '(b 2) '(c 3)) " a,1  b,2  c,3 ")
+  (equal? (format "~2:@{ ~a,~a ~} ~a" '(a 1) '(b 2) '(c 3)) " a,1  b,2  (c 3)")
+  (equal? (format "~{~}" "<~a,~a>" '(a 1 b 2 c 3)) "")
+  (equal? (format "~{ ~a ~{<~a>~}~} ~a" '(a (1 2) b (3 4)) 10)
+          " a <1><2> b <3><4> 10")
+)
+
+(mat format-slib22 ; up and out
+  (equal? (format "abc ~^ xyz") "abc ")
+  (equal? (format "~@(abc ~^ xyz~) ~a" 10) "Abc  xyz 10") ; ans was "ABC  xyz 10"
+  (equal? (format "done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ")
+  (equal? (format "done. ~^ ~d warning~:p. ~^ ~d error~:p." 10)
+          "done.  10 warnings. ")
+  (equal? (format "done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1)
+          "done.  10 warnings.  1 error.")
+  (equal? (format "~{ ~a ~^<~a>~} ~a" '(a b c d e f) 10)
+          " a  c  e  10")
+  (equal? (format "~{ ~a ~^<~a>~} ~a" '(a b c d e) 10)
+          " a  c  e  10")
+  (equal? (format "abc~0^ xyz") "abc")
+  (equal? (format "abc~9^ xyz") "abc xyz")
+  (equal? (format "abc~7,4^ xyz") "abc xyz")
+  (equal? (format "abc~7,7^ xyz") "abc")
+;  (equal? (format "abc~3,7,9^ xyz") "abc")
+;  (equal? (format "abc~8,7,9^ xyz") "abc xyz")
+;  (equal? (format "abc~3,7,5^ xyz") "abc xyz")
+)
+
+(mat format-slib23 ; complexity tests
+  (begin
+    (define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].")
+    (string? fmt))
+  (equal? (format fmt)  "Items: none.")
+  (equal? (format fmt 'foo) "Items: foo.")
+  (equal? (format fmt 'foo 'bar) "Items: foo and bar.")
+  (equal? (format fmt 'foo 'bar 'baz) "Items: foo, bar, and baz.")
+  (equal? (format fmt 'foo 'bar 'baz 'zok) "Items: foo, bar, baz, and zok.")
+)
+
+(mat format-slib24 ; fixed floating points
+  (equal? (format "~6,2f" 3.14159) "  3.14")
+  (equal? (format "~6,1f" 3.14159) "   3.1")
+  (equal? (format "~6,0f" 3.14159) "    3.")
+  (equal? (format "~5,1f" 0) "  0.0")
+  (equal? (format "~10,7f" 3.14159) " 3.1415900")
+  (equal? (format "~10,7f" -3.14159) "-3.1415900")
+  (equal? (format "~10,7@f" 3.14159) "+3.1415900")
+  (equal? (format "~6,3f" 0.0) " 0.000")
+  (equal? (format "~6,4f" 0.007) "0.0070")
+  (equal? (format "~6,3f" 0.007) " 0.007")
+  (equal? (format "~6,2f" 0.007) "  0.01")
+  (equal? (format "~3,2f" 0.007) ".01")
+  (equal? (format "~3,2f" -0.007) "-.01")
+  (equal? (format "~6,2,,,'*f" 3.14159) "**3.14")
+  (equal? (format "~6,3,,'?f" 12345.56789) "??????")
+  (equal? (format "~6,3f" 12345.6789) "12345.679")
+  (equal? (format "~,3f" 12345.6789) "12345.679")
+  (equal? (format "~,3f" 9.9999) "10.000")
+  (equal? (format "~6f" 23.4) "  23.4")
+  (equal? (format "~6f" 1234.5) "1234.5")
+  (equal? (format "~6f" 12345678) "12345678.")         ; ans was "12345678.0"
+  (equal? (format "~6,,,'?f" 12345678) "??????")
+  (equal? (format "~6f" 123.56789) "123.57")
+  (equal? (format "~6f" 123.0) " 123.0")
+  (equal? (format "~6f" -123.0) "-123.0")
+  (equal? (format "~6f" 0.0) "   0.0")
+  (equal? (format "~3f" 3.141) "3.1")
+  (equal? (format "~2f" 3.141) "3.")
+  (equal? (format "~1f" 3.141) "3.")                   ; ans was "3.141"
+  (equal? (format "~f" 123.56789) "123.56789")
+  (equal? (format "~f" -314.0) "-314.0")
+  (equal? (format "~f" 1e4) "10000.0")
+  (equal? (format "~f" -1.23e10) "-12300000000.0")
+  (equal? (format "~f" 1e-4) "0.0001")
+  (equal? (format "~f" -1.23e-10) "-0.000000000123")
+  (equal? (format "~@f" 314.0) "+314.0")
+  (equal? (format "~,,3f" 0.123456) "123.456")
+  (equal? (format "~,,-3f" -123.456) "-0.123456")
+  (equal? (format "~5,,3f" 0.123456) "123.5")
+)
+
+(mat format-slib25 ; exponent floating points
+  (equal? (format "~e" 3.14159) "3.14159e+0")
+  (equal? (format "~e" 0.00001234) "1.234e-5")
+  (equal? (format "~,,,0e" 0.00001234) "0.1234e-4")
+  (equal? (format "~,3e" 3.14159) "3.142e+0")
+  (equal? (format "~,3@e" 3.14159) "+3.142e+0")
+  (equal? (format "~,3@e" 0.0) "+0.000e+0")
+  (equal? (format "~,0e" 3.141) "3.e+0")
+  (equal? (format "~,3,,0e" 3.14159) "0.314e+1")
+  (equal? (format "~,5,3,-2e" 3.14159) "0.00314e+003")
+  (equal? (format "~,5,3,-5e" -3.14159) "-0.000003e+006")  ; ans was "-0.00000e+006"; this is a case where we have to grow d to accommodate given k
+  (equal? (format "~,5,2,2e" 3.14159) "31.4159e-01")
+  (equal? (format "~,5,2,,,,'ee" 0.0) "0.00000e+00")
+  (equal? (format "~12,3e" -3.141) "   -3.141e+0")
+  (equal? (format "~12,3,,,,'#e" -3.141) "###-3.141e+0")
+  (equal? (format "~10,2e" -1.236e-4) "  -1.24e-4")
+  (equal? (format "~5,3e" -3.141) "-3.141e+0")
+  (equal? (format "~5,3,,,'*e" -3.141) "*****")
+  (equal? (format "~3e" 3.14159) "3.e+0")     ; ans was "3.14159e+0"
+  (equal? (format "~4e" 3.14159) "3.e+0")     ; ans was "3.14159e+0"
+  (equal? (format "~5e" 3.14159) "3.e+0")
+  (equal? (format "~5,,,,'*e" 3.14159) "3.e+0")
+  (equal? (format "~6e" 3.14159) "3.1e+0")
+  (equal? (format "~7e" 3.14159) "3.14e+0")
+  (equal? (format "~7e" -3.14159) "-3.1e+0")
+  (equal? (format "~8e" 3.14159) "3.142e+0")
+  (equal? (format "~9e" 3.14159) "3.1416e+0")
+  (equal? (format "~9,,,,,,'ee" 3.14159) "3.1416e+0")
+  (equal? (format "~10e" 3.14159) "3.14159e+0")
+  (equal? (format "~11e" 3.14159) " 3.14159e+0")
+  (equal? (format "~12e" 3.14159) "  3.14159e+0")
+  (equal? (format "~13,6,2,-5e" 3.14159) " 0.000003e+06")
+  (equal? (format "~13,6,2,-4e" 3.14159) " 0.000031e+05")
+  (equal? (format "~13,6,2,-3e" 3.14159) " 0.000314e+04")
+  (equal? (format "~13,6,2,-2e" 3.14159) " 0.003142e+03")
+  (equal? (format "~13,6,2,-1e" 3.14159) " 0.031416e+02")
+  (equal? (format "~13,6,2,0e" 3.14159)  " 0.314159e+01")
+  (equal? (format "~13,6,2,1e" 3.14159)  " 3.141590e+00")
+  (equal? (format "~13,6,2,2e" 3.14159)  " 31.41590e-01")
+  (equal? (format "~13,6,2,3e" 3.14159)  " 314.1590e-02")
+  (equal? (format "~13,6,2,4e" 3.14159)  " 3141.590e-03")
+  (equal? (format "~13,6,2,5e" 3.14159)  " 31415.90e-04")
+  (equal? (format "~13,6,2,6e" 3.14159)  " 314159.0e-05")
+  (equal? (format "~13,6,2,7e" 3.14159)  " 3141590.e-06")
+  (equal? (format "~13,6,2,8e" 3.14159)  "31415900.e-07")
+  (equal? (format "~7,3,,-2e" 0.001) ".001e+0")
+  (equal? (format "~8,3,,-2@e" 0.001) "+.001e+0")
+  (equal? (format "~8,3,,-2@e" -0.001) "-.001e+0")
+  (equal? (format "~8,3,,-2e" 0.001) "0.001e+0")
+  (equal? (format "~7,,,-2e" 0.001) ".001e+0")              ; ans was "0.00e+0"
+  (equal? (format "~12,3,1e" 3.14159e12) "   3.142e+12")
+  (equal? (format "~12,3,1,,'*e" 3.14159e12) "************")
+  (equal? (format "~5,3,1e" 3.14159e12) "3.142e+12")
+)
+
+(mat format-slib26 ; general floating point (this test is from Steele's CL book)
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            0.0314159 0.0314159 0.0314159 0.0314159)
+          "  3.14e-2|314.2$-04|0.314e-01|  3.14e-2")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            0.314159 0.314159 0.314159 0.314159)
+          "  0.31   |0.314    |0.314    | 0.31    ")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            3.14159 3.14159 3.14159 3.14159)
+          "   3.1   | 3.14    | 3.14    |  3.1    ")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            31.4159 31.4159 31.4159 31.4159)
+          "   31.   | 31.4    | 31.4    |  31.    ")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            314.159 314.159 314.159 314.159)
+          "  3.14e+2| 314.    | 314.    |  3.14e+2")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            3141.59 3141.59 3141.59 3141.59)
+          "  3.14e+3|314.2$+01|0.314e+04|  3.14e+3")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            3.14e12 3.14e12 3.14e12 3.14e12)
+          "*********|314.0$+10|0.314e+13| 3.14e+12")
+  (equal? (format "~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
+            3.14e120 3.14e120 3.14e120 3.14e120)
+          "*********|?????????|%%%%%%%%%|3.14e+120")
+
+ ; the fixed-format in the following were followed by the apparently
+ ; required backpadding that we omit when w is not supplied
+  (equal? (format "~g" 0.0) "0.")
+  (equal? (format "~g" 0.1) "0.1")
+  (equal? (format "~g" 0.01) "1.0e-2")
+  (equal? (format "~g" 123.456) "123.456")
+  (equal? (format "~g" 123456.7) "123456.7")
+  (equal? (format "~g" 123456.78) "123456.78")
+  (equal? (format "~g" 0.9282) "0.9282")
+  (equal? (format "~g" 0.09282) "9.282e-2")
+  (equal? (format "~g" 1) "1.")
+  (equal? (format "~g" 12) "12.")
+)
+
+(mat format-slib27 ; dollar floating point
+  (equal? (format "~$" 1.23) "1.23")
+  (equal? (format "~$" 1.2) "1.20")
+  (equal? (format "~$" 0.0) "0.00")
+  (equal? (format "~$" 9.999) "10.00")
+  (equal? (format "~3$" 9.9999) "10.000")
+  (equal? (format "~,4$" 3.2) "0003.20")
+  (equal? (format "~,4$" 10000.2) "10000.20")
+  (equal? (format "~,4,10$" 3.2) "   0003.20")
+  (equal? (format "~,4,10@$" 3.2) "  +0003.20")
+  (equal? (format "~,4,10:@$" 3.2) "+  0003.20")
+  (equal? (format "~,4,10:$" -3.2) "-  0003.20")
+  (equal? (format "~,4,10$" -3.2) "  -0003.20")
+  (equal? (format "~,,10@$" 3.2) "     +3.20")
+  (equal? (format "~,,10:@$" 3.2) "+     3.20")
+  (equal? (format "~,,10:@$" -3.2) "-     3.20")
+  (equal? (format "~,,10,'_@$" 3.2) "_____+3.20")
+  (equal? (format "~,,4$" 1234.4) "1234.40")
+)
diff --git a/mats/freq.in b/mats/freq.in
new file mode 100644
index 0000000..3bafc5d
--- /dev/null
+++ b/mats/freq.in
@@ -0,0 +1,4 @@
+Peter Piper picked a peck of pickled peppers;
+A peck of pickled peppers Peter Piper picked.
+If Peter Piper picked a peck of pickled peppers,
+Where's the peck of pickled peppers Peter Piper picked?
diff --git a/mats/freq.out b/mats/freq.out
new file mode 100644
index 0000000..9e4aeb3
--- /dev/null
+++ b/mats/freq.out
@@ -0,0 +1,13 @@
+1 A
+1 If
+4 Peter
+4 Piper
+1 Where
+2 a
+4 of
+4 peck
+4 peppers
+4 picked
+4 pickled
+1 s
+1 the
diff --git a/mats/ftype.h b/mats/ftype.h
new file mode 100644
index 0000000..c56a682
--- /dev/null
+++ b/mats/ftype.h
@@ -0,0 +1,38 @@
+/* ftype.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#ifdef SPARC
+
+typedef signed char int8_t;
+typedef unsigned char uint8_t;
+typedef signed short int16_t;
+typedef unsigned short uint16_t;
+typedef signed int int32_t;
+typedef unsigned int uint32_t;
+typedef signed long long int64_t;
+typedef unsigned long long uint64_t;
+
+#else
+
+#include 
+
+#endif
+
+#ifdef WIN32
+#define EXPORT extern __declspec (dllexport)
+#else
+#define EXPORT extern
+#endif
diff --git a/mats/ftype.ms b/mats/ftype.ms
new file mode 100644
index 0000000..d070f40
--- /dev/null
+++ b/mats/ftype.ms
@@ -0,0 +1,5877 @@
+;;; ftype.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat ftype-sizeof
+  (equal?
+    (list
+      (ftype-sizeof integer-8)
+      (ftype-sizeof unsigned-8)
+      (ftype-sizeof integer-16)
+      (ftype-sizeof unsigned-16)
+      (ftype-sizeof integer-24)
+      (ftype-sizeof unsigned-24)
+      (ftype-sizeof integer-32)
+      (ftype-sizeof unsigned-32)
+      (ftype-sizeof integer-40)
+      (ftype-sizeof unsigned-40)
+      (ftype-sizeof integer-48)
+      (ftype-sizeof unsigned-48)
+      (ftype-sizeof integer-56)
+      (ftype-sizeof unsigned-56)
+      (ftype-sizeof integer-64)
+      (ftype-sizeof unsigned-64)
+      (ftype-sizeof single-float)
+      (ftype-sizeof double-float))
+    '(1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 4 8))
+  (eqv? (ftype-sizeof char) (foreign-sizeof 'char))
+  (eqv? (ftype-sizeof wchar) (foreign-sizeof 'wchar))
+  (eqv? (ftype-sizeof short) (foreign-sizeof 'short))
+  (eqv? (ftype-sizeof unsigned-short) (foreign-sizeof 'unsigned-short))
+  (eqv? (ftype-sizeof int) (foreign-sizeof 'int))
+  (eqv? (ftype-sizeof unsigned) (foreign-sizeof 'unsigned))
+  (eqv? (ftype-sizeof unsigned-int) (foreign-sizeof 'unsigned-int))
+  (eqv? (ftype-sizeof long) (foreign-sizeof 'long))
+  (eqv? (ftype-sizeof unsigned-long) (foreign-sizeof 'unsigned-long))
+  (eqv? (ftype-sizeof long-long) (foreign-sizeof 'long-long))
+  (eqv? (ftype-sizeof unsigned-long-long) (foreign-sizeof 'unsigned-long-long))
+  (eqv? (ftype-sizeof float) (foreign-sizeof 'float))
+  (eqv? (ftype-sizeof single-float) (foreign-sizeof 'single-float))
+  (eqv? (ftype-sizeof double) (foreign-sizeof 'double))
+  (eqv? (ftype-sizeof double-float) (foreign-sizeof 'double-float))
+  (eqv? (ftype-sizeof void*) (foreign-sizeof 'void*))
+  (eqv? (ftype-sizeof iptr) (foreign-sizeof 'iptr))
+  (eqv? (ftype-sizeof uptr) (foreign-sizeof 'uptr))
+)
+
+(mat ftype-setup
+  (begin
+    (define max-integer-alignment
+      (if (or (> (fixnum-width) 32)
+              (memq (machine-type) '(i3nt ti3nt i3qnx ti3qnx arm32le tarm32le ppc32le tppc32le)))
+          8
+          4))
+    (define max-float-alignment
+      (if (or (> (fixnum-width) 32)
+              (memq (machine-type) '(i3nt ti3nt arm32le tarm32le ppc32le tppc32le)))
+          8
+          4))
+    (define-syntax fptr-free
+      (syntax-rules ()
+        [(_ fptr)
+         (begin
+           (foreign-free (ftype-pointer-address fptr))
+           (set! fptr #f))]))
+    (define-syntax free-after
+      (syntax-rules ()
+        [(_ fptr e1 e2 ...)
+         (let ([ans (begin e1 e2 ...)])
+           (fptr-free fptr)
+           ans)]))
+    #t)
+)
+
+(mat ftype
+   (error? ; misplaced function type
+     (define-ftype IV1 (struct [i integer-8] [f (function (int) int)])))
+
+   (error? ; misplaced function type
+     (define-ftype IV1 (union [i uptr] [f (function (int) int)])))
+
+   (error? ; misplaced function type
+     (define-ftype IV1 (array 10 (function (int) int))))
+
+   (error? ; misplaced function type
+     (let ()
+       (define-ftype F1 (function (int) int))
+       (define-ftype IV1 (struct [i integer-8] [f F1]))
+       3))
+
+   (error? ; misplaced function type
+     (let ()
+       (define-ftype F1 (function (int) int))
+       (define-ftype IV1 (union [i uptr] [f F1]))
+       3))
+
+   (error? ; misplaced function type
+     (let ()
+       (define-ftype F1 (function (int) int))
+       (define-ftype IV1 (array 10 F1))
+       3))
+
+   (error? ; misplaced function type
+     (let ()
+       (define-ftype
+         [F1 (function (int) int)]
+         [IV1 (struct [i integer-8] [f F1])])
+       3))
+
+   (begin
+     (define-ftype F1 (function (int) int))
+     #t)
+
+   (error? ; function ftypes have unknown size
+     (ftype-sizeof F1))
+
+   (error? ; cannot calculate offset for function index 10
+     (ftype-ref F1 () (make-ftype-pointer F1 0) 10))
+
+   (error? ; cannot calculate offset for function index 1
+     (ftype-&ref F1 () (make-ftype-pointer F1 0) 1))
+
+   (error? ; cannot assign non-scalar type
+     (ftype-set! F1 () (make-ftype-pointer F1 0) 0 'foo))
+
+   (begin
+     (define-ftype F2 (struct [a1 int] [f (* (function (int) int))]))
+     #t)
+
+   (error? ; cannot calculate offset for function index 1
+     (ftype-ref F2 (f 1) (make-ftype-pointer F2 0)))
+
+   (error? ; cannot calculate offset for function index 14
+     (ftype-&ref F2 (f 14) (make-ftype-pointer F2 0)))
+
+   (error? ; cannot calculate offset for function index 7
+     (ftype-set! F2 (f 7) (make-ftype-pointer F2 0) 'foo))
+
+
+ ; ----------------
+  (begin
+    (define-ftype Aa (struct [a1 integer-8] [a2 integer-16] [a3 integer-8]))
+    (define-ftype Ab (struct [b1 integer-8]))
+    (define-ftype Ac (struct [c1 Aa] [c2 Ab] [c3 double]))
+    #t)
+  
+  (equal?
+    (let ([x (make-ftype-pointer Ac 0)])
+      (list
+        (ftype-sizeof Aa)
+        (ftype-sizeof Ab)
+        (ftype-sizeof Ac)
+        (ftype-pointer-address (ftype-&ref Ac (c1 a1) x))
+        (ftype-pointer-address (ftype-&ref Ac (c1 a2) x))
+        (ftype-pointer-address (ftype-&ref Ac (c1 a3) x))
+        (ftype-pointer-address (ftype-&ref Ac (c2 b1) x))
+        (ftype-pointer-address (ftype-&ref Ac (c3) x))))
+    '(6 1 16 0 2 4 6 8))
+
+  (begin
+    (define addr (foreign-alloc (ftype-sizeof Ac)))
+    (define x (make-ftype-pointer Ac addr))
+    #t)
+
+  (ftype-pointer? x)
+  (ftype-pointer? Ac x)
+  (not (ftype-pointer? Ab x))
+  (eqv? (ftype-pointer-address x) addr)
+  (eqv? (ftype-pointer-address (ftype-&ref Ac (c1 a1) x)) (+ addr 0))
+  (eqv? (ftype-pointer-address (ftype-&ref Ac (c1 a2) x)) (+ addr 2))
+  (eqv? (ftype-pointer-address (ftype-&ref Ac (c1 a3) x)) (+ addr 4))
+  (eqv? (ftype-pointer-address (ftype-&ref Ac (c2 b1) x)) (+ addr 6))
+  (eqv? (ftype-pointer-address (ftype-&ref Ac (c3) x)) (+ addr 8))
+
+  (error? ; not an ftype pointer
+    (ftype-&ref Aa (a1) 75))
+  (error? ; ftype mismatch
+    (ftype-&ref Ab (b1) x))
+
+  (eqv? (ftype-pointer-address (ftype-&ref Ac (c1) x)) (+ addr 0))
+
+  (error? ; unexpected accessor b1
+    (ftype-&ref Ac (b1) x))
+  (error? ; unexpected accessor 0
+    (ftype-&ref Ac (c1 0) x))
+
+  (begin
+    (ftype-set! Ac (c1 a1) x 7)
+    (ftype-set! Ac (c1 a2) x 30000)
+    (ftype-set! Ac (c1 a3) x -15)
+    (ftype-set! Ac (c2 b1) x #xFF)
+    (ftype-set! Ac (c3) x 3.25)
+    #t)
+
+  (error? ; unexpected accessor b1
+    (ftype-set! Ac (b1) x 7))
+  (error? ; unexpected accessor 0
+    (ftype-set! Ac (c1 0) x 7))
+  (error? ; ftype mismatch
+    (ftype-set! Ab (b1) x 7))
+  (error? ; #\a is not an integer-8
+    (ftype-set! Ac (c1 a1) x #\a))
+  (error? ; 30000 is not an integer-8
+    (ftype-set! Ac (c1 a1) x 30000))
+
+  (eqv? (ftype-ref Ac (c1 a1) x) 7)
+  (eqv? (ftype-ref Ac (c1 a2) x) 30000)
+  (eqv? (ftype-ref Ac (c1 a3) x) -15)
+  (eqv? (ftype-ref Ac (c2 b1) x) -1)
+  (eqv? (ftype-ref Ac (c3) x) 3.25)
+  (eqv? (ftype-ref Aa (a1) (ftype-&ref Ac (c1) x)) 7)
+  (eqv? (ftype-ref Aa (a2) (ftype-&ref Ac (c1) x)) 30000)
+  (eqv? (ftype-ref Aa (a3) (ftype-&ref Ac (c1) x)) -15)
+  (eqv? (ftype-ref Ab (b1) (ftype-&ref Ac (c2) x)) -1)
+  (eqv? (ftype-ref double () (ftype-&ref Ac (c3) x)) 3.25)
+  (let ([y (ftype-&ref Ac (c3) x)])
+    (= (ftype-pointer-address (ftype-&ref double () y))
+       (ftype-pointer-address y)))
+  (eqv? (foreign-ref 'double (ftype-pointer-address (ftype-&ref Ac (c3) x)) 0) 3.25)
+  (let ()
+    (define-syntax cast
+      (syntax-rules ()
+        [(_ ftype x)
+         (make-ftype-pointer ftype (ftype-pointer-address x))]))
+    (define-ftype double-array (array 1 double))
+    (eqv? (ftype-ref double-array (0)
+            (cast double-array (ftype-&ref Ac (c3) x)))
+      3.25))
+  (let ()
+    (define-syntax cast
+      (syntax-rules ()
+        [(_ ftype x)
+         (make-ftype-pointer ftype (ftype-pointer-address x))]))
+    (define-ftype double-array (array 1 double))
+    (let ([y (cast double-array (ftype-&ref Ac (c3) x))])
+      (and (ftype-pointer? y)
+           (eqv? (ftype-pointer-address y) (ftype-pointer-address (ftype-&ref Ac (c3) x)))
+           (ftype-pointer=? y (ftype-&ref Ac (c3) x))
+           (eqv? (ftype-ref double-array (0) y) 3.25))))
+
+  (error? ; unexpected accessor b1
+    (ftype-ref Ac (b1) x))
+  (error? ; unexpected accessor 0
+    (ftype-ref Ac (c1 0) x))
+  (error? ; ftype mismatch
+    (ftype-ref Ab (b1) x))
+  (error? ; ftype mismatch
+    (ftype-ref Aa (a1) (ftype-&ref Ac (c2) x)))
+
+  (begin
+    (foreign-free addr)
+    #t)
+
+ ; ----------------
+
+  (begin
+    (define-ftype Ba (struct [a1 integer-8] [a2 integer-32] [a3 integer-8]))
+    (define-ftype Bb (struct [b1 integer-8]))
+    (define-ftype Bc (struct [c1 Ba] [c2 Bb] [c3 double]))
+    #t)
+    
+  (equal?
+    (let ([x (make-ftype-pointer Bc 0)])
+      (list
+        (ftype-sizeof Ba)
+        (ftype-sizeof Bb)
+        (ftype-sizeof Bc)
+        (ftype-pointer-address (ftype-&ref Bc (c1 a1) x))
+        (ftype-pointer-address (ftype-&ref Bc (c1 a2) x))
+        (ftype-pointer-address (ftype-&ref Bc (c1 a3) x))
+        (ftype-pointer-address (ftype-&ref Bc (c2 b1) x))
+        (ftype-pointer-address (ftype-&ref Bc (c3) x))))
+    '(12 1 24 0 4 8 12 16))
+
+ ; ----------------
+
+  (begin
+    (define-ftype Ca (struct [a1 integer-8] [a2 double] [a3 integer-8]))
+    (define-ftype Cb (struct [b1 integer-8]))
+    (define-ftype Cc (struct [c1 Ca] [c2 Cb] [c3 double]))
+    #t)
+
+  (equal?
+    (let ([x (make-ftype-pointer Cc 0)])
+      (list
+        (ftype-sizeof Ca)
+        (ftype-sizeof Cb)
+        (ftype-sizeof Cc)
+        (ftype-pointer-address (ftype-&ref Cc (c1 a1) x))
+        (ftype-pointer-address (ftype-&ref Cc (c1 a2) x))
+        (ftype-pointer-address (ftype-&ref Cc (c1 a3) x))
+        (ftype-pointer-address (ftype-&ref Cc (c2 b1) x))
+        (ftype-pointer-address (ftype-&ref Cc (c3) x))))
+    (if (< max-float-alignment 8)
+        '(16 1 28 0 4 12 16 20)
+        '(24 1 40 0 8 16 24 32)))
+    
+ ; ----------------
+
+  (begin
+    (define-ftype Da (struct [a1 integer-8] [a2 integer-64] [a3 integer-8]))
+    (define-ftype Db (struct [b1 integer-8]))
+    (define-ftype Dc (struct [c1 Da] [c2 Db] [c3 integer-64]))
+    #t)
+
+  (equal?
+    (let ([x (make-ftype-pointer Dc 0)])
+      (list
+        (ftype-sizeof Da)
+        (ftype-sizeof Db)
+        (ftype-sizeof Dc)
+        (ftype-pointer-address (ftype-&ref Dc (c1 a1) x))
+        (ftype-pointer-address (ftype-&ref Dc (c1 a2) x))
+        (ftype-pointer-address (ftype-&ref Dc (c1 a3) x))
+        (ftype-pointer-address (ftype-&ref Dc (c2 b1) x))
+        (ftype-pointer-address (ftype-&ref Dc (c3) x))))
+    (if (< max-integer-alignment 8)
+        '(16 1 28 0 4 12 16 20)
+        '(24 1 40 0 8 16 24 32)))
+    
+ ; ----------------
+
+  (begin
+    (define-ftype Ea
+      (struct
+        [x integer-32]
+        [y double-float]
+        [z (array 25 (struct [_ integer-16] [b integer-16]))]
+        [w (struct
+             [a integer-32]
+             [b (union
+                  [b1 (struct [a integer-32] [b integer-32])]
+                  [b2 (struct [a integer-8] [b double])])])]
+        [v (* Ac)]))
+    #t)
+
+  (equal?
+    (let ([x (make-ftype-pointer Ea 0)])
+      (list
+        (ftype-sizeof Ea)
+        (ftype-pointer-address (ftype-&ref Ea (x) x))
+        (ftype-pointer-address (ftype-&ref Ea (y) x))
+        (ftype-pointer-address (ftype-&ref Ea (z) x))
+        (ftype-pointer-address (ftype-&ref Ea (w) x))
+        (ftype-pointer-address (ftype-&ref Ea (v) x))
+        (ftype-pointer-address (ftype-&ref Ea (z 0) x))
+        (ftype-pointer-address (ftype-&ref Ea (z 4 b) x))
+        (ftype-pointer-address (ftype-&ref Ea (w a) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b b1) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b b1 a) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b b1 b) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b b2) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b b2 a) x))
+        (ftype-pointer-address (ftype-&ref Ea (w b b2 b) x))))
+    (if (< max-float-alignment 8)
+        '(132 0 4 12 112 128 12 30 112 116 116 116 120 116 116 120)
+        '(152 0 8 16 120 144 16 34 120 128 128 128 132 128 128 136)))
+
+  (begin
+    (define-ftype Eb
+      (packed
+        (struct
+          [x integer-32]
+          [y double-float]
+          [z (array 25 (struct [_ integer-16] [b integer-16]))]
+          [w (struct
+               [a integer-32]
+               [b (union
+                    [b1 (struct [a integer-32] [b integer-32])]
+                    [b2 (struct [a integer-8] [b double])])])]
+          [v (* Ac)])))
+    #t)
+
+  (equal?
+    (let ([x (make-ftype-pointer Eb 0)])
+      (list
+        (ftype-sizeof Eb)
+        (ftype-pointer-address (ftype-&ref Eb (x) x))
+        (ftype-pointer-address (ftype-&ref Eb (y) x))
+        (ftype-pointer-address (ftype-&ref Eb (z) x))
+        (ftype-pointer-address (ftype-&ref Eb (w) x))
+        (ftype-pointer-address (ftype-&ref Eb (v) x))
+        (ftype-pointer-address (ftype-&ref Eb (z 0) x))
+        (ftype-pointer-address (ftype-&ref Eb (z 4 b) x))
+        (ftype-pointer-address (ftype-&ref Eb (w a) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b b1) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b b1 a) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b b1 b) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b b2) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b b2 a) x))
+        (ftype-pointer-address (ftype-&ref Eb (w b b2 b) x))))
+    (if (< (fixnum-width) 32)
+        '(129 0 4 12 112 125 12 30 112 116 116 116 120 116 116 117)
+        '(133 0 4 12 112 125 12 30 112 116 116 116 120 116 116 117)))
+
+ ; ----------------
+
+  (equal?
+    (let ()
+      (define-ftype A (struct [a1 integer-32]))
+      (define-ftype B (struct [b1 A] [b2 (* A)]))
+      (define x (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+      (define y (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (ftype-set! B (b2) x y)
+      (ftype-set! A (a1) y 72)
+      (ftype-set! B (b1 a1) x -35)
+      (free-after x
+        (free-after y
+          (list (ftype-ref A (a1) y) (ftype-ref B (b1 a1) x) (ftype-ref B (b2 * a1) x)))))
+    '(72 -35 72))
+
+  (begin
+    (define base-ftype*
+      `((short . "short")
+        (unsigned-short . "unsigned short")
+        (int . "int")
+        (unsigned . "unsigned")
+        (unsigned-int . "unsigned int")
+        (long . "long")
+        (unsigned-long . "unsigned long")
+        (long-long . "int64_t")
+        (unsigned-long-long . "uint64_t")
+        (char . "char")
+        (wchar . "wchar")
+        (float . "float")
+        (double . "double")
+        (void* . "void *")
+        (iptr . ,(if (< (fixnum-width) 32) "int32_t" "int64_t"))
+        (uptr . ,(if (< (fixnum-width) 32) "uint32_t" "uint64_t"))
+        (fixnum . ,(if (< (fixnum-width) 32) "int32_t" "int64_t"))
+        (boolean . "int")
+        (integer-8 . "int8_t")
+        (unsigned-8 . "uint8_t")
+        (integer-16 . "int16_t")
+        (unsigned-16 . "uint16_t")
+        (integer-32 . "int32_t")
+        (unsigned-32 . "uint32_t")
+        (integer-64 . "int64_t")
+        (unsigned-64 . "uint64_t")
+        (single-float . "float")
+        (double-float . "double")))
+
+    (define ftype-paths
+      (lambda (name ftype alist)
+        (map reverse
+          (let f ([ftype ftype] [path (list name)] [path* '()])
+            (if (symbol? ftype)
+                (cond
+                  [(assq ftype alist) =>
+                   (lambda (a) (f (cdr a) path path*))]
+                  [else (cons path path*)])
+                (cons path
+                  (record-case ftype
+                    [(struct) field*
+                     (fold-right
+                       (lambda (field path*)
+                         (f (cadr field) (cons (car field) path) path*))
+                       path* field*)]
+                    [(union) field*
+                     (fold-right
+                       (lambda (field path*)
+                         (f (cadr field) (cons (car field) path) path*))
+                       path* field*)]
+                    [(array) (length ftype)
+                     (if (= length 0)
+                         path*
+                         (f ftype (cons (- length 1) path) path*))]
+                    [(*) (ftype) path*]
+                    [else
+                     (errorf 'ftype-paths "can't handle ~s" ftype)])))))))
+
+    (define ftype-code
+      (lambda (ftype name)
+        (if (symbol? ftype)
+            (cond
+              [(assq ftype base-ftype*) =>
+               (lambda (a) (format "~a ~a;" (cdr a) name))]
+              [else (format "typedef_~a ~a;" ftype name)])
+            (record-case ftype
+              [(struct) field*
+               (format "struct { ~{~a ~}} ~a;"
+                 (map
+                   (lambda (field) (ftype-code (cadr field) (car field)))
+                   field*)
+                 name)]
+              [(union) field* 
+               (format "union { ~{~a ~}} ~a;"
+                 (map
+                   (lambda (field) (ftype-code (cadr field) (car field)))
+                   field*)
+                 name)]
+              [(array) (length ftype)
+               (ftype-code ftype (format "~a[~d]" name length))]
+              [(*) (ftype)
+               (ftype-code ftype (format "*~a" name))]
+              [else
+               (errorf 'ftype-code "can't handle ~s" ftype)]))))
+
+    (define C-test-code
+      (lambda (ftype-defn* path* ndefs npaths i* j*)
+        (let ([ndefs (length ftype-defn*)])
+          (printf "#include \"~a/ftype.h\"\n\
+                   #define offset(x, y) (int)((char *)&y - (char *)&x)\n\
+                   EXPORT int *foo() {\n\
+                     ~{~a\n~}\
+                     static int a[~d];\n\
+                     ~{~a\n~}\
+                     ~{~a\n~}\
+                     return a;\
+                   }\n"
+            *mats-dir*
+            (map
+              (lambda (ftype-defn)
+                (format "typedef ~a typedef_~a ~a;"
+                  (ftype-code (cdr ftype-defn) (format "typedef_~a" (car ftype-defn)))
+                  (car ftype-defn)
+                  (car ftype-defn)))
+              ftype-defn*)
+            (+ ndefs npaths)
+            (map
+              (lambda (i ftype-defn)
+                (format "a[~a] = sizeof(~a);" i (car ftype-defn)))
+              i* ftype-defn*)
+            (map
+              (lambda (j path)
+                (format "a[~d] = offset(~a,~a~{~a~});"
+                  j
+                  (car path)
+                  (car path)
+                  (map (lambda (x)
+                         (if (and (integer? x) (exact? x))
+                             (format "[~d]" x)
+                             (format ".~a" x)))
+                    (cdr path))))
+              j* path*)))))
+
+    (define C-compile&load
+      (lambda (testfile thunk)
+        (let ([testfile.c (format "testfile-~a.c" testfile)]
+              [testfile.so (format "testfile-~a.~:[so~;dll~]" testfile
+                             (windows?))])
+          (with-output-to-file testfile.c thunk 'replace)
+          (unless (= (case (machine-type)
+                       [(i3osx ti3osx)
+                        (system (format "cc -m32 -dynamiclib -o ~a ~a" testfile.so testfile.c))]
+                       [(a6osx a6osx)
+                        (system (format "cc -m64 -dynamiclib -o ~a ~a" testfile.so testfile.c))]
+                       [(a6nt ta6nt)
+                        (system (format "set cl= && ~a\\..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a"
+                                  (patch-exec-path *mats-dir*) testfile.so testfile.c))]
+                       [(i3nt ti3nt)
+                        (system (format "set cl= && ~a\\..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a"
+                                  (patch-exec-path *mats-dir*) testfile.so testfile.c))]
+                       [(arm32le tarm32le)
+                        (system (format "cc -fPIC -shared -o ~a ~a" testfile.so testfile.c))]
+                       [else ; this should work for most intel-based systems that use gcc...
+                        (if (> (fixnum-width) 32)
+                            (system (format "cc -m64 -fPIC -shared -o ~a ~a" testfile.so testfile.c))
+                            (system (format "cc -m32 -fPIC -shared -o ~a ~a" testfile.so testfile.c)))])
+                     0)
+            (errorf 'ftype-test "C compilation failed"))
+          (load-shared-object (format "./~a" testfile.so)))))
+
+    (define-syntax ftype-test
+      (lambda (x)
+        (syntax-case x ()
+          [(_ testfile (id ftype) ...)
+           (with-syntax ([((path ...) ...)
+                          (let ([id* (datum (id ...))]
+                                [ftype* (datum (ftype ...))])
+                            (let ([alist (map cons id* ftype*)])
+                              (map
+                                (lambda (id ftype)
+                                  (map (lambda (x) (datum->syntax #'* x))
+                                    (ftype-paths id ftype alist)))
+                                id* ftype*)))])
+               (let ([ndefs (length #'(ftype ...))]
+                     [npaths (length #'(path ... ...))])
+                 (with-syntax ([(i ...) (enumerate #'(ftype ...))]
+                               [(j ...) (list-tail (enumerate #'(ftype ... path ... ...)) ndefs)]
+                               [((idx . pathx) ...) #'(path ... ...)])
+                   #`(begin
+                       (define-ftype id ftype) ...
+                       (define-ftype result-type (array #,(+ ndefs npaths) int))
+                       (C-compile&load testfile
+                         (lambda ()
+                           (C-test-code
+                             '((id . ftype) ...) '(path ... ...)
+                             #,ndefs #,npaths
+                             '(i ...) '(j ...))))
+
+                       (let ([results (make-ftype-pointer result-type
+                                        ((foreign-procedure "foo" () void*)))]
+                             [status #t])
+                         (let ([Scheme-size (ftype-sizeof id)] [C-size (ftype-ref result-type (i) results)])
+                           (unless (= Scheme-size C-size)
+                             (printf "sizeof check failed for ~s (C says ~s, Scheme says ~s)\n" 'ftype C-size Scheme-size)
+                             (set! status #f)))
+                         ...
+                         (let ([Scheme-addr (ftype-pointer-address (ftype-&ref idx pathx (make-ftype-pointer idx 0)))]
+                               [C-addr (ftype-ref result-type (j) results)])
+                           (unless (= Scheme-addr C-addr)
+                             (printf "address check failed for ~s (C says ~s, Scheme says ~s)\n"
+                               (cons 'idx 'pathx) C-addr Scheme-addr)
+                             (set! status #f)))
+                         ...
+                         status)))))])))
+
+    #t)
+
+ ; can pack as many of these together as we want
+ ; should avoid too many ftype-test forms to avoid
+ ; excessive number of shared object
+ ; NB. choose a different testfile name for each
+  (ftype-test "ftype1"
+    [Aa (struct [a1 integer-8] [a2 integer-16] [a3 integer-8])]
+    [Ab (struct [b1 integer-8])]
+    [Ac (struct [c1 Aa] [c2 Ab] [c3 double])]
+
+    [A int]
+    [B (struct [a int] [b char])]
+    [C (struct [c1 B] [c2 A] [c3 double])]
+    [D (struct
+         [x integer-32]
+         [y double-float]
+         [z (array 25 (struct [a integer-16] [b integer-16]))]
+         [w (struct
+              [a integer-32]
+              [b (union
+                   [b1 (struct [a integer-32] [b integer-32])]
+                   [b2 (struct [a integer-8] [b double])])])]
+         [v (* C)])]
+    [E (struct
+         [z (array 25 (struct [a unsigned-short] [b unsigned]))]
+         [x unsigned-long]
+         [w (struct
+              [a long-long]
+              [b (union
+                   [b1 (struct [a int] [b int])]
+                   [b2 (struct [a char] [b double])])])]
+         [y double]
+         [u (array 9 float)]
+         [v (* C)]
+         [t char])]
+    [F (struct
+         [a integer-32]
+         [b double])]
+    [G (struct
+         [a double]
+         [b integer-32])]
+    [H (struct
+         [a integer-32]
+         [b (union
+              [b1 double]
+              [b2 (struct [b2a integer-32] [b2b integer-32])])])]
+    [I (struct
+         [a integer-32]
+         [b (array 1 double)])]
+    [J (struct
+         [a (array 1 double)]
+         [b integer-32])]
+    [K1 (union
+          [a double]
+          [b (struct
+               [a integer-32]
+               [b integer-32])])]
+    [K2 (struct
+          [a K1]
+          [b integer-32])]
+    [K2x (struct
+           [a integer-32]
+           [b (union
+                [a double]
+                [b (struct
+                     [a integer-32]
+                     [b integer-32])])])]
+    [K3 (struct
+          [a integer-32]
+          [b K1])]
+    [K3x (struct
+           [a integer-32]
+           [b (union
+                [a double]
+                [b (struct
+                     [a integer-32]
+                     [b integer-32])])])]
+    [M1 (union
+          [b (struct
+               [a integer-32]
+               [b double])]
+          [a double])]
+    [M2 (struct [a M1] [b integer-32])]
+    [M3 (struct [a integer-32] [b M1])]
+    [N1 (struct [a integer-32] [b integer-64])]
+  )
+
+ ; ----------------
+
+  (equal?
+    (let ()
+       (define-ftype A
+         (struct
+           [a1 double]
+           [a2 float]
+           [a3 long-long]
+           [a4 unsigned-long-long]
+           [a5 long]
+           [a6 unsigned-long]
+           [a7 int]
+           [a8 unsigned]
+           [a9 unsigned-int]
+           [a10 short]
+           [a11 unsigned-short]
+           [a12 wchar]
+           [a13 char]
+           [a14 boolean]
+           [a15 fixnum]
+           [a16 iptr]
+           [a17 uptr]
+           [a18 void*]))
+       (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+       (free-after a
+         (ftype-set! A (a1) a 3.5)
+         (ftype-set! A (a2) a -4.5)
+         (ftype-set! A (a3) a -30000)
+         (ftype-set! A (a4) a #xabcdef02)
+         (ftype-set! A (a5) a -30001)
+         (ftype-set! A (a6) a #xabcdef03)
+         (ftype-set! A (a7) a -30002)
+         (ftype-set! A (a8) a #xabcdef04)
+         (ftype-set! A (a9) a #xabcdef05)
+         (ftype-set! A (a10) a -30003)
+         (ftype-set! A (a11) a #xab06)
+         (ftype-set! A (a12) a #\a)
+         (ftype-set! A (a13) a #\b)
+         (ftype-set! A (a14) a 'hello)
+         (ftype-set! A (a15) a (most-positive-fixnum))
+         (ftype-set! A (a16) a -30004)
+         (ftype-set! A (a17) a #xabcdef07)
+         (ftype-set! A (a18) a 25000)
+         (list
+           (ftype-ref A (a1) a)
+           (ftype-ref A (a2) a)
+           (ftype-ref A (a3) a)
+           (ftype-ref A (a4) a)
+           (ftype-ref A (a5) a)
+           (ftype-ref A (a6) a)
+           (ftype-ref A (a7) a)
+           (ftype-ref A (a8) a)
+           (ftype-ref A (a9) a)
+           (ftype-ref A (a10) a)
+           (ftype-ref A (a11) a)
+           (ftype-ref A (a12) a)
+           (ftype-ref A (a13) a)
+           (ftype-ref A (a14) a)
+           (ftype-ref A (a15) a)
+           (ftype-ref A (a16) a)
+           (ftype-ref A (a17) a)
+           (ftype-ref A (a18) a))))
+    `(3.5
+      -4.5
+      -30000
+      #xabcdef02
+      -30001
+      #xabcdef03
+      -30002
+      #xabcdef04
+      #xabcdef05
+      -30003
+      #xab06
+      #\a
+      #\b
+      #t
+      ,(most-positive-fixnum)
+      -30004
+      #xabcdef07
+      25000))
+
+  (begin
+    (define-ftype A
+      (array 3
+        (struct
+          [a int]
+          [b short])))
+    (define x (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i 3))
+      (ftype-set! A (i a) x (expt 2 i))
+      (ftype-set! A (i b) x (- 1 (expt 2 i))))
+    #t)
+
+  (eqv? (ftype-ref A (0 a) x) 1)
+  (eqv? (ftype-ref A (0 b) x) 0)
+  (eqv? (ftype-ref A (1 a) x) 2)
+  (eqv? (ftype-ref A (1 b) x) -1)
+  (eqv? (ftype-ref A (2 a) x) 4)
+  (eqv? (ftype-ref A (2 b) x) -3)
+
+  (error? ; invalid index
+    (ftype-ref A (3 a) x))
+  (error? ; invalid index
+    (ftype-ref A (-1 a) x))
+  (error? ; invalid index
+    (ftype-ref A (x a) x))
+  (error? ; invalid index
+    (ftype-ref A (1.0 a) x))
+  (error? ; invalid index
+    (ftype-&ref A (3) x))
+  (error? ; invalid index
+    (ftype-&ref A (-1) x))
+  (error? ; invalid index
+    (ftype-&ref A (x) x))
+  (error? ; invalid index
+    (ftype-&ref A (1.0) x))
+  (error? ; invalid index
+    (ftype-&ref A (3 a) x))
+  (error? ; invalid index
+    (ftype-&ref A (-1 a) x))
+  (error? ; invalid index
+    (ftype-&ref A (x a) x))
+  (error? ; invalid index
+    (ftype-&ref A (1.0 a) x))
+  (error? ; invalid index
+    (ftype-set! A (3 a) x 0))
+  (error? ; invalid index
+    (ftype-set! A (-1 a) x 0))
+  (error? ; invalid index
+    (ftype-set! A (x a) x 0))
+  (error? ; invalid index
+    (ftype-set! A (1.0 a) x 0))
+  (error? ; invalid value
+    (ftype-set! A (1 a) x 3.2))
+  (error? ; invalid index
+    (ftype-set! A (1 a) x #\a))
+  (error? ; invalid index
+    (ftype-set! A (1 a) x (expt 2 1000)))
+  (error? ; target cannot be referenced
+    (ftype-ref A (1) x))
+  (error? ; target cannot be assigned
+    (ftype-set! A (1) x 0))
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+
+  (begin
+    (define-ftype Q
+      (struct
+        [x integer-16]
+        [y (array 100 integer-32)]))
+    (define x (make-ftype-pointer Q (foreign-alloc (- (ftype-sizeof Q) (* (ftype-sizeof integer-32) (- 100 10))))))
+    #t)
+  (eqv? (ftype-sizeof Q) 404)
+  (eqv? (ftype-pointer-address (ftype-&ref Q (y) (make-ftype-pointer Q 0))) 4)
+  (begin
+    (do ([i 0 (fx+ i 1)])
+        ((fx= i 10))
+      (ftype-set! Q (y i) x (+ (* i 3) 2)))
+    #t)
+  (equal?
+    (map (lambda (i) (ftype-ref Q (y i) x)) (iota 10))
+    (map (lambda (i) (+ (* i 3) 2)) (iota 10)))
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype A (struct [x double]))
+    (define-ftype B (struct [head int] [tail (* A)]))
+    (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+    (ftype-set! B (tail) b a)
+    (ftype-set! B (head) b 17)
+    (ftype-set! A (x) a 3.25)
+    #t)
+  (equal?
+    (ftype-pointer->sexpr a)
+    '(struct [x 3.25]))
+  (equal? 
+    (ftype-pointer->sexpr b)
+    '(struct [head 17] [tail (* (struct [x 3.25]))]))
+  (error? ; not a scalar
+    (ftype-ref B (tail *) b))
+  (ftype-pointer? (ftype-ref B (tail) b))
+  (begin
+    (ftype-set! A (x) (ftype-ref B (tail) b) -5.5)
+    #t)
+  (eqv? (ftype-ref B (tail * x) b) -5.5)
+
+  (begin
+    (fptr-free a)
+    (fptr-free b)
+    #t)
+ ; ----------------
+  (begin
+    (define-ftype Qlist
+      (struct
+        [head int]
+        [tail (* Qlist)]))
+    (define x (make-ftype-pointer Qlist (foreign-alloc (ftype-sizeof Qlist))))
+    (ftype-set! Qlist (head) x 17)
+    (ftype-set! Qlist (tail) x x)
+    #t)
+  (eqv? (ftype-ref Qlist (head) x) 17)
+  (eqv? (ftype-ref Qlist (tail * head) x) 17)
+  (eqv? (ftype-ref Qlist (tail * tail * tail * tail * head) x) 17)
+  (equal?
+    (ftype-pointer->sexpr x)
+    '#0=(struct [head 17] [tail (* #0#)]))
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype
+      [Qfrob (struct
+               [head int]
+               [tail (* Qsnark)])]
+      [Qsnark (struct
+                [head int]
+                [tail (* Qfrob)])])
+    (define x (make-ftype-pointer Qfrob (foreign-alloc (ftype-sizeof Qfrob))))
+    (ftype-set! Qfrob (head) x 17)
+    (define y (make-ftype-pointer Qsnark (foreign-alloc (ftype-sizeof Qsnark))))
+    (ftype-set! Qfrob (tail) x y)
+    (ftype-set! Qfrob (tail * head) x -57)
+    (ftype-set! Qfrob (tail * tail) x x)
+    #t)
+  (eqv? (ftype-ref Qfrob (head) x) 17)
+  (eqv? (ftype-ref Qfrob (tail * head) x) -57)
+  (eqv? (ftype-ref Qfrob (tail * tail * tail * tail * head) x) 17)
+  (eqv? (ftype-ref Qfrob (tail * tail * tail * tail * tail * head) x) -57)
+  (eqv? (ftype-ref Qsnark (head) (ftype-ref Qfrob (tail) x)) -57)
+  (equal?
+    (ftype-pointer->sexpr x)
+    '#1=(struct
+          [head 17]
+          [tail (* (struct [head -57] [tail (* #1#)]))]))
+  (begin
+    (fptr-free x)
+    (fptr-free y)
+    #t)
+
+ ; ----------------
+  (error? ; invalid recursive or forward reference
+    (define-ftype
+      [Qfrob (struct
+               [head int]
+               [xtra Qfrob]
+               [tail (* Qsnark)])]
+      [Qsnark (struct
+                [head int]
+                [tail (* Qfrob)])]))
+  (error? ; invalid recursive or forward reference
+    (define-ftype
+      [Qfrob (struct
+               [head int]
+               [xtra Qsnark]
+               [tail (* Qsnark)])]
+      [Qsnark (struct
+                [head int]
+                [tail (* Qfrob)])]))
+
+ ; ----------------
+  (begin
+    (define-ftype
+      [Qfrob (struct
+               [head int]
+               [tail (* Qsnark)])]
+      [Qsnark (struct
+                [head int]
+                [xtra Qfrob]
+                [tail (* Qfrob)])])
+    (define x (make-ftype-pointer Qfrob (foreign-alloc (ftype-sizeof Qfrob))))
+    (ftype-set! Qfrob (head) x 17)
+    (define y (make-ftype-pointer Qsnark (foreign-alloc (ftype-sizeof Qsnark))))
+    (ftype-set! Qfrob (tail) x y)
+    (ftype-set! Qfrob (tail * head) x -57)
+    (ftype-set! Qfrob (tail * tail) x x)
+    (ftype-set! Qfrob (tail * xtra head) x 83)
+    (ftype-set! Qfrob (tail * xtra tail) x (ftype-ref Qfrob (tail) x))
+    #t)
+  (eqv? (ftype-ref Qfrob (head) x) 17)
+  (eqv? (ftype-ref Qfrob (tail * head) x) -57)
+  (eqv? (ftype-ref Qfrob (tail * tail * tail * tail * head) x) 17)
+  (eqv? (ftype-ref Qfrob (tail * tail * tail * tail * tail * head) x) -57)
+  (eqv? (ftype-ref Qsnark (head) (ftype-ref Qfrob (tail) x)) -57)
+  (eqv? (ftype-ref Qfrob (tail * xtra head) x) 83)
+  (eqv? (ftype-ref Qfrob (tail * xtra tail * head) x) -57)
+  (equal?
+    (ftype-pointer-ftype x)
+    '(struct
+       [head int]
+       [tail (* Qsnark)]))
+  (equal?
+    (ftype-pointer-ftype (ftype-ref Qfrob (tail) x))
+    '(struct
+       [head int]
+       [xtra Qfrob]
+       [tail (* Qfrob)]))
+  (equal?
+    (ftype-pointer->sexpr x)
+    '#2=(struct
+          [head 17]
+          [tail (* #3=(struct
+                        [head -57]
+                        [xtra (struct [head 83] [tail (* #3#)])]
+                        [tail (* #2#)]))]))
+  (begin
+    (fptr-free x)
+    (fptr-free y)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype A (bits [x unsigned 3] [y unsigned 5]))
+    (define-ftype B (* A))
+    (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+    (ftype-set! B () b a)
+    #t)
+
+  (begin
+    (ftype-set! A (x) a 3)
+    (ftype-set! A (y) a 31)
+    #t)
+
+  (eqv? (ftype-ref A (x) a) 3)
+  (eqv? (ftype-ref A (y) a) 31)
+  (eqv? (ftype-ref B (* x) b) 3)
+  (eqv? (ftype-ref B (* y) b) 31)
+
+  (begin
+    (ftype-set! A (x) a 6)
+    (ftype-set! A (y) a 21)
+    #t)
+
+  (eqv? (ftype-ref A (x) a) 6)
+  (eqv? (ftype-ref A (y) a) 21)
+  (eqv? (ftype-ref B (* x) b) 6)
+  (eqv? (ftype-ref B (* y) b) 21)
+
+  (begin
+    (fptr-free a)
+    (fptr-free b)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Q
+      (struct
+        [x integer-16]
+        [y (array 0 iptr)]))
+    (define qlen 17)
+    (define q (make-ftype-pointer Q (foreign-alloc (+ (ftype-sizeof Q) (* qlen (ftype-sizeof iptr))))))
+    (do ([i 0 (fx+ i 1)]) ((fx= i qlen)) (ftype-set! Q (y i) q (* i 7)))
+    #t)
+
+  (error? ; invalid index
+    (ftype-ref Q (y -1) q))
+  (error? ; invalid index
+    (ftype-ref Q (y 3.2) q))
+  (error? ; invalid index
+    (ftype-ref Q (y (+ (most-positive-fixnum) 1)) q))
+  (error? ; invalid index
+    (ftype-set! Q (y -1) q 7))
+  (error? ; invalid index
+    (ftype-set! Q (y 3.2) q 7))
+  (error? ; invalid index
+    (ftype-set! Q (y (+ (most-positive-fixnum) 1)) q 7))
+  (error? ; invalid index
+    (ftype-&ref Q (y -1) q))
+  (error? ; invalid index
+    (ftype-&ref Q (y 3.2) q))
+  (error? ; invalid index
+    (ftype-&ref Q (y (+ (most-positive-fixnum) 1)) q))
+  (error? ; invalid index
+    (ftype-locked-incr! Q (y -1) q))
+  (error? ; invalid index
+    (ftype-locked-decr! Q (y 3.2) q))
+  (error? ; invalid index
+    (ftype-lock! Q (y (+ (most-positive-fixnum) 1)) q))
+  (error? ; invalid index
+    (ftype-spin-lock! Q (y (+ (most-positive-fixnum) 1)) q))
+  (eqv? (ftype-ref Q (y 0) q) 0)
+  (eqv? (ftype-ref Q (y 7) q) 49)
+  (eqv? (ftype-ref Q (y 16) q) 112)
+
+  (begin
+    (fptr-free q)
+    #t)
+
+ ; ----------------
+  (guard (c [(and (message-condition? c)
+                  (equal? (condition-message c) "non-fixnum overall size for ftype"))
+             #t])
+    (eval
+      '(meta-cond
+         [(= (fixnum-width) 30)
+          (define-ftype Q
+            (struct
+              [x integer-16]
+              [y (array #xFFFFFFF integer-32)]))]
+         [(= (fixnum-width) 61)
+          (define-ftype Q
+            (struct
+              [x integer-16]
+              [y (array #xFFFFFFFFFFFFFFF integer-32)]))]
+         [else (errorf #f "unexpected fixnum-width")]))
+    #t)
+
+ ; ----------------
+  (begin
+    (define-syntax $dfvalerr
+      (syntax-rules ()
+        [(_ type)
+         (let ()
+           (define-ftype A (endian big type))
+           (define x (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+           (guard (c [#t (fptr-free x) (raise c)])
+             (ftype-set! A () x 'oops)))]))
+    #t)
+
+  (error? ($dfvalerr (* float)))
+  (error? ($dfvalerr integer-8))
+  (error? ($dfvalerr unsigned-8))
+  (error? ($dfvalerr integer-16))
+  (error? ($dfvalerr unsigned-16))
+  (error? ($dfvalerr integer-32))
+  (error? ($dfvalerr unsigned-32))
+  (error? ($dfvalerr integer-64))
+  (error? ($dfvalerr unsigned-64))
+  (error? ($dfvalerr double-float))
+  (error? ($dfvalerr single-float))
+  (error? ($dfvalerr char))
+  (error? ($dfvalerr wchar))
+  (error? ($dfvalerr fixnum))
+  (error? ($dfvalerr iptr))
+  (error? ($dfvalerr uptr))
+  (error? ($dfvalerr void*))
+  (error? ($dfvalerr int))
+  (error? ($dfvalerr unsigned))
+  (error? ($dfvalerr unsigned-int))
+  (error? ($dfvalerr short))
+  (error? ($dfvalerr unsigned-short))
+  (error? ($dfvalerr long))
+  (error? ($dfvalerr unsigned-long))
+  (error? ($dfvalerr long-long))
+  (error? ($dfvalerr unsigned-long-long))
+  (error? ($dfvalerr double))
+  (error? ($dfvalerr float))
+
+ ; ----------------
+  (begin
+    (define-syntax $dfvalerr
+      (syntax-rules ()
+        [(_ type)
+         (let ()
+           (define-ftype A (endian little type))
+           (define x (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+           (guard (c [#t (fptr-free x) (raise c)])
+             (ftype-set! A () x 'oops)))]))
+    #t)
+
+  (error? ($dfvalerr (* float)))
+  (error? ($dfvalerr integer-8))
+  (error? ($dfvalerr unsigned-8))
+  (error? ($dfvalerr integer-16))
+  (error? ($dfvalerr unsigned-16))
+  (error? ($dfvalerr integer-32))
+  (error? ($dfvalerr unsigned-32))
+  (error? ($dfvalerr integer-64))
+  (error? ($dfvalerr unsigned-64))
+  (error? ($dfvalerr double-float))
+  (error? ($dfvalerr single-float))
+  (error? ($dfvalerr char))
+  (error? ($dfvalerr wchar))
+  (error? ($dfvalerr fixnum))
+  (error? ($dfvalerr iptr))
+  (error? ($dfvalerr uptr))
+  (error? ($dfvalerr void*))
+  (error? ($dfvalerr int))
+  (error? ($dfvalerr unsigned))
+  (error? ($dfvalerr unsigned-int))
+  (error? ($dfvalerr short))
+  (error? ($dfvalerr unsigned-short))
+  (error? ($dfvalerr long))
+  (error? ($dfvalerr unsigned-long))
+  (error? ($dfvalerr long-long))
+  (error? ($dfvalerr unsigned-long-long))
+  (error? ($dfvalerr double))
+  (error? ($dfvalerr float))
+
+ ; ----------------
+  (begin
+    (define-syntax $dfvalerr
+      (syntax-rules ()
+        [(_ type)
+         (begin
+           (with-output-to-file "testfile.ss"
+             (lambda ()
+               (pretty-print
+                 '(let ()
+                    (define-ftype A type)
+                    (define x (make-ftype-pointer A 0))
+                    (ftype-set! A () x 'oops))))
+             'replace)
+           (load "testfile.ss"))]))
+    #t)
+
+  (error? ($dfvalerr (* float)))
+  (error? ($dfvalerr integer-8))
+  (error? ($dfvalerr unsigned-8))
+  (error? ($dfvalerr integer-16))
+  (error? ($dfvalerr unsigned-16))
+  (error? ($dfvalerr integer-32))
+  (error? ($dfvalerr unsigned-32))
+  (error? ($dfvalerr integer-64))
+  (error? ($dfvalerr unsigned-64))
+  (error? ($dfvalerr double-float))
+  (error? ($dfvalerr single-float))
+  (error? ($dfvalerr char))
+  (error? ($dfvalerr wchar))
+  (error? ($dfvalerr fixnum))
+  (error? ($dfvalerr iptr))
+  (error? ($dfvalerr uptr))
+  (error? ($dfvalerr void*))
+  (error? ($dfvalerr int))
+  (error? ($dfvalerr unsigned))
+  (error? ($dfvalerr unsigned-int))
+  (error? ($dfvalerr short))
+  (error? ($dfvalerr unsigned-short))
+  (error? ($dfvalerr long))
+  (error? ($dfvalerr unsigned-long))
+  (error? ($dfvalerr long-long))
+  (error? ($dfvalerr unsigned-long-long))
+  (error? ($dfvalerr double))
+  (error? ($dfvalerr float))
+
+ ; ----------------
+  (error? ; invalid syntax
+    (ftype-sizeof (struct [a int])))
+  (error? ; invalid syntax
+    (make-ftype-pointer (struct [a int]) 0))
+  (error? ; invalid syntax
+    (ftype-pointer? (struct [a int]) 0))
+  (error? ; invalid syntax
+    (ftype-&ref (struct [a int]) (a) x))
+  (error? ; invalid syntax
+    (ftype-ref (struct [a int]) (a) x))
+  (error? ; invalid syntax
+    (ftype-set! (struct [a int]) (a) x 0))
+
+ ; ----------------
+  (begin
+    (define-ftype A (packed (struct [a char] [b int])))
+    (define-ftype B (struct [a A] [b (* A)]))
+    (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+    #t)
+
+  (ftype-pointer? A (ftype-&ref B (a) b))
+  (ftype-pointer? A (ftype-ref B (b) b))
+
+  (begin
+    (fptr-free b)
+    #t)
+
+ ; ----------------
+ (begin
+   ;; Bind a native built-in type as a normal ftype (note this fixes the endianness).
+   (define-ftype integer-8 integer-8)
+   (define-ftype float float)
+   (define-ftype S (struct [i integer-8] [f float]))
+   #t)
+ (let ([int-fptr (make-ftype-pointer integer-8 (foreign-alloc (ftype-sizeof integer-8)))]
+       [flo-fptr (make-ftype-pointer float (foreign-alloc (ftype-sizeof float)))]
+       [s-fptr (make-ftype-pointer S (foreign-alloc (ftype-sizeof S)))])
+   (ftype-set! integer-8 () int-fptr 42)
+   (ftype-set! float () flo-fptr 7.125)
+   (ftype-set! S (i) s-fptr 75)
+   (ftype-set! S (f) s-fptr 8.25)
+   (let ([a (ftype-ref integer-8 () int-fptr)]
+         [b (ftype-ref float () flo-fptr)]
+         [c (ftype-ref S (i) s-fptr)]
+         [d (ftype-ref S (f) s-fptr)])
+     (foreign-free (ftype-pointer-address int-fptr))
+     (foreign-free (ftype-pointer-address flo-fptr))
+     (foreign-free (ftype-pointer-address s-fptr))
+     (equal? (list a b c d) (list 42 7.125 75 8.25))))
+
+ (begin
+   ;; Show that binding does not interfere with native types.
+   (define-syntax unsigned-16 (make-compile-time-value "Non-interfering binding"))
+   (let ([fptr (make-ftype-pointer unsigned-16 0)])
+     (= (ftype-pointer-address fptr) 0)))
+)
+
+(mat ftype-pointer-address-optimizations
+  (begin
+    (define-ftype A (struct (x iptr)))
+    (define-ftype B (struct (x uptr)))
+    (define a1 (make-ftype-pointer A 0))
+    (define a1-also (make-ftype-pointer A 0))
+    (define a2 (make-ftype-pointer A (+ (most-positive-fixnum) 1)))
+    (define a2-also (make-ftype-pointer A (+ (most-positive-fixnum) 1)))
+    #t)
+
+  (error? (ftype-pointer-null? '()))
+  (error? (ftype-pointer=? "oops" a1))
+  (error? (ftype-pointer=? a1 17))
+
+  (ftype-pointer-null? a1)
+  (= (ftype-pointer-address a1) 0)
+  (r6rs:= (ftype-pointer-address a1) 0)
+  (eqv? (ftype-pointer-address a1) 0)
+  (equal? (ftype-pointer-address a1) 0)
+  (= 0 (ftype-pointer-address a1))
+  (r6rs:= 0 (ftype-pointer-address a1))
+  (eqv? 0 (ftype-pointer-address a1))
+  (equal? 0 (ftype-pointer-address a1))
+  (not (< (ftype-pointer-address a1) 0))
+
+  (not (ftype-pointer-null? a2))
+  (not (= (ftype-pointer-address a2) 0))
+  (not (r6rs:= (ftype-pointer-address a2) 0))
+  (not (eqv? (ftype-pointer-address a2) 0))
+  (not (equal? (ftype-pointer-address a2) 0))
+  (not (= 0 (ftype-pointer-address a2)))
+  (not (r6rs:= 0 (ftype-pointer-address a2)))
+  (not (eqv? 0 (ftype-pointer-address a2)))
+  (not (equal? 0 (ftype-pointer-address a2)))
+  (not (< (ftype-pointer-address a2) 0))
+
+  (ftype-pointer=? a1 a1-also)
+  (= (ftype-pointer-address a1) (ftype-pointer-address a1-also))
+  (r6rs:= (ftype-pointer-address a1) (ftype-pointer-address a1-also))
+  (eqv? (ftype-pointer-address a1) (ftype-pointer-address a1-also))
+  (equal? (ftype-pointer-address a1) (ftype-pointer-address a1-also))
+  (ftype-pointer=? a2 a2-also)
+  (= (ftype-pointer-address a2) (ftype-pointer-address a2-also))
+  (r6rs:= (ftype-pointer-address a2) (ftype-pointer-address a2-also))
+  (eqv? (ftype-pointer-address a2) (ftype-pointer-address a2-also))
+  (equal? (ftype-pointer-address a2) (ftype-pointer-address a2-also))
+  (not (ftype-pointer=? a1 a2))
+  (not (= (ftype-pointer-address a2) (ftype-pointer-address a1)))
+  (not (r6rs:= (ftype-pointer-address a2) (ftype-pointer-address a1)))
+  (not (eqv? (ftype-pointer-address a2) (ftype-pointer-address a1)))
+  (not (equal? (ftype-pointer-address a2) (ftype-pointer-address a1)))
+
+  (begin
+    (define $f1
+      (lambda (a)
+        (ftype-pointer-null? a)))
+    (define $f2a
+      (lambda (a)
+        (#%= (#3%ftype-pointer-address a1) 0)))
+    (define $f2b
+      (lambda (a)
+        (#%r6rs:= (#3%ftype-pointer-address a1) 0)))
+    (define $f3
+      (lambda (a)
+        (#%eqv? (#3%ftype-pointer-address a) 0)))
+    (define $f4
+      (lambda (a)
+        (#%equal? (#3%ftype-pointer-address a) 0)))
+    (define $f5a
+      (lambda (a)
+        (#%= 0 (#3%ftype-pointer-address a))))
+    (define $f5b
+      (lambda (a)
+        (#%r6rs:= 0 (#3%ftype-pointer-address a))))
+    (define $f6
+      (lambda (a)
+        (#%eqv? 0 (#3%ftype-pointer-address a))))
+    (define $f7
+      (lambda (a)
+        (#%equal? 0 (#3%ftype-pointer-address a))))
+    (define $f8
+      (lambda (a b)
+        (ftype-pointer=? a b)))
+    (define $f9a
+      (lambda (a b)
+        (#%= (#3%ftype-pointer-address b) (#3%ftype-pointer-address a))))
+    (define $f9b
+      (lambda (a b)
+        (#%r6rs:= (#3%ftype-pointer-address b) (#3%ftype-pointer-address a))))
+    (define $f10
+      (lambda (a b)
+        (#%eqv? (#3%ftype-pointer-address b) (#3%ftype-pointer-address a))))
+    (define $f11
+      (lambda (a b)
+        (#%equal? (#3%ftype-pointer-address b) (#3%ftype-pointer-address a))))
+    #t)
+
+  ; check to make sure we don't allocate a bignum while checking
+  (let ([s0 (statistics)])
+    (do ([n 1000 (fx- n 1)])
+        ((fx= n 0))
+      ($f1 a1)
+      ($f2a a1)
+      ($f2b a1)
+      ($f3 a1)
+      ($f4 a1)
+      ($f5a a1)
+      ($f5b a1)
+      ($f6 a1)
+      ($f7 a1))
+    (let ([s1 (statistics)])
+      (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000)))
+
+  (or (eq? (current-eval) interpret)
+      (eq? (compile-profile) 'source)
+      (let ([s0 (statistics)])
+        (do ([n 1000 (fx- n 1)])
+          ((fx= n 0))
+          ($f1 a2)
+          ($f2a a2)
+          ($f2b a2)
+          ($f3 a2)
+          ($f4 a2)
+          ($f5a a2)
+          ($f5b a2)
+          ($f6 a2)
+          ($f7 a2))
+        (let ([s1 (statistics)])
+          (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000))))
+
+  (let ([s0 (statistics)])
+    (do ([n 1000 (fx- n 1)])
+      ((fx= n 0))
+      ($f8 a1-also a1)
+      ($f9a a1-also a1)
+      ($f9b a1-also a1)
+      ($f10 a1-also a1)
+      ($f11 a1-also a1))
+    (let ([s1 (statistics)])
+      (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000)))
+
+  (or (eq? (current-eval) interpret)
+      (eq? (compile-profile) 'source)
+      (let ([s0 (statistics)])
+        (do ([n 1000 (fx- n 1)])
+          ((fx= n 0))
+          ($f8 a1 a2)
+          ($f9a a1 a2)
+          ($f9b a1 a2)
+          ($f10 a1 a2)
+          ($f11 a1 a2))
+        (let ([s1 (statistics)])
+          (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000))))
+
+  (or (eq? (current-eval) interpret)
+      (eq? (compile-profile) 'source)
+      (let ([s0 (statistics)])
+        (do ([n 1000 (fx- n 1)])
+          ((fx= n 0))
+          ($f8 a2-also a2)
+          ($f9a a2-also a2)
+          ($f9b a2-also a2)
+          ($f10 a2-also a2)
+          ($f11 a2-also a2))
+        (let ([s1 (statistics)])
+          (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000))))
+
+  (begin
+    (define x (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    #t)
+  (begin
+    (define $not-much-alloc?
+      (lambda (require-cp0? p)
+        (or (eq? (current-eval) interpret)
+            (#%$suppress-primitive-inlining)
+            (eq? (compile-profile) 'source)
+            (not (= (optimize-level) 3))
+            (and require-cp0? (not (enable-cp0)))
+            (let ([s0 (statistics)])
+              (and (let f ([n 1000])
+                     (or (fx= n 0)
+                         (begin
+                           (let ([x (p n)]) (unless (eq? x #t) (errorf #f "p returned non-#t value ~s for n=~s" x n)))
+                           (f (fx- n 1)))))
+                   (let ([s1 (statistics)])
+                     (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000)))))))
+    #t)
+
+  ; might should also check ftype-&ref, ftype-locked-decr!, ftype-init-lock,
+  ; ftype-lock!, ftype-spin-lock!, and ftype-unlock!, plus more flavors of
+  ; ftype-ref (including bit-field references) and all the others.
+  ($not-much-alloc? #f
+    (lambda (n)
+      (ftype-set! A (x) x (fx+ n 10))
+      (and (fx= (ftype-ref B (x) (make-ftype-pointer B (ftype-pointer-address x))) (fx+ n 10))
+           (begin
+             (ftype-set! B (x) (make-ftype-pointer B (ftype-pointer-address x)) (fx+ n 19))
+             (and (fx= (ftype-ref A (x) x) (fx+ n 19))
+                  (begin
+                    (ftype-locked-incr! B (x) (make-ftype-pointer B (ftype-pointer-address x)))
+                    (fx= (ftype-ref A (x) x) (fx+ n 20))))))))
+
+  (begin
+    (define $ftp1 (make-ftype-pointer A 0))
+    (define $ftp2 (make-ftype-pointer A (+ (most-positive-fixnum) 1)))
+    ; this should cost the same at o=3 whether address is a fixnum or bignum
+    (define $mkftp (lambda (x) (make-ftype-pointer B (ftype-pointer-address x))))
+    #t)
+
+  (or (eq? (current-eval) interpret)
+      (#%$suppress-primitive-inlining)
+      (eq? (compile-profile) 'source)
+      (not (= (optimize-level) 3))
+      (<=
+        -100
+        (- (let ([s0 (statistics)])
+             (ftype-pointer?
+               (do ([n 100 (fx- n 1)] [x $ftp1 ($mkftp x)])
+                 ((fx= n 0) x)))
+             (let ([s1 (statistics)])
+               (- (sstats-bytes s1) (sstats-bytes s0))))
+           (let ([s0 (statistics)])
+             (ftype-pointer?
+               (do ([n 100 (fx- n 1)] [x $ftp2 ($mkftp x)])
+                 ((fx= n 0) x)))
+             (let ([s1 (statistics)])
+               (- (sstats-bytes s1) (sstats-bytes s0)))))
+        100))
+
+  (begin
+    (fptr-free x)
+    #t)
+
+  ($not-much-alloc? #t
+    (let ()
+      (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))
+      (define-ftype B (* A))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+      (lambda (n)
+        (and
+          (eqv? (ftype-set! B () b a) (void))
+          (eqv? (ftype-set! A (x 3) a 17) (void))
+          (eqv? (ftype-set! A (y y1) a 5) (void))
+          (eqv? (ftype-set! A (y y2) a 2795) (void))
+          (eqv? (ftype-set! A (y y3) a -9493) (void))
+          (eqv? (ftype-ref A (x 3) (ftype-ref B () b)) 17)
+          (eqv? (ftype-set! A (x 3) (ftype-ref B () b) 37) (void))
+          (eqv? (ftype-ref A (x 3) (ftype-ref B () b)) 37)
+          (eqv? (ftype-ref A (y y1) (ftype-ref B () b)) 5)
+          (eqv? (ftype-ref A (y y2) (ftype-ref B () b)) 2795)
+          (eqv? (ftype-ref A (y y3) (ftype-ref B () b)) -9493)
+          (eqv? (ftype-set! A (y y1) (ftype-ref B () b) 6) (void))
+          (eqv? (ftype-set! A (y y2) (ftype-ref B () b) 1037) (void))
+          (eqv? (ftype-set! A (y y3) (ftype-ref B () b) 9493) (void))
+          (eqv? (ftype-ref A (y y1) (ftype-ref B () b)) 6)
+          (eqv? (ftype-ref A (y y2) (ftype-ref B () b)) 1037)
+          (eqv? (ftype-ref A (y y3) (ftype-ref B () b)) 9493)))))
+
+  ($not-much-alloc? #t
+    (let ()
+      (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))
+      (define-ftype B (* A))
+      (define-ftype BB (struct [b1 char] [b2 B]))
+      (define-ftype BBB (* BB))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (define bb (make-ftype-pointer BB (foreign-alloc (ftype-sizeof BB))))
+      (define bbb (make-ftype-pointer BBB (foreign-alloc (ftype-sizeof BBB))))
+      (lambda (n)
+        (and
+          (eqv? (ftype-set! BB (b2) bb a) (void))
+          (eqv? (ftype-set! BBB () bbb bb) (void))
+          (eqv? (ftype-set! A (x 3) a 17) (void))
+          (eqv? (ftype-set! A (y y1) a 5) (void))
+          (eqv? (ftype-set! A (y y2) a 2795) (void))
+          (eqv? (ftype-set! A (y y3) a -9493) (void))
+          (eqv? (ftype-ref A (x 3) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 17)
+          (eqv? (ftype-set! A (x 3) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb))) 37) (void))
+          (eqv? (ftype-ref A (x 3) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 37)
+          (eqv? (ftype-ref A (y y1) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 5)
+          (eqv? (ftype-ref A (y y2) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 2795)
+          (eqv? (ftype-ref A (y y3) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) -9493)
+          (eqv? (ftype-set! A (y y1) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb))) 6) (void))
+          (eqv? (ftype-set! A (y y2) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb))) 1037) (void))
+          (eqv? (ftype-set! A (y y3) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb))) 9493) (void))
+          (eqv? (ftype-ref A (y y1) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 6)
+          (eqv? (ftype-ref A (y y2) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 1037)
+          (eqv? (ftype-ref A (y y3) (ftype-ref B () (ftype-&ref BB (b2) (ftype-ref BBB () bbb)))) 9493)))))
+
+  ($not-much-alloc? #t
+    (let ()
+      (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))
+      (define-ftype C (struct [c1 int] [c2 A]))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (define c (make-ftype-pointer C (foreign-alloc (ftype-sizeof C))))
+      (lambda (n)
+        (and
+          (ftype-set! C (c2 x 7) c 53)
+          (eqv? (ftype-ref A (x 7) (ftype-&ref C (c2) c)) 53)
+          (eqv? (ftype-set! A (x 7) (ftype-&ref C (c2) c) 71) (void))
+          (eqv? (ftype-ref A (x 7) (ftype-&ref C (c2) c)) 71)))))
+
+  ($not-much-alloc? #t
+    (let ()
+      (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (define a-addr (ftype-pointer-address a))
+      (lambda (n)
+        (and
+          (eqv? (ftype-set! A (x 3) (make-ftype-pointer A (ftype-pointer-address a)) n) (void))
+          (eqv? (ftype-ref A (x 3) (make-ftype-pointer A (ftype-pointer-address a))) n)
+          (eqv? (ftype-set! A (x 3) (make-ftype-pointer A (ftype-pointer-address a)) (- n 3)) (void))
+          (eqv? (ftype-ref A (x 3) (make-ftype-pointer A a-addr)) (- n 3))))))
+    
+  ($not-much-alloc? #t
+    (let ()
+      (define-ftype A iptr)
+      (define-ftype B (* A))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+      (ftype-set! A () a 0)
+      (ftype-set! B () b a)
+      (lambda (n)
+        (and
+          (not (ftype-locked-incr! A () (ftype-ref B () b)))
+          (ftype-locked-decr! A () (ftype-ref B () b))))))
+
+  ($not-much-alloc? #t
+    (let ()
+      (define-ftype A iptr)
+      (define-ftype B (* A))
+      (define-ftype BB (* B))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B))))
+      (define bb (make-ftype-pointer BB (foreign-alloc (ftype-sizeof BB))))
+      (ftype-set! A () a 0)
+      (ftype-set! B () b a)
+      (ftype-set! BB () bb b)
+      (lambda (n)
+        (and
+          (eq? (ftype-spin-lock! A () (ftype-ref B () (ftype-ref BB () bb))) (void))
+          (eq? (ftype-unlock! A () (ftype-ref B () (ftype-ref BB () bb))) (void))))))
+  )
+
+(mat ftype-odd
+  (begin
+    (define-ftype O
+      (struct
+        [i (struct
+             [i24 integer-24]
+             [i40 integer-40]
+             [i48 integer-48]
+             [i56 integer-56])]
+        [u (struct
+             [u56 unsigned-56]
+             [u48 unsigned-48]
+             [u40 unsigned-40]
+             [u24 unsigned-24])]))
+    #t)
+    
+  (equal?
+    (let ([x (make-ftype-pointer O 0)])
+      (list
+        (ftype-sizeof O)
+        (ftype-pointer-address (ftype-&ref O (i i24) x))
+        (ftype-pointer-address (ftype-&ref O (i i40) x))
+        (ftype-pointer-address (ftype-&ref O (i i48) x))
+        (ftype-pointer-address (ftype-&ref O (i i56) x))
+        (ftype-pointer-address (ftype-&ref O (u u56) x))
+        (ftype-pointer-address (ftype-&ref O (u u48) x))
+        (ftype-pointer-address (ftype-&ref O (u u40) x))
+        (ftype-pointer-address (ftype-&ref O (u u24) x))))
+    '(44 0 3 8 14 22 30 36 41))
+
+  (begin
+    (define o (make-ftype-pointer O (foreign-alloc (ftype-sizeof O))))
+    #t)
+
+  (begin
+    (ftype-set! O (i i24) o 0)
+    (ftype-set! O (i i40) o 0)
+    (ftype-set! O (i i48) o 0)
+    (ftype-set! O (i i56) o 0)
+    (ftype-set! O (u u24) o 0)
+    (ftype-set! O (u u40) o 0)
+    (ftype-set! O (u u48) o 0)
+    (ftype-set! O (u u56) o 0)
+    (equal?
+      (list 
+        (ftype-ref O (i i24) o)
+        (ftype-ref O (i i40) o)
+        (ftype-ref O (i i48) o)
+        (ftype-ref O (i i56) o)
+        (ftype-ref O (u u24) o)
+        (ftype-ref O (u u40) o)
+        (ftype-ref O (u u48) o)
+        (ftype-ref O (u u56) o))
+      '(0 0 0 0 0 0 0 0)))
+
+  (let ([n24 (- (ash 1 24) 1)]
+        [n40  (- (ash 1 40) 1)]
+        [n48  (- (ash 1 48) 1)]
+        [n56  (- (ash 1 56) 1)])
+    (ftype-set! O (i i24) o -1)
+    (ftype-set! O (i i40) o -1)
+    (ftype-set! O (i i48) o -1)
+    (ftype-set! O (i i56) o -1)
+    (ftype-set! O (u u24) o -1)
+    (ftype-set! O (u u40) o -1)
+    (ftype-set! O (u u48) o -1)
+    (ftype-set! O (u u56) o -1)
+    (equal?
+      (list 
+        (ftype-ref O (i i24) o)
+        (ftype-ref O (i i40) o)
+        (ftype-ref O (i i48) o)
+        (ftype-ref O (i i56) o)
+        (ftype-ref O (u u24) o)
+        (ftype-ref O (u u40) o)
+        (ftype-ref O (u u48) o)
+        (ftype-ref O (u u56) o))
+      (list -1 -1 -1 -1 n24 n40 n48 n56)))
+
+  (let ([n24 (- (ash 1 24) 1)]
+        [n40  (- (ash 1 40) 1)]
+        [n48  (- (ash 1 48) 1)]
+        [n56  (- (ash 1 56) 1)])
+    (ftype-set! O (i i24) o n24)
+    (ftype-set! O (i i40) o n40)
+    (ftype-set! O (i i48) o n48)
+    (ftype-set! O (i i56) o n56)
+    (ftype-set! O (u u24) o n24)
+    (ftype-set! O (u u40) o n40)
+    (ftype-set! O (u u48) o n48)
+    (ftype-set! O (u u56) o n56)
+    (equal?
+      (list 
+        (ftype-ref O (i i24) o)
+        (ftype-ref O (i i40) o)
+        (ftype-ref O (i i48) o)
+        (ftype-ref O (i i56) o)
+        (ftype-ref O (u u24) o)
+        (ftype-ref O (u u40) o)
+        (ftype-ref O (u u48) o)
+        (ftype-ref O (u u56) o))
+      (list -1 -1 -1 -1 n24 n40 n48 n56)))
+
+  (let ([n24 (- (ash 1 23))]
+        [n40  (- (ash 1 39))]
+        [n48  (- (ash 1 47))]
+        [n56  (- (ash 1 55))])
+    (ftype-set! O (i i24) o n24)
+    (ftype-set! O (i i40) o n40)
+    (ftype-set! O (i i48) o n48)
+    (ftype-set! O (i i56) o n56)
+    (ftype-set! O (u u24) o n24)
+    (ftype-set! O (u u40) o n40)
+    (ftype-set! O (u u48) o n48)
+    (ftype-set! O (u u56) o n56)
+    (equal?
+      (list 
+        (ftype-ref O (i i24) o)
+        (ftype-ref O (i i40) o)
+        (ftype-ref O (i i48) o)
+        (ftype-ref O (i i56) o)
+        (ftype-ref O (u u24) o)
+        (ftype-ref O (u u40) o)
+        (ftype-ref O (u u48) o)
+        (ftype-ref O (u u56) o))
+      (list n24 n40 n48 n56 (- n24) (- n40) (- n48) (- n56))))
+
+  (equal?
+    (ftype-pointer->sexpr o)
+    '(struct
+       [i (struct
+            [i24 #x-800000]
+            [i40 #x-8000000000]
+            [i48 #x-800000000000]
+            [i56 #x-80000000000000])]
+       [u (struct
+            [u56 #x80000000000000]
+            [u48 #x800000000000]
+            [u40 #x8000000000]
+            [u24 #x800000])]))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([i24 (- (random (ash 1 24)) (ash 1 23))]
+          [i40 (- (random (ash 1 40)) (ash 1 39))]
+          [i48 (- (random (ash 1 48)) (ash 1 47))]
+          [i56 (- (random (ash 1 56)) (ash 1 55))]
+          [u24 (- (random (ash #b11 23)) (ash 1 23))]
+          [u40 (- (random (ash #b11 39)) (ash 1 39))]
+          [u48 (- (random (ash #b11 47)) (ash 1 47))]
+          [u56 (- (random (ash #b11 55)) (ash 1 55))])
+      (ftype-set! O (i i24) o i24)
+      (ftype-set! O (i i40) o i40)
+      (ftype-set! O (i i48) o i48)
+      (ftype-set! O (i i56) o i56)
+      (ftype-set! O (u u24) o u24)
+      (ftype-set! O (u u40) o u40)
+      (ftype-set! O (u u48) o u48)
+      (ftype-set! O (u u56) o u56)
+      (and
+        (= (ftype-ref O (i i24) o) i24)
+        (= (ftype-ref O (i i40) o) i40)
+        (= (ftype-ref O (i i48) o) i48)
+        (= (ftype-ref O (i i56) o) i56)
+        (= (ftype-ref O (u u24) o) u24)
+        (= (ftype-ref O (u u40) o) u40)
+        (= (ftype-ref O (u u48) o) u48)
+        (= (ftype-ref O (u u56) o) u56))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([i24 (- (random (ash 1 24)) (ash 1 23))]
+          [i40 (- (random (ash 1 40)) (ash 1 39))]
+          [i48 (- (random (ash 1 48)) (ash 1 47))]
+          [i56 (- (random (ash 1 56)) (ash 1 55))]
+          [u24 (- (random (ash #b11 23)) (ash 1 23))]
+          [u40 (- (random (ash #b11 39)) (ash 1 39))]
+          [u48 (- (random (ash #b11 47)) (ash 1 47))]
+          [u56 (- (random (ash #b11 55)) (ash 1 55))])
+      (ftype-set! O (u u56) o u56)
+      (ftype-set! O (u u48) o u48)
+      (ftype-set! O (u u40) o u40)
+      (ftype-set! O (u u24) o u24)
+      (ftype-set! O (i i56) o i56)
+      (ftype-set! O (i i48) o i48)
+      (ftype-set! O (i i40) o i40)
+      (ftype-set! O (i i24) o i24)
+      (and
+        (= (ftype-ref O (i i24) o) i24)
+        (= (ftype-ref O (i i40) o) i40)
+        (= (ftype-ref O (i i48) o) i48)
+        (= (ftype-ref O (i i56) o) i56)
+        (= (ftype-ref O (u u24) o) u24)
+        (= (ftype-ref O (u u40) o) u40)
+        (= (ftype-ref O (u u48) o) u48)
+        (= (ftype-ref O (u u56) o) u56))))
+
+  (begin
+    (fptr-free o)
+    #t)
+
+ ; ----------------
+
+  (begin
+    (define-ftype O
+      (packed
+        ; NB: tests with this version will cause unaligned access errors on
+        ; NB: machines that don't support unalinged accesses
+        (struct
+          [i (struct
+               [i24 integer-24]
+               [i40 integer-40]
+               [i48 integer-48]
+               [i56 integer-56])]
+          [u (struct
+               [u56 unsigned-56]
+               [u48 unsigned-48]
+               [u40 unsigned-40]
+               [u24 unsigned-24])])))
+    #t)
+    
+  (equal?
+    (let ([x (make-ftype-pointer O 0)])
+      (list
+        (ftype-sizeof O)
+        (ftype-pointer-address (ftype-&ref O (i i24) x))
+        (ftype-pointer-address (ftype-&ref O (i i40) x))
+        (ftype-pointer-address (ftype-&ref O (i i48) x))
+        (ftype-pointer-address (ftype-&ref O (i i56) x))
+        (ftype-pointer-address (ftype-&ref O (u u56) x))
+        (ftype-pointer-address (ftype-&ref O (u u48) x))
+        (ftype-pointer-address (ftype-&ref O (u u40) x))
+        (ftype-pointer-address (ftype-&ref O (u u24) x))))
+    '(42 0 3 8 14 21 28 34 39))
+
+  (begin
+    (define o (make-ftype-pointer O (foreign-alloc (ftype-sizeof O))))
+    #t)
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([i24 (- (random (ash 1 24)) (ash 1 23))]
+          [i40 (- (random (ash 1 40)) (ash 1 39))]
+          [i48 (- (random (ash 1 48)) (ash 1 47))]
+          [i56 (- (random (ash 1 56)) (ash 1 55))]
+          [u24 (- (random (ash #b11 23)) (ash 1 23))]
+          [u40 (- (random (ash #b11 39)) (ash 1 39))]
+          [u48 (- (random (ash #b11 47)) (ash 1 47))]
+          [u56 (- (random (ash #b11 55)) (ash 1 55))])
+      (ftype-set! O (i i24) o i24)
+      (ftype-set! O (i i40) o i40)
+      (ftype-set! O (i i48) o i48)
+      (ftype-set! O (i i56) o i56)
+      (ftype-set! O (u u24) o u24)
+      (ftype-set! O (u u40) o u40)
+      (ftype-set! O (u u48) o u48)
+      (ftype-set! O (u u56) o u56)
+      (and
+        (= (ftype-ref O (i i24) o) i24)
+        (= (ftype-ref O (i i40) o) i40)
+        (= (ftype-ref O (i i48) o) i48)
+        (= (ftype-ref O (i i56) o) i56)
+        (= (ftype-ref O (u u24) o) u24)
+        (= (ftype-ref O (u u40) o) u40)
+        (= (ftype-ref O (u u48) o) u48)
+        (= (ftype-ref O (u u56) o) u56))))
+
+  (do ([i 1000 (fx- i 1)])
+      ((fx= i 0) #t)
+    (let ([i24 (- (random (ash 1 24)) (ash 1 23))]
+          [i40 (- (random (ash 1 40)) (ash 1 39))]
+          [i48 (- (random (ash 1 48)) (ash 1 47))]
+          [i56 (- (random (ash 1 56)) (ash 1 55))]
+          [u24 (- (random (ash #b11 23)) (ash 1 23))]
+          [u40 (- (random (ash #b11 39)) (ash 1 39))]
+          [u48 (- (random (ash #b11 47)) (ash 1 47))]
+          [u56 (- (random (ash #b11 55)) (ash 1 55))])
+      (ftype-set! O (u u56) o u56)
+      (ftype-set! O (u u48) o u48)
+      (ftype-set! O (u u40) o u40)
+      (ftype-set! O (u u24) o u24)
+      (ftype-set! O (i i56) o i56)
+      (ftype-set! O (i i48) o i48)
+      (ftype-set! O (i i40) o i40)
+      (ftype-set! O (i i24) o i24)
+      (and
+        (= (ftype-ref O (i i24) o) i24)
+        (= (ftype-ref O (i i40) o) i40)
+        (= (ftype-ref O (i i48) o) i48)
+        (= (ftype-ref O (i i56) o) i56)
+        (= (ftype-ref O (u u24) o) u24)
+        (= (ftype-ref O (u u40) o) u40)
+        (= (ftype-ref O (u u48) o) u48)
+        (= (ftype-ref O (u u56) o) u56))))
+
+  (begin
+    (fptr-free o)
+    #t)
+)
+
+(mat ftype-indexing
+  (begin
+    (define-ftype pdouble (* double))
+    (define ftype-indexing-test
+      (lambda (init-array!)
+        (define ls '(2.17 3.14 1.85 10.75 18.32))
+        (equal?
+          (let ([doubles (make-ftype-pointer double (foreign-alloc (* (ftype-sizeof double) 5)))]
+                [pdoubles (make-ftype-pointer pdouble (foreign-alloc (ftype-sizeof pdouble)))])
+            (ftype-set! pdouble () pdoubles doubles)
+            (init-array! doubles ls)
+            (let ([v (list
+                       (ftype-ref double () doubles)
+                       (ftype-ref double () doubles *)
+                       (ftype-ref double () doubles 0)
+                       (ftype-ref double () doubles 1)
+                       (ftype-ref double () doubles 2)
+                       (ftype-ref double () doubles 3)
+                       (ftype-ref double () doubles 4)
+                       (ftype-ref pdouble (*) pdoubles)
+                       (ftype-ref pdouble (0) pdoubles)
+                       (ftype-ref pdouble (1) pdoubles)
+                       (ftype-ref pdouble (2) pdoubles)
+                       (ftype-ref pdouble (3) pdoubles)
+                       (ftype-ref pdouble (4) pdoubles))])
+              (foreign-free (ftype-pointer-address doubles))
+              (foreign-free (ftype-pointer-address pdoubles))
+              v))
+          `(,(car ls) ,(car ls) ,@ls ,(car ls) ,@ls))))
+    #t)
+
+  (ftype-indexing-test
+    (lambda (d ls)
+      (unless (null? ls)
+        (let f ([dbl (car ls)] [ls (cdr ls)] [d d])
+          (ftype-set! double () d dbl)
+          (unless (null? ls)
+            (f (car ls) (cdr ls) 
+              (make-ftype-pointer double
+                (+ (ftype-sizeof double)
+                   (ftype-pointer-address d)))))))))
+  (ftype-indexing-test
+    (lambda (d ls)
+      (unless (null? ls)
+        (let f ([dbl (car ls)] [ls (cdr ls)] [idx 0])
+          (ftype-set! double () d idx dbl)
+          (unless (null? ls)
+            (f (car ls) (cdr ls) (fx+ idx 1)))))))
+  (ftype-indexing-test
+    (lambda (d ls)
+      (unless (null? ls)
+        (let f ([dbl (car ls)] [ls (cdr ls)] [idx 0])
+          (ftype-set! double () (ftype-&ref double () d idx) * dbl)
+          (unless (null? ls)
+            (f (car ls) (cdr ls) (fx+ idx 1)))))))
+  (ftype-indexing-test
+    (lambda (d ls)
+      (unless (null? ls)
+        (let ([pdbl (make-ftype-pointer pdouble (foreign-alloc (ftype-sizeof pdouble)))])
+          (ftype-set! pdouble () pdbl (ftype-&ref double () d *))
+          (let f ([dbl (car ls)] [ls (cdr ls)] [idx 0])
+            (ftype-set! pdouble (idx) pdbl * dbl)
+            (unless (null? ls)
+              (f (car ls) (cdr ls) (fx+ idx 1))))))))
+  (ftype-indexing-test
+    (lambda (d ls)
+      (unless (null? ls)
+        (let ([pdbl (make-ftype-pointer pdouble (foreign-alloc (ftype-sizeof pdouble)))])
+          (ftype-set! pdouble () pdbl (ftype-&ref double () d (length ls)))
+          (let ([ls (reverse ls)])
+            (let f ([dbl (car ls)] [ls (cdr ls)] [idx 0])
+              (ftype-set! pdouble ((- -1 idx)) pdbl * dbl)
+              (unless (null? ls)
+                (f (car ls) (cdr ls) (fx+ idx 1)))))))))
+
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double 0)])
+      (ftype-&ref double () doubles 4.5)))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double 0)])
+      (ftype-&ref double () doubles (most-positive-fixnum))))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double (foreign-alloc (* (ftype-sizeof double) 5)))]
+          [pdoubles (make-ftype-pointer pdouble (foreign-alloc (ftype-sizeof pdouble)))])
+      (ftype-set! pdouble () pdoubles doubles)
+      (guard (c [#t (foreign-free (ftype-pointer-address doubles))
+                    (foreign-free (ftype-pointer-address pdoubles))
+                    (raise c)])
+        (pretty-print (ftype-&ref pdouble ('a) pdoubles)))))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double 0)])
+      (ftype-ref double () doubles 4.5)))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double 0)])
+      (ftype-ref double () doubles (most-positive-fixnum))))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double (foreign-alloc (* (ftype-sizeof double) 5)))]
+          [pdoubles (make-ftype-pointer pdouble (foreign-alloc (ftype-sizeof pdouble)))])
+      (ftype-set! pdouble () pdoubles doubles)
+      (guard (c [#t (foreign-free (ftype-pointer-address doubles))
+                    (foreign-free (ftype-pointer-address pdoubles))
+                    (raise c)])
+        (pretty-print (ftype-ref pdouble ('a) pdoubles)))))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double 0)])
+      (ftype-set! double () doubles 4.5 7.0)))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double 0)])
+      (ftype-set! double () doubles (most-positive-fixnum) 7.0)))
+  (error? ; invalid index
+    (let ([doubles (make-ftype-pointer double (foreign-alloc (* (ftype-sizeof double) 5)))]
+          [pdoubles (make-ftype-pointer pdouble (foreign-alloc (ftype-sizeof pdouble)))])
+      (ftype-set! pdouble () pdoubles doubles)
+      (guard (c [#t (foreign-free (ftype-pointer-address doubles))
+                    (foreign-free (ftype-pointer-address pdoubles))
+                    (raise c)])
+        (pretty-print (ftype-set! pdouble ('a) pdoubles 7.0)))))
+
+  (begin
+    (define-ftype A (struct [x int] [y double]))
+    (define-ftype pA (* A))
+    (define ftype-indexing-test
+      (lambda (init-array!)
+        (define int* '(2 3 4 -5 -6))
+        (define dbl* '(2.0 3.0 4.0 -5.0 -6.0))
+        (let ([array (make-ftype-pointer A (foreign-alloc (* (ftype-sizeof A) (length int*))))]
+              [parray (make-ftype-pointer pA (foreign-alloc (ftype-sizeof pA)))])
+          (ftype-set! pA () parray array)
+          (init-array! array int* dbl*)
+          (let ([v (and (eqv? (ftype-ref A (x) array) (car int*))
+                        (eqv? (ftype-ref A (y) array) (car dbl*))
+                        (eqv? (ftype-ref A (x) array *) (car int*))
+                        (eqv? (ftype-ref A (y) array *) (car dbl*))
+                        (andmap
+                          (lambda (int dbl i)
+                            (and
+                              (eqv? (ftype-ref A (x) array i) int)
+                              (eqv? (ftype-ref A (y) array i) dbl)))
+                          int* dbl* (enumerate int*))
+                        (eqv? (ftype-ref pA (* x) parray) (car int*))
+                        (eqv? (ftype-ref pA (* y) parray) (car dbl*))
+                        (andmap
+                          (lambda (int dbl i)
+                            (and
+                              (eqv? (ftype-ref pA (i x) parray) int)
+                              (eqv? (ftype-ref pA (i y) parray) dbl)))
+                          int* dbl* (enumerate int*)))])
+            (foreign-free (ftype-pointer-address array))
+            (foreign-free (ftype-pointer-address parray))
+            v))))
+    #t)
+
+  (ftype-indexing-test
+    (lambda (array int* dbl*)
+      (unless (null? int*)
+        (for-each
+          (lambda (int dbl i)
+            (ftype-set! A (x)
+              (make-ftype-pointer A
+                (+ (ftype-pointer-address array)
+                   (* (ftype-sizeof A) i)))
+              int)
+            (ftype-set! A (y)
+              (make-ftype-pointer A
+                (+ (ftype-pointer-address array)
+                   (* (ftype-sizeof A) i)))
+              dbl))
+          int* dbl* (enumerate int*)))))
+  (ftype-indexing-test
+    (lambda (array int* dbl*)
+      (unless (null? int*)
+        (for-each
+          (lambda (int dbl i)
+            (ftype-set! A (x) array i int)
+            (ftype-set! A (y) array i dbl))
+          int* dbl* (enumerate int*)))))
+
+  ; test for source info attached to index errors
+  ; ...first with invalid value for optional index subform
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x i) (ftype-&ref A () x i))
+            (foo (make-ftype-pointer A 0) 'q))))
+      'replace)
+    #t)
+  (error? ; invalid index q w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x i) (ftype-ref A () x i))
+            (foo (make-ftype-pointer A 0) 'q))))
+      'replace)
+    #t)
+  (error? ; invalid index q w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x i) (ftype-set! A () x i 55))
+            (foo (make-ftype-pointer A 0) 'q))))
+      'replace)
+    #t)
+  (error? ; invalid index q w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A uptr)
+            (define (foo x i) (ftype-locked-incr! A () x i))
+            (foo (make-ftype-pointer A 0) 'q))))
+      'replace)
+    #t)
+  (error? ; invalid index q w/source info
+    (load "testfile.ss"))
+
+  ; now with invalid array accessor
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A (array 17 int))
+            (define (foo x i) (ftype-&ref A (i) x))
+            (foo (make-ftype-pointer A 0) 25))))
+      'replace)
+    #t)
+  (error? ; invalid index 25 w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A (array 17 int))
+            (define (foo x i) (ftype-ref A (i) x))
+            (foo (make-ftype-pointer A 0) 25))))
+      'replace)
+    #t)
+  (error? ; invalid index 25 w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A (array 17 int))
+            (define (foo x i) (ftype-set! A (i) x 55))
+            (foo (make-ftype-pointer A 0) 25))))
+      'replace)
+    #t)
+  (error? ; invalid index 25 w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A (array 17 uptr))
+            (define (foo x i) (ftype-locked-incr! A (i) x))
+            (foo (make-ftype-pointer A 0) 25))))
+      'replace)
+    #t)
+  (error? ; invalid index 25 w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A (array 17 int))
+            (eval '(define (foo x i) (ftype-&ref A (i) x)))
+            (foo (make-ftype-pointer A 0) 25))))
+      'replace)
+    #t)
+  (error? ; invalid index 25 w/o source info
+    (load "testfile.ss"))
+
+  ; test for source info attached to fptr errors
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x) (ftype-&ref A () x))
+            (foo (make-ftype-pointer double 0)))))
+      'replace)
+    #t)
+  (error? ; ftype mismatch w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x) (ftype-ref A () x))
+            (foo 17))))
+      'replace)
+    #t)
+  (error? ; 17 is not an fptr w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x) (ftype-set! A () x 55))
+            (foo (make-ftype-pointer double 0)))))
+      'replace)
+    #t)
+  (error? ; ftype mismatch w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A int)
+            (define (foo x y) (ftype-set! A () x y))
+            (foo (make-ftype-pointer A 0) (make-ftype-pointer double 0)))))
+      'replace)
+    #t)
+  (error? ; ftype mismatch w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A uptr)
+            (define (foo x) (ftype-locked-incr! A () x))
+            (foo 17))))
+      'replace)
+    #t)
+  (error? ; 17 is not an fptr w/source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A uptr)
+            (eval '(define (foo x) (ftype-locked-incr! A () x)))
+            (foo 17))))
+      'replace)
+    #t)
+  (error? ; 17 is not an fptr w/o source info
+    (load "testfile.ss"))
+
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((define-ftype A (* uptr))
+            (define (foo x n) (ftype-ref A (n) x))
+            (define x (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+            (define y (make-ftype-pointer uptr (foreign-alloc (ftype-sizeof uptr))))
+            (ftype-set! A () x y)
+            (guard (c [else
+                        (foreign-free (ftype-pointer-address x))
+                        (foreign-free (ftype-pointer-address y))
+                        (raise c)])
+              (foo x 'a)))))
+      'replace)
+    #t)
+  (error? ; invalid index a for A
+    (load "testfile.ss"))
+)
+
+(mat ftype-inheritance
+  (begin
+    (define-ftype A (struct [a double] [b int]))
+    (define-ftype Bl (endian little (struct [a double] [b int])))
+    (define-ftype Bb (endian big (struct [a double] [b int])))
+    (define-ftype C (union [a int] [b unsigned]))
+    (define-ftype D double)
+    (define-ftype Dl (endian little double))
+    (define-ftype Db (endian big double))
+    (define-ftype E (packed (struct [a double] [b int])))
+    (define-ftype G (packed (array 5 double)))
+    (define-ftype Gu (array 5 double))
+    (define-ftype H (struct [a (endian big G)] [b int]))
+    (define-ftype I (struct [a Gu] [b int]))
+    (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (define bl (make-ftype-pointer Bl (foreign-alloc (ftype-sizeof Bl))))
+    (define bb (make-ftype-pointer Bb (foreign-alloc (ftype-sizeof Bb))))
+    (define c (make-ftype-pointer C (foreign-alloc (ftype-sizeof C))))
+    (define d (make-ftype-pointer D (foreign-alloc (ftype-sizeof D))))
+    (define e (make-ftype-pointer E (foreign-alloc (ftype-sizeof E))))
+    (define f (make-ftype-pointer double (foreign-alloc (ftype-sizeof double))))
+    (define g (make-ftype-pointer G (foreign-alloc (ftype-sizeof G))))
+    (define h (make-ftype-pointer H (foreign-alloc (ftype-sizeof H))))
+    (define i (make-ftype-pointer I (foreign-alloc (ftype-sizeof I))))
+    (ftype-set! A (a) a 3.14)
+    (ftype-set! A (b) a 75)
+    (ftype-set! Bl (a) bl -3.14)
+    (ftype-set! Bl (b) bl -75)
+    (ftype-set! Bb (a) bb -3.14)
+    (ftype-set! Bb (b) bb -75)
+    (ftype-set! C (a) c -750)
+    (ftype-set! D () d 3.0)
+    (ftype-set! E (a) e -3.1415)
+    (ftype-set! E (b) e -7755)
+    (ftype-set! G (0) g 88.5)
+    (ftype-set! H (a 0) h 100.5)
+    (ftype-set! I (a 0) i 100.5)
+    (ftype-set! double () f -3.0)
+    #t)
+
+  (error? ; ftype mismatch
+    (ftype-ref A (a) bl))
+  (error? ; ftype mismatch
+    (ftype-ref A (a) bb))
+  (error? ; ftype mismatch
+    (ftype-ref A (a) c))
+  (error? ; ftype mismatch
+    (ftype-ref A (a) d))
+  (error? ; ftype mismatch
+    (ftype-ref A (a) e))
+  (error? ; ftype mismatch
+    (ftype-ref A (a) f))
+
+  (error? ; ftype mismatch
+    (ftype-ref Bl (b) a))
+  (error? ; ftype mismatch
+    (ftype-ref Bl (b) c))
+  (error? ; ftype mismatch
+    (ftype-ref Bl (b) d))
+  (error? ; ftype mismatch
+    (ftype-ref Bl (b) e))
+  (error? ; ftype mismatch
+    (ftype-ref Bl (b) f))
+
+  (error? ; ftype mismatch
+    (ftype-set! E (a) a 0.0))
+  (error? ; ftype mismatch
+    (ftype-set! E (a) bl 0.0))
+  (error? ; ftype mismatch
+    (ftype-set! E (a) bb 0.0))
+  (error? ; ftype mismatch
+    (ftype-set! E (a) c 0))
+  (error? ; ftype mismatch
+    (ftype-set! E (a) d 0.0))
+  (error? ; ftype mismatch
+    (ftype-set! E (a) f 0.0))
+
+  (error? ; ftype mismatch
+    (ftype-ref int () c))
+  (error? ; ftype mismatch
+    (ftype-ref unsigned () c))
+  (error? ; ftype mismatch
+    (ftype-set! int () c 0))
+  (error? ; ftype mismatch
+    (ftype-set! unsigned () c 0))
+
+  (eqv? (ftype-ref A (a) a) 3.14)
+  (eqv? (ftype-ref D () a) 3.14)
+  (eqv? (ftype-ref double () a) 3.14)
+  (eqv? (ftype-set! D () a -3.5) (void))
+  (eqv? (ftype-ref A (a) a) -3.5)
+  (eqv? (ftype-set! double () a 666.6) (void))
+  (eqv? (ftype-ref A (a) a) 666.6)
+
+  (error? ; ftype mismatch
+    (ftype-ref int () a))
+
+  (eqv? (ftype-ref Bl (a) bl) -3.14)
+  (or (not (eq? (native-endianness) 'little))
+      (eqv? (ftype-ref D () bl) -3.14))
+  (eqv? (ftype-ref Dl () bl) -3.14)
+  (or (not (eq? (native-endianness) 'little))
+      (eqv? (ftype-ref double () bl) -3.14))
+  (error? ; invalid syntax
+    (ftype-ref (endian little double) () bl))
+
+  (eqv? (ftype-ref Bb (a) bb) -3.14)
+  (or (not (eq? (native-endianness) 'big))
+      (eqv? (ftype-ref D () bb) -3.14))
+  (eqv? (ftype-ref Db () bb) -3.14)
+  (or (not (eq? (native-endianness) 'big))
+      (eqv? (ftype-ref double () bb) -3.14))
+  (error? ; invalid syntax
+    (ftype-ref (endian big double) () bb))
+
+  (eqv? (ftype-ref E (a) e) -3.1415)
+  (eqv? (ftype-ref D () e) -3.1415)
+  (eqv? (ftype-ref double () e) -3.1415)
+  (eqv? (ftype-set! D () e 3.1416) (void))
+  (eqv? (ftype-ref E (a) e) 3.1416)
+  (eqv? (ftype-set! double () e -3.1416) (void))
+  (eqv? (ftype-ref E (a) e) -3.1416)
+
+  (eqv? (ftype-ref G (0) g) 88.5)
+  (eqv? (ftype-ref D () g) 88.5)
+  (eqv? (ftype-ref double () g) 88.5)
+  (eqv? (ftype-set! D () g 3.1416) (void))
+  (eqv? (ftype-ref G (0) g) 3.1416)
+  (eqv? (ftype-set! double () g -3.1416) (void))
+  (eqv? (ftype-ref G (0) g) -3.1416)
+
+  (eqv? (ftype-ref H (a 0) h) 100.5)
+  (eqv? (ftype-ref G (0) h) 100.5)
+  (eqv? (ftype-ref D () h) 100.5)
+  (eqv? (ftype-ref double () h) 100.5)
+  (eqv? (ftype-set! D () h 3.1416) (void))
+  (eqv? (ftype-ref H (a 0) h) 3.1416)
+  (eqv? (ftype-set! double () h -3.1416) (void))
+  (eqv? (ftype-ref H (a 0) h) -3.1416)
+
+  (eqv? (ftype-ref I (a 0) i) 100.5)
+  (eqv? (ftype-ref Gu (0) i) 100.5)
+  (eqv? (ftype-ref D () i) 100.5)
+  (eqv? (ftype-ref double () i) 100.5)
+  (eqv? (ftype-set! D () i 3.1416) (void))
+  (eqv? (ftype-ref I (a 0) i) 3.1416)
+  (eqv? (ftype-set! double () i -3.1416) (void))
+  (eqv? (ftype-ref I (a 0) i) -3.1416)
+
+  (begin
+    (fptr-free a)
+    (fptr-free bl)
+    (fptr-free bb)
+    (fptr-free c)
+    (fptr-free d)
+    (fptr-free e)
+    (fptr-free f)
+    (fptr-free g)
+    (fptr-free h)
+    (fptr-free i)
+    #t)
+)
+
+(mat ftype-lock-operations ; also tested in thread.ms
+  (begin
+    (meta-cond
+      [(eq? (native-endianness) 'little)
+       (define-ftype swapped-iptr (endian big iptr))]
+      [else
+       (define-ftype swapped-iptr (endian little iptr))])
+    (define-ftype A
+      (struct
+        [a double]
+        [b wchar]
+        [c uptr]
+        [d float]
+        [e integer-16]
+        [f (struct
+             (f1 iptr)
+             (f2 (array 3 (union (f3a fixnum) (f3b iptr)))))]
+        [g (* iptr)]
+        [h swapped-iptr]))
+    (define g (make-ftype-pointer iptr (foreign-alloc (ftype-sizeof iptr))))
+    (define x (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (ftype-set! A (g) x g)
+    (define $idx 2)
+    #t)
+
+  (error? ; invalid syntax
+    (ftype-locked-incr!))
+  (error? ; invalid syntax
+    (ftype-locked-incr! A))
+  (error? ; invalid syntax
+    (ftype-locked-incr! A x))
+  (error? ; invalid syntax
+    (ftype-locked-incr! A (a . b) x))
+  (error? ; not an ftype
+    (ftype-locked-incr! x () x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-incr! A (a) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-incr! A (b) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-incr! A (d) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-incr! A (e) x))
+  (error? ; unsupported non-base
+    (ftype-locked-incr! A (f) x))
+  (error? ; unsupported non-base
+    (ftype-locked-incr! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-locked-incr! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-locked-incr! A (f f2 0) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-incr! A (f f2 0 f3a) x))
+  (error? ; unsupported non-base
+    (ftype-locked-incr! A (g) x))
+  (error? ; unsupported swapped
+    (ftype-locked-incr! A (h) x))
+
+  (error? ; invalid syntax
+    (ftype-locked-decr!))
+  (error? ; invalid syntax
+    (ftype-locked-decr! A))
+  (error? ; invalid syntax
+    (ftype-locked-decr! A x))
+  (error? ; invalid syntax
+    (ftype-locked-decr! A (a . b) x))
+  (error? ; not an ftype
+    (ftype-locked-decr! x () x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-decr! A (a) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-decr! A (b) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-decr! A (d) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-decr! A (e) x))
+  (error? ; unsupported non-base
+    (ftype-locked-decr! A (f) x))
+  (error? ; unsupported non-base
+    (ftype-locked-decr! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-locked-decr! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-locked-decr! A (f f2 0) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-locked-decr! A (f f2 0 f3a) x))
+  (error? ; unsupported non-base
+    (ftype-locked-decr! A (g) x))
+  (error? ; unsupported swapped
+    (ftype-locked-decr! A (h) x))
+
+  (error? ; invalid syntax
+    (ftype-init-lock!))
+  (error? ; invalid syntax
+    (ftype-init-lock! A))
+  (error? ; invalid syntax
+    (ftype-init-lock! A x))
+  (error? ; invalid syntax
+    (ftype-init-lock! A (a . b) x))
+  (error? ; not an ftype
+    (ftype-init-lock! x () x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-init-lock! A (a) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-init-lock! A (b) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-init-lock! A (d) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-init-lock! A (e) x))
+  (error? ; unsupported non-base
+    (ftype-init-lock! A (f) x))
+  (error? ; unsupported non-base
+    (ftype-init-lock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-init-lock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-init-lock! A (f f2 0) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-init-lock! A (f f2 0 f3a) x))
+  (error? ; unsupported non-base
+    (ftype-init-lock! A (g) x))
+  (error? ; unsupported swapped
+    (ftype-init-lock! A (h) x))
+
+  (error? ; invalid syntax
+    (ftype-lock!))
+  (error? ; invalid syntax
+    (ftype-lock! A))
+  (error? ; invalid syntax
+    (ftype-lock! A x))
+  (error? ; invalid syntax
+    (ftype-lock! A (a . b) x))
+  (error? ; not an ftype
+    (ftype-lock! x () x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-lock! A (a) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-lock! A (b) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-lock! A (d) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-lock! A (e) x))
+  (error? ; unsupported non-base
+    (ftype-lock! A (f) x))
+  (error? ; unsupported non-base
+    (ftype-lock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-lock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-lock! A (f f2 0) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-lock! A (f f2 0 f3a) x))
+  (error? ; unsupported non-base
+    (ftype-lock! A (g) x))
+  (error? ; unsupported swapped
+    (ftype-lock! A (h) x))
+
+  (error? ; invalid syntax
+    (ftype-spin-lock!))
+  (error? ; invalid syntax
+    (ftype-spin-lock! A))
+  (error? ; invalid syntax
+    (ftype-spin-lock! A x))
+  (error? ; invalid syntax
+    (ftype-spin-lock! A (a . b) x))
+  (error? ; not an ftype
+    (ftype-spin-lock! x () x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-spin-lock! A (a) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-spin-lock! A (b) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-spin-lock! A (d) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-spin-lock! A (e) x))
+  (error? ; unsupported non-base
+    (ftype-spin-lock! A (f) x))
+  (error? ; unsupported non-base
+    (ftype-spin-lock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-spin-lock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-spin-lock! A (f f2 0) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-spin-lock! A (f f2 0 f3a) x))
+  (error? ; unsupported non-base
+    (ftype-spin-lock! A (g) x))
+  (error? ; unsupported swapped
+    (ftype-spin-lock! A (h) x))
+
+  (error? ; invalid syntax
+    (ftype-unlock!))
+  (error? ; invalid syntax
+    (ftype-unlock! A))
+  (error? ; invalid syntax
+    (ftype-unlock! A x))
+  (error? ; invalid syntax
+    (ftype-unlock! A (a . b) x))
+  (error? ; not an ftype
+    (ftype-unlock! x () x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-unlock! A (a) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-unlock! A (b) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-unlock! A (d) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-unlock! A (e) x))
+  (error? ; unsupported non-base
+    (ftype-unlock! A (f) x))
+  (error? ; unsupported non-base
+    (ftype-unlock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-unlock! A (f f2) x))
+  (error? ; unsupported non-base
+    (ftype-unlock! A (f f2 0) x))
+  (error? ; unsupported non-integer or non-word-size
+    (ftype-unlock! A (f f2 0 f3a) x))
+  (error? ; unsupported non-base
+    (ftype-unlock! A (g) x))
+  (error? ; unsupported swapped
+    (ftype-unlock! A (h) x))
+
+  (begin
+    (ftype-set! A (c) x 0)
+    (ftype-set! A (f f1) x 0)
+    (ftype-set! A (f f2 1 f3b) x 0)
+    (ftype-set! A (f f2 $idx f3b) x 0)
+    (ftype-set! A (g *) x 0)
+    #t)
+
+  (not (ftype-locked-incr! A (c) x))
+  (not (ftype-locked-incr! A (f f1) x))
+  (not (ftype-locked-incr! A (f f2 1 f3b) x))
+  (not (ftype-locked-incr! A (f f2 $idx f3b) x))
+  (not (ftype-locked-incr! A (g *) x))
+
+  (ftype-locked-decr! A (c) x)
+  (ftype-locked-decr! A (f f1) x)
+  (ftype-locked-decr! A (f f2 1 f3b) x)
+  (ftype-locked-decr! A (f f2 $idx f3b) x)
+  (ftype-locked-decr! A (g *) x)
+
+  (not (ftype-locked-decr! A (c) x))
+  (not (ftype-locked-decr! A (f f1) x))
+  (not (ftype-locked-decr! A (f f2 1 f3b) x))
+  (not (ftype-locked-decr! A (f f2 $idx f3b) x))
+  (not (ftype-locked-decr! A (g *) x))
+
+  (not (ftype-locked-decr! A (c) x))
+  (not (ftype-locked-decr! A (f f1) x))
+  (not (ftype-locked-decr! A (f f2 1 f3b) x))
+  (not (ftype-locked-decr! A (f f2 $idx f3b) x))
+  (not (ftype-locked-decr! A (g *) x))
+
+  (not (ftype-locked-incr! A (c) x))
+  (not (ftype-locked-incr! A (f f1) x))
+  (not (ftype-locked-incr! A (f f2 1 f3b) x))
+  (not (ftype-locked-incr! A (f f2 $idx f3b) x))
+  (not (ftype-locked-incr! A (g *) x))
+
+  (ftype-locked-incr! A (c) x)
+  (ftype-locked-incr! A (f f1) x)
+  (ftype-locked-incr! A (f f2 1 f3b) x)
+  (ftype-locked-incr! A (f f2 $idx f3b) x)
+  (ftype-locked-incr! A (g *) x)
+
+  (equal?
+    (list
+      (ftype-ref A (c) x)
+      (ftype-ref A (f f1) x)
+      (ftype-ref A (f f2 1 f3b) x)
+      (ftype-ref A (f f2 $idx f3b) x)
+      (ftype-ref A (g *) x))
+    '(0 0 0 0 0))
+
+  (begin
+    (ftype-init-lock! A (c) x)
+    (ftype-init-lock! A (f f1) x)
+    (ftype-init-lock! A (f f2 1 f3b) x)
+    (ftype-init-lock! A (f f2 $idx f3b) x)
+    (ftype-init-lock! A (g *) x)
+    #t)
+
+  (ftype-lock! A (c) x)
+  (ftype-lock! A (f f1) x)
+  (ftype-lock! A (f f2 1 f3b) x)
+  (ftype-lock! A (f f2 $idx f3b) x)
+  (ftype-lock! A (g *) x)
+
+  (not (ftype-lock! A (c) x))
+  (not (ftype-lock! A (f f1) x))
+  (not (ftype-lock! A (f f2 1 f3b) x))
+  (not (ftype-lock! A (f f2 $idx f3b) x))
+  (not (ftype-lock! A (g *) x))
+
+  (eq? (ftype-unlock! A (c) x) (void))
+  (eq? (ftype-unlock! A (f f1) x) (void))
+  (eq? (ftype-unlock! A (f f2 1 f3b) x) (void))
+  (eq? (ftype-unlock! A (f f2 $idx f3b) x) (void))
+  (eq? (ftype-unlock! A (g *) x) (void))
+
+  (eq? (ftype-spin-lock! A (c) x) (void))
+  (eq? (ftype-spin-lock! A (f f1) x) (void))
+  (eq? (ftype-spin-lock! A (f f2 1 f3b) x) (void))
+  (eq? (ftype-spin-lock! A (f f2 $idx f3b) x) (void))
+  (eq? (ftype-spin-lock! A (g *) x) (void))
+
+  (not (ftype-lock! A (c) x))
+  (not (ftype-lock! A (f f1) x))
+  (not (ftype-lock! A (f f2 1 f3b) x))
+  (not (ftype-lock! A (f f2 $idx f3b) x))
+  (not (ftype-lock! A (g *) x))
+
+  (begin
+    (fptr-free x)
+    (fptr-free g)
+    #t)
+)
+
+(mat ftype-compile-file
+ ; first, load from source
+  (begin
+    (with-output-to-file "testfile-ftype1.ss"
+      (lambda ()
+        (pretty-print
+          '(define-ftype fcf-A (struct [a double] [b wchar])))
+        (pretty-print
+          '(define a (make-ftype-pointer fcf-A (foreign-alloc (ftype-sizeof fcf-A))))))
+      'replace)
+    (load "testfile-ftype1.ss")
+    #t)
+
+  (begin
+    (ftype-set! fcf-A (a) a 3.4)
+    (ftype-set! fcf-A (b) a #\$)
+    #t)
+
+  (eqv? (ftype-ref fcf-A (a) a) 3.4)
+  (eqv? (ftype-ref fcf-A (b) a) #\$)
+  (eqv? (ftype-ref double () a) 3.4)
+
+ ; now try compile-file and load the object file
+  (begin
+    (with-output-to-file "testfile-ftype1.ss"
+      (lambda ()
+        (pretty-print
+          '(define-ftype fcf-A (struct [a double] [b wchar])))
+        (pretty-print
+          '(define a (make-ftype-pointer fcf-A (foreign-alloc (ftype-sizeof fcf-A))))))
+      'replace)
+    (for-each separate-compile '(ftype1))
+    (load "testfile-ftype1.so")
+    #t)
+
+  (begin
+    (ftype-set! fcf-A (a) a 3.4)
+    (ftype-set! fcf-A (b) a #\$)
+    #t)
+
+  (eqv? (ftype-ref fcf-A (a) a) 3.4)
+  (eqv? (ftype-ref fcf-A (b) a) #\$)
+  (eqv? (ftype-ref double () a) 3.4)
+
+  (begin
+    (define old-a a)
+    (load "testfile-ftype1.so")
+    #t)
+
+  (begin
+    (ftype-set! fcf-A (a) old-a 3.4)
+    (ftype-set! fcf-A (b) old-a #\$)
+    #t)
+
+  (eqv? (ftype-ref fcf-A (a) old-a) 3.4)
+  (eqv? (ftype-ref fcf-A (b) old-a) #\$)
+  (eqv? (ftype-ref double () old-a) 3.4)
+
+  ; check fasling of recursive ftype definitions
+  (begin
+    (with-output-to-file "testfile-ftype2.ss"
+      (lambda ()
+        (pretty-print
+          '(define-ftype fcf-B
+             (struct
+               [data double]
+               [next (* fcf-B)]))))
+      'replace)
+    (separate-compile "testfile-ftype2")
+    (load "testfile-ftype2.so")
+    #t)
+  (equal?
+    (ftype-pointer-ftype (make-ftype-pointer fcf-B 0))
+    '(struct
+       [data double]
+       [next (* fcf-B)]))
+  ; directly check that cyclic rtd fasl'd in okay
+  (let ([ftd (record-rtd (make-ftype-pointer fcf-B 0))])
+    (let ([ftd2 (caddr (cadr ((record-accessor (record-rtd ftd) 0) ftd)))])
+      (eq? ((record-accessor (record-rtd ftd2) 0) ftd2) ftd)))
+  ; indirectly check
+  (let* ([addr (foreign-alloc (ftype-sizeof fcf-B))]
+         [x (make-ftype-pointer fcf-B addr)])
+    (dynamic-wind
+      void
+      (lambda ()
+        (ftype-set! fcf-B (next) x (make-ftype-pointer fcf-B 0))
+        (ftype-pointer? (ftype-ref fcf-B (next) x)))
+      (lambda () (foreign-free addr))))
+  ; regression test: verify that we can fasl in a cyclic ftd that's already registered on its uid
+  (begin
+    (mkfile "testfile-ftype3.ss"
+      '(define-ftype
+         [ftype3-A (* ftype3-B)]
+         [ftype3-B (struct [h ftype3-A])]))
+    (compile-file "testfile-ftype3")
+    #t)
+  (begin ; once should prove it
+    (load "testfile-ftype3.so")
+    (ftype-pointer? ftype3-A (make-ftype-pointer ftype3-B 0)))
+  (begin ; twice for that warm fuzzy feeling
+    (load "testfile-ftype3.so")
+    (ftype-pointer? ftype3-A (make-ftype-pointer ftype3-B 0)))
+  (begin
+    (mkfile "testfile-ftype4.ss"
+      '(define-ftype
+         [ftype4-A (struct [q (* ftype4-B)])]
+         [ftype4-B (struct [h (* ftype4-A)])]))
+    (compile-file "testfile-ftype4")
+    #t)
+  (begin ; once should prove it
+    (load "testfile-ftype4.so")
+      (ftype-pointer? ftype4-A (make-ftype-pointer ftype4-A 0)))
+  (begin ; twice for that warm fuzzy feeling
+    (load "testfile-ftype4.so")
+    (ftype-pointer? ftype4-B (make-ftype-pointer ftype4-B 0)))
+  (begin
+    (mkfile "testfile-ftype5.ss"
+      '(define-ftype
+         [ftype5-A (struct [q (* ftype4-A)])]))
+    (compile-file "testfile-ftype5")
+    #t)
+  (begin
+    (load "testfile-ftype5.so")
+    (ftype-pointer? ftype5-A (make-ftype-pointer ftype5-A 0)))
+)
+
+(mat ftype-bits
+  (begin
+    (define z (make-ftype-pointer unsigned-32 (foreign-alloc (ftype-sizeof unsigned-32))))
+    (ftype-set! unsigned-32 () z #b101101011010111010)
+    #t)
+
+  (equal?
+    (list 
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 0 4)
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 0 5)
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 0 6)
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 0 7)
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 1 7)
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 1 6))
+    '(10 26 58 58 29 29))
+
+  (equal?
+    (list 
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 0 4)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 0 5)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 0 6)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 0 7)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 1 7)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 1 6))
+    '(-6 -6 -6 58 29 -3))
+
+  (begin
+    (#%$fptr-set-bits! 'unsigned-32 #f z 0 1 6 5)
+    (#%$fptr-set-bits! 'unsigned-32 #f z 0 6 10 -3)
+    (#%$fptr-set-bits! 'unsigned-32 #f z 0 10 15 10)
+    #t)
+
+  (equal?
+    (list
+      (#%$fptr-ref-bits 'unsigned-32 #f #f z 0 1 6)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 6 10)
+      (#%$fptr-ref-bits 'unsigned-32 #f #t z 0 10 15))
+    '(5 -3 10))
+
+  (begin
+    (fptr-free z)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Bbits
+      (endian little
+        (union
+          [a1 (struct
+                [a1 unsigned-16]
+                [a2 unsigned-8]
+                [a3 unsigned-64]
+                [a4 unsigned-32])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 1]
+                      [a2 signed 15])]
+                [a2 (bits
+                      [a1 signed 3]
+                      [a2 signed 5])]
+                [a3 (bits
+                      [a1 signed 50]
+                      [a2 signed 14])]
+                [a4 (bits
+                      [a1 signed 19]
+                      [a2 signed 13])])]
+          [a3 (struct
+                [a1 (bits
+                      [a1 unsigned 1]
+                      [a2 unsigned 15])]
+                [a2 (bits
+                      [a1 unsigned 3]
+                      [a2 unsigned 5])]
+                [a3 (bits
+                      [a1 unsigned 50]
+                      [a2 unsigned 14])]
+                [a4 (bits
+                      [a1 unsigned 19]
+                      [a2 unsigned 13])])])))
+    (define x (make-ftype-pointer Bbits (foreign-alloc (ftype-sizeof Bbits))))
+    #t)
+
+  (error? ;; invalid value 113886 for bit field of size 1
+    (ftype-set! Bbits (a2 a1 a1) x #x1bcde))
+
+  (error? ;; invalid value #\a for bit field of size 3
+    (ftype-set! Bbits (a2 a2 a1) x #\a))
+
+  (error? ;; invalid value oops for bit field of size 14
+    (ftype-set! Bbits (a3 a3 a2) x 'oops))
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #xabce)
+    (ftype-set! Bbits (a1 a2) x #xde)
+    (ftype-set! Bbits (a1 a3) x #xf9357c18d679e35b)
+    (ftype-set! Bbits (a1 a4) x #x7c18d679)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) #x0)
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (- #x55e7 (expt 2 15)))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (- #x1b (expt 2 5)))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) #x17c18d679e35b)
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (- #x3e4d (expt 2 14)))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) #xd679)
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) #xf83)
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) #x0)
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) #x55e7)
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) #x6)
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) #x1b)
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) #x17c18d679e35b)
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) #x3e4d)
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) #xd679)
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) #xf83)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #x7c7c)
+    (ftype-set! Bbits (a1 a2) x #xa8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x91919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x #x-1)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #x7c7d)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x #x0)
+    (ftype-set! Bbits (a2 a1 a2) x (- #x55e7 (expt 2 15)))
+    (ftype-set! Bbits (a2 a2 a1) x (- #x6 (expt 2 3)))
+    (ftype-set! Bbits (a2 a2 a2) x (- #x1b (expt 2 5)))
+    (ftype-set! Bbits (a2 a3 a1) x #x17c18d679e35b)
+    (ftype-set! Bbits (a2 a3 a2) x (- #x3e4d (expt 2 14)))
+    (ftype-set! Bbits (a2 a4 a1) x #xd679)
+    (ftype-set! Bbits (a2 a4 a2) x #xf83)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #xabce)
+  (eqv? (ftype-ref Bbits (a1 a2) x) #xde)
+  (eqv? (ftype-ref Bbits (a1 a3) x) #xf9357c18d679e35b)
+  (eqv? (ftype-ref Bbits (a1 a4) x) #x7c18d679)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) #x0)
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (- #x55e7 (expt 2 15)))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (- #x1b (expt 2 5)))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) #x17c18d679e35b)
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (- #x3e4d (expt 2 14)))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) #xd679)
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) #xf83)
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) #x0)
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) #x55e7)
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) #x6)
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) #x1b)
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) #x17c18d679e35b)
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) #x3e4d)
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) #xd679)
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) #xf83)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #xc7c7)
+    (ftype-set! Bbits (a1 a2) x #xa8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x91919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a3 a1 a1) x #x0)
+    (ftype-set! Bbits (a3 a1 a2) x #x55e7)
+    (ftype-set! Bbits (a3 a2 a1) x #x6)
+    (ftype-set! Bbits (a3 a2 a2) x #x1b)
+    (ftype-set! Bbits (a3 a3 a1) x #x17c18d679e35b)
+    (ftype-set! Bbits (a3 a3 a2) x #x3e4d)
+    (ftype-set! Bbits (a3 a4 a1) x #xd679)
+    (ftype-set! Bbits (a3 a4 a2) x #xf83)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #xabce)
+  (eqv? (ftype-ref Bbits (a1 a2) x) #xde)
+  (eqv? (ftype-ref Bbits (a1 a3) x) #xf9357c18d679e35b)
+  (eqv? (ftype-ref Bbits (a1 a4) x) #x7c18d679)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) #x0)
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (- #x55e7 (expt 2 15)))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (- #x1b (expt 2 5)))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) #x17c18d679e35b)
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (- #x3e4d (expt 2 14)))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) #xd679)
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) #xf83)
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) #x0)
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) #x55e7)
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) #x6)
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) #x1b)
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) #x17c18d679e35b)
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) #x3e4d)
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) #xd679)
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) #xf83)
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+
+  (begin
+    (define-ftype Ebits (bits [x signed 32]))
+    (define ebits (make-ftype-pointer Ebits 0))
+    #t)
+
+  (error? ;; invalid value oops for type bit-field
+    (ftype-set! Ebits (x) ebits 'oops))
+
+  (error? ;; invalid value  for type bit-field
+    (ftype-set! Ebits (x) ebits (expt 2 32)))
+
+ ; ----------------
+  (begin
+    (define-ftype Bbits
+      (endian big
+        (union
+          [a1 (struct
+                [a1 unsigned-16]
+                [a2 unsigned-8]
+                [a3 unsigned-64]
+                [a4 unsigned-32])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 1]
+                      [a2 signed 15])]
+                [a2 (bits
+                      [a1 signed 3]
+                      [a2 signed 5])]
+                [a3 (bits
+                      [a1 signed 50]
+                      [a2 signed 14])]
+                [a4 (bits
+                      [a1 signed 19]
+                      [a2 signed 13])])]
+          [a3 (struct
+                [a1 (bits
+                      [a1 unsigned 1]
+                      [a2 unsigned 15])]
+                [a2 (bits
+                      [a1 unsigned 3]
+                      [a2 unsigned 5])]
+                [a3 (bits
+                      [a1 unsigned 50]
+                      [a2 unsigned 14])]
+                [a4 (bits
+                      [a1 unsigned 19]
+                      [a2 unsigned 13])])])))
+    (define x (make-ftype-pointer Bbits (foreign-alloc (ftype-sizeof Bbits))))
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #xabce)
+    (ftype-set! Bbits (a1 a2) x #xde)
+    (ftype-set! Bbits (a1 a3) x #xf9357c18d679e35b)
+    (ftype-set! Bbits (a1 a4) x #x7c18d679)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) -1)
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) #x2bce)
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (- #x1e (expt 2 5)))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (- #x3e4d5f06359e7 (expt 2 50)))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (- #x235b (expt 2 14)))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) #x3e0c6)
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (- #x1679 (expt 2 13)))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) 1)
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) #x2bce)
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) #x6)
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) #x1e)
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) #x3e4d5f06359e7)
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) #x235b)
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) #x3e0c6)
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) #x1679)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #x7c7c)
+    (ftype-set! Bbits (a1 a2) x #xa8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x91919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x -1)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #xfc7c)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x -1)
+    (ftype-set! Bbits (a2 a1 a2) x #x2bce)
+    (ftype-set! Bbits (a2 a2 a1) x (- #x6 (expt 2 3)))
+    (ftype-set! Bbits (a2 a2 a2) x (- #x1e (expt 2 5)))
+    (ftype-set! Bbits (a2 a3 a1) x (- #x3e4d5f06359e7 (expt 2 50)))
+    (ftype-set! Bbits (a2 a3 a2) x (- #x235b (expt 2 14)))
+    (ftype-set! Bbits (a2 a4 a1) x #x3e0c6)
+    (ftype-set! Bbits (a2 a4 a2) x (- #x1679 (expt 2 13)))
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #xabce)
+  (eqv? (ftype-ref Bbits (a1 a2) x) #xde)
+  (eqv? (ftype-ref Bbits (a1 a3) x) #xf9357c18d679e35b)
+  (eqv? (ftype-ref Bbits (a1 a4) x) #x7c18d679)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) -1)
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) #x2bce)
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (- #x1e (expt 2 5)))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (- #x3e4d5f06359e7 (expt 2 50)))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (- #x235b (expt 2 14)))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) #x3e0c6)
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (- #x1679 (expt 2 13)))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) 1)
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) #x2bce)
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) #x6)
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) #x1e)
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) #x3e4d5f06359e7)
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) #x235b)
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) #x3e0c6)
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) #x1679)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #xc7c7)
+    (ftype-set! Bbits (a1 a2) x #xa8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x91919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a3 a1 a1) x 1)
+    (ftype-set! Bbits (a3 a1 a2) x #x2bce)
+    (ftype-set! Bbits (a3 a2 a1) x #x6)
+    (ftype-set! Bbits (a3 a2 a2) x #x1e)
+    (ftype-set! Bbits (a3 a3 a1) x #x3e4d5f06359e7)
+    (ftype-set! Bbits (a3 a3 a2) x #x235b)
+    (ftype-set! Bbits (a3 a4 a1) x #x3e0c6)
+    (ftype-set! Bbits (a3 a4 a2) x #x1679)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #xabce)
+  (eqv? (ftype-ref Bbits (a1 a2) x) #xde)
+  (eqv? (ftype-ref Bbits (a1 a3) x) #xf9357c18d679e35b)
+  (eqv? (ftype-ref Bbits (a1 a4) x) #x7c18d679)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) -1)
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) #x2bce)
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (- #x1e (expt 2 5)))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (- #x3e4d5f06359e7 (expt 2 50)))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (- #x235b (expt 2 14)))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) #x3e0c6)
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (- #x1679 (expt 2 13)))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) 1)
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) #x2bce)
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) #x6)
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) #x1e)
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) #x3e4d5f06359e7)
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) #x235b)
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) #x3e0c6)
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) #x1679)
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Cbits
+      (endian little
+        (union
+          [a1 (struct
+                [a1 unsigned-64]
+                [a2 unsigned-64]
+                [a3 unsigned-64]
+                [a4 unsigned-64]
+                [a5 unsigned-64]
+                [a6 unsigned-64]
+                [a7 unsigned-64])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 64])]
+                [a2 (bits
+                      [a1 unsigned 64])]
+                [a3 (bits
+                      [a1 unsigned 63]
+                      [a2 signed 1])]
+                [a4 (bits
+                      [a1 unsigned 1]
+                      [a2 signed 63])]
+                [a5 (bits
+                      [a1 signed 32]
+                      [a2 unsigned 16]
+                      [a3 signed 8]
+                      [a4 unsigned 5]
+                      [a5 signed 3])]
+                [a6 (bits
+                      [a1 unsigned 5]
+                      [a2 signed 8]
+                      [a3 unsigned 16]
+                      [a4 signed 32]
+                      [a5 signed 3])]
+                [a7 (bits
+                      [a1 unsigned 32]
+                      [a2 signed 16]
+                      [a3 unsigned 8]
+                      [a4 signed 5]
+                      [a5 unsigned 3])])])))
+    (define x (make-ftype-pointer Cbits (foreign-alloc (ftype-sizeof Cbits))))
+    #t)
+
+  (begin
+    (ftype-set! Cbits (a1 a1) x #x923456789abcdef9)
+    (ftype-set! Cbits (a1 a2) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a1 a3) x #x923456789abcdef9)
+    (ftype-set! Cbits (a1 a4) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a1 a5) x #x923456789abcdef9)
+    (ftype-set! Cbits (a1 a6) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a1 a7) x #x923456789abcdef9)
+    #t)
+
+  (eqv? (ftype-ref Cbits (a2 a1 a1) x) (- #x923456789abcdef9 (expt 2 64)))
+  (eqv? (ftype-ref Cbits (a2 a2 a1) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a2 a3 a1) x) #x123456789abcdef9)
+  (eqv? (ftype-ref Cbits (a2 a3 a2) x) -1)
+  (eqv? (ftype-ref Cbits (a2 a4 a1) x) 0)
+  (eqv? (ftype-ref Cbits (a2 a4 a2) x) (- (ash #xda3c2d784b69f01e -1) (expt 2 63)))
+  (eqv? (ftype-ref Cbits (a2 a5 a1) x) (- #x9abcdef9 (expt 2 32)))
+  (eqv? (ftype-ref Cbits (a2 a5 a2) x) #x5678)
+  (eqv? (ftype-ref Cbits (a2 a5 a3) x) #x34)
+  (eqv? (ftype-ref Cbits (a2 a5 a4) x) #x12)
+  (eqv? (ftype-ref Cbits (a2 a5 a5) x) #x-4)
+  (eqv? (ftype-ref Cbits (a2 a6 a1) x) #x1e)
+  (eqv? (ftype-ref Cbits (a2 a6 a2) x) #x-80)
+  (eqv? (ftype-ref Cbits (a2 a6 a3) x) #x5b4f)
+  (eqv? (ftype-ref Cbits (a2 a6 a4) x) (- #xD1E16BC2 (expt 2 32)))
+  (eqv? (ftype-ref Cbits (a2 a6 a5) x) #x-2)
+  (eqv? (ftype-ref Cbits (a2 a7 a1) x) #x9abcdef9)
+  (eqv? (ftype-ref Cbits (a2 a7 a2) x) #x5678)
+  (eqv? (ftype-ref Cbits (a2 a7 a3) x) #x34)
+  (eqv? (ftype-ref Cbits (a2 a7 a4) x) (- #x12 (expt 2 5)))
+  (eqv? (ftype-ref Cbits (a2 a7 a5) x) #x4)
+
+  (begin
+    (ftype-set! Cbits (a1 a1) x 0)
+    (ftype-set! Cbits (a1 a2) x 0)
+    (ftype-set! Cbits (a1 a3) x 0)
+    (ftype-set! Cbits (a1 a4) x 0)
+    (ftype-set! Cbits (a1 a5) x 0)
+    (ftype-set! Cbits (a1 a6) x 0)
+    (ftype-set! Cbits (a1 a7) x 0)
+    #t)
+
+  (begin
+    (ftype-set! Cbits (a2 a1 a1) x (- #x923456789abcdef9 (expt 2 64)))
+    (ftype-set! Cbits (a2 a2 a1) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a2 a3 a1) x #x123456789abcdef9)
+    (ftype-set! Cbits (a2 a3 a2) x -1)
+    (ftype-set! Cbits (a2 a4 a1) x 0)
+    (ftype-set! Cbits (a2 a4 a2) x (- (ash #xda3c2d784b69f01e -1) (expt 2 63)))
+    (ftype-set! Cbits (a2 a5 a1) x (- #x9abcdef9 (expt 2 32)))
+    (ftype-set! Cbits (a2 a5 a2) x #x5678)
+    (ftype-set! Cbits (a2 a5 a3) x #x34)
+    (ftype-set! Cbits (a2 a5 a4) x #x12)
+    (ftype-set! Cbits (a2 a5 a5) x #x-4)
+    (ftype-set! Cbits (a2 a6 a1) x #x1e)
+    (ftype-set! Cbits (a2 a6 a2) x #x-80)
+    (ftype-set! Cbits (a2 a6 a3) x #x5b4f)
+    (ftype-set! Cbits (a2 a6 a4) x (- #xD1E16BC2 (expt 2 32)))
+    (ftype-set! Cbits (a2 a6 a5) x #x-2)
+    (ftype-set! Cbits (a2 a7 a1) x #x9abcdef9)
+    (ftype-set! Cbits (a2 a7 a2) x #x5678)
+    (ftype-set! Cbits (a2 a7 a3) x #x34)
+    (ftype-set! Cbits (a2 a7 a4) x #x12)
+    (ftype-set! Cbits (a2 a7 a5) x #x4)
+    #t)
+
+  (eqv? (ftype-ref Cbits (a1 a1) x) #x923456789abcdef9)
+  (eqv? (ftype-ref Cbits (a1 a2) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a1 a3) x) #x923456789abcdef9)
+  (eqv? (ftype-ref Cbits (a1 a4) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a1 a5) x) #x923456789abcdef9)
+  (eqv? (ftype-ref Cbits (a1 a6) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a1 a7) x) #x923456789abcdef9)
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Cbits
+      (endian big
+        (union
+          [a1 (struct
+                [a1 unsigned-64]
+                [a2 unsigned-64]
+                [a3 unsigned-64]
+                [a4 unsigned-64]
+                [a5 unsigned-64]
+                [a6 unsigned-64]
+                [a7 unsigned-64])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 64])]
+                [a2 (bits
+                      [a1 unsigned 64])]
+                [a3 (bits
+                      [a1 unsigned 63]
+                      [a2 signed 1])]
+                [a4 (bits
+                      [a1 unsigned 1]
+                      [a2 signed 63])]
+                [a5 (bits
+                      [a1 signed 32]
+                      [a2 unsigned 16]
+                      [a3 signed 8]
+                      [a4 unsigned 5]
+                      [a5 signed 3])]
+                [a6 (bits
+                      [a1 unsigned 5]
+                      [a2 signed 8]
+                      [a3 unsigned 16]
+                      [a4 signed 32]
+                      [a5 signed 3])]
+                [a7 (bits
+                      [a1 unsigned 32]
+                      [a2 signed 16]
+                      [a3 unsigned 8]
+                      [a4 signed 5]
+                      [a5 unsigned 3])])])))
+    (define x (make-ftype-pointer Cbits (foreign-alloc (ftype-sizeof Cbits))))
+    #t)
+
+  (begin
+    (ftype-set! Cbits (a1 a1) x #x923456789abcdef9)
+    (ftype-set! Cbits (a1 a2) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a1 a3) x #x923456789abcdef9)
+    (ftype-set! Cbits (a1 a4) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a1 a5) x #x923456789abcdefe)
+    (ftype-set! Cbits (a1 a6) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a1 a7) x #x923456789abcdefe)
+    #t)
+
+  (eqv? (ftype-ref Cbits (a2 a1 a1) x) (- #x923456789abcdef9 (expt 2 64)))
+  (eqv? (ftype-ref Cbits (a2 a2 a1) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a2 a3 a1) x) #x491A2B3C4D5E6F7C)
+  (eqv? (ftype-ref Cbits (a2 a3 a2) x) -1)
+  (eqv? (ftype-ref Cbits (a2 a4 a1) x) 1)
+  (eqv? (ftype-ref Cbits (a2 a4 a2) x) (- #x5A3C2D784B69F01E (expt 2 63)))
+  (eqv? (ftype-ref Cbits (a2 a5 a1) x) (- #x92345678 (expt 2 32)))
+  (eqv? (ftype-ref Cbits (a2 a5 a2) x) #x9abc)
+  (eqv? (ftype-ref Cbits (a2 a5 a3) x) (- #xde (expt 2 8)))
+  (eqv? (ftype-ref Cbits (a2 a5 a4) x) #x1f)
+  (eqv? (ftype-ref Cbits (a2 a5 a5) x) (- 6 (expt 2 3)))
+  (eqv? (ftype-ref Cbits (a2 a6 a1) x) #x1b)
+  (eqv? (ftype-ref Cbits (a2 a6 a2) x) #x47)
+  (eqv? (ftype-ref Cbits (a2 a6 a3) x) #x85af)
+  (eqv? (ftype-ref Cbits (a2 a6 a4) x) #x96d3e03)
+  (eqv? (ftype-ref Cbits (a2 a6 a5) x) (- #x6 (expt 2 3)))
+  (eqv? (ftype-ref Cbits (a2 a7 a1) x) #x92345678)
+  (eqv? (ftype-ref Cbits (a2 a7 a2) x) (- #x9abc (expt 2 16)))
+  (eqv? (ftype-ref Cbits (a2 a7 a3) x) #xde)
+  (eqv? (ftype-ref Cbits (a2 a7 a4) x) (- #x1f (expt 2 5)))
+  (eqv? (ftype-ref Cbits (a2 a7 a5) x) 6)
+
+  (begin
+    (ftype-set! Cbits (a1 a1) x 0)
+    (ftype-set! Cbits (a1 a2) x 0)
+    (ftype-set! Cbits (a1 a3) x 0)
+    (ftype-set! Cbits (a1 a4) x 0)
+    (ftype-set! Cbits (a1 a5) x 0)
+    (ftype-set! Cbits (a1 a6) x 0)
+    (ftype-set! Cbits (a1 a7) x 0)
+    #t)
+
+  (begin
+    (ftype-set! Cbits (a2 a1 a1) x (- #x923456789abcdef9 (expt 2 64)))
+    (ftype-set! Cbits (a2 a2 a1) x #xda3c2d784b69f01e)
+    (ftype-set! Cbits (a2 a3 a1) x #x491A2B3C4D5E6F7C)
+    (ftype-set! Cbits (a2 a3 a2) x -1)
+    (ftype-set! Cbits (a2 a4 a1) x 1)
+    (ftype-set! Cbits (a2 a4 a2) x (- #x5A3C2D784B69F01E (expt 2 63)))
+    (ftype-set! Cbits (a2 a5 a1) x (- #x92345678 (expt 2 32)))
+    (ftype-set! Cbits (a2 a5 a2) x #x9abc)
+    (ftype-set! Cbits (a2 a5 a3) x (- #xde (expt 2 8)))
+    (ftype-set! Cbits (a2 a5 a4) x #x1f)
+    (ftype-set! Cbits (a2 a5 a5) x (- 6 (expt 2 3)))
+    (ftype-set! Cbits (a2 a6 a1) x #x1b)
+    (ftype-set! Cbits (a2 a6 a2) x #x47)
+    (ftype-set! Cbits (a2 a6 a3) x #x85af)
+    (ftype-set! Cbits (a2 a6 a4) x #x96d3e03)
+    (ftype-set! Cbits (a2 a6 a5) x (- #x6 (expt 2 3)))
+    (ftype-set! Cbits (a2 a7 a1) x #x92345678)
+    (ftype-set! Cbits (a2 a7 a2) x (- #x9abc (expt 2 16)))
+    (ftype-set! Cbits (a2 a7 a3) x #xde)
+    (ftype-set! Cbits (a2 a7 a4) x (- #x1f (expt 2 5)))
+    (ftype-set! Cbits (a2 a7 a5) x 6)
+  #t)
+
+  (eqv? (ftype-ref Cbits (a1 a1) x) #x923456789abcdef9)
+  (eqv? (ftype-ref Cbits (a1 a2) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a1 a3) x) #x923456789abcdef9)
+  (eqv? (ftype-ref Cbits (a1 a4) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a1 a5) x) #x923456789abcdefe)
+  (eqv? (ftype-ref Cbits (a1 a6) x) #xda3c2d784b69f01e)
+  (eqv? (ftype-ref Cbits (a1 a7) x) #x923456789abcdefe)
+
+  (begin
+    (fptr-free x)
+    #t)
+)
+
+(mat ftype-odd-bits
+  (begin
+    (define-ftype Bbits
+      (endian little
+        (union
+          [a1 (struct
+                [a1 unsigned-24]
+                [a2 unsigned-40]
+                [a3 unsigned-56]
+                [a4 unsigned-48])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 1]
+                      [a2 signed 23])]
+                [a2 (bits
+                      [a1 signed 3]
+                      [a2 signed 37])]
+                [a3 (bits
+                      [a1 signed 42]
+                      [a2 signed 14])]
+                [a4 (bits
+                      [a1 signed 19]
+                      [a2 signed 29])])]
+          [a3 (struct
+                [a1 (bits
+                      [a1 unsigned 1]
+                      [a2 unsigned 23])]
+                [a2 (bits
+                      [a1 unsigned 3]
+                      [a2 unsigned 37])]
+                [a3 (bits
+                      [a1 unsigned 42]
+                      [a2 unsigned 14])]
+                [a4 (bits
+                      [a1 unsigned 19]
+                      [a2 unsigned 29])])])))
+    (define x (make-ftype-pointer Bbits (foreign-alloc (ftype-sizeof Bbits))))
+    (define unsigned-bit-field
+      (lambda (n start end)
+        (bitwise-bit-field n start end)))
+    (define signed-bit-field
+      (lambda (n start end)
+        (let ([n (bitwise-bit-field n start end)])
+          (if (fx= (bitwise-arithmetic-shift-right n (fx- end start 1)) 0)
+              n
+              (- n (bitwise-arithmetic-shift-left 1 (fx- end start)))))))
+    #t)
+
+  (error? ;; invalid value 113886 for bit field of size 1
+    (ftype-set! Bbits (a2 a1 a1) x #x1bcde))
+
+  (error? ;; invalid value #\a for bit field of size 3
+    (ftype-set! Bbits (a2 a2 a1) x #\a))
+
+  (error? ;; invalid value oops for bit field of size 14
+    (ftype-set! Bbits (a3 a3 a2) x 'oops))
+
+  (begin
+    (define A1 #xabcfde) 
+    (define A2 #xde13752b) 
+    (define A3 #xf93578d679e35b) 
+    (define A4 #x7c18d679)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x A1)
+    (ftype-set! Bbits (a1 a2) x A2)
+    (ftype-set! Bbits (a1 a3) x A3)
+    (ftype-set! Bbits (a1 a4) x A4)
+    #t)
+
+  (equal?
+    (list
+      (ftype-ref Bbits (a1 a1) x)
+      (ftype-ref Bbits (a1 a2) x)
+      (ftype-ref Bbits (a1 a3) x)
+      (ftype-ref Bbits (a1 a4) x))
+    (list A1 A2 A3 A4))
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) (signed-bit-field A1 0 1))
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (signed-bit-field A1 1 24))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (signed-bit-field A2 0 3))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (signed-bit-field A2 3 40))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (signed-bit-field A3 0 42))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (signed-bit-field A3 42 56))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) (signed-bit-field A4 0 19))
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (signed-bit-field A4 19 48))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) (unsigned-bit-field A1 0 1))
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) (unsigned-bit-field A1 1 24))
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) (unsigned-bit-field A2 0 3))
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) (unsigned-bit-field A2 3 40))
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) (unsigned-bit-field A3 0 42))
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) (unsigned-bit-field A3 42 56))
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) (unsigned-bit-field A4 0 19))
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) (unsigned-bit-field A4 19 48))
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #x7c7c7c)
+    (ftype-set! Bbits (a1 a2) x #xa8a8a8a8a8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x919191919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x #x-1)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #x7c7c7d)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x (signed-bit-field A1 0 1))
+    (ftype-set! Bbits (a2 a1 a2) x (signed-bit-field A1 1 24))
+    (ftype-set! Bbits (a2 a2 a1) x (signed-bit-field A2 0 3))
+    (ftype-set! Bbits (a2 a2 a2) x (signed-bit-field A2 3 40))
+    (ftype-set! Bbits (a2 a3 a1) x (signed-bit-field A3 0 42))
+    (ftype-set! Bbits (a2 a3 a2) x (signed-bit-field A3 42 56))
+    (ftype-set! Bbits (a2 a4 a1) x (signed-bit-field A4 0 19))
+    (ftype-set! Bbits (a2 a4 a2) x (signed-bit-field A4 19 48))
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) A1)
+  (eqv? (ftype-ref Bbits (a1 a2) x) A2)
+  (eqv? (ftype-ref Bbits (a1 a3) x) A3)
+  (eqv? (ftype-ref Bbits (a1 a4) x) A4)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) (signed-bit-field A1 0 1))
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (signed-bit-field A1 1 24))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (signed-bit-field A2 0 3))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (signed-bit-field A2 3 40))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (signed-bit-field A3 0 42))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (signed-bit-field A3 42 56))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) (signed-bit-field A4 0 19))
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (signed-bit-field A4 19 48))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) (unsigned-bit-field A1 0 1))
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) (unsigned-bit-field A1 1 24))
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) (unsigned-bit-field A2 0 3))
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) (unsigned-bit-field A2 3 40))
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) (unsigned-bit-field A3 0 42))
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) (unsigned-bit-field A3 42 56))
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) (unsigned-bit-field A4 0 19))
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) (unsigned-bit-field A4 19 48))
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #x7c7c7c)
+    (ftype-set! Bbits (a1 a2) x #xa8a8a8a8a8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x919191919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a3 a1 a1) x (unsigned-bit-field A1 0 1))
+    (ftype-set! Bbits (a3 a1 a2) x (unsigned-bit-field A1 1 24))
+    (ftype-set! Bbits (a3 a2 a1) x (unsigned-bit-field A2 0 3))
+    (ftype-set! Bbits (a3 a2 a2) x (unsigned-bit-field A2 3 40))
+    (ftype-set! Bbits (a3 a3 a1) x (unsigned-bit-field A3 0 42))
+    (ftype-set! Bbits (a3 a3 a2) x (unsigned-bit-field A3 42 56))
+    (ftype-set! Bbits (a3 a4 a1) x (unsigned-bit-field A4 0 19))
+    (ftype-set! Bbits (a3 a4 a2) x (unsigned-bit-field A4 19 48))
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) A1)
+  (eqv? (ftype-ref Bbits (a1 a2) x) A2)
+  (eqv? (ftype-ref Bbits (a1 a3) x) A3)
+  (eqv? (ftype-ref Bbits (a1 a4) x) A4)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) (signed-bit-field A1 0 1))
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (signed-bit-field A1 1 24))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (signed-bit-field A2 0 3))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (signed-bit-field A2 3 40))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (signed-bit-field A3 0 42))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (signed-bit-field A3 42 56))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) (signed-bit-field A4 0 19))
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (signed-bit-field A4 19 48))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) (unsigned-bit-field A1 0 1))
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) (unsigned-bit-field A1 1 24))
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) (unsigned-bit-field A2 0 3))
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) (unsigned-bit-field A2 3 40))
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) (unsigned-bit-field A3 0 42))
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) (unsigned-bit-field A3 42 56))
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) (unsigned-bit-field A4 0 19))
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) (unsigned-bit-field A4 19 48))
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Bbits
+      (endian big
+        (union
+          [a1 (struct
+                [a1 unsigned-24]
+                [a2 unsigned-40]
+                [a3 unsigned-56]
+                [a4 unsigned-48])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 1]
+                      [a2 signed 23])]
+                [a2 (bits
+                      [a1 signed 3]
+                      [a2 signed 37])]
+                [a3 (bits
+                      [a1 signed 42]
+                      [a2 signed 14])]
+                [a4 (bits
+                      [a1 signed 19]
+                      [a2 signed 29])])]
+          [a3 (struct
+                [a1 (bits
+                      [a1 unsigned 1]
+                      [a2 unsigned 23])]
+                [a2 (bits
+                      [a1 unsigned 3]
+                      [a2 unsigned 37])]
+                [a3 (bits
+                      [a1 unsigned 42]
+                      [a2 unsigned 14])]
+                [a4 (bits
+                      [a1 unsigned 19]
+                      [a2 unsigned 29])])])))
+    (define x (make-ftype-pointer Bbits (foreign-alloc (ftype-sizeof Bbits))))
+    (define unsigned-bit-field
+      (lambda (n start end)
+        (bitwise-bit-field n start end)))
+    (define signed-bit-field
+      (lambda (n start end)
+        (let ([n (bitwise-bit-field n start end)])
+          (if (fx= (bitwise-arithmetic-shift-right n (fx- end start 1)) 0)
+              n
+              (- n (bitwise-arithmetic-shift-left 1 (fx- end start)))))))
+    #t)
+
+  (error? ;; invalid value 113886 for bit field of size 1
+    (ftype-set! Bbits (a2 a1 a1) x #x1bcde))
+
+  (error? ;; invalid value #\a for bit field of size 3
+    (ftype-set! Bbits (a2 a2 a1) x #\a))
+
+  (error? ;; invalid value oops for bit field of size 14
+    (ftype-set! Bbits (a3 a3 a2) x 'oops))
+
+  (begin
+    (define A1 #xabcfde) 
+    (define A2 #xde13752b) 
+    (define A3 #xf93578d679e35b) 
+    (define A4 #x7c18d679)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x A1)
+    (ftype-set! Bbits (a1 a2) x A2)
+    (ftype-set! Bbits (a1 a3) x A3)
+    (ftype-set! Bbits (a1 a4) x A4)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) A1)
+  (eqv? (ftype-ref Bbits (a1 a2) x) A2)
+  (eqv? (ftype-ref Bbits (a1 a3) x) A3)
+  (eqv? (ftype-ref Bbits (a1 a4) x) A4)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) (signed-bit-field A1 23 24))
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (signed-bit-field A1 0 23))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (signed-bit-field A2 37 40))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (signed-bit-field A2 0 37))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (signed-bit-field A3 14 56))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (signed-bit-field A3 0 14))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) (signed-bit-field A4 29 48))
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (signed-bit-field A4 0 29))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) (unsigned-bit-field A1 23 24))
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) (unsigned-bit-field A1 0 23))
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) (unsigned-bit-field A2 37 40))
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) (unsigned-bit-field A2 0 37))
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) (unsigned-bit-field A3 14 56))
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) (unsigned-bit-field A3 0 14))
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) (unsigned-bit-field A4 29 48))
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) (unsigned-bit-field A4 0 29))
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #x7c7c7c)
+    (ftype-set! Bbits (a1 a2) x #xa8a8a8a8a8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x919191919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x #x-1)
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) #xfc7c7c)
+
+  (begin
+    (ftype-set! Bbits (a2 a1 a1) x (signed-bit-field A1 23 24))
+    (ftype-set! Bbits (a2 a1 a2) x (signed-bit-field A1 0 23))
+    (ftype-set! Bbits (a2 a2 a1) x (signed-bit-field A2 37 40))
+    (ftype-set! Bbits (a2 a2 a2) x (signed-bit-field A2 0 37))
+    (ftype-set! Bbits (a2 a3 a1) x (signed-bit-field A3 14 56))
+    (ftype-set! Bbits (a2 a3 a2) x (signed-bit-field A3 0 14))
+    (ftype-set! Bbits (a2 a4 a1) x (signed-bit-field A4 29 48))
+    (ftype-set! Bbits (a2 a4 a2) x (signed-bit-field A4 0 29))
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) A1)
+  (eqv? (ftype-ref Bbits (a1 a2) x) A2)
+  (eqv? (ftype-ref Bbits (a1 a3) x) A3)
+  (eqv? (ftype-ref Bbits (a1 a4) x) A4)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) (signed-bit-field A1 23 24))
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (signed-bit-field A1 0 23))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (signed-bit-field A2 37 40))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (signed-bit-field A2 0 37))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (signed-bit-field A3 14 56))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (signed-bit-field A3 0 14))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) (signed-bit-field A4 29 48))
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (signed-bit-field A4 0 29))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) (unsigned-bit-field A1 23 24))
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) (unsigned-bit-field A1 0 23))
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) (unsigned-bit-field A2 37 40))
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) (unsigned-bit-field A2 0 37))
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) (unsigned-bit-field A3 14 56))
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) (unsigned-bit-field A3 0 14))
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) (unsigned-bit-field A4 29 48))
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) (unsigned-bit-field A4 0 29))
+
+  (begin
+    (ftype-set! Bbits (a1 a1) x #x7c7c7c)
+    (ftype-set! Bbits (a1 a2) x #xa8a8a8a8a8)
+    (ftype-set! Bbits (a1 a3) x #x3b3b3b3b3b3b3b)
+    (ftype-set! Bbits (a1 a4) x #x919191919191)
+    #t)
+
+  (begin
+    (ftype-set! Bbits (a3 a1 a1) x (unsigned-bit-field A1 23 24))
+    (ftype-set! Bbits (a3 a1 a2) x (unsigned-bit-field A1 0 23))
+    (ftype-set! Bbits (a3 a2 a1) x (unsigned-bit-field A2 37 40))
+    (ftype-set! Bbits (a3 a2 a2) x (unsigned-bit-field A2 0 37))
+    (ftype-set! Bbits (a3 a3 a1) x (unsigned-bit-field A3 14 56))
+    (ftype-set! Bbits (a3 a3 a2) x (unsigned-bit-field A3 0 14))
+    (ftype-set! Bbits (a3 a4 a1) x (unsigned-bit-field A4 29 48))
+    (ftype-set! Bbits (a3 a4 a2) x (unsigned-bit-field A4 0 29))
+    #t)
+
+  (eqv? (ftype-ref Bbits (a1 a1) x) A1)
+  (eqv? (ftype-ref Bbits (a1 a2) x) A2)
+  (eqv? (ftype-ref Bbits (a1 a3) x) A3)
+  (eqv? (ftype-ref Bbits (a1 a4) x) A4)
+
+  (eqv? (ftype-ref Bbits (a2 a1 a1) x) (signed-bit-field A1 23 24))
+  (eqv? (ftype-ref Bbits (a2 a1 a2) x) (signed-bit-field A1 0 23))
+  (eqv? (ftype-ref Bbits (a2 a2 a1) x) (signed-bit-field A2 37 40))
+  (eqv? (ftype-ref Bbits (a2 a2 a2) x) (signed-bit-field A2 0 37))
+  (eqv? (ftype-ref Bbits (a2 a3 a1) x) (signed-bit-field A3 14 56))
+  (eqv? (ftype-ref Bbits (a2 a3 a2) x) (signed-bit-field A3 0 14))
+  (eqv? (ftype-ref Bbits (a2 a4 a1) x) (signed-bit-field A4 29 48))
+  (eqv? (ftype-ref Bbits (a2 a4 a2) x) (signed-bit-field A4 0 29))
+
+  (eqv? (ftype-ref Bbits (a3 a1 a1) x) (unsigned-bit-field A1 23 24))
+  (eqv? (ftype-ref Bbits (a3 a1 a2) x) (unsigned-bit-field A1 0 23))
+  (eqv? (ftype-ref Bbits (a3 a2 a1) x) (unsigned-bit-field A2 37 40))
+  (eqv? (ftype-ref Bbits (a3 a2 a2) x) (unsigned-bit-field A2 0 37))
+  (eqv? (ftype-ref Bbits (a3 a3 a1) x) (unsigned-bit-field A3 14 56))
+  (eqv? (ftype-ref Bbits (a3 a3 a2) x) (unsigned-bit-field A3 0 14))
+  (eqv? (ftype-ref Bbits (a3 a4 a1) x) (unsigned-bit-field A4 29 48))
+  (eqv? (ftype-ref Bbits (a3 a4 a2) x) (unsigned-bit-field A4 0 29))
+
+  (begin
+    (fptr-free x)
+    #t)
+
+)
+
+(mat ftype-endian
+  (equal?
+    (let ()
+      (define-ftype A (endian native double))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (free-after a
+        (ftype-set! A () a 3.5)
+        (ftype-ref A () a)))
+    3.5)
+  (equal?
+    (let ()
+      (define-ftype A (endian big double))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (free-after a
+        (ftype-set! A () a 3.5)
+        (ftype-ref A () a)))
+    3.5)
+  (equal?
+    (let ()
+      (define-ftype A (endian little double))
+      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+      (free-after a
+        (ftype-set! A () a 3.5)
+        (ftype-ref A () a)))
+    3.5)
+  (equal?
+    (let ()
+       (define-ftype A
+         (endian big
+           (struct
+             [a1 double]
+             [a2 float]
+             [a3 long-long]
+             [a4 unsigned-long-long]
+             [a5 long]
+             [a6 unsigned-long]
+             [a7 int]
+             [a8 unsigned]
+             [a9 unsigned-int]
+             [a10 short]
+             [a11 unsigned-short]
+             [a12 wchar]
+             [a13 char]
+             [a14 boolean]
+             [a15 fixnum]
+             [a16 iptr]
+             [a17 uptr]
+             [a18 void*])))
+       (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+       (free-after a
+         (ftype-set! A (a1) a 3.5)
+         (ftype-set! A (a2) a -4.5)
+         (ftype-set! A (a3) a -30000)
+         (ftype-set! A (a4) a #xabcdef02)
+         (ftype-set! A (a5) a -30001)
+         (ftype-set! A (a6) a #xabcdef03)
+         (ftype-set! A (a7) a -30002)
+         (ftype-set! A (a8) a #xabcdef04)
+         (ftype-set! A (a9) a #xabcdef05)
+         (ftype-set! A (a10) a -30003)
+         (ftype-set! A (a11) a #xab06)
+         (ftype-set! A (a12) a #\a)
+         (ftype-set! A (a13) a #\b)
+         (ftype-set! A (a14) a 'hello)
+         (ftype-set! A (a15) a (most-positive-fixnum))
+         (ftype-set! A (a16) a -30004)
+         (ftype-set! A (a17) a #xabcdef07)
+         (ftype-set! A (a18) a 25000)
+         (list
+           (ftype-ref A (a1) a)
+           (ftype-ref A (a2) a)
+           (ftype-ref A (a3) a)
+           (ftype-ref A (a4) a)
+           (ftype-ref A (a5) a)
+           (ftype-ref A (a6) a)
+           (ftype-ref A (a7) a)
+           (ftype-ref A (a8) a)
+           (ftype-ref A (a9) a)
+           (ftype-ref A (a10) a)
+           (ftype-ref A (a11) a)
+           (ftype-ref A (a12) a)
+           (ftype-ref A (a13) a)
+           (ftype-ref A (a14) a)
+           (ftype-ref A (a15) a)
+           (ftype-ref A (a16) a)
+           (ftype-ref A (a17) a)
+           (ftype-ref A (a18) a))))
+    `(3.5
+      -4.5
+      -30000
+      #xabcdef02
+      -30001
+      #xabcdef03
+      -30002
+      #xabcdef04
+      #xabcdef05
+      -30003
+      #xab06
+      #\a
+      #\b
+      #t
+      ,(most-positive-fixnum)
+      -30004
+      #xabcdef07
+      25000))
+  (equal?
+    (let ()
+       (define-ftype A
+         (endian little
+           (struct
+             [a1 double]
+             [a2 float]
+             [a3 long-long]
+             [a4 unsigned-long-long]
+             [a5 long]
+             [a6 unsigned-long]
+             [a7 int]
+             [a8 unsigned]
+             [a9 unsigned-int]
+             [a10 short]
+             [a11 unsigned-short]
+             [a12 wchar]
+             [a13 char]
+             [a14 boolean]
+             [a15 fixnum]
+             [a16 iptr]
+             [a17 uptr]
+             [a18 void*])))
+       (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+       (free-after a
+         (ftype-set! A (a1) a 3.5)
+         (ftype-set! A (a2) a -4.5)
+         (ftype-set! A (a3) a -30000)
+         (ftype-set! A (a4) a #xabcdef02)
+         (ftype-set! A (a5) a -30001)
+         (ftype-set! A (a6) a #xabcdef03)
+         (ftype-set! A (a7) a -30002)
+         (ftype-set! A (a8) a #xabcdef04)
+         (ftype-set! A (a9) a #xabcdef05)
+         (ftype-set! A (a10) a -30003)
+         (ftype-set! A (a11) a #xab06)
+         (ftype-set! A (a12) a #\a)
+         (ftype-set! A (a13) a #\b)
+         (ftype-set! A (a14) a 'hello)
+         (ftype-set! A (a15) a (most-positive-fixnum))
+         (ftype-set! A (a16) a -30004)
+         (ftype-set! A (a17) a #xabcdef07)
+         (ftype-set! A (a18) a 25000)
+         (list
+           (ftype-ref A (a1) a)
+           (ftype-ref A (a2) a)
+           (ftype-ref A (a3) a)
+           (ftype-ref A (a4) a)
+           (ftype-ref A (a5) a)
+           (ftype-ref A (a6) a)
+           (ftype-ref A (a7) a)
+           (ftype-ref A (a8) a)
+           (ftype-ref A (a9) a)
+           (ftype-ref A (a10) a)
+           (ftype-ref A (a11) a)
+           (ftype-ref A (a12) a)
+           (ftype-ref A (a13) a)
+           (ftype-ref A (a14) a)
+           (ftype-ref A (a15) a)
+           (ftype-ref A (a16) a)
+           (ftype-ref A (a17) a)
+           (ftype-ref A (a18) a))))
+    `(3.5
+      -4.5
+      -30000
+      #xabcdef02
+      -30001
+      #xabcdef03
+      -30002
+      #xabcdef04
+      #xabcdef05
+      -30003
+      #xab06
+      #\a
+      #\b
+      #t
+      ,(most-positive-fixnum)
+      -30004
+      #xabcdef07
+      25000))
+  (equal?
+    (let ()
+       (define-ftype A
+         (endian native
+           (struct
+             [a1 double]
+             [a2 float]
+             [a3 long-long]
+             [a4 unsigned-long-long]
+             [a5 long]
+             [a6 unsigned-long]
+             [a7 int]
+             [a8 unsigned]
+             [a9 unsigned-int]
+             [a10 short]
+             [a11 unsigned-short]
+             [a12 wchar]
+             [a13 char]
+             [a14 boolean]
+             [a15 fixnum]
+             [a16 iptr]
+             [a17 uptr]
+             [a18 void*])))
+       (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+       (free-after a
+         (ftype-set! A (a1) a 3.5)
+         (ftype-set! A (a2) a -4.5)
+         (ftype-set! A (a3) a -30000)
+         (ftype-set! A (a4) a #xabcdef02)
+         (ftype-set! A (a5) a -30001)
+         (ftype-set! A (a6) a #xabcdef03)
+         (ftype-set! A (a7) a -30002)
+         (ftype-set! A (a8) a #xabcdef04)
+         (ftype-set! A (a9) a #xabcdef05)
+         (ftype-set! A (a10) a -30003)
+         (ftype-set! A (a11) a #xab06)
+         (ftype-set! A (a12) a #\a)
+         (ftype-set! A (a13) a #\b)
+         (ftype-set! A (a14) a 'hello)
+         (ftype-set! A (a15) a (most-positive-fixnum))
+         (ftype-set! A (a16) a -30004)
+         (ftype-set! A (a17) a #xabcdef07)
+         (ftype-set! A (a18) a 25000)
+         (list
+           (ftype-ref A (a1) a)
+           (ftype-ref A (a2) a)
+           (ftype-ref A (a3) a)
+           (ftype-ref A (a4) a)
+           (ftype-ref A (a5) a)
+           (ftype-ref A (a6) a)
+           (ftype-ref A (a7) a)
+           (ftype-ref A (a8) a)
+           (ftype-ref A (a9) a)
+           (ftype-ref A (a10) a)
+           (ftype-ref A (a11) a)
+           (ftype-ref A (a12) a)
+           (ftype-ref A (a13) a)
+           (ftype-ref A (a14) a)
+           (ftype-ref A (a15) a)
+           (ftype-ref A (a16) a)
+           (ftype-ref A (a17) a)
+           (ftype-ref A (a18) a))))
+    `(3.5
+      -4.5
+      -30000
+      #xabcdef02
+      -30001
+      #xabcdef03
+      -30002
+      #xabcdef04
+      #xabcdef05
+      -30003
+      #xab06
+      #\a
+      #\b
+      #t
+      ,(most-positive-fixnum)
+      -30004
+      #xabcdef07
+      25000))
+
+ ; ----------------
+  (begin
+    (define-ftype Aendian
+      (union
+        [a1 (endian native
+              (struct
+                [a1 integer-64]
+                [a2 integer-32]
+                [a3 integer-16]))]
+        [a2 (endian big
+              (struct
+                [a1 integer-64]
+                [a2 integer-32]
+                [a3 integer-16]))]
+        [a3 (endian little
+              (struct
+                [a1 integer-64]
+                [a2 integer-32]
+                [a3 integer-16]))]))
+    (define x (make-ftype-pointer Aendian (foreign-alloc (ftype-sizeof Aendian))))
+    (define xcheck
+      (lambda (x1 x2 x3)
+        (define iswap
+          (lambda (k n)
+            (let ([n (if (< n 0) (+ (expt 2 k) n) n)])
+              (do ([i 0 (fx+ i 8)]
+                   [m 0 (logor (ash m 8) (bitwise-bit-field n i (+ i 8)))])
+                ((fx= i k) (if (>= m (expt 2 (- k 1))) (- m (expt 2 k)) m))))))
+        (define okay?
+          (let ([s1 (iswap 64 x1)] [s2 (iswap 32 x2)] [s3 (iswap 16 x3)])
+            (lambda (eness)
+              (and
+                (equal? (ftype-ref Aendian (a1 a1) x)
+                        (if (eq? eness (native-endianness)) x1 s1))
+                (equal? (ftype-ref Aendian (a1 a2) x)
+                        (if (eq? eness (native-endianness)) x2 s2))
+                (equal? (ftype-ref Aendian (a1 a3) x)
+                        (if (eq? eness (native-endianness)) x3 s3))
+                (equal? (ftype-ref Aendian (a2 a1) x)
+                        (if (eq? eness 'big) x1 s1))
+                (equal? (ftype-ref Aendian (a2 a2) x)
+                        (if (eq? eness 'big) x2 s2))
+                (equal? (ftype-ref Aendian (a2 a3) x)
+                        (if (eq? eness 'big) x3 s3))
+                (equal? (ftype-ref Aendian (a3 a1) x)
+                        (if (eq? eness 'little) x1 s1))
+                (equal? (ftype-ref Aendian (a3 a2) x)
+                        (if (eq? eness 'little) x2 s2))
+                (equal? (ftype-ref Aendian (a3 a3) x)
+                        (if (eq? eness 'little) x3 s3))))))
+        (and
+          (begin
+            (ftype-set! Aendian (a1 a1) x x1)
+            (ftype-set! Aendian (a1 a2) x x2)
+            (ftype-set! Aendian (a1 a3) x x3)
+            (okay? (native-endianness)))
+          (begin
+            (ftype-set! Aendian (a2 a1) x x1)
+            (ftype-set! Aendian (a2 a2) x x2)
+            (ftype-set! Aendian (a2 a3) x x3)
+            (okay? 'big))
+          (begin
+            (ftype-set! Aendian (a3 a1) x x1)
+            (ftype-set! Aendian (a3 a2) x x2)
+            (ftype-set! Aendian (a3 a3) x x3)
+            (okay? 'little)))))
+    #t)
+
+  (xcheck 0 0 0)
+  (xcheck -1 -1 -1)
+  (xcheck 15 25 35)
+  (xcheck -15 -25 -35)
+  (xcheck #x123456780fedcba9 #x4ca97531 #x3efa)
+  (xcheck #x-123456780fedcba9 #x-4ca97531 #x-3efa)
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Bendian
+      (union
+        [a1 (endian native
+              (struct
+                [a1 unsigned-64]
+                [a2 unsigned-32]
+                [a3 unsigned-16]))]
+        [a2 (endian big
+              (struct
+                [a1 unsigned-64]
+                [a2 unsigned-32]
+                [a3 unsigned-16]))]
+        [a3 (endian little
+              (struct
+                [a1 unsigned-64]
+                [a2 unsigned-32]
+                [a3 unsigned-16]))]))
+    (define x (make-ftype-pointer Bendian (foreign-alloc (ftype-sizeof Bendian))))
+    (define xcheck
+      (lambda (x1 x2 x3)
+        (define uswap
+          (lambda (k n)
+            (do ([i 0 (fx+ i 8)]
+                 [m 0 (logor (ash m 8) (bitwise-bit-field n i (+ i 8)))])
+              ((fx= i k) m))))
+        (define okay?
+          (let ([s1 (uswap 64 x1)] [s2 (uswap 32 x2)] [s3 (uswap 16 x3)])
+            (lambda (eness)
+              (and
+                (equal? (ftype-ref Bendian (a1 a1) x)
+                        (if (eq? eness (native-endianness)) x1 s1))
+                (equal? (ftype-ref Bendian (a1 a2) x)
+                        (if (eq? eness (native-endianness)) x2 s2))
+                (equal? (ftype-ref Bendian (a1 a3) x)
+                        (if (eq? eness (native-endianness)) x3 s3))
+                (equal? (ftype-ref Bendian (a2 a1) x)
+                        (if (eq? eness 'big) x1 s1))
+                (equal? (ftype-ref Bendian (a2 a2) x)
+                        (if (eq? eness 'big) x2 s2))
+                (equal? (ftype-ref Bendian (a2 a3) x)
+                        (if (eq? eness 'big) x3 s3))
+                (equal? (ftype-ref Bendian (a3 a1) x)
+                        (if (eq? eness 'little) x1 s1))
+                (equal? (ftype-ref Bendian (a3 a2) x)
+                        (if (eq? eness 'little) x2 s2))
+                (equal? (ftype-ref Bendian (a3 a3) x)
+                        (if (eq? eness 'little) x3 s3))))))
+        (and
+          (begin
+            (ftype-set! Bendian (a1 a1) x x1)
+            (ftype-set! Bendian (a1 a2) x x2)
+            (ftype-set! Bendian (a1 a3) x x3)
+            (okay? (native-endianness)))
+          (begin
+            (ftype-set! Bendian (a2 a1) x x1)
+            (ftype-set! Bendian (a2 a2) x x2)
+            (ftype-set! Bendian (a2 a3) x x3)
+            (okay? 'big))
+          (begin
+            (ftype-set! Bendian (a3 a1) x x1)
+            (ftype-set! Bendian (a3 a2) x x2)
+            (ftype-set! Bendian (a3 a3) x x3)
+            (okay? 'little)))))
+    #t)
+
+  (xcheck 0 0 0)
+  (xcheck #xffffffffffffffff #xffffffff #xffff)
+  (xcheck #x8000000000000015 #x80000025 #x8035)
+  (xcheck #x123456780fedcba9 #x4ca97531 #x3efa)
+  (xcheck #xf23456780fedcba9 #xdca97531 #x9efa)
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Abits
+      (endian little
+        (union
+          [a1 (struct
+                [a1 unsigned-32]
+                [a2 unsigned-32]
+                [a3 unsigned-32]
+                [a4 unsigned-32]
+                [a5 unsigned-32]
+                [a6 unsigned-32]
+                [a7 unsigned-32]
+                [a8 unsigned-32]
+                [a9 unsigned-32]
+                [a10 unsigned-32]
+                [a11 unsigned-32]
+                [a12 unsigned-32]
+                [a13 unsigned-32]
+                [a14 unsigned-32]
+                [a15 unsigned-32]
+                [a16 unsigned-32]
+                [a17 unsigned-32]
+                [a18 unsigned-32]
+                [a19 unsigned-32]
+                [a20 unsigned-32]
+                [a21 unsigned-32])]
+          [a2 (struct
+                [a1 (bits
+                      [_ signed 4]
+                      [a1 signed 1]
+                      [a2 signed 2]
+                      [a3 signed 3]
+                      [a4 signed 4]
+                      [a5 signed 5]
+                      [a6 signed 6]
+                      [a7 signed 7])]
+                [a2 (bits
+                      [_ signed 5]
+                      [a8 signed 8]
+                      [a9 signed 9]
+                      [a10 signed 10])]
+                [a3 (bits
+                      [a11 signed 11]
+                      [a12 signed 12]
+                      [_ signed 9])]
+                [a4 (bits
+                      [a13 signed 13]
+                      [_ signed 5]
+                      [a14 signed 14])]
+                [a5 (bits
+                      [_ signed 1]
+                      [a15 signed 15]
+                      [a16 signed 16])]
+                [a6 (bits [a17 signed 17] [_ signed 15])]
+                [a7 (bits [_ signed 14] [a18 signed 18])]
+                [a8 (bits [a19 signed 19] [_ signed 13])]
+                [a9 (bits [_ signed 12] [a20 signed 20])]
+                [a10 (bits [a21 signed 21] [_ signed 11])]
+                [a11 (bits [_ signed 10] [a22 signed 22])]
+                [a12 (bits [a23 signed 23] [_ signed 9])]
+                [a13 (bits [_ signed 8] [a24 signed 24])]
+                [a14 (bits [a25 signed 25] [_ signed 7])]
+                [a15 (bits [_ signed 6] [a26 signed 26])]
+                [a16 (bits [a27 signed 27] [_ signed 5])]
+                [a17 (bits [_ signed 4] [a28 signed 28])]
+                [a18 (bits [a29 signed 29] [_ signed 3])]
+                [a19 (bits [_ signed 2] [a30 signed 30])]
+                [a20 (bits [a31 signed 31] [_ signed 1])]
+                [a21 (bits [a32 signed 32])])]
+          [a3 (struct
+                [a1 (bits
+                      [_ unsigned 4]
+                      [a1 unsigned 1]
+                      [a2 unsigned 2]
+                      [a3 unsigned 3]
+                      [a4 unsigned 4]
+                      [a5 unsigned 5]
+                      [a6 unsigned 6]
+                      [a7 unsigned 7])]
+                [a2 (bits
+                      [_ unsigned 5]
+                      [a8 unsigned 8]
+                      [a9 unsigned 9]
+                      [a10 unsigned 10])]
+                [a3 (bits
+                      [a11 unsigned 11]
+                      [a12 unsigned 12]
+                      [_ unsigned 9])]
+                [a4 (bits
+                      [a13 unsigned 13]
+                      [_ unsigned 5]
+                      [a14 unsigned 14])]
+                [a5 (bits
+                      [_ unsigned 1]
+                      [a15 unsigned 15]
+                      [a16 unsigned 16])]
+                [a6 (bits [a17 unsigned 17] [_ unsigned 15])]
+                [a7 (bits [_ unsigned 14] [a18 unsigned 18])]
+                [a8 (bits [a19 unsigned 19] [_ unsigned 13])]
+                [a9 (bits [_ unsigned 12] [a20 unsigned 20])]
+                [a10 (bits [a21 unsigned 21] [_ unsigned 11])]
+                [a11 (bits [_ unsigned 10] [a22 unsigned 22])]
+                [a12 (bits [a23 unsigned 23] [_ unsigned 9])]
+                [a13 (bits [_ unsigned 8] [a24 unsigned 24])]
+                [a14 (bits [a25 unsigned 25] [_ unsigned 7])]
+                [a15 (bits [_ unsigned 6] [a26 unsigned 26])]
+                [a16 (bits [a27 unsigned 27] [_ unsigned 5])]
+                [a17 (bits [_ unsigned 4] [a28 unsigned 28])]
+                [a18 (bits [a29 unsigned 29] [_ unsigned 3])]
+                [a19 (bits [_ unsigned 2] [a30 unsigned 30])]
+                [a20 (bits [a31 unsigned 31] [_ unsigned 1])]
+                [a21 (bits [a32 unsigned 32])])])))
+    (define x (make-ftype-pointer Abits (foreign-alloc (ftype-sizeof Abits))))
+    (define (get-a1)
+      (list
+        (ftype-ref Abits (a1 a1) x)
+        (ftype-ref Abits (a1 a2) x)
+        (ftype-ref Abits (a1 a3) x)
+        (ftype-ref Abits (a1 a4) x)
+        (ftype-ref Abits (a1 a5) x)
+        (ftype-ref Abits (a1 a6) x)
+        (ftype-ref Abits (a1 a7) x)
+        (ftype-ref Abits (a1 a8) x)
+        (ftype-ref Abits (a1 a9) x)
+        (ftype-ref Abits (a1 a10) x)
+        (ftype-ref Abits (a1 a11) x)
+        (ftype-ref Abits (a1 a12) x)
+        (ftype-ref Abits (a1 a13) x)
+        (ftype-ref Abits (a1 a14) x)
+        (ftype-ref Abits (a1 a15) x)
+        (ftype-ref Abits (a1 a16) x)
+        (ftype-ref Abits (a1 a17) x)
+        (ftype-ref Abits (a1 a18) x)
+        (ftype-ref Abits (a1 a19) x)
+        (ftype-ref Abits (a1 a20) x)
+        (ftype-ref Abits (a1 a21) x)))
+    (define (get-a2)
+      (list
+        (ftype-ref Abits (a2 a1 a1) x)
+        (ftype-ref Abits (a2 a1 a2) x)
+        (ftype-ref Abits (a2 a1 a3) x)
+        (ftype-ref Abits (a2 a1 a4) x)
+        (ftype-ref Abits (a2 a1 a5) x)
+        (ftype-ref Abits (a2 a1 a6) x)
+        (ftype-ref Abits (a2 a1 a7) x)
+        (ftype-ref Abits (a2 a2 a8) x)
+        (ftype-ref Abits (a2 a2 a9) x)
+        (ftype-ref Abits (a2 a2 a10) x)
+        (ftype-ref Abits (a2 a3 a11) x)
+        (ftype-ref Abits (a2 a3 a12) x)
+        (ftype-ref Abits (a2 a4 a13) x)
+        (ftype-ref Abits (a2 a4 a14) x)
+        (ftype-ref Abits (a2 a5 a15) x)
+        (ftype-ref Abits (a2 a5 a16) x)
+        (ftype-ref Abits (a2 a6 a17) x)
+        (ftype-ref Abits (a2 a7 a18) x)
+        (ftype-ref Abits (a2 a8 a19) x)
+        (ftype-ref Abits (a2 a9 a20) x)
+        (ftype-ref Abits (a2 a10 a21) x)
+        (ftype-ref Abits (a2 a11 a22) x)
+        (ftype-ref Abits (a2 a12 a23) x)
+        (ftype-ref Abits (a2 a13 a24) x)
+        (ftype-ref Abits (a2 a14 a25) x)
+        (ftype-ref Abits (a2 a15 a26) x)
+        (ftype-ref Abits (a2 a16 a27) x)
+        (ftype-ref Abits (a2 a17 a28) x)
+        (ftype-ref Abits (a2 a18 a29) x)
+        (ftype-ref Abits (a2 a19 a30) x)
+        (ftype-ref Abits (a2 a20 a31) x)
+        (ftype-ref Abits (a2 a21 a32) x)))
+    (define (get-a3)
+      (list
+        (ftype-ref Abits (a3 a1 a1) x)
+        (ftype-ref Abits (a3 a1 a2) x)
+        (ftype-ref Abits (a3 a1 a3) x)
+        (ftype-ref Abits (a3 a1 a4) x)
+        (ftype-ref Abits (a3 a1 a5) x)
+        (ftype-ref Abits (a3 a1 a6) x)
+        (ftype-ref Abits (a3 a1 a7) x)
+        (ftype-ref Abits (a3 a2 a8) x)
+        (ftype-ref Abits (a3 a2 a9) x)
+        (ftype-ref Abits (a3 a2 a10) x)
+        (ftype-ref Abits (a3 a3 a11) x)
+        (ftype-ref Abits (a3 a3 a12) x)
+        (ftype-ref Abits (a3 a4 a13) x)
+        (ftype-ref Abits (a3 a4 a14) x)
+        (ftype-ref Abits (a3 a5 a15) x)
+        (ftype-ref Abits (a3 a5 a16) x)
+        (ftype-ref Abits (a3 a6 a17) x)
+        (ftype-ref Abits (a3 a7 a18) x)
+        (ftype-ref Abits (a3 a8 a19) x)
+        (ftype-ref Abits (a3 a9 a20) x)
+        (ftype-ref Abits (a3 a10 a21) x)
+        (ftype-ref Abits (a3 a11 a22) x)
+        (ftype-ref Abits (a3 a12 a23) x)
+        (ftype-ref Abits (a3 a13 a24) x)
+        (ftype-ref Abits (a3 a14 a25) x)
+        (ftype-ref Abits (a3 a15 a26) x)
+        (ftype-ref Abits (a3 a16 a27) x)
+        (ftype-ref Abits (a3 a17 a28) x)
+        (ftype-ref Abits (a3 a18 a29) x)
+        (ftype-ref Abits (a3 a19 a30) x)
+        (ftype-ref Abits (a3 a20 a31) x)
+        (ftype-ref Abits (a3 a21 a32) x)))
+    (define (set-a1! ls)
+      (map
+        (lambda (f v) (f v))
+        (list
+          (lambda (v) (ftype-set! Abits (a1 a1) x v))
+          (lambda (v) (ftype-set! Abits (a1 a2) x v))
+          (lambda (v) (ftype-set! Abits (a1 a3) x v))
+          (lambda (v) (ftype-set! Abits (a1 a4) x v))
+          (lambda (v) (ftype-set! Abits (a1 a5) x v))
+          (lambda (v) (ftype-set! Abits (a1 a6) x v))
+          (lambda (v) (ftype-set! Abits (a1 a7) x v))
+          (lambda (v) (ftype-set! Abits (a1 a8) x v))
+          (lambda (v) (ftype-set! Abits (a1 a9) x v))
+          (lambda (v) (ftype-set! Abits (a1 a10) x v))
+          (lambda (v) (ftype-set! Abits (a1 a11) x v))
+          (lambda (v) (ftype-set! Abits (a1 a12) x v))
+          (lambda (v) (ftype-set! Abits (a1 a13) x v))
+          (lambda (v) (ftype-set! Abits (a1 a14) x v))
+          (lambda (v) (ftype-set! Abits (a1 a15) x v))
+          (lambda (v) (ftype-set! Abits (a1 a16) x v))
+          (lambda (v) (ftype-set! Abits (a1 a17) x v))
+          (lambda (v) (ftype-set! Abits (a1 a18) x v))
+          (lambda (v) (ftype-set! Abits (a1 a19) x v))
+          (lambda (v) (ftype-set! Abits (a1 a20) x v))
+          (lambda (v) (ftype-set! Abits (a1 a21) x v)))
+        ls))
+    (define (set-a2! ls)
+      (map
+        (lambda (f v) (f v))
+        (list
+          (lambda (v) (ftype-set! Abits (a2 a1 a1) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a2) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a3) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a4) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a5) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a6) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a7) x v))
+          (lambda (v) (ftype-set! Abits (a2 a2 a8) x v))
+          (lambda (v) (ftype-set! Abits (a2 a2 a9) x v))
+          (lambda (v) (ftype-set! Abits (a2 a2 a10) x v))
+          (lambda (v) (ftype-set! Abits (a2 a3 a11) x v))
+          (lambda (v) (ftype-set! Abits (a2 a3 a12) x v))
+          (lambda (v) (ftype-set! Abits (a2 a4 a13) x v))
+          (lambda (v) (ftype-set! Abits (a2 a4 a14) x v))
+          (lambda (v) (ftype-set! Abits (a2 a5 a15) x v))
+          (lambda (v) (ftype-set! Abits (a2 a5 a16) x v))
+          (lambda (v) (ftype-set! Abits (a2 a6 a17) x v))
+          (lambda (v) (ftype-set! Abits (a2 a7 a18) x v))
+          (lambda (v) (ftype-set! Abits (a2 a8 a19) x v))
+          (lambda (v) (ftype-set! Abits (a2 a9 a20) x v))
+          (lambda (v) (ftype-set! Abits (a2 a10 a21) x v))
+          (lambda (v) (ftype-set! Abits (a2 a11 a22) x v))
+          (lambda (v) (ftype-set! Abits (a2 a12 a23) x v))
+          (lambda (v) (ftype-set! Abits (a2 a13 a24) x v))
+          (lambda (v) (ftype-set! Abits (a2 a14 a25) x v))
+          (lambda (v) (ftype-set! Abits (a2 a15 a26) x v))
+          (lambda (v) (ftype-set! Abits (a2 a16 a27) x v))
+          (lambda (v) (ftype-set! Abits (a2 a17 a28) x v))
+          (lambda (v) (ftype-set! Abits (a2 a18 a29) x v))
+          (lambda (v) (ftype-set! Abits (a2 a19 a30) x v))
+          (lambda (v) (ftype-set! Abits (a2 a20 a31) x v))
+          (lambda (v) (ftype-set! Abits (a2 a21 a32) x v)))
+        ls))
+    (define (set-a3! ls)
+      (map
+        (lambda (f v) (f v))
+        (list
+          (lambda (v) (ftype-set! Abits (a3 a1 a1) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a2) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a3) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a4) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a5) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a6) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a7) x v))
+          (lambda (v) (ftype-set! Abits (a3 a2 a8) x v))
+          (lambda (v) (ftype-set! Abits (a3 a2 a9) x v))
+          (lambda (v) (ftype-set! Abits (a3 a2 a10) x v))
+          (lambda (v) (ftype-set! Abits (a3 a3 a11) x v))
+          (lambda (v) (ftype-set! Abits (a3 a3 a12) x v))
+          (lambda (v) (ftype-set! Abits (a3 a4 a13) x v))
+          (lambda (v) (ftype-set! Abits (a3 a4 a14) x v))
+          (lambda (v) (ftype-set! Abits (a3 a5 a15) x v))
+          (lambda (v) (ftype-set! Abits (a3 a5 a16) x v))
+          (lambda (v) (ftype-set! Abits (a3 a6 a17) x v))
+          (lambda (v) (ftype-set! Abits (a3 a7 a18) x v))
+          (lambda (v) (ftype-set! Abits (a3 a8 a19) x v))
+          (lambda (v) (ftype-set! Abits (a3 a9 a20) x v))
+          (lambda (v) (ftype-set! Abits (a3 a10 a21) x v))
+          (lambda (v) (ftype-set! Abits (a3 a11 a22) x v))
+          (lambda (v) (ftype-set! Abits (a3 a12 a23) x v))
+          (lambda (v) (ftype-set! Abits (a3 a13 a24) x v))
+          (lambda (v) (ftype-set! Abits (a3 a14 a25) x v))
+          (lambda (v) (ftype-set! Abits (a3 a15 a26) x v))
+          (lambda (v) (ftype-set! Abits (a3 a16 a27) x v))
+          (lambda (v) (ftype-set! Abits (a3 a17 a28) x v))
+          (lambda (v) (ftype-set! Abits (a3 a18 a29) x v))
+          (lambda (v) (ftype-set! Abits (a3 a19 a30) x v))
+          (lambda (v) (ftype-set! Abits (a3 a20 a31) x v))
+          (lambda (v) (ftype-set! Abits (a3 a21 a32) x v)))
+        ls))
+    (define a3-c7c7c7c7
+      '(#b0
+        #b10
+        #b111
+        #b0001
+        #b11111
+        #b111000
+        #b1100011
+        #b00111110
+        #b000111110
+        #b1100011111
+        #b11111000111
+        #b100011111000
+        #b0011111000111
+        #b11000111110001
+        #b110001111100011
+        #b1100011111000111
+        #b11100011111000111
+        #b110001111100011111
+        #b1111100011111000111
+        #b11000111110001111100
+        #b001111100011111000111
+        #b1100011111000111110001
+        #b10001111100011111000111
+        #b110001111100011111000111
+        #b1110001111100011111000111
+        #b11000111110001111100011111
+        #b111110001111100011111000111
+        #b1100011111000111110001111100
+        #b00111110001111100011111000111
+        #b110001111100011111000111110001
+        #b1000111110001111100011111000111
+        #b11000111110001111100011111000111))
+    (define a3-13579bdf
+      '(#b1
+        #b10
+        #b111
+        #b0110
+        #b11110
+        #b101010
+        #b0001001
+        #b11011110
+        #b010111100
+        #b0001001101
+        #b01111011111
+        #b101011110011
+        #b1101111011111
+        #b00010011010101
+        #b100110111101111
+        #b0001001101010111
+        #b11001101111011111
+        #b000100110101011110
+        #b1111001101111011111
+        #b00010011010101111001
+        #b101111001101111011111
+        #b0001001101010111100110
+        #b10101111001101111011111
+        #b000100110101011110011011
+        #b1010101111001101111011111
+        #b00010011010101111001101111
+        #b011010101111001101111011111
+        #b0001001101010111100110111101
+        #b10011010101111001101111011111
+        #b000100110101011110011011110111
+        #b0010011010101111001101111011111
+        #b00010011010101111001101111011111))
+    (define a2-from-a3
+      (lambda (ls)
+        (map (lambda (i n)
+               (let* ([radix/2 (expt 2 i)])
+                 (if (>= n radix/2)
+                     (- n (ash radix/2 1))
+                     n)))
+          (enumerate ls) ls)))
+    #t)
+  (begin
+    (set-a1! (make-list 21 0))
+    #t)
+  (equal?
+    (get-a2)
+    (make-list 32 0))
+  (equal?
+    (get-a3)
+    (make-list 32 0))
+  (begin
+    (set-a1! (make-list 21 #xffffffff))
+    #t)
+  (equal?
+    (get-a2)
+    (make-list 32 -1))
+  (equal?
+    (get-a3)
+    (do ([n 32 (fx- n 1)]
+         [ls '() (cons (- (expt 2 n) 1) ls)])
+      ((= n 0) ls)))
+  (begin
+    (set-a1! (make-list 21 #xc7c7c7c7))
+    #t)
+  (equal?
+    (get-a3)
+    a3-c7c7c7c7)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-c7c7c7c7))
+  (begin
+    (ftype-set! Abits (a1 a1) x #x13579bdf)
+    (ftype-set! Abits (a1 a2) x #x13579bdf)
+    (ftype-set! Abits (a1 a3) x #x13579bdf)
+    (ftype-set! Abits (a1 a4) x #x13579bdf)
+    (ftype-set! Abits (a1 a5) x #x13579bdf)
+    (ftype-set! Abits (a1 a6) x #x13579bdf)
+    (ftype-set! Abits (a1 a7) x #x13579bdf)
+    (ftype-set! Abits (a1 a8) x #x13579bdf)
+    (ftype-set! Abits (a1 a9) x #x13579bdf)
+    (ftype-set! Abits (a1 a10) x #x13579bdf)
+    (ftype-set! Abits (a1 a11) x #x13579bdf)
+    (ftype-set! Abits (a1 a12) x #x13579bdf)
+    (ftype-set! Abits (a1 a13) x #x13579bdf)
+    (ftype-set! Abits (a1 a14) x #x13579bdf)
+    (ftype-set! Abits (a1 a15) x #x13579bdf)
+    (ftype-set! Abits (a1 a16) x #x13579bdf)
+    (ftype-set! Abits (a1 a17) x #x13579bdf)
+    (ftype-set! Abits (a1 a18) x #x13579bdf)
+    (ftype-set! Abits (a1 a19) x #x13579bdf)
+    (ftype-set! Abits (a1 a20) x #x13579bdf)
+    (ftype-set! Abits (a1 a21) x #x13579bdf)
+    #t)
+  (equal?
+    (get-a3)
+    a3-13579bdf)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-13579bdf))
+  (begin
+    (set-a1! (make-list 21 0))
+    (set-a3! a3-c7c7c7c7)
+    #t)
+  (equal?
+    (get-a3)
+    a3-c7c7c7c7)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-c7c7c7c7))
+  (equal?
+    (get-a1)
+    '(#xc7c7c7c0
+      #xc7c7c7c0
+      #x0047c7c7
+      #xc7c407c7
+      #xc7c7c7c6
+      #x0001c7c7
+      #xc7c7c000
+      #x0007c7c7
+      #xc7c7c000
+      #x0007c7c7
+      #xc7c7c400
+      #x0047c7c7
+      #xc7c7c700
+      #x01c7c7c7
+      #xc7c7c7c0
+      #x07c7c7c7
+      #xc7c7c7c0
+      #x07c7c7c7
+      #xc7c7c7c4
+      #x47c7c7c7
+      #xc7c7c7c7))
+  (begin
+    (set-a1! (make-list 21 0))
+    (set-a2! (a2-from-a3 a3-13579bdf))
+    #t)
+  (equal?
+    (get-a3)
+    a3-13579bdf)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-13579bdf))
+  (equal?
+    (get-a1)
+    '(#x13579bd0
+      #x13579bc0
+      #x00579bdf
+      #x13541bdf
+      #x13579bde
+      #x00019bdf
+      #x13578000
+      #x00079bdf
+      #x13579000
+      #x00179bdf
+      #x13579800
+      #x00579bdf
+      #x13579b00
+      #x01579bdf
+      #x13579bc0
+      #x03579bdf
+      #x13579bd0
+      #x13579bdf
+      #x13579bdc
+      #x13579bdf
+      #x13579bdf))
+
+  (begin
+    (fptr-free x)
+    #t)
+
+ ; ----------------
+  (begin
+    (define-ftype Abits
+      (endian big
+        (union
+          [a1 (struct
+                [a1 unsigned-32]
+                [a2 unsigned-32]
+                [a3 unsigned-32]
+                [a4 unsigned-32]
+                [a5 unsigned-32]
+                [a6 unsigned-32]
+                [a7 unsigned-32]
+                [a8 unsigned-32]
+                [a9 unsigned-32]
+                [a10 unsigned-32]
+                [a11 unsigned-32]
+                [a12 unsigned-32]
+                [a13 unsigned-32]
+                [a14 unsigned-32]
+                [a15 unsigned-32]
+                [a16 unsigned-32]
+                [a17 unsigned-32]
+                [a18 unsigned-32]
+                [a19 unsigned-32]
+                [a20 unsigned-32]
+                [a21 unsigned-32])]
+          [a2 (struct
+                [a1 (bits
+                      [_ signed 4]
+                      [a1 signed 1]
+                      [a2 signed 2]
+                      [a3 signed 3]
+                      [a4 signed 4]
+                      [a5 signed 5]
+                      [a6 signed 6]
+                      [a7 signed 7])]
+                [a2 (bits
+                      [_ signed 5]
+                      [a8 signed 8]
+                      [a9 signed 9]
+                      [a10 signed 10])]
+                [a3 (bits
+                      [a11 signed 11]
+                      [a12 signed 12]
+                      [_ signed 9])]
+                [a4 (bits
+                      [a13 signed 13]
+                      [_ signed 5]
+                      [a14 signed 14])]
+                [a5 (bits
+                      [_ signed 1]
+                      [a15 signed 15]
+                      [a16 signed 16])]
+                [a6 (bits [a17 signed 17] [_ signed 15])]
+                [a7 (bits [_ signed 14] [a18 signed 18])]
+                [a8 (bits [a19 signed 19] [_ signed 13])]
+                [a9 (bits [_ signed 12] [a20 signed 20])]
+                [a10 (bits [a21 signed 21] [_ signed 11])]
+                [a11 (bits [_ signed 10] [a22 signed 22])]
+                [a12 (bits [a23 signed 23] [_ signed 9])]
+                [a13 (bits [_ signed 8] [a24 signed 24])]
+                [a14 (bits [a25 signed 25] [_ signed 7])]
+                [a15 (bits [_ signed 6] [a26 signed 26])]
+                [a16 (bits [a27 signed 27] [_ signed 5])]
+                [a17 (bits [_ signed 4] [a28 signed 28])]
+                [a18 (bits [a29 signed 29] [_ signed 3])]
+                [a19 (bits [_ signed 2] [a30 signed 30])]
+                [a20 (bits [a31 signed 31] [_ signed 1])]
+                [a21 (bits [a32 signed 32])])]
+          [a3 (struct
+                [a1 (bits
+                      [_ unsigned 4]
+                      [a1 unsigned 1]
+                      [a2 unsigned 2]
+                      [a3 unsigned 3]
+                      [a4 unsigned 4]
+                      [a5 unsigned 5]
+                      [a6 unsigned 6]
+                      [a7 unsigned 7])]
+                [a2 (bits
+                      [_ unsigned 5]
+                      [a8 unsigned 8]
+                      [a9 unsigned 9]
+                      [a10 unsigned 10])]
+                [a3 (bits
+                      [a11 unsigned 11]
+                      [a12 unsigned 12]
+                      [_ unsigned 9])]
+                [a4 (bits
+                      [a13 unsigned 13]
+                      [_ unsigned 5]
+                      [a14 unsigned 14])]
+                [a5 (bits
+                      [_ unsigned 1]
+                      [a15 unsigned 15]
+                      [a16 unsigned 16])]
+                [a6 (bits [a17 unsigned 17] [_ unsigned 15])]
+                [a7 (bits [_ unsigned 14] [a18 unsigned 18])]
+                [a8 (bits [a19 unsigned 19] [_ unsigned 13])]
+                [a9 (bits [_ unsigned 12] [a20 unsigned 20])]
+                [a10 (bits [a21 unsigned 21] [_ unsigned 11])]
+                [a11 (bits [_ unsigned 10] [a22 unsigned 22])]
+                [a12 (bits [a23 unsigned 23] [_ unsigned 9])]
+                [a13 (bits [_ unsigned 8] [a24 unsigned 24])]
+                [a14 (bits [a25 unsigned 25] [_ unsigned 7])]
+                [a15 (bits [_ unsigned 6] [a26 unsigned 26])]
+                [a16 (bits [a27 unsigned 27] [_ unsigned 5])]
+                [a17 (bits [_ unsigned 4] [a28 unsigned 28])]
+                [a18 (bits [a29 unsigned 29] [_ unsigned 3])]
+                [a19 (bits [_ unsigned 2] [a30 unsigned 30])]
+                [a20 (bits [a31 unsigned 31] [_ unsigned 1])]
+                [a21 (bits [a32 unsigned 32])])])))
+    (define x (make-ftype-pointer Abits (foreign-alloc (ftype-sizeof Abits))))
+    (define (get-a1)
+      (list
+        (ftype-ref Abits (a1 a1) x)
+        (ftype-ref Abits (a1 a2) x)
+        (ftype-ref Abits (a1 a3) x)
+        (ftype-ref Abits (a1 a4) x)
+        (ftype-ref Abits (a1 a5) x)
+        (ftype-ref Abits (a1 a6) x)
+        (ftype-ref Abits (a1 a7) x)
+        (ftype-ref Abits (a1 a8) x)
+        (ftype-ref Abits (a1 a9) x)
+        (ftype-ref Abits (a1 a10) x)
+        (ftype-ref Abits (a1 a11) x)
+        (ftype-ref Abits (a1 a12) x)
+        (ftype-ref Abits (a1 a13) x)
+        (ftype-ref Abits (a1 a14) x)
+        (ftype-ref Abits (a1 a15) x)
+        (ftype-ref Abits (a1 a16) x)
+        (ftype-ref Abits (a1 a17) x)
+        (ftype-ref Abits (a1 a18) x)
+        (ftype-ref Abits (a1 a19) x)
+        (ftype-ref Abits (a1 a20) x)
+        (ftype-ref Abits (a1 a21) x)))
+    (define (get-a2)
+      (list
+        (ftype-ref Abits (a2 a1 a1) x)
+        (ftype-ref Abits (a2 a1 a2) x)
+        (ftype-ref Abits (a2 a1 a3) x)
+        (ftype-ref Abits (a2 a1 a4) x)
+        (ftype-ref Abits (a2 a1 a5) x)
+        (ftype-ref Abits (a2 a1 a6) x)
+        (ftype-ref Abits (a2 a1 a7) x)
+        (ftype-ref Abits (a2 a2 a8) x)
+        (ftype-ref Abits (a2 a2 a9) x)
+        (ftype-ref Abits (a2 a2 a10) x)
+        (ftype-ref Abits (a2 a3 a11) x)
+        (ftype-ref Abits (a2 a3 a12) x)
+        (ftype-ref Abits (a2 a4 a13) x)
+        (ftype-ref Abits (a2 a4 a14) x)
+        (ftype-ref Abits (a2 a5 a15) x)
+        (ftype-ref Abits (a2 a5 a16) x)
+        (ftype-ref Abits (a2 a6 a17) x)
+        (ftype-ref Abits (a2 a7 a18) x)
+        (ftype-ref Abits (a2 a8 a19) x)
+        (ftype-ref Abits (a2 a9 a20) x)
+        (ftype-ref Abits (a2 a10 a21) x)
+        (ftype-ref Abits (a2 a11 a22) x)
+        (ftype-ref Abits (a2 a12 a23) x)
+        (ftype-ref Abits (a2 a13 a24) x)
+        (ftype-ref Abits (a2 a14 a25) x)
+        (ftype-ref Abits (a2 a15 a26) x)
+        (ftype-ref Abits (a2 a16 a27) x)
+        (ftype-ref Abits (a2 a17 a28) x)
+        (ftype-ref Abits (a2 a18 a29) x)
+        (ftype-ref Abits (a2 a19 a30) x)
+        (ftype-ref Abits (a2 a20 a31) x)
+        (ftype-ref Abits (a2 a21 a32) x)))
+    (define (get-a3)
+      (list
+        (ftype-ref Abits (a3 a1 a1) x)
+        (ftype-ref Abits (a3 a1 a2) x)
+        (ftype-ref Abits (a3 a1 a3) x)
+        (ftype-ref Abits (a3 a1 a4) x)
+        (ftype-ref Abits (a3 a1 a5) x)
+        (ftype-ref Abits (a3 a1 a6) x)
+        (ftype-ref Abits (a3 a1 a7) x)
+        (ftype-ref Abits (a3 a2 a8) x)
+        (ftype-ref Abits (a3 a2 a9) x)
+        (ftype-ref Abits (a3 a2 a10) x)
+        (ftype-ref Abits (a3 a3 a11) x)
+        (ftype-ref Abits (a3 a3 a12) x)
+        (ftype-ref Abits (a3 a4 a13) x)
+        (ftype-ref Abits (a3 a4 a14) x)
+        (ftype-ref Abits (a3 a5 a15) x)
+        (ftype-ref Abits (a3 a5 a16) x)
+        (ftype-ref Abits (a3 a6 a17) x)
+        (ftype-ref Abits (a3 a7 a18) x)
+        (ftype-ref Abits (a3 a8 a19) x)
+        (ftype-ref Abits (a3 a9 a20) x)
+        (ftype-ref Abits (a3 a10 a21) x)
+        (ftype-ref Abits (a3 a11 a22) x)
+        (ftype-ref Abits (a3 a12 a23) x)
+        (ftype-ref Abits (a3 a13 a24) x)
+        (ftype-ref Abits (a3 a14 a25) x)
+        (ftype-ref Abits (a3 a15 a26) x)
+        (ftype-ref Abits (a3 a16 a27) x)
+        (ftype-ref Abits (a3 a17 a28) x)
+        (ftype-ref Abits (a3 a18 a29) x)
+        (ftype-ref Abits (a3 a19 a30) x)
+        (ftype-ref Abits (a3 a20 a31) x)
+        (ftype-ref Abits (a3 a21 a32) x)))
+    (define (set-a1! ls)
+      (map
+        (lambda (f v) (f v))
+        (list
+          (lambda (v) (ftype-set! Abits (a1 a1) x v))
+          (lambda (v) (ftype-set! Abits (a1 a2) x v))
+          (lambda (v) (ftype-set! Abits (a1 a3) x v))
+          (lambda (v) (ftype-set! Abits (a1 a4) x v))
+          (lambda (v) (ftype-set! Abits (a1 a5) x v))
+          (lambda (v) (ftype-set! Abits (a1 a6) x v))
+          (lambda (v) (ftype-set! Abits (a1 a7) x v))
+          (lambda (v) (ftype-set! Abits (a1 a8) x v))
+          (lambda (v) (ftype-set! Abits (a1 a9) x v))
+          (lambda (v) (ftype-set! Abits (a1 a10) x v))
+          (lambda (v) (ftype-set! Abits (a1 a11) x v))
+          (lambda (v) (ftype-set! Abits (a1 a12) x v))
+          (lambda (v) (ftype-set! Abits (a1 a13) x v))
+          (lambda (v) (ftype-set! Abits (a1 a14) x v))
+          (lambda (v) (ftype-set! Abits (a1 a15) x v))
+          (lambda (v) (ftype-set! Abits (a1 a16) x v))
+          (lambda (v) (ftype-set! Abits (a1 a17) x v))
+          (lambda (v) (ftype-set! Abits (a1 a18) x v))
+          (lambda (v) (ftype-set! Abits (a1 a19) x v))
+          (lambda (v) (ftype-set! Abits (a1 a20) x v))
+          (lambda (v) (ftype-set! Abits (a1 a21) x v)))
+        ls))
+    (define (set-a2! ls)
+      (map
+        (lambda (f v) (f v))
+        (list
+          (lambda (v) (ftype-set! Abits (a2 a1 a1) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a2) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a3) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a4) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a5) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a6) x v))
+          (lambda (v) (ftype-set! Abits (a2 a1 a7) x v))
+          (lambda (v) (ftype-set! Abits (a2 a2 a8) x v))
+          (lambda (v) (ftype-set! Abits (a2 a2 a9) x v))
+          (lambda (v) (ftype-set! Abits (a2 a2 a10) x v))
+          (lambda (v) (ftype-set! Abits (a2 a3 a11) x v))
+          (lambda (v) (ftype-set! Abits (a2 a3 a12) x v))
+          (lambda (v) (ftype-set! Abits (a2 a4 a13) x v))
+          (lambda (v) (ftype-set! Abits (a2 a4 a14) x v))
+          (lambda (v) (ftype-set! Abits (a2 a5 a15) x v))
+          (lambda (v) (ftype-set! Abits (a2 a5 a16) x v))
+          (lambda (v) (ftype-set! Abits (a2 a6 a17) x v))
+          (lambda (v) (ftype-set! Abits (a2 a7 a18) x v))
+          (lambda (v) (ftype-set! Abits (a2 a8 a19) x v))
+          (lambda (v) (ftype-set! Abits (a2 a9 a20) x v))
+          (lambda (v) (ftype-set! Abits (a2 a10 a21) x v))
+          (lambda (v) (ftype-set! Abits (a2 a11 a22) x v))
+          (lambda (v) (ftype-set! Abits (a2 a12 a23) x v))
+          (lambda (v) (ftype-set! Abits (a2 a13 a24) x v))
+          (lambda (v) (ftype-set! Abits (a2 a14 a25) x v))
+          (lambda (v) (ftype-set! Abits (a2 a15 a26) x v))
+          (lambda (v) (ftype-set! Abits (a2 a16 a27) x v))
+          (lambda (v) (ftype-set! Abits (a2 a17 a28) x v))
+          (lambda (v) (ftype-set! Abits (a2 a18 a29) x v))
+          (lambda (v) (ftype-set! Abits (a2 a19 a30) x v))
+          (lambda (v) (ftype-set! Abits (a2 a20 a31) x v))
+          (lambda (v) (ftype-set! Abits (a2 a21 a32) x v)))
+        ls))
+    (define (set-a3! ls)
+      (map
+        (lambda (f v) (f v))
+        (list
+          (lambda (v) (ftype-set! Abits (a3 a1 a1) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a2) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a3) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a4) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a5) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a6) x v))
+          (lambda (v) (ftype-set! Abits (a3 a1 a7) x v))
+          (lambda (v) (ftype-set! Abits (a3 a2 a8) x v))
+          (lambda (v) (ftype-set! Abits (a3 a2 a9) x v))
+          (lambda (v) (ftype-set! Abits (a3 a2 a10) x v))
+          (lambda (v) (ftype-set! Abits (a3 a3 a11) x v))
+          (lambda (v) (ftype-set! Abits (a3 a3 a12) x v))
+          (lambda (v) (ftype-set! Abits (a3 a4 a13) x v))
+          (lambda (v) (ftype-set! Abits (a3 a4 a14) x v))
+          (lambda (v) (ftype-set! Abits (a3 a5 a15) x v))
+          (lambda (v) (ftype-set! Abits (a3 a5 a16) x v))
+          (lambda (v) (ftype-set! Abits (a3 a6 a17) x v))
+          (lambda (v) (ftype-set! Abits (a3 a7 a18) x v))
+          (lambda (v) (ftype-set! Abits (a3 a8 a19) x v))
+          (lambda (v) (ftype-set! Abits (a3 a9 a20) x v))
+          (lambda (v) (ftype-set! Abits (a3 a10 a21) x v))
+          (lambda (v) (ftype-set! Abits (a3 a11 a22) x v))
+          (lambda (v) (ftype-set! Abits (a3 a12 a23) x v))
+          (lambda (v) (ftype-set! Abits (a3 a13 a24) x v))
+          (lambda (v) (ftype-set! Abits (a3 a14 a25) x v))
+          (lambda (v) (ftype-set! Abits (a3 a15 a26) x v))
+          (lambda (v) (ftype-set! Abits (a3 a16 a27) x v))
+          (lambda (v) (ftype-set! Abits (a3 a17 a28) x v))
+          (lambda (v) (ftype-set! Abits (a3 a18 a29) x v))
+          (lambda (v) (ftype-set! Abits (a3 a19 a30) x v))
+          (lambda (v) (ftype-set! Abits (a3 a20 a31) x v))
+          (lambda (v) (ftype-set! Abits (a3 a21 a32) x v)))
+        ls))
+    (define a3-c7c7c7c7
+      '(#b0
+        #b11
+        #b111
+        #b0001
+        #b11110
+        #b001111
+        #b1000111
+        #b11111000
+        #b111110001
+        #b1111000111
+        #b11000111110
+        #b001111100011
+        #b1100011111000
+        #b00011111000111
+        #b100011111000111
+        #b1100011111000111
+        #b11000111110001111
+        #b111100011111000111
+        #b1100011111000111110
+        #b01111100011111000111
+        #b110001111100011111000
+        #b0001111100011111000111
+        #b11000111110001111100011
+        #b110001111100011111000111
+        #b1100011111000111110001111
+        #b11110001111100011111000111
+        #b110001111100011111000111110
+        #b0111110001111100011111000111
+        #b11000111110001111100011111000
+        #b000111110001111100011111000111
+        #b1100011111000111110001111100011
+        #b11000111110001111100011111000111))
+    (define a3-13579bdf
+      '(#b0
+        #b01
+        #b101
+        #b0101
+        #b11100
+        #b110111
+        #b1011111
+        #b01101010
+        #b111100110
+        #b1111011111
+        #b00010011010
+        #b101111001101
+        #b0001001101010
+        #b01101111011111
+        #b001001101010111
+        #b1001101111011111
+        #b00010011010101111
+        #b111001101111011111
+        #b0001001101010111100
+        #b01111001101111011111
+        #b000100110101011110011
+        #b0101111001101111011111
+        #b00010011010101111001101
+        #b010101111001101111011111
+        #b0001001101010111100110111
+        #b11010101111001101111011111
+        #b000100110101011110011011110
+        #b0011010101111001101111011111
+        #b00010011010101111001101111011
+        #b010011010101111001101111011111
+        #b0001001101010111100110111101111
+        #b00010011010101111001101111011111))
+    (define a2-from-a3
+      (lambda (ls)
+        (map (lambda (i n)
+               (let* ([radix/2 (expt 2 i)])
+                 (if (>= n radix/2)
+                     (- n (ash radix/2 1))
+                     n)))
+          (enumerate ls) ls)))
+    #t)
+  (begin
+    (set-a1! (make-list 21 0))
+    #t)
+  (equal?
+    (get-a2)
+    (make-list 32 0))
+  (equal?
+    (get-a3)
+    (make-list 32 0))
+  (begin
+    (set-a1! (make-list 21 #xffffffff))
+    #t)
+  (equal?
+    (get-a2)
+    (make-list 32 -1))
+  (equal?
+    (get-a3)
+    (do ([n 32 (fx- n 1)]
+         [ls '() (cons (- (expt 2 n) 1) ls)])
+      ((= n 0) ls)))
+  (begin
+    (set-a1! (make-list 21 #xc7c7c7c7))
+    #t)
+  (equal?
+    (get-a3)
+    a3-c7c7c7c7)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-c7c7c7c7))
+  (begin
+    (ftype-set! Abits (a1 a1) x #x13579bdf)
+    (ftype-set! Abits (a1 a2) x #x13579bdf)
+    (ftype-set! Abits (a1 a3) x #x13579bdf)
+    (ftype-set! Abits (a1 a4) x #x13579bdf)
+    (ftype-set! Abits (a1 a5) x #x13579bdf)
+    (ftype-set! Abits (a1 a6) x #x13579bdf)
+    (ftype-set! Abits (a1 a7) x #x13579bdf)
+    (ftype-set! Abits (a1 a8) x #x13579bdf)
+    (ftype-set! Abits (a1 a9) x #x13579bdf)
+    (ftype-set! Abits (a1 a10) x #x13579bdf)
+    (ftype-set! Abits (a1 a11) x #x13579bdf)
+    (ftype-set! Abits (a1 a12) x #x13579bdf)
+    (ftype-set! Abits (a1 a13) x #x13579bdf)
+    (ftype-set! Abits (a1 a14) x #x13579bdf)
+    (ftype-set! Abits (a1 a15) x #x13579bdf)
+    (ftype-set! Abits (a1 a16) x #x13579bdf)
+    (ftype-set! Abits (a1 a17) x #x13579bdf)
+    (ftype-set! Abits (a1 a18) x #x13579bdf)
+    (ftype-set! Abits (a1 a19) x #x13579bdf)
+    (ftype-set! Abits (a1 a20) x #x13579bdf)
+    (ftype-set! Abits (a1 a21) x #x13579bdf)
+    #t)
+  (equal?
+    (get-a3)
+    a3-13579bdf)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-13579bdf))
+  (begin
+    (set-a1! (make-list 21 0))
+    (set-a3! a3-c7c7c7c7)
+    #t)
+  (equal?
+    (get-a3)
+    a3-c7c7c7c7)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-c7c7c7c7))
+  (equal?
+    (get-a1)
+    '(#x07c7c7c7
+      #x07c7c7c7
+      #xc7c7c600
+      #xc7c007c7
+      #x47c7c7c7
+      #xc7c78000
+      #x0003c7c7
+      #xc7c7c000
+      #x0007c7c7
+      #xc7c7c000
+      #x0007c7c7
+      #xc7c7c600
+      #x00c7c7c7
+      #xc7c7c780
+      #x03c7c7c7
+      #xc7c7c7c0
+      #x07c7c7c7
+      #xc7c7c7c0
+      #x07c7c7c7
+      #xc7c7c7c6
+      #xc7c7c7c7))
+  (begin
+    (set-a1! (make-list 21 0))
+    (set-a2! (a2-from-a3 a3-13579bdf))
+    #t)
+  (equal?
+    (get-a3)
+    a3-13579bdf)
+  (equal?
+    (get-a2)
+    (a2-from-a3 a3-13579bdf))
+  (equal?
+    (get-a1)
+    '(#x03579bdf
+      #x03579bdf
+      #x13579a00
+      #x13501bdf
+      #x13579bdf
+      #x13578000
+      #x00039bdf
+      #x13578000
+      #x00079bdf
+      #x13579800
+      #x00179bdf
+      #x13579a00
+      #x00579bdf
+      #x13579b80
+      #x03579bdf
+      #x13579bc0
+      #x03579bdf
+      #x13579bd8
+      #x13579bdf
+      #x13579bde
+      #x13579bdf))
+
+  (begin
+    (fptr-free x)
+    #t)
+)
+
+(mat ftype-inspection
+  (begin
+    (define-ftype Qa
+      (struct
+        [x short]
+        [y long]))
+    (define-ftype Q
+      (struct
+        [x (packed integer-32)]
+        [y double-float]
+        [z (array 4 (struct [_ integer-16] [b integer-16]))]
+        [w (endian big
+             (union
+               [a integer-32]
+               [b unsigned-32]))]
+        [v (* Qa)]
+        [u (array 3 float)]
+        [t char]
+        [s (endian little
+             (array 2
+               (bits
+                 [x unsigned 3]
+                 [y signed 4]
+                 [_ unsigned 17]
+                 [z unsigned 8])))]))
+    (define q (make-ftype-pointer Q (foreign-alloc (ftype-sizeof Q))))
+    (ftype-set! Q (x) q -73)
+    (ftype-set! Q (y) q 3.25)
+    (ftype-set! Q (z 0 b) q 11)
+    (ftype-set! Q (z 1 b) q -15)
+    (ftype-set! Q (z 2 b) q 53)
+    (ftype-set! Q (z 3 b) q -71)
+    (ftype-set! Q (w a) q -1)
+    (ftype-set! Q (v) q (make-ftype-pointer Qa (foreign-alloc (ftype-sizeof Qa))))
+    (ftype-set! Q (v * x) q 7)
+    (ftype-set! Q (v * y) q -503)
+    (ftype-set! Q (u 0) q 1.0)
+    (ftype-set! Q (u 1) q 2.0)
+    (ftype-set! Q (u 2) q 3.0)
+    (ftype-set! Q (t) q #\$)
+    (ftype-set! Q (s 0 x) q 5)
+    (ftype-set! Q (s 0 y) q -2)
+    (ftype-set! Q (s 0 z) q 225)
+    (ftype-set! Q (s 1 x) q 2)
+    (ftype-set! Q (s 1 y) q 7)
+    (ftype-set! Q (s 1 z) q 47)
+    #t)
+
+  (equal?
+    (ftype-pointer-ftype q)
+    '(struct
+       [x (packed integer-32)]
+       [y double-float]
+       [z (array 4 (struct [_ integer-16] [b integer-16]))]
+       [w (endian big
+            (union
+              [a integer-32]
+              [b unsigned-32]))]
+       [v (* Qa)]
+       [u (array 3 float)]
+       [t char]
+       [s (endian little
+            (array 2
+              (bits
+                [x unsigned 3]
+                [y signed 4]
+                [_ unsigned 17]
+                [z unsigned 8])))]))
+
+  (eq? ; verify sharing in internal type field
+    (ftype-pointer-ftype (ftype-&ref Q (s) q))
+    (cadr (list-ref (ftype-pointer-ftype q) 8)))
+
+  (equal?
+    (ftype-pointer->sexpr q)
+    '(struct
+       [x -73]
+       [y 3.25]
+       [z (array 4
+            (struct [_ _] [b 11])
+            (struct [_ _] [b -15])
+            (struct [_ _] [b 53])
+            (struct [_ _] [b -71]))]
+       [w (union [a -1] [b #xffffffff])]
+       [v (* (struct [x 7] [y -503]))]
+       [u (array 3 1.0 2.0 3.0)]
+       [t #\$]
+       [s (array 2
+            (bits [x 5] [y -2] [_ _] [z 225])
+            (bits [x 2] [y 7] [_ _] [z 47]))]))
+
+  (begin
+    (fptr-free q)
+    #t)
+
+ ; ----------------
+
+  (begin
+    (define-ftype big-wchar (endian big wchar))
+    (define-ftype little-wchar (endian little wchar))
+    (define-ftype Q
+      (struct
+        [a (array 10 char)]
+        [b (array 10 wchar)]
+        [c (endian big (array 10 wchar))]
+        [d (endian little (array 10 wchar))]
+        [e (* char)]
+        [f (* wchar)]
+        [g (* big-wchar)]
+        [h (* little-wchar)]
+        [i (* char)]
+        [j (* wchar)]))
+    (define q (make-ftype-pointer Q (foreign-alloc (ftype-sizeof Q))))
+
+    (define-syntax ftype-set-char-array!
+      (syntax-rules ()
+        [(_ maxlen ftype (a ...) fptr str)
+         (let ([len (min (string-length str) maxlen)])
+           (do ([i 0 (fx+ i 1)])
+               ((fx= i len))
+             (ftype-set! ftype (a ... i) fptr (string-ref str i)))
+           (when (< len maxlen) (ftype-set! ftype (a ... len) fptr #\nul)))]))
+
+    (ftype-set-char-array! 10 Q (a) q "abcd")
+    (ftype-set-char-array! 10 Q (b) q "abcdefghijklmnop")
+    (ftype-set-char-array! 10 Q (c) q "ABCDEFGHIJKLMNOP")
+    (ftype-set-char-array! 10 Q (d) q "ABCDEFG")
+    
+    (define-syntax ftype-set-string!
+      (syntax-rules ()
+        [(_ char ftype (a ...) fptr str p)
+         (let ([len (string-length str)])
+           (set! p (make-ftype-pointer char (foreign-alloc (fx* (ftype-sizeof char) (fx+ len 1)))))
+           (do ([i 0 (fx+ i 1)])
+             ((fx= i len))
+             (ftype-set! char () p i (string-ref str i)))
+           (ftype-set! char () p len #\nul)
+           (ftype-set! ftype (a ...) fptr p))]))
+
+    (ftype-set-string! char Q (e) q "hello!" q-e)
+    (ftype-set-string! wchar Q (f) q "Hello!" q-f)
+    (ftype-set-string! big-wchar Q (g) q "HELLO!" q-g)
+    (ftype-set-string! little-wchar Q (h) q "GoodBye" q-h)
+
+    (ftype-set! Q (i) q (make-ftype-pointer char 0))
+    (ftype-set! Q (j) q (make-ftype-pointer wchar 1))
+
+    #t)
+
+  (if (memq (machine-type) '(ti3ob ta6ob)) ; avoid openbsd/pthreads signal bugs
+      (error #f "openbsd pthreads + signals is fubar")
+      (equal?
+        (ftype-pointer->sexpr q)
+        '(struct
+           [a "abcd"]
+           [b "abcdefghij"]
+           [c "ABCDEFGHIJ"]
+           [d "ABCDEFG"]
+           [e "hello!"]
+           [f "Hello!"]
+           [g "HELLO!"]
+           [h "GoodBye"]
+           [i null]
+           [j (* invalid)])))
+
+  (if (memq (machine-type) '(ti3ob ta6ob)) ; avoid openbsd/pthreads signal bugs
+      (error #f "openbsd pthreads + signals is fubar")
+      (equal?
+        (ftype-pointer->sexpr (make-ftype-pointer Q 0))
+        '(struct
+           [a (array 10 invalid)]
+           [b (array 10 invalid)]
+           [c (array 10 invalid)]
+           [d (array 10 invalid)]
+           [e invalid]
+           [f invalid]
+           [g invalid]
+           [h invalid]
+           [i invalid]
+           [j invalid])))
+
+  (begin
+    (fptr-free q-e)
+    (fptr-free q-f)
+    (fptr-free q-g)
+    (fptr-free q-h)
+    (fptr-free q)
+    #t)
+
+ ; ----------------
+
+  (begin
+    (define-ftype A (endian little double))
+    (define-ftype B (endian big double))
+    #t)
+
+  (equal?
+    (ftype-pointer-ftype (make-ftype-pointer A 0))
+    (case (native-endianness)
+      [(big) '(endian little double)]
+      [(little) 'double]
+      [else (errorf #f "unexpected native endianness")]))
+
+  (equal?
+    (ftype-pointer-ftype (make-ftype-pointer B 0))
+    (case (native-endianness)
+      [(big) 'double]
+      [(little) '(endian big double)]
+      [else (errorf #f "unexpected native endianness")]))
+
+  (begin
+    (define-ftype A (endian little char))
+    (define-ftype B (endian big char))
+    #t)
+
+  (eq? (ftype-pointer-ftype (make-ftype-pointer A 0)) 'char)
+  (eq? (ftype-pointer-ftype (make-ftype-pointer B 0)) 'char)
+)
+
+(mat discarded-refs
+  (begin
+    (define-ftype A
+      (endian big
+        (struct
+          [a1 double]
+          [a2 float]
+          [a3 long-long]
+          [a4 unsigned-long-long]
+          [a5 long]
+          [a6 unsigned-long]
+          [a7 int]
+          [a8 unsigned]
+          [a9 unsigned-int]
+          [a10 short]
+          [a11 unsigned-short]
+          [a12 wchar]
+          [a13 char]
+          [a14 boolean]
+          [a15 fixnum]
+          [a16 iptr]
+          [a17 uptr]
+          [a18 void*])))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x)
+           (ftype-ref A (a1) x)
+           (ftype-ref A (a2) x)
+           (ftype-ref A (a3) x)
+           (ftype-ref A (a4) x)
+           (ftype-ref A (a5) x)
+           (ftype-ref A (a6) x)
+           (ftype-ref A (a7) x)
+           (ftype-ref A (a8) x)
+           (ftype-ref A (a9) x)
+           (ftype-ref A (a10) x)
+           (ftype-ref A (a11) x)
+           (ftype-ref A (a12) x)
+           (ftype-ref A (a13) x)
+           (ftype-ref A (a14) x)
+           (ftype-ref A (a15) x)
+           (ftype-ref A (a16) x)
+           (ftype-ref A (a17) x)
+           (ftype-ref A (a18) x)
+           x)))
+    '(lambda (x) x))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x)
+           (ftype-&ref A (a1) x)
+           (ftype-&ref A (a2) x)
+           (ftype-&ref A (a3) x)
+           (ftype-&ref A (a4) x)
+           (ftype-&ref A (a5) x)
+           (ftype-&ref A (a6) x)
+           (ftype-&ref A (a7) x)
+           (ftype-&ref A (a8) x)
+           (ftype-&ref A (a9) x)
+           (ftype-&ref A (a10) x)
+           (ftype-&ref A (a11) x)
+           (ftype-&ref A (a12) x)
+           (ftype-&ref A (a13) x)
+           (ftype-&ref A (a14) x)
+           (ftype-&ref A (a15) x)
+           (ftype-&ref A (a16) x)
+           (ftype-&ref A (a17) x)
+           (ftype-&ref A (a18) x)
+           x)))
+    '(lambda (x) x))
+  (begin
+    (define-ftype A
+      (endian little
+        (struct
+          [a1 double]
+          [a2 float]
+          [a3 long-long]
+          [a4 unsigned-long-long]
+          [a5 long]
+          [a6 unsigned-long]
+          [a7 int]
+          [a8 unsigned]
+          [a9 unsigned-int]
+          [a10 short]
+          [a11 unsigned-short]
+          [a12 wchar]
+          [a13 char]
+          [a14 boolean]
+          [a15 fixnum]
+          [a16 iptr]
+          [a17 uptr]
+          [a18 void*])))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x)
+           (ftype-ref A (a1) x)
+           (ftype-ref A (a2) x)
+           (ftype-ref A (a3) x)
+           (ftype-ref A (a4) x)
+           (ftype-ref A (a5) x)
+           (ftype-ref A (a6) x)
+           (ftype-ref A (a7) x)
+           (ftype-ref A (a8) x)
+           (ftype-ref A (a9) x)
+           (ftype-ref A (a10) x)
+           (ftype-ref A (a11) x)
+           (ftype-ref A (a12) x)
+           (ftype-ref A (a13) x)
+           (ftype-ref A (a14) x)
+           (ftype-ref A (a15) x)
+           (ftype-ref A (a16) x)
+           (ftype-ref A (a17) x)
+           (ftype-ref A (a18) x)
+           x)))
+    '(lambda (x) x))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x)
+           (ftype-&ref A (a1) x)
+           (ftype-&ref A (a2) x)
+           (ftype-&ref A (a3) x)
+           (ftype-&ref A (a4) x)
+           (ftype-&ref A (a5) x)
+           (ftype-&ref A (a6) x)
+           (ftype-&ref A (a7) x)
+           (ftype-&ref A (a8) x)
+           (ftype-&ref A (a9) x)
+           (ftype-&ref A (a10) x)
+           (ftype-&ref A (a11) x)
+           (ftype-&ref A (a12) x)
+           (ftype-&ref A (a13) x)
+           (ftype-&ref A (a14) x)
+           (ftype-&ref A (a15) x)
+           (ftype-&ref A (a16) x)
+           (ftype-&ref A (a17) x)
+           (ftype-&ref A (a18) x)
+           x)))
+    '(lambda (x) x))
+  (begin
+    (define-ftype A
+      (endian big
+        (union
+          [a1 (struct
+                [a1 unsigned-16]
+                [a2 unsigned-8]
+                [a3 unsigned-64]
+                [a4 unsigned-32])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 1]
+                      [a2 signed 15])]
+                [a2 (bits
+                      [a1 signed 3]
+                      [a2 signed 5])]
+                [a3 (bits
+                      [a1 signed 50]
+                      [a2 signed 14])]
+                [a4 (bits
+                      [a1 signed 19]
+                      [a2 signed 13])])]
+          [a3 (struct
+                [a1 (bits
+                      [a1 unsigned 1]
+                      [a2 unsigned 15])]
+                [a2 (bits
+                      [a1 unsigned 3]
+                      [a2 unsigned 5])]
+                [a3 (bits
+                      [a1 unsigned 50]
+                      [a2 unsigned 14])]
+                [a4 (bits
+                      [a1 unsigned 19]
+                      [a2 unsigned 13])])])))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x)
+           (ftype-ref A (a1 a1) x)
+           (ftype-ref A (a1 a2) x)
+           (ftype-ref A (a1 a3) x)
+           (ftype-ref A (a1 a4) x)
+           (ftype-ref A (a2 a1 a1) x)
+           (ftype-ref A (a2 a1 a2) x)
+           (ftype-ref A (a2 a2 a1) x)
+           (ftype-ref A (a2 a2 a2) x)
+           (ftype-ref A (a2 a3 a1) x)
+           (ftype-ref A (a2 a3 a2) x)
+           (ftype-ref A (a2 a4 a1) x)
+           (ftype-ref A (a2 a4 a2) x)
+           (ftype-ref A (a3 a1 a1) x)
+           (ftype-ref A (a3 a1 a2) x)
+           (ftype-ref A (a3 a2 a1) x)
+           (ftype-ref A (a3 a2 a2) x)
+           (ftype-ref A (a3 a3 a1) x)
+           (ftype-ref A (a3 a3 a2) x)
+           (ftype-ref A (a3 a4 a1) x)
+           (ftype-ref A (a3 a4 a2) x)
+           x)))
+    '(lambda (x) x))
+  (begin
+    (define-ftype A
+      (endian little
+        (union
+          [a1 (struct
+                [a1 unsigned-16]
+                [a2 unsigned-8]
+                [a3 unsigned-64]
+                [a4 unsigned-32])]
+          [a2 (struct
+                [a1 (bits
+                      [a1 signed 1]
+                      [a2 signed 15])]
+                [a2 (bits
+                      [a1 signed 3]
+                      [a2 signed 5])]
+                [a3 (bits
+                      [a1 signed 50]
+                      [a2 signed 14])]
+                [a4 (bits
+                      [a1 signed 19]
+                      [a2 signed 13])])]
+          [a3 (struct
+                [a1 (bits
+                      [a1 unsigned 1]
+                      [a2 unsigned 15])]
+                [a2 (bits
+                      [a1 unsigned 3]
+                      [a2 unsigned 5])]
+                [a3 (bits
+                      [a1 unsigned 50]
+                      [a2 unsigned 14])]
+                [a4 (bits
+                      [a1 unsigned 19]
+                      [a2 unsigned 13])])])))
+    #t)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x)
+           (ftype-ref A (a1 a1) x)
+           (ftype-ref A (a1 a2) x)
+           (ftype-ref A (a1 a3) x)
+           (ftype-ref A (a1 a4) x)
+           (ftype-ref A (a2 a1 a1) x)
+           (ftype-ref A (a2 a1 a2) x)
+           (ftype-ref A (a2 a2 a1) x)
+           (ftype-ref A (a2 a2 a2) x)
+           (ftype-ref A (a2 a3 a1) x)
+           (ftype-ref A (a2 a3 a2) x)
+           (ftype-ref A (a2 a4 a1) x)
+           (ftype-ref A (a2 a4 a2) x)
+           (ftype-ref A (a3 a1 a1) x)
+           (ftype-ref A (a3 a1 a2) x)
+           (ftype-ref A (a3 a2 a1) x)
+           (ftype-ref A (a3 a2 a2) x)
+           (ftype-ref A (a3 a3 a1) x)
+           (ftype-ref A (a3 a3 a2) x)
+           (ftype-ref A (a3 a4 a1) x)
+           (ftype-ref A (a3 a4 a2) x)
+           x)))
+    '(lambda (x) x))
+)
diff --git a/mats/fx.ms b/mats/fx.ms
new file mode 100644
index 0000000..7654f50
--- /dev/null
+++ b/mats/fx.ms
@@ -0,0 +1,2906 @@
+;;; fx.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat fx=
+   (not (fx= 3 4))
+   (not (fx= 4 3))
+   (fx= 4 4)
+   (not (fx= -4 4))
+   (not (fx= 4 -4))
+   (not (fx= -4 -3))
+   (not (fx= -3 -4))
+   (fx= -4)
+   (fx= -4 -4)
+   (fx= -4 -4 -4)
+   (error? (fx= (list 'a)))
+   (error? (fx= (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx= (- (most-negative-fixnum) 1) 3))
+   (guard (c [#t #t]) (fx= 3 4 (error #f "oops")))
+   (guard (c [#t #t]) (fx= 3 (error #f "oops") 4))
+   (guard (c [#t #t]) (fx= (error #f "oops") 3 4))
+   (guard (c [#t #t]) (not (fx= (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx= -3 -7) #f)
+   (test-cp0-expansion eqv? '(fx= -3 0) #f)
+   (test-cp0-expansion eqv? '(fx= 0 -3) #f)
+   (test-cp0-expansion eqv? '(fx= 0 0) #t)
+   (test-cp0-expansion eqv? '(fx= -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx= 12 12) #t)
+   (test-cp0-expansion eqv? '(fx= -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx= -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx= 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx= 0 0 0) #t)
+   (test-cp0-expansion eqv? '(fx= -3 -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx= 12 12 12) #t)
+ )
+
+(mat fx<
+   (fx< 3 4)
+   (not (fx< 4 3))
+   (not (fx< 4 4))
+   (fx< -4 4)
+   (not (fx< 4 -4))
+   (fx< -4 -3)
+   (not (fx< -3 -4))
+   (not (fx< -4 -4))
+   (not (fx< -4 -4))
+   (not (fx< -4 -4 -4))
+   (error? (fx< 'a))
+   (error? (fx< (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx< (- (most-negative-fixnum) 1) 3))
+   (guard (c [#t #t]) (fx< 4 3 (error #f "oops")))
+   (guard (c [#t #t]) (fx< 4 (error #f "oops") 3))
+   (guard (c [#t #t]) (fx< (error #f "oops") 4 3))
+   (guard (c [#t #t]) (not (fx< (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx< -3 -7) #f)
+   (test-cp0-expansion eqv? '(fx< -3 0) #t)
+   (test-cp0-expansion eqv? '(fx< 0 -3) #f)
+   (test-cp0-expansion eqv? '(fx< 0 0) #f)
+   (test-cp0-expansion eqv? '(fx< -3 -3) #f)
+   (test-cp0-expansion eqv? '(fx< 12 12) #f)
+   (test-cp0-expansion eqv? '(fx< -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx< -3 -2 0) #t)
+   (test-cp0-expansion eqv? '(fx< -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx< 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx< 0 0 0) #f)
+   (test-cp0-expansion eqv? '(fx< -3 -3 -3) #f)
+   (test-cp0-expansion eqv? '(fx< 12 12 12) #f)
+ )
+
+(mat fx>
+   (not (fx> 3 4))
+   (fx> 4 3)
+   (not (fx> 4 4))
+   (not (fx> -4 4))
+   (fx> 4 -4)
+   (not (fx> -4 -3))
+   (fx> -3 -4)
+   (fx> -4)
+   (not (fx> -4 -4))
+   (not (fx> -4 -4 -4))
+   (error? (fx> "hi"))
+   (error? (fx> (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx> (- (most-negative-fixnum) 1) 3))
+   (guard (c [#t #t]) (fx> 3 4 (error #f "oops")))
+   (guard (c [#t #t]) (fx> 3 (error #f "oops") 4))
+   (guard (c [#t #t]) (fx> (error #f "oops") 3 4))
+   (guard (c [#t #t]) (not (fx> (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx> -3 -7) #t)
+   (test-cp0-expansion eqv? '(fx> -3 0) #f)
+   (test-cp0-expansion eqv? '(fx> 0 -3) #t)
+   (test-cp0-expansion eqv? '(fx> 0 0) #f)
+   (test-cp0-expansion eqv? '(fx> -3 -3) #f)
+   (test-cp0-expansion eqv? '(fx> 12 12) #f)
+   (test-cp0-expansion eqv? '(fx> -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx> -3 -2 0) #f)
+   (test-cp0-expansion eqv? '(fx> 0 -2 -3) #t)
+   (test-cp0-expansion eqv? '(fx> -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx> 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx> 0 0 0) #f)
+   (test-cp0-expansion eqv? '(fx> -3 -3 -3) #f)
+   (test-cp0-expansion eqv? '(fx> 12 12 12) #f)
+ )
+
+(mat fx<=
+   (fx<= 3 4)
+   (not (fx<= 4 3))
+   (fx<= 4 4)
+   (fx<= -4 4)
+   (not (fx<= 4 -4))
+   (fx<= -4 -3)
+   (not (fx<= -3 -4))
+   (fx<= -4)
+   (fx<= -4 -4)
+   (fx<= -4 -4 -4)
+   (error? (fx<= '(a . b)))
+   (error? (fx<= (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx<= (- (most-negative-fixnum) 1) 3))
+   (guard (c [#t #t]) (fx<= 4 3 (error #f "oops")))
+   (guard (c [#t #t]) (fx<= 4 (error #f "oops") 3))
+   (guard (c [#t #t]) (fx<= (error #f "oops") 4 3))
+   (guard (c [#t #t]) (not (fx<= (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx<= -3 -7) #f)
+   (test-cp0-expansion eqv? '(fx<= -3 0) #t)
+   (test-cp0-expansion eqv? '(fx<= 0 -3) #f)
+   (test-cp0-expansion eqv? '(fx<= 0 0) #t)
+   (test-cp0-expansion eqv? '(fx<= -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx<= 12 12) #t)
+   (test-cp0-expansion eqv? '(fx<= -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx<= -3 -2 0) #t)
+   (test-cp0-expansion eqv? '(fx<= 0 -2 -3) #f)
+   (test-cp0-expansion eqv? '(fx<= -3 -3 0) #t)
+   (test-cp0-expansion eqv? '(fx<= 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx<= 0 0 0) #t)
+   (test-cp0-expansion eqv? '(fx<= -3 -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx<= 12 12 12) #t)
+ )
+
+(mat fx>=
+   (not (fx>= 3 4))
+   (fx>= 4 3)
+   (fx>= 4 4)
+   (not (fx>= -4 4))
+   (fx>= 4 -4)
+   (not (fx>= -4 -3))
+   (fx>= -3 -4)
+   (fx>= -4)
+   (fx>= -4 -4)
+   (fx>= -4 -4 -4)
+   (error? (fx>= '(a . b)))
+   (error? (fx>= (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx>= (- (most-negative-fixnum) 1) 3))
+   (guard (c [#t #t]) (fx>= 3 4 (error #f "oops")))
+   (guard (c [#t #t]) (fx>= 3 (error #f "oops") 4))
+   (guard (c [#t #t]) (fx>= (error #f "oops") 3 4))
+   (guard (c [#t #t]) (not (fx<= (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx>= -3 -7) #t)
+   (test-cp0-expansion eqv? '(fx>= -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>= 0 -3) #t)
+   (test-cp0-expansion eqv? '(fx>= 0 0) #t)
+   (test-cp0-expansion eqv? '(fx>= -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx>= 12 12) #t)
+   (test-cp0-expansion eqv? '(fx>= -3 -7 -7) #t)
+   (test-cp0-expansion eqv? '(fx>= -3 -2 0) #f)
+   (test-cp0-expansion eqv? '(fx>= 0 -2 -3) #t)
+   (test-cp0-expansion eqv? '(fx>= -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>= 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>= 0 0 0) #t)
+   (test-cp0-expansion eqv? '(fx>= -3 -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx>= 12 12 12) #t)
+ )
+
+(mat fx=?
+   (not (fx=? 3 4))
+   (not (fx=? 4 3))
+   (fx=? 4 4)
+   (not (fx=? -4 4))
+   (not (fx=? 4 -4))
+   (not (fx=? -4 -3))
+   (not (fx=? -3 -4))
+   (fx=? -4 -4)
+   (fx=? -4 -4 -4)
+   (error? (fx=? (list 'a) 3))
+   (error? (fx=? (+ (greatest-fixnum) 1) 3 2))
+   (error? (fx=? (- (least-fixnum) 1) 3))
+   (error? (fx=? 1))
+   (fx=? (least-fixnum) (- (expt 2 (- (fixnum-width) 1))))
+   (fx=? (greatest-fixnum) (- (expt 2 (- (fixnum-width) 1)) 1))
+   (guard (c [#t #t]) (fx=? 3 4 (error #f "oops")))
+   (guard (c [#t #t]) (fx=? 3 (error #f "oops") 4))
+   (guard (c [#t #t]) (fx=? (error #f "oops") 3 4))
+   (guard (c [#t #t]) (not (fx=? (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx=? -3 -7) #f)
+   (test-cp0-expansion eqv? '(fx=? -3 0) #f)
+   (test-cp0-expansion eqv? '(fx=? 0 -3) #f)
+   (test-cp0-expansion eqv? '(fx=? 0 0) #t)
+   (test-cp0-expansion eqv? '(fx=? -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx=? 12 12) #t)
+   (test-cp0-expansion eqv? '(fx=? -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx=? -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx=? 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx=? 0 0 0) #t)
+   (test-cp0-expansion eqv? '(fx=? -3 -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx=? 12 12 12) #t)
+ )
+
+(mat fx?
+   (not (fx>? 3 4))
+   (fx>? 4 3)
+   (not (fx>? 4 4))
+   (not (fx>? -4 4))
+   (fx>? 4 -4)
+   (not (fx>? -4 -3))
+   (fx>? -3 -4)
+   (not (fx>? -4 -4))
+   (not (fx>? -4 -4 -4))
+   (error? (fx>? 3 "hi"))
+   (error? (fx>? (+ (greatest-fixnum) 1) 3 2))
+   (error? (fx>? (- (least-fixnum) 1) 3))
+   (error? (fx>? 1))
+   (guard (c [#t #t]) (fx>? 3 4 (error #f "oops")))
+   (guard (c [#t #t]) (fx>? 3 (error #f "oops") 4))
+   (guard (c [#t #t]) (fx>? (error #f "oops") 3 4))
+   (guard (c [#t #t]) (not (fx>? (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx>? -3 -7) #t)
+   (test-cp0-expansion eqv? '(fx>? -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>? 0 -3) #t)
+   (test-cp0-expansion eqv? '(fx>? 0 0) #f)
+   (test-cp0-expansion eqv? '(fx>? -3 -3) #f)
+   (test-cp0-expansion eqv? '(fx>? 12 12) #f)
+   (test-cp0-expansion eqv? '(fx>? -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx>? -3 -2 0) #f)
+   (test-cp0-expansion eqv? '(fx>? 0 -2 -3) #t)
+   (test-cp0-expansion eqv? '(fx>? -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>? 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>? 0 0 0) #f)
+   (test-cp0-expansion eqv? '(fx>? -3 -3 -3) #f)
+   (test-cp0-expansion eqv? '(fx>? 12 12 12) #f)
+ )
+
+(mat fx<=?
+   (fx<=? 3 4)
+   (not (fx<=? 4 3))
+   (fx<=? 4 4)
+   (fx<=? -4 4)
+   (not (fx<=? 4 -4))
+   (fx<=? -4 -3)
+   (not (fx<=? -3 -4))
+   (fx<=? -4 -4)
+   (fx<=? -4 -4 -4)
+   (error? (fx<=? 3 '(a . b)))
+   (error? (fx<=? (+ (greatest-fixnum) 1) 3 2))
+   (error? (fx<=? (- (least-fixnum) 1) 3))
+   (error? (fx<=? 1))
+   (guard (c [#t #t]) (fx<=? 4 3 (error #f "oops")))
+   (guard (c [#t #t]) (fx<=? 4 (error #f "oops") 3))
+   (guard (c [#t #t]) (fx<=? (error #f "oops") 4 3))
+   (guard (c [#t #t]) (not (fx<=? (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx<=? -3 -7) #f)
+   (test-cp0-expansion eqv? '(fx<=? -3 0) #t)
+   (test-cp0-expansion eqv? '(fx<=? 0 -3) #f)
+   (test-cp0-expansion eqv? '(fx<=? 0 0) #t)
+   (test-cp0-expansion eqv? '(fx<=? -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx<=? 12 12) #t)
+   (test-cp0-expansion eqv? '(fx<=? -3 -7 -7) #f)
+   (test-cp0-expansion eqv? '(fx<=? -3 -2 0) #t)
+   (test-cp0-expansion eqv? '(fx<=? 0 -2 -3) #f)
+   (test-cp0-expansion eqv? '(fx<=? -3 -3 0) #t)
+   (test-cp0-expansion eqv? '(fx<=? 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx<=? 0 0 0) #t)
+   (test-cp0-expansion eqv? '(fx<=? -3 -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx<=? 12 12 12) #t)
+ )
+
+(mat fx>=?
+   (not (fx>=? 3 4))
+   (fx>=? 4 3)
+   (fx>=? 4 4)
+   (not (fx>=? -4 4))
+   (fx>=? 4 -4)
+   (not (fx>=? -4 -3))
+   (fx>=? -3 -4)
+   (fx>=? -4 -4)
+   (fx>=? -4 -4 -4)
+   (error? (fx>=? 3 '(a . b)))
+   (error? (fx>=? (+ (greatest-fixnum) 1) 3 2))
+   (error? (fx>=? (- (least-fixnum) 1) 3))
+   (error? (fx>=? 1))
+   (guard (c [#t #t]) (fx>=? 3 4 (error #f "oops")))
+   (guard (c [#t #t]) (fx>=? 3 (error #f "oops") 4))
+   (guard (c [#t #t]) (fx>=? (error #f "oops") 3 4))
+   (guard (c [#t #t]) (not (fx>=? (error #f "oops"))))
+   (test-cp0-expansion eqv? '(fx>=? -3 -7) #t)
+   (test-cp0-expansion eqv? '(fx>=? -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>=? 0 -3) #t)
+   (test-cp0-expansion eqv? '(fx>=? 0 0) #t)
+   (test-cp0-expansion eqv? '(fx>=? -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx>=? 12 12) #t)
+   (test-cp0-expansion eqv? '(fx>=? -3 -7 -7) #t)
+   (test-cp0-expansion eqv? '(fx>=? -3 -2 0) #f)
+   (test-cp0-expansion eqv? '(fx>=? 0 -2 -3) #t)
+   (test-cp0-expansion eqv? '(fx>=? -3 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>=? 0 -3 0) #f)
+   (test-cp0-expansion eqv? '(fx>=? 0 0 0) #t)
+   (test-cp0-expansion eqv? '(fx>=? -3 -3 -3) #t)
+   (test-cp0-expansion eqv? '(fx>=? 12 12 12) #t)
+ )
+
+(mat $fxu<
+  (#%$fxu< 3 7)
+  (#%$fxu< 3 -7)
+  (not (#%$fxu< -3 -7))
+  (not (#%$fxu< -3 7))
+  (not (#%$fxu< -3 -3))
+  (not (#%$fxu< 3 3))
+  (not (#%$fxu< 0 0))
+  (not (#%$fxu< -3 0))
+  (#%$fxu< 0 -3)
+  (not (#%$fxu< 3 0))
+  (#%$fxu< 0 3)
+  (error? (#%$fxu< 'a))
+  (error? (#%$fxu< (+ (most-positive-fixnum) 1) 3 2))
+  (error? (#%$fxu< (- (most-negative-fixnum) 1) 3))
+  (guard (c [#t #t]) (#%$fxu< 4 3 (error #f "oops")))
+  (guard (c [#t #t]) (#%$fxu< 4 (error #f "oops") 3))
+  (guard (c [#t #t]) (#%$fxu< (error #f "oops") 4 3))
+  (guard (c [#t #t]) (not (#%$fxu< (error #f "oops"))))
+  (test-cp0-expansion eqv? '(#%$fxu< -3 -7) #f)
+  (test-cp0-expansion eqv? '(#%$fxu< -3 0) #f)
+  (test-cp0-expansion eqv? '(#%$fxu< 0 -3) #t)
+ )
+
+(mat fx+
+   (eqv? (fx+ 3 0) 3)
+   (eqv? (fx+ 3 1) 4)
+   (eqv? (fx+ 3 4) 7)
+   (eqv? (fx+ -3 4) 1)
+   (eqv? (fx+ 3 -4) -1)
+   (eqv? (fx+ 3 -3) 0)
+   (eqv? (fx+ 3 3) 6)
+   (eqv? (fx+) 0)
+   (eqv? (fx+ 3) 3)
+   (eqv? (fx+ 3 4 5) 12)
+   (error? (fx+ '(a . b)))
+   (error? (fx+ (most-positive-fixnum) 1))
+   (error? (fx+ (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx+ (- (most-negative-fixnum) 1) 3))
+  ; test for bug introduced temporarily into 4.1q
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx+ x 1))))) (g 2)) 3)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx+ 1 x))))) (g 2)) 3)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx+ x x))))) (g 2)) 4)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx+ (f x) 1))))) (g 2)) 3)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx+ 1 (f x)))))) (g 2)) 3)
+  ; test for bug introduced into 4.1s or before & fixed in 4.1v
+   (eqv?
+     (let ([f (lambda (n)
+                (do ((i 0 (fx+ i 1)))
+                    ((fx= i n))
+                  (fx+ i 1)))])
+       (f 1000))
+     (void))
+   (error? ; oops
+     (fx+ 'a 'b (error #f "oops")))
+   (error? ; oops
+     (fx+ 'a (error #f "oops") 'c))
+   (error? ; oops
+     (fx+ (error #f "oops") 'b 'c))
+   (error? ; #f is not a fixnum
+     (fx+ 3 #f))
+   (error? ; #f is not a fixnum
+     (fx+ #f 3))
+   (test-cp0-expansion eqv? '(fx+ 3 0) 3)
+   (test-cp0-expansion eqv? '(fx+ 3 1) 4)
+   (test-cp0-expansion eqv? '(fx+ 3 4) 7)
+   (test-cp0-expansion eqv? '(fx+ -3 4) 1)
+   (test-cp0-expansion eqv? '(fx+ 3 -4) -1)
+   (test-cp0-expansion eqv? '(fx+ 3 -3) 0)
+   (test-cp0-expansion eqv? '(fx+ 3 3) 6)
+   (test-cp0-expansion eqv? '(fx+) 0)
+   (test-cp0-expansion eqv? '(fx+ 3) 3)
+   (test-cp0-expansion eqv? '(fx+ 3 4 5) 12)
+ )
+
+(mat r6rs:fx+
+   (eqv? (r6rs:fx+ 3 0) 3)
+   (eqv? (r6rs:fx+ 3 1) 4)
+   (eqv? (r6rs:fx+ 3 4) 7)
+   (eqv? (r6rs:fx+ -3 4) 1)
+   (eqv? (r6rs:fx+ 3 -4) -1)
+   (eqv? (r6rs:fx+ 3 -3) 0)
+   (eqv? (r6rs:fx+ 3 3) 6)
+   (error? (r6rs:fx+ '(a . b) 3))
+   (error? (r6rs:fx+ (greatest-fixnum) 1))
+   (error? (r6rs:fx+ (+ (greatest-fixnum) 1) 3))
+   (error? (r6rs:fx+ (- (least-fixnum) 1) 3))
+  ; test for bug introduced temporarily into 4.1q
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx+ x 1))))) (g 2)) 3)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx+ 1 x))))) (g 2)) 3)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx+ x x))))) (g 2)) 4)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx+ (f x) 1))))) (g 2)) 3)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx+ 1 (f x)))))) (g 2)) 3)
+  ; test for bug introduced into 4.1s or before & fixed in 4.1v
+   (eqv?
+     (let ([f (lambda (n)
+                (do ((i 0 (r6rs:fx+ i 1)))
+                    ((fx= i n))
+                  (r6rs:fx+ i 1)))])
+       (f 1000))
+     (void))
+   (error? ; #f is not a fixnum
+     (fx+ 3 #f))
+   (error? ; #f is not a fixnum
+     (fx+ #f 3))
+   (test-cp0-expansion eqv? '(r6rs:fx+ 3 0) 3)
+   (test-cp0-expansion eqv? '(r6rs:fx+ 3 1) 4)
+   (test-cp0-expansion eqv? '(r6rs:fx+ 3 4) 7)
+   (test-cp0-expansion eqv? '(r6rs:fx+ -3 4) 1)
+   (test-cp0-expansion eqv? '(r6rs:fx+ 3 -4) -1)
+   (test-cp0-expansion eqv? '(r6rs:fx+ 3 -3) 0)
+   (test-cp0-expansion eqv? '(r6rs:fx+ 3 3) 6)
+ )
+
+(mat fx-
+   (eqv? (fx- 3 0) 3)
+   (eqv? (fx- 3 1) 2)
+   (eqv? (fx- 3 4) -1)
+   (eqv? (fx- -3 4) -7)
+   (eqv? (fx- 3 -4) 7)
+   (eqv? (fx- 3 -3) 6)
+   (eqv? (fx- 3 3) 0)
+   (eqv? (fx- 3) -3)
+   (eqv? (fx- 3 4 5) -6)
+   (error? (fx- '(a . b)))
+   (error? (fx- (most-negative-fixnum) 1))
+   (error? (fx- (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx- (- (most-negative-fixnum) 1) 3))
+  ; test for bug introduced temporarily into 4.1q
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx- x 1))))) (g 2)) 1)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx- 1 x))))) (g 2)) -1)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx- x x))))) (g 2)) 0)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx- (f x) 1))))) (g 2)) 1)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (fx- 1 (f x)))))) (g 2)) -1)
+   (error? ; #f is not a fixnum
+     (fx- 3 #f))
+   (error? ; #f is not a fixnum
+     (fx- #f 3))
+   (test-cp0-expansion eqv? '(fx- 3 0) 3)
+   (test-cp0-expansion eqv? '(fx- 3 1) 2)
+   (test-cp0-expansion eqv? '(fx- 3 4) -1)
+   (test-cp0-expansion eqv? '(fx- -3 4) -7)
+   (test-cp0-expansion eqv? '(fx- 3 -4) 7)
+   (test-cp0-expansion eqv? '(fx- 3 -3) 6)
+   (test-cp0-expansion eqv? '(fx- 3 3) 0)
+   (test-cp0-expansion eqv? '(fx- 3) -3)
+   (test-cp0-expansion eqv? '(fx- 3 4 5) -6)
+ )
+
+(mat r6rs:fx-
+   (eqv? (r6rs:fx- 3 0) 3)
+   (eqv? (r6rs:fx- 3 1) 2)
+   (eqv? (r6rs:fx- 3 4) -1)
+   (eqv? (r6rs:fx- -3 4) -7)
+   (eqv? (r6rs:fx- 3 -4) 7)
+   (eqv? (r6rs:fx- 3 -3) 6)
+   (eqv? (r6rs:fx- 3 3) 0)
+   (eqv? (r6rs:fx- 3) -3)
+   (error? (r6rs:fx- '(a . b)))
+   (error? (r6rs:fx- (least-fixnum) 1))
+   (error? (r6rs:fx- (+ (greatest-fixnum) 1) 3))
+   (error? (r6rs:fx- (- (least-fixnum) 1) 3))
+  ; test for bug introduced temporarily into 4.1q
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx- x 1))))) (g 2)) 1)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx- 1 x))))) (g 2)) -1)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx- x x))))) (g 2)) 0)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx- (f x) 1))))) (g 2)) 1)
+   (eqv? (let* ((f (lambda (x) x)) (g (lambda (x) (f (r6rs:fx- 1 (f x)))))) (g 2)) -1)
+   (error? ; #f is not a fixnum
+     (fx- 3 #f))
+   (error? ; #f is not a fixnum
+     (fx- #f 3))
+   (test-cp0-expansion eqv? '(r6rs:fx- 3 0) 3)
+   (test-cp0-expansion eqv? '(r6rs:fx- 3 1) 2)
+   (test-cp0-expansion eqv? '(r6rs:fx- 3 4) -1)
+   (test-cp0-expansion eqv? '(r6rs:fx- -3 4) -7)
+   (test-cp0-expansion eqv? '(r6rs:fx- 3 -4) 7)
+   (test-cp0-expansion eqv? '(r6rs:fx- 3 -3) 6)
+   (test-cp0-expansion eqv? '(r6rs:fx- 3 3) 0)
+   (test-cp0-expansion eqv? '(r6rs:fx- 3) -3)
+ )
+
+(mat fx*
+   (eqv? (fx* 3 0) 0)
+   (eqv? (fx* 3 1) 3)
+   (eqv? (fx* 3 4) 12)
+   (eqv? (fx* -3 4) -12)
+   (eqv? (fx* 3 -4) -12)
+   (eqv? (fx* 3 -3) -9)
+   (eqv? (fx* 3 3) 9)
+   (eqv? (fx*) 1)
+   (eqv? (fx* 3) 3)
+   (eqv? (fx* 3 4 5) 60)
+   (error? (fx* '(a . b)))
+   (error? (fx* (most-positive-fixnum) 2))
+   (error? (fx* (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx* (- (most-negative-fixnum) 1) 3))
+   (error? ; #f is not a fixnum
+     (fx* 3 #f))
+   (error? ; #f is not a fixnum
+     (fx* #f 3))
+   (test-cp0-expansion eqv? '(fx* 3 0) 0)
+   (test-cp0-expansion eqv? '(fx* 3 1) 3)
+   (test-cp0-expansion eqv? '(fx* 3 4) 12)
+   (test-cp0-expansion eqv? '(fx* -3 4) -12)
+   (test-cp0-expansion eqv? '(fx* 3 -4) -12)
+   (test-cp0-expansion eqv? '(fx* 3 -3) -9)
+   (test-cp0-expansion eqv? '(fx* 3 3) 9)
+   (test-cp0-expansion eqv? '(fx*) 1)
+   (test-cp0-expansion eqv? '(fx* 3) 3)
+   (test-cp0-expansion eqv? '(fx* 3 4 5) 60)
+ )
+
+(mat r6rs:fx*
+   (eqv? (r6rs:fx* 3 0) 0)
+   (eqv? (r6rs:fx* 3 1) 3)
+   (eqv? (r6rs:fx* 3 4) 12)
+   (eqv? (r6rs:fx* -3 4) -12)
+   (eqv? (r6rs:fx* 3 -4) -12)
+   (eqv? (r6rs:fx* 3 -3) -9)
+   (eqv? (r6rs:fx* 3 3) 9)
+   (error? (r6rs:fx* 3 '(a . b)))
+   (error? (r6rs:fx* (greatest-fixnum) 2))
+   (error? (r6rs:fx* (+ (greatest-fixnum) 1) 3))
+   (error? (r6rs:fx* (- (least-fixnum) 1) 3))
+   (error? ; #f is not a fixnum
+     (fx* 3 #f))
+   (error? ; #f is not a fixnum
+     (fx* #f 3))
+   (test-cp0-expansion eqv? '(r6rs:fx* 3 0) 0)
+   (test-cp0-expansion eqv? '(r6rs:fx* 3 1) 3)
+   (test-cp0-expansion eqv? '(r6rs:fx* 3 4) 12)
+   (test-cp0-expansion eqv? '(r6rs:fx* -3 4) -12)
+   (test-cp0-expansion eqv? '(r6rs:fx* 3 -4) -12)
+   (test-cp0-expansion eqv? '(r6rs:fx* 3 -3) -9)
+   (test-cp0-expansion eqv? '(r6rs:fx* 3 3) 9)
+ )
+
+(mat fxquotient
+  (eqv? (fxquotient 3 1) 3)
+  (eqv? (fxquotient 3 4) 0)
+  (eqv? (fxquotient -4 3) -1)
+  (eqv? (fxquotient 4 -3) -1)
+  (eqv? (fxquotient 3 -3) -1)
+  (eqv? (fxquotient 3 3) 1)
+  (eqv? (fxquotient 13 3) 4)
+  (eqv? (fxquotient -13 3) -4)
+  (eqv? (fxquotient 13 -3) -4)
+  (eqv? (fxquotient -13 -3) 4)
+  (eqv? (fxquotient 3) 0)
+  (eqv? (fxquotient -3) 0)
+  (eqv? (fxquotient 1) 1)
+  (eqv? (fxquotient -1) -1)
+  (eqv? (fxquotient 19 3 2) 3)
+  (error? (fxquotient '(a . b)))
+  (error? (fxquotient 0))
+  (error? (fxquotient (+ (most-positive-fixnum) 1) 3 2))
+  (error? (fxquotient (- (most-negative-fixnum) 1) 3))
+  (error? (fxquotient (most-negative-fixnum) -1))
+  (equal?
+    (map (lambda (x) (fxquotient x 64))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 0 0 0 0 0 1 1 1 2 2))
+  (equal?
+    (map (lambda (x) (fxquotient x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 0 0 0 0 0 -1 -1 -1 -2 -2))
+  (test-cp0-expansion eqv? '(fxquotient 3 1) 3)
+  (test-cp0-expansion eqv? '(fxquotient 3 4) 0)
+  (test-cp0-expansion eqv? '(fxquotient -4 3) -1)
+  (test-cp0-expansion eqv? '(fxquotient 4 -3) -1)
+  (test-cp0-expansion eqv? '(fxquotient 3 -3) -1)
+  (test-cp0-expansion eqv? '(fxquotient 3 3) 1)
+  (test-cp0-expansion eqv? '(fxquotient 13 3) 4)
+  (test-cp0-expansion eqv? '(fxquotient -13 3) -4)
+  (test-cp0-expansion eqv? '(fxquotient 13 -3) -4)
+  (test-cp0-expansion eqv? '(fxquotient -13 -3) 4)
+  (test-cp0-expansion eqv? '(fxquotient 3) 0)
+  (test-cp0-expansion eqv? '(fxquotient -3) 0)
+  (test-cp0-expansion eqv? '(fxquotient 1) 1)
+  (test-cp0-expansion eqv? '(fxquotient -1) -1)
+  (test-cp0-expansion eqv? '(fxquotient 19 3 2) 3)
+  )
+
+(mat fx/
+   (eqv? (fx/ 3 1) 3)
+   (eqv? (fx/ 3 4) 0)
+   (eqv? (fx/ -4 3) -1)
+   (eqv? (fx/ 4 -3) -1)
+   (eqv? (fx/ 3 -3) -1)
+   (eqv? (fx/ 3 3) 1)
+   (eqv? (fx/ 13 3) 4)
+   (eqv? (fx/ -13 3) -4)
+   (eqv? (fx/ 13 -3) -4)
+   (eqv? (fx/ -13 -3) 4)
+   (eqv? (fx/ -13 4) -3)
+   (eqv? (fx/ 3) 0)
+   (eqv? (fx/ -3) 0)
+   (eqv? (fx/ 1) 1)
+   (eqv? (fx/ -1) -1)
+   (eqv? (fx/ 19 3 2) 3)
+   (error? (fx/ '(a . b)))
+   (error? (fx/ 0))
+   (error? (fx/ (+ (most-positive-fixnum) 1) 3 2))
+   (error? (fx/ (- (most-negative-fixnum) 1) 3))
+   (error? (fx/ (most-negative-fixnum) -1))
+   (equal?
+     (map (lambda (x) (fx/ x 64))
+       '(0 5 31 32 33 63 64 65 127 128 129))
+     '(0 0 0 0 0 0 1 1 1 2 2))
+   (equal?
+     (map (lambda (x) (fx/ x 64))
+       '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+     '(0 0 0 0 0 0 -1 -1 -1 -2 -2))
+   (test-cp0-expansion eqv? '(fx/ 3 1) 3)
+   (test-cp0-expansion eqv? '(fx/ 3 4) 0)
+   (test-cp0-expansion eqv? '(fx/ -4 3) -1)
+   (test-cp0-expansion eqv? '(fx/ 4 -3) -1)
+   (test-cp0-expansion eqv? '(fx/ 3 -3) -1)
+   (test-cp0-expansion eqv? '(fx/ 3 3) 1)
+   (test-cp0-expansion eqv? '(fx/ 13 3) 4)
+   (test-cp0-expansion eqv? '(fx/ -13 3) -4)
+   (test-cp0-expansion eqv? '(fx/ 13 -3) -4)
+   (test-cp0-expansion eqv? '(fx/ -13 -3) 4)
+   (test-cp0-expansion eqv? '(fx/ -13 4) -3)
+   (test-cp0-expansion eqv? '(fx/ 3) 0)
+   (test-cp0-expansion eqv? '(fx/ -3) 0)
+   (test-cp0-expansion eqv? '(fx/ 1) 1)
+   (test-cp0-expansion eqv? '(fx/ -1) -1)
+   (test-cp0-expansion eqv? '(fx/ 19 3 2) 3)
+ )
+
+(mat fxzero?
+   (fxzero? 0)
+   (not (fxzero? 1))
+   (not (fxzero? -1))
+   (not (fxzero? (most-positive-fixnum)))
+   (not (fxzero? (most-negative-fixnum)))
+   (error? (fxzero? 'a))
+   (error? (fxzero? (+ (most-positive-fixnum) 1)))
+   (error? (fxzero? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(fxzero? 0) #t)
+   (test-cp0-expansion eqv? '(not (fxzero? 1)) #t)
+   (test-cp0-expansion eqv? '(not (fxzero? -1)) #t)
+   (test-cp0-expansion eqv? '(not (fxzero? (most-positive-fixnum))) #t)
+   (test-cp0-expansion eqv? '(not (fxzero? (most-negative-fixnum))) #t)
+ )
+
+(mat fxpositive?
+   (not (fxpositive? 0))
+   (fxpositive? 1)
+   (not (fxpositive? -1))
+   (fxpositive? (most-positive-fixnum))
+   (not (fxpositive? (most-negative-fixnum)))
+   (error? (fxpositive? 'a))
+   (error? (fxpositive? (+ (most-positive-fixnum) 1)))
+   (error? (fxpositive? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(not (fxpositive? 0)) #t)
+   (test-cp0-expansion eqv? '(fxpositive? 1) #t)
+   (test-cp0-expansion eqv? '(not (fxpositive? -1)) #t)
+   (test-cp0-expansion eqv? '(fxpositive? (most-positive-fixnum)) #t)
+   (test-cp0-expansion eqv? '(not (fxpositive? (most-negative-fixnum))) #t)
+ )
+
+(mat fxnonpositive?
+   (fxnonpositive? 0)
+   (not (fxnonpositive? 1))
+   (fxnonpositive? -1)
+   (not (fxnonpositive? (most-positive-fixnum)))
+   (fxnonpositive? (most-negative-fixnum))
+   (error? (fxnonpositive? 'a))
+   (error? (fxnonpositive? (+ (most-positive-fixnum) 1)))
+   (error? (fxnonpositive? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(fxnonpositive? 0) #t)
+   (test-cp0-expansion eqv? '(not (fxnonpositive? 1)) #t)
+   (test-cp0-expansion eqv? '(fxnonpositive? -1) #t)
+   (test-cp0-expansion eqv? '(not (fxnonpositive? (most-positive-fixnum))) #t)
+   (test-cp0-expansion eqv? '(fxnonpositive? (most-negative-fixnum)) #t)
+ )
+
+(mat fxnegative?
+   (not (fxnegative? 0))
+   (not (fxnegative? 1))
+   (fxnegative? -1)
+   (not (fxnegative? (most-positive-fixnum)))
+   (fxnegative? (most-negative-fixnum))
+   (error? (fxnegative? 'a))
+   (error? (fxnegative? (+ (most-positive-fixnum) 1)))
+   (error? (fxnegative? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(not (fxnegative? 0)) #t)
+   (test-cp0-expansion eqv? '(not (fxnegative? 1)) #t)
+   (test-cp0-expansion eqv? '(fxnegative? -1) #t)
+   (test-cp0-expansion eqv? '(not (fxnegative? (most-positive-fixnum))) #t)
+   (test-cp0-expansion eqv? '(fxnegative? (most-negative-fixnum)) #t)
+ )
+
+(mat fxnonnegative?
+   (fxnonnegative? 0)
+   (fxnonnegative? 1)
+   (not (fxnonnegative? -1))
+   (fxnonnegative? (most-positive-fixnum))
+   (not (fxnonnegative? (most-negative-fixnum)))
+   (error? (fxnonnegative? 'a))
+   (error? (fxnonnegative? (+ (most-positive-fixnum) 1)))
+   (error? (fxnonnegative? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(fxnonnegative? 0) #t)
+   (test-cp0-expansion eqv? '(fxnonnegative? 1) #t)
+   (test-cp0-expansion eqv? '(not (fxnonnegative? -1)) #t)
+   (test-cp0-expansion eqv? '(fxnonnegative? (most-positive-fixnum)) #t)
+   (test-cp0-expansion eqv? '(not (fxnonnegative? (most-negative-fixnum))) #t)
+ )
+
+(mat fxodd?
+   (not (fxodd? 0))
+   (fxodd? 1)
+   (not (fxodd? 2))
+   (fxodd? -1)
+   (not (fxodd? -2))
+   (fxodd? (most-positive-fixnum))
+   (not (fxodd? (most-negative-fixnum)))
+   (error? (fxodd? 'a))
+   (error? (fxodd? (+ (most-positive-fixnum) 1)))
+   (error? (fxodd? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(not (fxodd? 0)) #t)
+   (test-cp0-expansion eqv? '(fxodd? 1) #t)
+   (test-cp0-expansion eqv? '(not (fxodd? 2)) #t)
+   (test-cp0-expansion eqv? '(fxodd? -1) #t)
+   (test-cp0-expansion eqv? '(not (fxodd? -2)) #t)
+   (test-cp0-expansion eqv? '(fxodd? (most-positive-fixnum)) #t)
+   (test-cp0-expansion eqv? '(not (fxodd? (most-negative-fixnum))) #t)
+ )
+
+(mat fxeven?
+   (fxeven? 0)
+   (not (fxeven? 1))
+   (fxeven? 2)
+   (not (fxeven? -1))
+   (fxeven? -2)
+   (not (fxeven? (most-positive-fixnum)))
+   (fxeven? (most-negative-fixnum))
+   (error? (fxeven? 'a))
+   (error? (fxeven? (+ (most-positive-fixnum) 1)))
+   (error? (fxeven? (- (most-negative-fixnum) 1)))
+   (test-cp0-expansion eqv? '(fxeven? 0) #t)
+   (test-cp0-expansion eqv? '(not (fxeven? 1)) #t)
+   (test-cp0-expansion eqv? '(fxeven? 2) #t)
+   (test-cp0-expansion eqv? '(not (fxeven? -1)) #t)
+   (test-cp0-expansion eqv? '(fxeven? -2) #t)
+   (test-cp0-expansion eqv? '(not (fxeven? (most-positive-fixnum))) #t)
+   (test-cp0-expansion eqv? '(fxeven? (most-negative-fixnum)) #t)
+ )
+
+(mat fxabs
+   (eqv? (fxabs 0) 0)
+   (eqv? (fxabs -1) 1)
+   (eqv? (fxabs 1) 1)
+   (eqv? (fxabs (most-positive-fixnum)) (most-positive-fixnum))
+   (eqv? (fxabs (+ (most-negative-fixnum) 1)) (most-positive-fixnum))
+   (error? (fxabs (most-negative-fixnum)))
+   (error? (fxabs (+ (most-positive-fixnum) 1)))
+   (error? (fxabs (- (most-negative-fixnum) 1)))
+   (error? (fxabs "hi there"))
+   (error? (fxabs 1.2))
+   (error? (fxabs -1.2))
+   (test-cp0-expansion eqv? '(fxabs 0) 0)
+   (test-cp0-expansion eqv? '(fxabs 2) 2)
+   (test-cp0-expansion eqv? '(fxabs -2) 2)
+ )
+
+(mat fx1-
+   (eqv? (fx1- 0) -1)
+   (eqv? (fx1- 1) 0)
+   (eqv? (fx1- -1) -2)
+   (test-cp0-expansion eqv? '(fx1- 0) -1)
+   (test-cp0-expansion eqv? '(fx1- 1) 0)
+   (test-cp0-expansion eqv? '(fx1- -1) -2)
+   (error? (fx1- (most-negative-fixnum)))
+   (error? (fx1- (- (most-negative-fixnum) 1)))
+   (error? (fx1- (+ (most-positive-fixnum) 1)))
+   (error? (fx1- 'a))
+ )
+
+(mat fx1+
+   (eqv? (fx1+ 0) 1)
+   (eqv? (fx1+ 1) 2)
+   (eqv? (fx1+ -1) 0)
+   (test-cp0-expansion eqv? '(fx1+ 0) 1)
+   (test-cp0-expansion eqv? '(fx1+ 1) 2)
+   (test-cp0-expansion eqv? '(fx1+ -1) 0)
+   (error? (fx1+ (most-positive-fixnum)))
+   (error? (fx1+ (- (most-negative-fixnum) 1)))
+   (error? (fx1+ (+ (most-positive-fixnum) 1)))
+   (error? (fx1+ 'a))
+  ; test for bug introduced into 4.1s or before & fixed in 4.1v
+   (eqv?
+     (let ([f (lambda (n)
+                (do ((i 0 (fx+ i 1)))
+                    ((fx= i n))
+                  (fx1+ i)))])
+       (f 1000))
+     (void))
+ )
+
+(mat fxmin
+   (error? (fxmin))
+   (eqv? (fxmin -1) -1)
+   (eqv? (fxmin -1 0) -1)
+   (eqv? (fxmin 0 -1) -1)
+   (eqv? (fxmin -1 1) -1)
+   (eqv? (fxmin 1 -1) -1)
+   (eqv? (fxmin 1 0 -1) -1)
+   (eqv? (fxmin 1 (most-negative-fixnum) 0 -1) (most-negative-fixnum))
+   (eqv? (fxmin 1 (most-positive-fixnum) 0 -1) -1)
+   (error? (fxmin 'a 0 1))
+   (error? (fxmin (+ (most-positive-fixnum) 1)))
+   (error? (fxmin (- (most-negative-fixnum) 1) 0))
+   (error? (fxmin 'a))
+   (error? (fxmin 0 1 -2 1 'a))
+   (test-cp0-expansion eqv? '(fxmin 0 1 2) 0)
+   (test-cp0-expansion eqv? '(fxmin 2 1 0) 0)
+   (test-cp0-expansion eqv? '(fxmin 0 2 1) 0)
+ )
+
+(mat fxmax
+   (error? (fxmax))
+   (eqv? (fxmax -1) -1)
+   (eqv? (fxmax -1 0) 0)
+   (eqv? (fxmax 0 -1) 0)
+   (eqv? (fxmax -1 1) 1)
+   (eqv? (fxmax 1 -1) 1)
+   (eqv? (fxmax 1 0 -1) 1)
+   (eqv? (fxmax 1 (most-negative-fixnum) 0 -1) 1)
+   (eqv? (fxmax 1 (most-positive-fixnum) 0 -1) (most-positive-fixnum))
+   (error? (fxmax 'a 0 1))
+   (error? (fxmax (+ (most-positive-fixnum) 1)))
+   (error? (fxmax (- (most-negative-fixnum) 1) 0))
+   (error? (fxmax 'a))
+   (error? (fxmax 0 1 -2 1 'a))
+   (test-cp0-expansion eqv? '(fxmax 0 1 2) 2)
+   (test-cp0-expansion eqv? '(fxmax 2 1 0) 2)
+   (test-cp0-expansion eqv? '(fxmax 0 2 1) 2)
+ )
+
+(mat fxmodulo
+   (eqv? (fxmodulo -7 2) 1)
+   (eqv? (fxmodulo 5 3) 2)
+   (eqv? (fxmodulo 5 -3) -1)
+   (eqv? (fxmodulo -5 -3) -2)
+   (error? (fxmodulo 'a 3))
+   (error? (fxmodulo (+ (most-positive-fixnum) 1) 3))
+   (error? (fxmodulo (- (most-negative-fixnum) 1) 3))
+   (error? (fxmodulo 7 0))
+  (equal?
+    (map (lambda (x) (fxmodulo x 64))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 32 33 63 0 1 63 0 1))
+  (equal?
+    (map (lambda (x) (fxmodulo x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 59 33 32 31 1 0 63 1 0 63))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxmodulo ,x 64))))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 32 33 63 0 1 63 0 1))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxmodulo ,x 64))))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 59 33 32 31 1 0 63 1 0 63))
+ )
+
+(mat fxremainder
+   (eqv? (fxremainder -7 2) -1)
+   (eqv? (fxremainder 5 3) 2)
+   (eqv? (fxremainder 5 -3) 2)
+   (eqv? (fxremainder -5 -3) -2)
+   (error? (fxremainder 'a 3))
+   (error? (fxremainder (+ (most-positive-fixnum) 1) 3))
+   (error? (fxremainder (- (most-negative-fixnum) 1) 3))
+   (error? (fxremainder 7 0))
+  (equal?
+    (map (lambda (x) (fxremainder x 64))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 32 33 63 0 1 63 0 1))
+  (equal?
+    (map (lambda (x) (fxremainder x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 -5 -31 -32 -33 -63 0 -1 -63 0 -1))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxremainder ,x 64))))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 32 33 63 0 1 63 0 1))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxremainder ,x 64))))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 -5 -31 -32 -33 -63 0 -1 -63 0 -1))
+ )
+
+(mat fxlogior ; same as fxlogor
+  (error? (fxlogior "hello"))
+  (error? (fxlogior (+ (most-positive-fixnum) 1)))
+  (error? (fxlogior (- (most-negative-fixnum) 1) 7))
+  (error? (fxlogior 7 8 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxlogior 0 0) 0)
+  (eqv? (fxlogior 1 0) 1)
+  (eqv? (fxlogior 1 1) 1)
+  (eqv? (fxlogior 0 1) 1)
+  (eqv? (fxlogior 2 1) 3)
+  (eqv? (fxlogior 5 2) 7)
+  (eqv? (fxlogior -1 2) -1)
+  (eqv? (fxlogior) 0)
+  (eqv? (fxlogior #x1212121)
+        #x1212121)
+  (eqv? (fxlogior #x1212121
+                 #x2222222
+                 #x0301030)
+        #x3333333)
+  (eqv? (fxlogior #b1010111
+                 #b1001011
+                 -1
+                 #b1011110
+                 #b1000111)
+        -1)
+  (eqv? (fxlogior #b1010111
+                 #b1001011
+                 0
+                 #b1011110
+                 #b1000111)
+        #b1011111)
+  (test-cp0-expansion eqv? '(fxlogior 0 0) 0)
+  (test-cp0-expansion eqv? '(fxlogior 1 0) 1)
+  (test-cp0-expansion eqv? '(fxlogior 1 1) 1)
+  (test-cp0-expansion eqv? '(fxlogior 0 1) 1)
+  (test-cp0-expansion eqv? '(fxlogior 2 1) 3)
+  (test-cp0-expansion eqv? '(fxlogior 5 2) 7)
+  (test-cp0-expansion eqv? '(fxlogior -1 2) -1)
+  (test-cp0-expansion eqv? '(fxlogior) 0)
+  (test-cp0-expansion eqv? 
+    '(fxlogior #x1212121)
+    #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxlogior #x1212121
+       #x2222222
+       #x0301030)
+    #x3333333)
+  (test-cp0-expansion eqv? 
+    '(fxlogior #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -1)
+  (test-cp0-expansion eqv? 
+    '(fxlogior #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    #b1011111)
+ )
+
+(mat fxior ; same as fxlogor
+  (error? (fxior "hello"))
+  (error? (fxior (+ (most-positive-fixnum) 1)))
+  (error? (fxior (- (most-negative-fixnum) 1) 7))
+  (error? (fxior 7 8 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxior 0 0) 0)
+  (eqv? (fxior 1 0) 1)
+  (eqv? (fxior 1 1) 1)
+  (eqv? (fxior 0 1) 1)
+  (eqv? (fxior 2 1) 3)
+  (eqv? (fxior 5 2) 7)
+  (eqv? (fxior -1 2) -1)
+  (eqv? (fxior) 0)
+  (eqv? (fxior #x1212121)
+        #x1212121)
+  (eqv? (fxior #x1212121
+                 #x2222222
+                 #x0301030)
+        #x3333333)
+  (eqv? (fxior #b1010111
+                 #b1001011
+                 -1
+                 #b1011110
+                 #b1000111)
+        -1)
+  (eqv? (fxior #b1010111
+                 #b1001011
+                 0
+                 #b1011110
+                 #b1000111)
+        #b1011111)
+  (test-cp0-expansion eqv? '(fxior 0 0) 0)
+  (test-cp0-expansion eqv? '(fxior 1 0) 1)
+  (test-cp0-expansion eqv? '(fxior 1 1) 1)
+  (test-cp0-expansion eqv? '(fxior 0 1) 1)
+  (test-cp0-expansion eqv? '(fxior 2 1) 3)
+  (test-cp0-expansion eqv? '(fxior 5 2) 7)
+  (test-cp0-expansion eqv? '(fxior -1 2) -1)
+  (test-cp0-expansion eqv? '(fxior) 0)
+  (test-cp0-expansion eqv? 
+    '(fxior #x1212121)
+    #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxior #x1212121
+       #x2222222
+       #x0301030)
+    #x3333333)
+  (test-cp0-expansion eqv? 
+    '(fxior #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -1)
+  (test-cp0-expansion eqv? 
+    '(fxior #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    #b1011111)
+ )
+
+(mat fxlogor
+  (error? (fxlogor "hello"))
+  (error? (fxlogor (+ (most-positive-fixnum) 1)))
+  (error? (fxlogor (- (most-negative-fixnum) 1) 7))
+  (error? (fxlogor 7 8 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxlogor 0 0) 0)
+  (eqv? (fxlogor 1 0) 1)
+  (eqv? (fxlogor 1 1) 1)
+  (eqv? (fxlogor 0 1) 1)
+  (eqv? (fxlogor 2 1) 3)
+  (eqv? (fxlogor 5 2) 7)
+  (eqv? (fxlogor -1 2) -1)
+  (eqv? (fxlogor) 0)
+  (eqv? (fxlogor #x1212121)
+        #x1212121)
+  (eqv? (fxlogor #x1212121
+                 #x2222222
+                 #x0301030)
+        #x3333333)
+  (eqv? (fxlogor #b1010111
+                 #b1001011
+                 -1
+                 #b1011110
+                 #b1000111)
+        -1)
+  (eqv? (fxlogor #b1010111
+                 #b1001011
+                 0
+                 #b1011110
+                 #b1000111)
+        #b1011111)
+  (test-cp0-expansion eqv? '(fxlogor 0 0) 0)
+  (test-cp0-expansion eqv? '(fxlogor 1 0) 1)
+  (test-cp0-expansion eqv? '(fxlogor 1 1) 1)
+  (test-cp0-expansion eqv? '(fxlogor 0 1) 1)
+  (test-cp0-expansion eqv? '(fxlogor 2 1) 3)
+  (test-cp0-expansion eqv? '(fxlogor 5 2) 7)
+  (test-cp0-expansion eqv? '(fxlogor -1 2) -1)
+  (test-cp0-expansion eqv? '(fxlogor) 0)
+  (test-cp0-expansion eqv? 
+    '(fxlogor #x1212121)
+    #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxlogor #x1212121
+       #x2222222
+       #x0301030)
+    #x3333333)
+  (test-cp0-expansion eqv? 
+    '(fxlogor #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -1)
+  (test-cp0-expansion eqv? 
+    '(fxlogor #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    #b1011111)
+ )
+
+(mat fxlogand
+  (error? (fxlogand "hello"))
+  (error? (fxlogand (+ (most-positive-fixnum) 1)))
+  (error? (fxlogand 7 (- (most-negative-fixnum) 1)))
+  (error? (fxlogand 7 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxlogand 0 0) 0)
+  (eqv? (fxlogand 1 0) 0)
+  (eqv? (fxlogand 0 1) 0)
+  (eqv? (fxlogand 1 1) 1)
+  (eqv? (fxlogand 2 1) 0)
+  (eqv? (fxlogand 3 1) 1)
+  (eqv? (fxlogand 12 6) 4)
+  (eqv? (fxlogand) -1)
+  (eqv? (fxlogand #x1212121)
+        #x1212121)
+  (eqv? (fxlogand #x1212121
+                  #x2222222
+                  #x0301030)
+        #x200020)
+  (eqv? (fxlogand #b1110111
+                  #b1101011
+                  -1
+                  #b1011110
+                  #b1000111)
+        #b1000010)
+  (eqv? (fxlogand #b1110111
+                  #b1101011
+                  0
+                  #b1011110
+                  #b1000111)
+        0)
+  (test-cp0-expansion eqv? '(fxlogand 0 0) 0)
+  (test-cp0-expansion eqv? '(fxlogand 1 0) 0)
+  (test-cp0-expansion eqv? '(fxlogand 0 1) 0)
+  (test-cp0-expansion eqv? '(fxlogand 1 1) 1)
+  (test-cp0-expansion eqv? '(fxlogand 2 1) 0)
+  (test-cp0-expansion eqv? '(fxlogand 3 1) 1)
+  (test-cp0-expansion eqv? '(fxlogand 12 6) 4)
+  (test-cp0-expansion eqv? '(fxlogand) -1)
+  (test-cp0-expansion eqv? 
+    '(fxlogand #x1212121)
+    #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxlogand #x1212121
+       #x2222222
+       #x0301030)
+    #x200020)
+  (test-cp0-expansion eqv? 
+    '(fxlogand #b1110111
+       #b1101011
+       -1
+       #b1011110
+       #b1000111)
+    #b1000010)
+  (test-cp0-expansion eqv? 
+    '(fxlogand #b1110111
+       #b1101011
+       0
+       #b1011110
+       #b1000111)
+    0)
+ )
+
+(mat fxand
+  (error? (fxand "hello"))
+  (error? (fxand (+ (most-positive-fixnum) 1)))
+  (error? (fxand 7 (- (most-negative-fixnum) 1)))
+  (error? (fxand 7 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxand 0 0) 0)
+  (eqv? (fxand 1 0) 0)
+  (eqv? (fxand 0 1) 0)
+  (eqv? (fxand 1 1) 1)
+  (eqv? (fxand 2 1) 0)
+  (eqv? (fxand 3 1) 1)
+  (eqv? (fxand 12 6) 4)
+  (eqv? (fxand) -1)
+  (eqv? (fxand #x1212121)
+        #x1212121)
+  (eqv? (fxand #x1212121
+                  #x2222222
+                  #x0301030)
+        #x200020)
+  (eqv? (fxand #b1110111
+                  #b1101011
+                  -1
+                  #b1011110
+                  #b1000111)
+        #b1000010)
+  (eqv? (fxand #b1110111
+                  #b1101011
+                  0
+                  #b1011110
+                  #b1000111)
+        0)
+  (test-cp0-expansion eqv? '(fxand 0 0) 0)
+  (test-cp0-expansion eqv? '(fxand 1 0) 0)
+  (test-cp0-expansion eqv? '(fxand 0 1) 0)
+  (test-cp0-expansion eqv? '(fxand 1 1) 1)
+  (test-cp0-expansion eqv? '(fxand 2 1) 0)
+  (test-cp0-expansion eqv? '(fxand 3 1) 1)
+  (test-cp0-expansion eqv? '(fxand 12 6) 4)
+  (test-cp0-expansion eqv? '(fxand) -1)
+  (test-cp0-expansion eqv? 
+    '(fxand #x1212121)
+    #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxand #x1212121
+       #x2222222
+       #x0301030)
+    #x200020)
+  (test-cp0-expansion eqv? 
+    '(fxand #b1110111
+       #b1101011
+       -1
+       #b1011110
+       #b1000111)
+    #b1000010)
+  (test-cp0-expansion eqv? 
+    '(fxand #b1110111
+       #b1101011
+       0
+       #b1011110
+       #b1000111)
+    0)
+ )
+
+(mat fxlogxor
+  (error? (fxlogxor "hello"))
+  (error? (fxlogxor (+ (most-positive-fixnum) 1)))
+  (error? (fxlogxor 7 (- (most-negative-fixnum) 1)))
+  (error? (fxlogxor 7 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxlogxor 0 0) 0)
+  (eqv? (fxlogxor 1 0) 1)
+  (eqv? (fxlogxor 1 1) 0)
+  (eqv? (fxlogxor 0 1) 1)
+  (eqv? (fxlogxor 2 1) 3)
+  (eqv? (fxlogxor 5 2) 7)
+  (eqv? (fxlogxor -1 2) -3)
+  (eqv? (fxlogxor) 0)
+  (eqv? (fxlogxor #x1212121)
+        #x1212121)
+  (eqv? (fxlogxor #x1212121
+                  #x2222222
+                  #x0301030)
+        #x3331333)
+  (eqv? (fxlogxor #b1010111
+                  #b1001011
+                  -1
+                  #b1011110
+                  #b1000111)
+        -6)
+  (eqv? (fxlogxor #b1010111
+                  #b1001011
+                  0
+                  #b1011110
+                  #b1000111)
+        5)
+  (test-cp0-expansion eqv? '(fxlogxor 0 0) 0)
+  (test-cp0-expansion eqv? '(fxlogxor 1 0) 1)
+  (test-cp0-expansion eqv? '(fxlogxor 1 1) 0)
+  (test-cp0-expansion eqv? '(fxlogxor 0 1) 1)
+  (test-cp0-expansion eqv? '(fxlogxor 2 1) 3)
+  (test-cp0-expansion eqv? '(fxlogxor 5 2) 7)
+  (test-cp0-expansion eqv? '(fxlogxor -1 2) -3)
+  (test-cp0-expansion eqv? '(fxlogxor) 0)
+  (test-cp0-expansion eqv? '(fxlogxor #x1212121) #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxlogxor #x1212121
+       #x2222222
+       #x0301030)
+    #x3331333)
+  (test-cp0-expansion eqv? 
+    '(fxlogxor #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -6)
+  (test-cp0-expansion eqv? 
+    '(fxlogxor #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    5)
+ )
+
+(mat fxxor
+  (error? (fxxor "hello"))
+  (error? (fxxor (+ (most-positive-fixnum) 1)))
+  (error? (fxxor 7 (- (most-negative-fixnum) 1)))
+  (error? (fxxor 7 (- (most-negative-fixnum) 1) 8 9))
+  (eqv? (fxxor 0 0) 0)
+  (eqv? (fxxor 1 0) 1)
+  (eqv? (fxxor 1 1) 0)
+  (eqv? (fxxor 0 1) 1)
+  (eqv? (fxxor 2 1) 3)
+  (eqv? (fxxor 5 2) 7)
+  (eqv? (fxxor -1 2) -3)
+  (eqv? (fxxor) 0)
+  (eqv? (fxxor #x1212121)
+        #x1212121)
+  (eqv? (fxxor #x1212121
+                  #x2222222
+                  #x0301030)
+        #x3331333)
+  (eqv? (fxxor #b1010111
+                  #b1001011
+                  -1
+                  #b1011110
+                  #b1000111)
+        -6)
+  (eqv? (fxxor #b1010111
+                  #b1001011
+                  0
+                  #b1011110
+                  #b1000111)
+        5)
+  (test-cp0-expansion eqv? '(fxxor 0 0) 0)
+  (test-cp0-expansion eqv? '(fxxor 1 0) 1)
+  (test-cp0-expansion eqv? '(fxxor 1 1) 0)
+  (test-cp0-expansion eqv? '(fxxor 0 1) 1)
+  (test-cp0-expansion eqv? '(fxxor 2 1) 3)
+  (test-cp0-expansion eqv? '(fxxor 5 2) 7)
+  (test-cp0-expansion eqv? '(fxxor -1 2) -3)
+  (test-cp0-expansion eqv? '(fxxor) 0)
+  (test-cp0-expansion eqv? '(fxxor #x1212121) #x1212121)
+  (test-cp0-expansion eqv? 
+    '(fxxor #x1212121
+       #x2222222
+       #x0301030)
+    #x3331333)
+  (test-cp0-expansion eqv? 
+    '(fxxor #b1010111
+       #b1001011
+       -1
+       #b1011110
+       #b1000111)
+    -6)
+  (test-cp0-expansion eqv? 
+    '(fxxor #b1010111
+       #b1001011
+       0
+       #b1011110
+       #b1000111)
+    5)
+ )
+
+(mat fxlognot
+  (error? (fxlognot "hello"))
+  (error? (fxlognot (+ (most-positive-fixnum) 1)))
+  (error? (fxlognot (- (most-negative-fixnum) 1)))
+  (eqv? (fxlognot 0) -1)
+  (eqv? (fxlognot -1) 0)
+  (eqv? (fxlognot 2) -3)
+  (test-cp0-expansion eqv? '(fxlognot 0) -1)
+  (test-cp0-expansion eqv? '(fxlognot -1) 0)
+  (test-cp0-expansion eqv? '(fxlognot 2) -3)
+ )
+
+(mat fxnot
+  (error? (fxnot "hello"))
+  (error? (fxnot (+ (most-positive-fixnum) 1)))
+  (error? (fxnot (- (most-negative-fixnum) 1)))
+  (eqv? (fxnot 0) -1)
+  (eqv? (fxnot -1) 0)
+  (eqv? (fxnot 2) -3)
+  (test-cp0-expansion eqv? '(fxnot 0) -1)
+  (test-cp0-expansion eqv? '(fxnot -1) 0)
+  (test-cp0-expansion eqv? '(fxnot 2) -3)
+ )
+
+(mat fxsll
+  (error? (fxsll 1 -1))
+  (eqv? (fxsll 1 0) 1)
+  (eqv? (fxsll 1 1) 2)
+  (eqv? (fxsll 1 2) 4)
+  (eqv? (fxsll 1 3) 8)
+  (eqv? (fxsll 1 4) 16)
+  (eqv? (fxsll 1 (/ 8 2)) 16)
+  (eqv? (fxsll (fxsra (most-positive-fixnum) 1) 1) (- (most-positive-fixnum) 1))
+  (eqv? (fxsll (fxsra (most-negative-fixnum) 1) 1) (most-negative-fixnum))
+  (error? (fxsll 0 (+ (fixnum-width) 1)))
+ ; check for overflow error when sign changes
+  (error? (fxsll 1 (- (fixnum-width) 1)))
+  (error? (fxsll #x1001 (- (fixnum-width) 2)))
+  (error? (fxsll -1 (fixnum-width)))
+  (error? (fxsll (most-positive-fixnum) 1))
+  (error? (fxsll (most-positive-fixnum) 10))
+  (error? (fxsll #x-1001 (- (fixnum-width) 2)))
+  (error? (fxsll (most-negative-fixnum) 1))
+  (eqv? (fxsll 0 (fixnum-width)) 0)
+  (let ()
+    (define expt2
+      (lambda (i)
+        (if (= i 0)
+            1
+            (* 2 (expt2 (- i 1))))))
+    (define check ; use trace-define to debug
+      (lambda (i)
+        (let ([x (expt2 i)])
+          (and (eqv? (fxsll 1 i) x)
+               (eqv? (fxsll -1 i) (- x))))))
+    (do ([i 0 (fx+ i 1)] [a #t (and a (check i))])
+        ((fx= i (- (fixnum-width) 1)) a)))
+  (test-cp0-expansion eqv? '(fxsll 1 0) 1)
+  (test-cp0-expansion eqv? '(fxsll 1 1) 2)
+  (test-cp0-expansion eqv? '(fxsll 1 2) 4)
+  (test-cp0-expansion eqv? '(fxsll 1 3) 8)
+  (test-cp0-expansion eqv? '(fxsll 1 4) 16)
+  (test-cp0-expansion eqv? '(fxsll 1 (/ 8 2)) 16)
+ )
+
+(mat fxarithmetic-shift-left
+ ; bound on shift count is one less than for fxsll
+  (error? (fxarithmetic-shift-left 0 (fixnum-width)))
+  (error? (fxarithmetic-shift-left 0 'a))
+  (error? (fxarithmetic-shift-left 0 1e23))
+  (error? (fxarithmetic-shift-left 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxarithmetic-shift-left 1 -1))
+  (eqv? (fxarithmetic-shift-left 1 0) 1)
+  (eqv? (fxarithmetic-shift-left 1 1) 2)
+  (eqv? (fxarithmetic-shift-left 1 2) 4)
+  (eqv? (fxarithmetic-shift-left 1 3) 8)
+  (eqv? (fxarithmetic-shift-left 1 4) 16)
+  (eqv? (fxarithmetic-shift-left 1 (/ 8 2)) 16)
+  (eqv? (fxarithmetic-shift-left (fxsra (most-positive-fixnum) 1) 1) (- (most-positive-fixnum) 1))
+  (eqv? (fxarithmetic-shift-left (fxsra (most-negative-fixnum) 1) 1) (most-negative-fixnum))
+ ; check for overflow error when sign changes
+  (error? (fxarithmetic-shift-left 1 (- (fixnum-width) 1)))
+  (error? (fxarithmetic-shift-left #x1001 (- (fixnum-width) 2)))
+  (error? (fxarithmetic-shift-left -1 (fixnum-width)))
+  (error? (fxarithmetic-shift-left (most-positive-fixnum) 1))
+  (error? (fxarithmetic-shift-left (most-positive-fixnum) 10))
+  (error? (fxarithmetic-shift-left #x-1001 (- (fixnum-width) 2)))
+  (error? (fxarithmetic-shift-left (most-negative-fixnum) 1))
+  (let ()
+    (define expt2
+      (lambda (i)
+        (if (= i 0)
+            1
+            (* 2 (expt2 (- i 1))))))
+    (define check ; use trace-define to debug
+      (lambda (i)
+        (let ([x (expt2 i)])
+          (and (eqv? (fxarithmetic-shift-left 1 i) x)
+               (eqv? (fxarithmetic-shift-left -1 i) (- x))))))
+    (do ([i 0 (fx+ i 1)] [a #t (and a (check i))])
+        ((fx= i (- (fixnum-width) 1)) a)))
+  (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 0) 1)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 1) 2)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 2) 4)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 3) 8)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 4) 16)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 (/ 8 2)) 16)
+ )
+
+(mat fxsrl
+   (error? (fxsrl 1 -1))
+   (error? (fxsrl 1 (+ (integer-length (most-positive-fixnum)) 2)))
+   (error? (fxsrl 1 'a))
+   (error? (fxsrl 'a 17))
+   (error? (fxsrl (+ (most-positive-fixnum) 1) 2))
+   (eqv? (fxsrl 16 5) 0)
+   (eqv? (fxsrl 16 4) 1)
+   (eqv? (fxsrl 16 3) 2)
+   (eqv? (fxsrl 16 2) 4)
+   (eqv? (fxsrl 16 1) 8)
+   (eqv? (fxsrl 16 0) 16)
+   (eqv? (fxsrl -1 1) (most-positive-fixnum))
+   (eqv? (fxsrl 16 (/ 8 2)) 1)
+   (test-cp0-expansion eqv? '(fxsrl 16 5) 0)
+   (test-cp0-expansion eqv? '(fxsrl 16 4) 1)
+   (test-cp0-expansion eqv? '(fxsrl 16 3) 2)
+   (test-cp0-expansion eqv? '(fxsrl 16 2) 4)
+   (test-cp0-expansion eqv? '(fxsrl 16 1) 8)
+   (test-cp0-expansion eqv? '(fxsrl 16 0) 16)
+   (test-cp0-expansion eqv? '(fxsrl -1 1) (most-positive-fixnum))
+   (test-cp0-expansion eqv? '(fxsrl 16 (/ 8 2)) 1)
+)
+
+(mat fxsra
+   (error? (fxsra 1 -1))
+   (error? (fxsra 1 (+ (integer-length (most-positive-fixnum)) 2)))
+   (error? (fxsra 1 'a))
+   (error? (fxsra 'a 17))
+   (error? (fxsra (+ (most-positive-fixnum) 1) 2))
+   (error? (fxsra 0 (+ (fixnum-width) 1)))
+   (eqv? (fxsra 0 (fixnum-width)) 0)
+   (eqv? (fxsra 16 5) 0)
+   (eqv? (fxsra 16 4) 1)
+   (eqv? (fxsra 16 3) 2)
+   (eqv? (fxsra 16 2) 4)
+   (eqv? (fxsra 16 1) 8)
+   (eqv? (fxsra 16 0) 16)
+   (eqv? (fxsra -1 1) -1)
+   (eqv? (fxsra 16 (/ 8 2)) 1)
+   (test-cp0-expansion eqv? '(fxsra 0 (fixnum-width)) 0)
+   (test-cp0-expansion eqv? '(fxsra 16 5) 0)
+   (test-cp0-expansion eqv? '(fxsra 16 4) 1)
+   (test-cp0-expansion eqv? '(fxsra 16 3) 2)
+   (test-cp0-expansion eqv? '(fxsra 16 2) 4)
+   (test-cp0-expansion eqv? '(fxsra 16 1) 8)
+   (test-cp0-expansion eqv? '(fxsra 16 0) 16)
+   (test-cp0-expansion eqv? '(fxsra -1 1) -1)
+   (test-cp0-expansion eqv? '(fxsra 16 (/ 8 2)) 1)
+)
+
+(mat fxarithmetic-shift-right
+ ; bound on shift count is one less than for fxsll
+   (error? (fxarithmetic-shift-right 1 -1))
+   (error? (fxarithmetic-shift-right 1 (+ (integer-length (most-positive-fixnum)) 2)))
+   (error? (fxarithmetic-shift-right 1 'a))
+   (error? (fxarithmetic-shift-right 'a 17))
+   (error? (fxarithmetic-shift-right (+ (most-positive-fixnum) 1) 2))
+   (error? (fxarithmetic-shift-right 0 (fixnum-width)))
+   (eqv? (fxarithmetic-shift-right 16 5) 0)
+   (eqv? (fxarithmetic-shift-right 16 4) 1)
+   (eqv? (fxarithmetic-shift-right 16 3) 2)
+   (eqv? (fxarithmetic-shift-right 16 2) 4)
+   (eqv? (fxarithmetic-shift-right 16 1) 8)
+   (eqv? (fxarithmetic-shift-right 16 0) 16)
+   (eqv? (fxarithmetic-shift-right -1 1) -1)
+   (eqv? (fxarithmetic-shift-right 16 (/ 8 2)) 1)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 5) 0)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 4) 1)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 3) 2)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 2) 4)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 1) 8)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 0) 16)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right -1 1) -1)
+   (test-cp0-expansion eqv? '(fxarithmetic-shift-right 16 (/ 8 2)) 1)
+)
+
+(mat fxarithmetic-shift
+  (error? (fxarithmetic-shift 1 (fixnum-width)))
+  (error? (fxarithmetic-shift 1 (- (fixnum-width))))
+  (error? (fxarithmetic-shift 1 'a))
+  (error? (fxarithmetic-shift 'a 17))
+  (error? (fxarithmetic-shift (+ (most-positive-fixnum) 1) 2))
+  (eqv? (fxarithmetic-shift 0 (- (fixnum-width) 1)) 0)
+  (eqv? (fxarithmetic-shift 16 -5) 0)
+  (eqv? (fxarithmetic-shift 16 -4) 1)
+  (eqv? (fxarithmetic-shift 16 -3) 2)
+  (eqv? (fxarithmetic-shift 16 -2) 4)
+  (eqv? (fxarithmetic-shift 16 -1) 8)
+  (eqv? (fxarithmetic-shift 16 -0) 16)
+  (eqv? (fxarithmetic-shift -1 -1) -1)
+  (eqv? (fxarithmetic-shift 16 (/ -8 2)) 1)
+  (eqv? (fxarithmetic-shift 1 0) 1)
+  (eqv? (fxarithmetic-shift 1 1) 2)
+  (eqv? (fxarithmetic-shift 1 2) 4)
+  (eqv? (fxarithmetic-shift 1 3) 8)
+  (eqv? (fxarithmetic-shift 1 4) 16)
+  (eqv? (fxarithmetic-shift 1 (/ 8 2)) 16)
+  (eqv? (fxarithmetic-shift (fxsra (most-positive-fixnum) 1) 1) (- (most-positive-fixnum) 1))
+  (eqv? (fxarithmetic-shift (fxsra (most-negative-fixnum) 1) 1) (most-negative-fixnum))
+ ; check for overflow error when sign changes
+  (error? (fxarithmetic-shift 1 (- (fixnum-width) 1)))
+  (error? (fxarithmetic-shift #x1001 (- (fixnum-width) 2)))
+  (error? (fxarithmetic-shift -1 (fixnum-width)))
+  (error? (fxarithmetic-shift (most-positive-fixnum) 1))
+  (error? (fxarithmetic-shift (most-positive-fixnum) 10))
+  (error? (fxarithmetic-shift #x-1001 (- (fixnum-width) 2)))
+  (error? (fxarithmetic-shift (most-negative-fixnum) 1))
+  (let ()
+    (define expt2
+      (lambda (i)
+        (if (= i 0)
+            1
+            (* 2 (expt2 (- i 1))))))
+    (define check ; use trace-define to debug
+      (lambda (i)
+        (let ([x (expt2 i)])
+          (and (eqv? (fxarithmetic-shift 1 i) x)
+               (eqv? (fxarithmetic-shift -1 i) (- x))))))
+    (do ([i 0 (fx+ i 1)] [a #t (and a (check i))])
+        ((fx= i (- (fixnum-width) 1)) a)))
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 0 (- (fixnum-width) 1)) 0)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 -5) 0)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 -4) 1)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 -3) 2)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 -2) 4)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 -1) 8)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 -0) 16)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift -1 -1) -1)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 16 (/ -8 2)) 1)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 1 0) 1)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 1 1) 2)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 1 2) 4)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 1 3) 8)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 1 4) 16)
+  (test-cp0-expansion eqv? '(fxarithmetic-shift 1 (/ 8 2)) 16)
+ )
+
+(mat fxbit-field
+  (error? (fxbit-field))
+  (error? (fxbit-field 35))
+  (error? (fxbit-field 35 5))
+  (error? (fxbit-field 35 5 8 15))
+  (error? (fxbit-field 35.0 5 8))
+  (error? (fxbit-field 35 5.0 8))
+  (error? (fxbit-field 35 5 8.0))
+  (error? (fxbit-field 'a 5 8))
+  (error? (fxbit-field 35 '(a b) 8))
+  (error? (fxbit-field 35 5 "hello"))
+  (error? (fxbit-field 35 -5 8))
+  (error? (fxbit-field 35 5 -8))
+  (error? (fxbit-field 35 5 3))
+  (error? (fxbit-field 35 (* (greatest-fixnum) 2) (+ (* (greatest-fixnum) 2) 10)))
+  (error? (fxbit-field 35 10 (+ (* (greatest-fixnum) 2) 10)))
+  (error? (fxbit-field 35 (fixnum-width) (fixnum-width)))
+  (error? (fxbit-field 35 0 (fixnum-width)))
+  (eqv? (fxbit-field #b11100100111110101011 5 5) 0)
+  (eqv? (fxbit-field #b11100100111110101011 5 6) 1)
+  (eqv? (fxbit-field #b11100100111110101011 0 8) #b10101011)
+  (eqv? (fxbit-field #b11100100111110101011 5 15) #b1001111101)
+  (eqv? (fxbit-field #b11100100111110101011 5 23) #b111001001111101)
+  (eqv? (fxbit-field -1 5 23) #b111111111111111111)
+  (eqv? (fxbit-field -5 0 5) #b11011)
+  (eqv? (fxbit-field -5 1 5) #b1101)
+  (eqv? (fxbit-field -5 2 5) #b110)
+  (eqv? (fxbit-field -5 2 20) #b111111111111111110)
+  (do ([n 10000 (fx- n 1)])
+      ((fx= n 0) #t)
+    (let ([x (random (greatest-fixnum))])
+      (let ([len (fxlength x)])
+        (let ([i (random len)] [j (random len)])
+          (let-values ([(i j) (if (fx< i j) (values i j) (values j i))])
+            (unless (= (fxior (fxarithmetic-shift-left (fxbit-field x i j) i)
+                              (fxarithmetic-shift-left (fxbit-field x j len) j)
+                              (fxbit-field x 0 i))
+                       x)
+              (errorf #f "failed for ~s, ~s, ~s" x i j)))))))
+  (do ([n 10000 (fx- n 1)])
+      ((fx= n 0) #t)
+    (let ([x (- (random (greatest-fixnum)))])
+      (let ([len (fxlength x)])
+        (let ([i (random len)] [j (random len)])
+          (let-values ([(i j) (if (fx< i j) (values i j) (values j i))])
+            (unless (= (fxior (fxarithmetic-shift-left -1 len)
+                              (fxarithmetic-shift-left (fxbit-field x i j) i)
+                              (fxarithmetic-shift-left (fxbit-field x j len) j)
+                              (fxbit-field x 0 i))
+                       x)
+              (errorf #f "failed for ~s, ~s, ~s" x i j)))))))
+  (eqv? (fxbit-field 3 15 23) 0)
+  (eqv? (fxbit-field -3 15 23) #b11111111)
+
+  (test-cp0-expansion eqv? '(fxbit-field #b11100100111110101011 5 5) 0)
+  (test-cp0-expansion eqv? '(fxbit-field #b11100100111110101011 5 6) 1)
+  (test-cp0-expansion eqv? '(fxbit-field #b11100100111110101011 0 8) #b10101011)
+  (test-cp0-expansion eqv? '(fxbit-field #b11100100111110101011 5 15) #b1001111101)
+  (test-cp0-expansion eqv? '(fxbit-field #b11100100111110101011 5 23) #b111001001111101)
+  (test-cp0-expansion eqv? '(fxbit-field -1 5 23) #b111111111111111111)
+  (test-cp0-expansion eqv? '(fxbit-field -5 0 5) #b11011)
+  (test-cp0-expansion eqv? '(fxbit-field -5 1 5) #b1101)
+  (test-cp0-expansion eqv? '(fxbit-field -5 2 5) #b110)
+  (test-cp0-expansion eqv? '(fxbit-field -5 2 20) #b111111111111111110)
+  (test-cp0-expansion eqv? '(fxbit-field 3 15 23) 0)
+  (test-cp0-expansion eqv? '(fxbit-field -3 15 23) #b11111111)
+)
+
+(mat fxlength
+   (error? (fxlength))
+   (error? (fxlength 1 1 1))
+   (error? (fxlength .1))
+   (= (fxlength 0) 0)
+   (= (fxlength 1) 1)
+   (= (fxlength 3) 2)
+   (= (fxlength 4) 3)
+   (= (fxlength 7) 3)
+   (= (fxlength -1) 0)
+   (= (fxlength -4) 2)
+   (= (fxlength -7) 3)
+   (= (fxlength -8) 3)
+   (= (fxlength (most-positive-fixnum)) (- (fixnum-width) 1))
+   (= (fxlength (most-negative-fixnum)) (- (fixnum-width) 1))
+   (test-cp0-expansion = '(fxlength 0) 0)
+   (test-cp0-expansion = '(fxlength 1) 1)
+   (test-cp0-expansion = '(fxlength 3) 2)
+   (test-cp0-expansion = '(fxlength 4) 3)
+   (test-cp0-expansion = '(fxlength 7) 3)
+   (test-cp0-expansion = '(fxlength -1) 0)
+   (test-cp0-expansion = '(fxlength -4) 2)
+   (test-cp0-expansion = '(fxlength -7) 3)
+   (test-cp0-expansion = '(fxlength -8) 3)
+   (test-cp0-expansion = '(fxlength (most-positive-fixnum)) (- (fixnum-width) 1))
+   (test-cp0-expansion = '(fxlength (most-negative-fixnum)) (- (fixnum-width) 1))
+   (let ()
+     (define r6rs-length
+       (lambda (x)
+         (do ([result 0 (fx+ result 1)]
+              [bits (if (fxnegative? x) (fxnot x) x)
+                    (fxarithmetic-shift-right bits 1)])
+             ((fxzero? bits) result))))
+     (let f ([n 10000])
+       (or (fx= n 0)
+           (let ([x (random (greatest-fixnum))])
+             (and (= (fxlength x) (r6rs-length x))
+                  (= (fxlength (- x)) (r6rs-length (- x)))
+                  (f (fx- n 1)))))))
+)
+
+(mat fxbit-count
+  (error? (fxbit-count))
+  (error? (fxbit-count 75 32))
+  (error? (fxbit-count 3.0))
+  (error? (fxbit-count 'a))
+  (error? (fxbit-count (+ (most-positive-fixnum) 1)))
+  (error? (fxbit-count (- (most-negative-fixnum) 1)))
+  (eqv? (fxbit-count 0) 0)
+  (eqv? (fxbit-count #xabcd) 10)
+  (eqv? (fxbit-count -1) -1)
+  (eqv? (fxbit-count -10) -3)
+  (equal?
+    (map fxbit-count '(0 1 2 3 4 5 6 7 8 9 10))
+    '(0 1 1 2 1 2 2 3 1 2 2))
+  (equal?
+    (map fxbit-count '(-1 -2 -3 -4 -5 -6 -7 -8 -9 -10))
+    '(-1 -2 -2 -3 -2 -3 -3 -4 -2 -3))
+  (test-cp0-expansion eqv? '(fxbit-count 0) 0)
+  (test-cp0-expansion eqv? '(fxbit-count #xabcd) 10)
+  (test-cp0-expansion eqv? '(fxbit-count -1) -1)
+  (test-cp0-expansion eqv? '(fxbit-count -10) -3)
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxbit-count ,x))))
+      '(0 1 2 3 4 5 6 7 8 9 10))
+    '(0 1 1 2 1 2 2 3 1 2 2))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxbit-count ,x))))
+      '(-1 -2 -3 -4 -5 -6 -7 -8 -9 -10))
+    '(-1 -2 -2 -3 -2 -3 -3 -4 -2 -3))
+  (let ([n (+ (greatest-fixnum) 1)])
+    (let f ([i 2] [j 1])
+      (or (= i n)
+          (and (eqv? (fxbit-count i) 1)
+               (eqv? (fxbit-count (+ i 1)) 2)
+               (eqv? (fxbit-count (- i 1)) j)
+               (f (bitwise-arithmetic-shift i 1) (+ j 1))))))
+  (let ([n (+ (greatest-fixnum) 1)])
+    (define slow-bit-count
+      (lambda (x)
+        (if (< x 0)
+            (bitwise-not (slow-bit-count (bitwise-not x)))
+            (let f ([x x] [c 0])
+              (if (= x 0)
+                  c
+                  (f (bitwise-arithmetic-shift-right x 1)
+                     (if (bitwise-bit-set? x 0) (+ c 1) c)))))))
+    (let f ([i 10000])
+      (let ([r (random n)])
+        (or (fx= i 0)
+            (and (= (fxbit-count r) (slow-bit-count r))
+                 (= (fxbit-count (- r)) (slow-bit-count (- r)))
+                 (f (fx- i 1)))))))
+)
+
+(mat fxfirst-bit-set
+  (error? (fxfirst-bit-set))
+  (error? (fxfirst-bit-set 75 32))
+  (error? (fxfirst-bit-set 3.0))
+  (error? (fxfirst-bit-set 'a))
+  (error? (fxfirst-bit-set (+ (most-positive-fixnum) 1)))
+  (error? (fxfirst-bit-set (- (most-negative-fixnum) 1)))
+  (eqv? (fxfirst-bit-set 0) -1)
+  (eqv? (fxfirst-bit-set 1) 0)
+  (eqv? (fxfirst-bit-set -1) 0)
+  (eqv? (fxfirst-bit-set -4) 2)
+  (eqv? (fxfirst-bit-set (least-fixnum)) (fx- (fixnum-width) 1))
+  (equal?
+    (map fxfirst-bit-set '(0 1 2 3 4 5 6 7 8 9 10))
+    '(-1 0 1 0 2 0 1 0 3 0 1))
+  (equal?
+    (map fxfirst-bit-set '(-1 -2 -3 -4 -5 -6 -7 -8 -9 -10))
+    '(0 1 0 2 0 1 0 3 0 1))
+  (test-cp0-expansion eqv? '(fxfirst-bit-set 0) -1)
+  (test-cp0-expansion eqv? '(fxfirst-bit-set 1) 0)
+  (test-cp0-expansion eqv? '(fxfirst-bit-set -1) 0)
+  (test-cp0-expansion eqv? '(fxfirst-bit-set -4) 2)
+  (test-cp0-expansion eqv? '(fxfirst-bit-set (least-fixnum)) (fx- (fixnum-width) 1))
+  (equal?
+    (map (lambda (x)
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxfirst-bit-set ,x))))
+      '(0 1 2 3 4 5 6 7 8 9 10))
+    '(-1 0 1 0 2 0 1 0 3 0 1))
+  (equal?
+    (map (lambda (x)
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxfirst-bit-set ,x))))
+      '(-1 -2 -3 -4 -5 -6 -7 -8 -9 -10))
+    '(0 1 0 2 0 1 0 3 0 1))
+  (let ([n (+ (greatest-fixnum) 1)])
+    (let f ([i 2] [j 1])
+      (or (= i n)
+          (and (eqv? (fxfirst-bit-set i) j)
+               (eqv? (fxfirst-bit-set (+ i 1)) 0)
+               (eqv? (fxfirst-bit-set (- i 1)) 0)
+               (f (bitwise-arithmetic-shift i 1) (fx+ j 1))))))
+  (let ([n (+ (greatest-fixnum) 1)])
+    (define slow-first-bit-set
+      (lambda (x)
+        (if (= x 0)
+            0
+            (let f ([x x])
+              (if (fxodd? x) 0 (+ (f (fxsrl x 1)) 1))))))
+    (let f ([i 10000])
+      (let ([r (random n)])
+        (unless (fx= i 0)
+          (unless (and (= (fxfirst-bit-set r) (slow-first-bit-set r))
+                       (= (fxfirst-bit-set (- r)) (slow-first-bit-set (- r))))
+            (errorf #f "failed for ~s" r))
+          (f (fx- i 1)))))
+    #t)
+)
+
+(mat fxlogtest
+  (error? (fxlogtest))
+  (error? (fxlogtest 1))
+  (error? (fxlogtest 1 2 3))
+  (error? (fxlogtest 3.4 5))
+  (error? (fxlogtest 5 "3"))
+  (error? (fxlogtest (+ (most-positive-fixnum) 1) 0))
+  (error? (fxlogtest 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxlogtest (- (most-negative-fixnum) 1) 0))
+  (error? (fxlogtest 0 (- (most-negative-fixnum) 1)))
+  (eqv? (fxlogtest 750 -1) #t)
+  (eqv? (fxlogtest -1 -6) #t)
+  (eqv? (fxlogtest 0 -1) #f)
+  (eqv? (fxlogtest -1 0) #f)
+  (eqv? (fxlogtest #b1000101001 #b0111010110) #f)
+  (eqv? (fxlogtest #b1000101001 #b0111110110) #t)
+  (eqv? (fxlogtest #b1010101001 #b0111010110) #t)
+  (eqv? (fxlogtest (most-positive-fixnum) 3) #t)
+  (eqv? (fxlogtest (most-negative-fixnum) 3) #f)
+  (eqv? (fxlogtest (most-negative-fixnum) (most-negative-fixnum)) #t)
+  (eqv? (fxlogtest (most-negative-fixnum) (most-positive-fixnum)) #f)
+  (test-cp0-expansion eqv? '(fxlogtest #b1000101001 #b0111010110) #f)
+  (test-cp0-expansion eqv? '(fxlogtest #b1000101001 #b0111110110) #t)
+  (test-cp0-expansion eqv? '(fxlogtest #b1010101001 #b0111010110) #t)
+  (test-cp0-expansion eqv? '(fxlogtest (most-positive-fixnum) 3) #t)
+  (test-cp0-expansion eqv? '(fxlogtest (most-negative-fixnum) 3) #f)
+  (test-cp0-expansion eqv? '(fxlogtest (most-negative-fixnum) (most-negative-fixnum)) #t)
+  (test-cp0-expansion eqv? '(fxlogtest (most-negative-fixnum) (most-positive-fixnum)) #f)
+
+ ; make sure we've properly labeled fxlogtest an arith-pred in primvars.ss
+  (begin
+    (define ($fxlogtest-foo x y)
+      (if (fxlogtest x y)
+          'yes
+          'no))
+    (equal?
+      (list ($fxlogtest-foo 3 4) ($fxlogtest-foo 3 3))
+      '(no yes)))
+)
+
+(mat fxif
+  (error? (fxif))
+  (error? (fxif 0))
+  (error? (fxif 0 0))
+  (error? (fxif 0 0 0 0))
+  (error? (fxif 'a 0 0))
+  (error? (fxif 0 3.4 0))
+  (error? (fxif 0 0 '(a)))
+  (error? (fxif (+ (most-positive-fixnum) 1) 0 0))
+  (error? (fxif 0 (+ (most-positive-fixnum) 1) 0))
+  (error? (fxif 0 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxif (- (most-negative-fixnum) 1) 0 0))
+  (error? (fxif 0 (- (most-negative-fixnum) 1) 0))
+  (error? (fxif 0 0 (- (most-negative-fixnum) 1)))
+  (eqv? (fxif 0 0 0) 0)
+  (eqv? (fxif 0 -1 0) 0)
+  (eqv? (fxif 0 0 -1) -1)
+  (eqv? (fxif #b10101010 0 -1) (fxnot #b10101010))
+  (eqv? (fxif #b10101010 -1 0) #b10101010)
+  (eqv? (fxif #b11001110001101
+              #b11111110000000
+              #b11001100110011)
+        #b11001110110010)
+  (test-cp0-expansion eqv? '(fxif 0 0 0) 0)
+  (test-cp0-expansion eqv? '(fxif 0 -1 0) 0)
+  (test-cp0-expansion eqv? '(fxif 0 0 -1) -1)
+  (test-cp0-expansion eqv? '(fxif #b10101010 0 -1) (fxnot #b10101010))
+  (test-cp0-expansion eqv? '(fxif #b10101010 -1 0) #b10101010)
+  (test-cp0-expansion eqv? 
+    '(fxif #b11001110001101
+       #b11111110000000
+       #b11001100110011)
+    #b11001110110010)
+  (let ([n (+ (greatest-fixnum) 1)])
+    (define r6rs-fxif
+      (lambda (ei1 ei2 ei3)
+        (bitwise-ior (bitwise-and ei1 ei2)
+                     (bitwise-and (bitwise-not ei1) ei3))))
+    (let f ([i 10000])
+      (unless (fx= i 0)
+        (let ([x (random n)] [y (random n)] [z (random n)])
+          (unless (and (= (fxif x y z) (r6rs-fxif x y z))
+                       (= (fxif (fxnot x) y z) (r6rs-fxif (fxnot x) y z))
+                       (= (fxif (fxnot x) y (fxnot z)) (r6rs-fxif (fxnot x) y (fxnot z)))
+                       (= (fxif x (fxnot y) z) (r6rs-fxif x (fxnot y) z))
+                       (= (fxif (fxnot x) (fxnot y) (fxnot z)) (r6rs-fxif (fxnot x) (fxnot y) (fxnot z))))
+            (errorf #f "failed for ~s, ~s, ~s" x y z)))
+        (f (fx- i 1))))
+    #t)
+)
+
+(mat fxlogbit?
+  (error? (fxlogbit?))
+  (error? (fxlogbit? 1))
+  (error? (fxlogbit? 1 2 3))
+  (error? (fxlogbit? 3.4 5))
+  (error? (fxlogbit? 5 "3"))
+  (error? (fxlogbit? 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxlogbit? 0 (- (most-negative-fixnum) 1)))
+  (error? (fxlogbit? -1 -1))
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (fxlogbit? i -1))])
+            ((fx> i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (fxlogbit? i (most-positive-fixnum)))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (fxlogbit? (integer-length (most-positive-fixnum)) (most-positive-fixnum)) #f)
+  (eqv? (fxlogbit? 0 #b0111010110) #f)
+  (eqv? (fxlogbit? 4 #b0111010110) #t)
+  (eqv? (fxlogbit? 8 #b0111010110) #t)
+  (eqv? (fxlogbit? 9 #b0111010110) #f)
+  (eqv? (fxlogbit? (integer-length (most-positive-fixnum)) #b0111010110) #f)
+  (eqv? (fxlogbit? 0 -6) #f)
+  (eqv? (fxlogbit? 1 -6) #t)
+  (eqv? (fxlogbit? 2 -6) #f)
+  (eqv? (do ([i 3 (fx+ i 1)] [a #t (and a (fxlogbit? i -6))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+ ; check to see if we can look as far to the left as we please ...
+  (eqv? (fxlogbit? (+ (integer-length (most-positive-fixnum)) 1) -1) #t)
+  (eqv? (fxlogbit? (expt (integer-length (most-positive-fixnum)) 2) (most-positive-fixnum)) #f)
+  (eqv? (fxlogbit? (expt (integer-length (most-positive-fixnum)) 2) -1) #t)
+
+ ; make sure we've properly labeled fxlogbit? an arith-pred in primvars.ss
+  (begin
+    (define ($fxlogbit?-foo x y)
+      (if (fxlogbit? x y)
+          'yes
+          'no))
+    (equal?
+      (list ($fxlogbit?-foo 2 4) ($fxlogbit?-foo 3 3))
+      '(yes no)))
+  (test-cp0-expansion eqv? '(fxlogbit? (integer-length (most-positive-fixnum)) (most-positive-fixnum)) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? 0 #b0111010110) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? 4 #b0111010110) #t)
+  (test-cp0-expansion eqv? '(fxlogbit? 8 #b0111010110) #t)
+  (test-cp0-expansion eqv? '(fxlogbit? 9 #b0111010110) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? (integer-length (most-positive-fixnum)) #b0111010110) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? 0 -6) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? 1 -6) #t)
+  (test-cp0-expansion eqv? '(fxlogbit? 2 -6) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? (+ (integer-length (most-positive-fixnum)) 1) -1) #t)
+  (test-cp0-expansion eqv? '(fxlogbit? (expt (integer-length (most-positive-fixnum)) 2) (most-positive-fixnum)) #f)
+  (test-cp0-expansion eqv? '(fxlogbit? (expt (integer-length (most-positive-fixnum)) 2) -1) #t)
+)
+
+(mat fxbit-set?
+  (error? (fxbit-set?))
+  (error? (fxbit-set? 1))
+  (error? (fxbit-set? 1 2 3))
+  (error? (fxbit-set? 3.4 5))
+  (error? (fxbit-set? 5 "3"))
+  (error? (fxbit-set? (+ (most-positive-fixnum) 1) 0))
+  (error? (fxbit-set? (- (most-negative-fixnum) 1) 0))
+  (error? (fxbit-set? -1 -1))
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (fxbit-set? -1 i))])
+            ((fx> i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (do ([i 0 (fx+ i 1)] [a #t (and a (fxbit-set? (most-positive-fixnum) i))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+  (eqv? (fxbit-set? (most-positive-fixnum) (integer-length (most-positive-fixnum))) #f)
+  (eqv? (fxbit-set? #b0111010110 0) #f)
+  (eqv? (fxbit-set? #b0111010110 4) #t)
+  (eqv? (fxbit-set? #b0111010110 8) #t)
+  (eqv? (fxbit-set? #b0111010110 9) #f)
+  (eqv? (fxbit-set? #b0111010110 (integer-length (most-positive-fixnum))) #f)
+  (eqv? (fxbit-set? -6 0) #f)
+  (eqv? (fxbit-set? -6 1) #t)
+  (eqv? (fxbit-set? -6 2) #f)
+  (eqv? (do ([i 3 (fx+ i 1)] [a #t (and a (fxbit-set? -6 i))])
+            ((fx= i (integer-length (most-positive-fixnum))) a))
+        #t)
+ ; check to see if we can look as far to the left as we please ...
+  (eqv? (fxbit-set? -1 (+ (integer-length (most-positive-fixnum)) 1)) #t)
+  (eqv? (fxbit-set? (most-positive-fixnum) (expt (integer-length (most-positive-fixnum)) 2)) #f)
+  (eqv? (fxbit-set? -1 (expt (integer-length (most-positive-fixnum)) 2)) #t)
+
+ ; make sure we've properly labeled fxbit-set? an arith-pred in primvars.ss
+  (begin
+    (define ($fxbit-set?-foo x y)
+      (if (fxbit-set? x y)
+          'yes
+          'no))
+    (equal?
+      (list ($fxbit-set?-foo 4 2) ($fxbit-set?-foo 3 3))
+      '(yes no)))
+  ;; cp0 handler tests
+  (test-cp0-expansion eqv? '(fxbit-set? (most-positive-fixnum) (integer-length (most-positive-fixnum))) #f)
+  (test-cp0-expansion eqv? '(fxbit-set? #b0111010110 0) #f)
+  (test-cp0-expansion eqv? '(fxbit-set? #b0111010110 4) #t)
+  (test-cp0-expansion eqv? '(fxbit-set? #b0111010110 8) #t)
+  (test-cp0-expansion eqv? '(fxbit-set? #b0111010110 9) #f)
+  (test-cp0-expansion eqv? '(fxbit-set? #b0111010110 (integer-length (most-positive-fixnum))) #f)
+  (test-cp0-expansion eqv? '(fxbit-set? -6 0) #f)
+  (test-cp0-expansion eqv? '(fxbit-set? -6 1) #t)
+  (test-cp0-expansion eqv? '(fxbit-set? -6 2) #f)
+  ; check to see if we can look as far to the left as we please ...
+  (test-cp0-expansion eqv? '(fxbit-set? -1 (+ (integer-length (most-positive-fixnum)) 1)) #t)
+  (test-cp0-expansion eqv? '(fxbit-set? (most-positive-fixnum) (expt (integer-length (most-positive-fixnum)) 2)) #f)
+  (test-cp0-expansion eqv? '(fxbit-set? -1 (expt (integer-length (most-positive-fixnum)) 2)) #t)
+
+ ; make sure we've properly labeled fxbit-set? an arith-pred in primvars.ss
+  (begin
+    (define ($fxbit-set?-foo x y)
+      (if (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+            (expand/optimize `(fxbit-set? ,x ,y)))
+          'yes
+          'no))
+    (equal?
+      (list ($fxbit-set?-foo 4 2) ($fxbit-set?-foo 3 3))
+      '(yes no)))
+)
+
+(mat fxlogbit0
+  (error? (fxlogbit0))
+  (error? (fxlogbit0 1))
+  (error? (fxlogbit0 1 2 3))
+  (error? (fxlogbit0 3.4 5))
+  (error? (fxlogbit0 5 "3"))
+  (error? (fxlogbit0 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxlogbit0 0 (- (most-negative-fixnum) 1)))
+  (error? (fxlogbit0 -1 -1))
+  (error? (fxlogbit0 (integer-length (most-positive-fixnum)) -1))
+  (eqv? (fxlogbit0 2 0) 0)
+  (eqv? (fxlogbit0 2 -1) -5)
+  (eqv? (fxlogbit0 3 #b10101010) #b10100010)
+  (eqv? (fxlogbit0 4 #b10101010) #b10101010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (fxlogbit0 i -1) (fx- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (fxlogbit0 i n)
+                               (fxlogand (lognot (fxsll 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (test-cp0-expansion eqv? '(fxlogbit0 2 0) 0)
+  (test-cp0-expansion eqv? '(fxlogbit0 2 -1) -5)
+  (test-cp0-expansion eqv? '(fxlogbit0 3 #b10101010) #b10100010)
+  (test-cp0-expansion eqv? '(fxlogbit0 4 #b10101010) #b10101010)
+)
+
+(mat fxlogbit1
+  (error? (fxlogbit1))
+  (error? (fxlogbit1 1))
+  (error? (fxlogbit1 1 2 3))
+  (error? (fxlogbit1 3.4 5))
+  (error? (fxlogbit1 5 "3"))
+  (error? (fxlogbit1 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxlogbit1 0 (- (most-negative-fixnum) 1)))
+  (error? (fxlogbit1 -1 -1))
+  (error? (fxlogbit1 (integer-length (most-positive-fixnum)) 0))
+  (eqv? (fxlogbit1 2 0) 4)
+  (eqv? (fxlogbit1 2 -1) -1)
+  (eqv? (fxlogbit1 3 #b10101010) #b10101010)
+  (eqv? (fxlogbit1 4 #b10101010) #b10111010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (fxlogbit1 i 0) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (fxlogbit1 i n) (fxlogor (fxsll 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (test-cp0-expansion eqv? '(fxlogbit1 2 0) 4)
+  (test-cp0-expansion eqv? '(fxlogbit1 2 -1) -1)
+  (test-cp0-expansion eqv? '(fxlogbit1 3 #b10101010) #b10101010)
+  (test-cp0-expansion eqv? '(fxlogbit1 4 #b10101010) #b10111010)
+)
+
+(mat fxcopy-bit
+  (error? (fxcopy-bit))
+  (error? (fxcopy-bit 1))
+  (error? (fxcopy-bit 3 1))
+  (error? (fxcopy-bit 3 1 0 0))
+  (error? (fxcopy-bit 5 3.4 0))
+  (error? (fxcopy-bit "3" 5 0))
+  (error? (fxcopy-bit (+ (most-positive-fixnum) 1) 0 0))
+  (error? (fxcopy-bit (- (most-negative-fixnum) 1) 0 1))
+  (error? (fxcopy-bit -1 -1 0))
+  (error? (fxcopy-bit -1 -1 1))
+  (error? (fxcopy-bit -1 (fx- (fixnum-width) 1) 0))
+  (error? (fxcopy-bit -1 (fx- (fixnum-width) 1) 1))
+  (eqv? (fxcopy-bit 0 2 0) 0)
+  (eqv? (fxcopy-bit -1 2 0) -5)
+  (eqv? (fxcopy-bit #b10101010 3 0) #b10100010)
+  (eqv? (fxcopy-bit #b10101010 4 0) #b10101010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (fxcopy-bit -1 i 0) (fx- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (fxcopy-bit n i 0)
+                               (fxlogand (lognot (fxsll 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv? (fxcopy-bit 0 2 1) 4)
+  (eqv? (fxcopy-bit -1 2 1) -1)
+  (eqv? (fxcopy-bit #b10101010 3 1) #b10101010)
+  (eqv? (fxcopy-bit #b10101010 4 1) #b10111010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (fxcopy-bit 0 i 1) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (fxcopy-bit n i 1) (fxlogor (fxsll 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  ;; cp0 handler tests
+  (test-cp0-expansion eqv? '(fxcopy-bit 0 2 1) 4)
+  (test-cp0-expansion eqv? '(fxcopy-bit -1 2 1) -1)
+  (test-cp0-expansion eqv? '(fxcopy-bit #b10101010 3 1) #b10101010)
+  (test-cp0-expansion eqv? '(fxcopy-bit #b10101010 4 1) #b10111010)
+  (andmap values
+    (let ([p? (lambda (i) 
+                (fx= 
+                  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+                    (expand/optimize `(fxcopy-bit 0 ,i 1)))
+                  (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) 
+              (fx= 
+                (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+                  (expand/optimize `(fxcopy-bit ,n ,i 1)))
+                (fxlogor (fxsll 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+)
+
+(mat fxcopy-bit-field
+  (error? (fxcopy-bit-field))
+  (error? (fxcopy-bit-field 1))
+  (error? (fxcopy-bit-field 3 1))
+  (error? (fxcopy-bit-field 3 1 0))
+  (error? (fxcopy-bit-field 3 1 0 0 0))
+  (error? (fxcopy-bit-field "3" 0 0 0))
+  (error? (fxcopy-bit-field 0 3.4 0 0))
+  (error? (fxcopy-bit-field 0 0 3/4 0))
+  (error? (fxcopy-bit-field 0 0 0 'spam))
+  (error? (fxcopy-bit-field (+ (most-positive-fixnum) 1) 0 0 0))
+  (error? (fxcopy-bit-field (- (most-negative-fixnum) 1) 0 0 0))
+  (error? (fxcopy-bit-field 0 (+ (most-positive-fixnum) 1) 0 0))
+  (error? (fxcopy-bit-field 0 (- (most-negative-fixnum) 1) 0 0))
+  (error? (fxcopy-bit-field 0 0 (+ (most-positive-fixnum) 1) 0))
+  (error? (fxcopy-bit-field 0 0 (- (most-negative-fixnum) 1) 0))
+  (error? (fxcopy-bit-field 0 0 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxcopy-bit-field 0 0 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxcopy-bit-field 0 -1 0 0))
+  (error? (fxcopy-bit-field 0 0 -1 0))
+  (error? (fxcopy-bit-field 0 (fixnum-width) (fixnum-width) 0))
+  (error? (fxcopy-bit-field 0 0 (fixnum-width) 0))
+  (error? (fxcopy-bit-field 0 1 0 0))
+  (error? (fxcopy-bit-field 0 5 2 0))
+  (error? (fxcopy-bit-field 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2) 0))
+  (eqv? (fxcopy-bit-field 0 2 3 0) 0)
+  (eqv? (fxcopy-bit-field 0 2 3 -1) 4)
+  (eqv? (fxcopy-bit-field -1 2 3 0) -5)
+  (eqv? (fxcopy-bit-field -1 0 3 0) -8)
+  (eqv? (fxcopy-bit-field 0 0 3 -1) 7)
+  (eqv? (fxcopy-bit-field #b10101010 3 4 0) #b10100010)
+  (eqv? (fxcopy-bit-field #b10101010 4 5 0) #b10101010)
+  (eqv? (fxcopy-bit-field #b10101010 0 4 0) #b10100000)
+  (eqv? (fxcopy-bit-field #b10101010 0 4 #b0101) #b10100101)
+  (begin
+    (define $fxbf1
+      (let ([fb (fixnum-width)])
+        (lambda (x v)
+          (list
+            (fxcopy-bit-field x 0 (- fb 1) v)
+            (fxcopy-bit-field x 20 (- fb 1) v)))))
+    #t)
+  (equal?
+    ($fxbf1 0 0)
+    '(0 0))
+  (equal?
+    ($fxbf1 0 -1)
+    (list
+      (most-positive-fixnum)
+      (- (most-positive-fixnum) (- (expt 2 20) 1))))
+  (equal?
+    ($fxbf1 -1 0)
+    (list
+      (most-negative-fixnum)
+      (+ (most-negative-fixnum) (- (expt 2 20) 1))))
+
+  (andmap values
+    (let ([p? (lambda (i) (fx= (fxcopy-bit-field -1 i (fx+ i 1) 0) (fx- -1 (expt 2 i))))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (fxcopy-bit-field n i (fx+ i 1) 0)
+                               (fxlogand (lognot (fxsll 1 i)) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv? (fxcopy-bit-field 0 2 3 1) 4)
+  (eqv? (fxcopy-bit-field -1 2 3 1) -1)
+  (eqv? (fxcopy-bit-field #b10101010 3 4 1) #b10101010)
+  (eqv? (fxcopy-bit-field #b10101010 4 5 1) #b10111010)
+  (andmap values
+    (let ([p? (lambda (i) (fx= (fxcopy-bit-field 0 i (fx+ i 1) 1) (ash 1 i)))])
+      (let f ([i 0])
+        (if (fx= i (integer-length (most-positive-fixnum)))
+            '()
+            (cons (p? i) (f (fx+ i 1)))))))
+  (let ([p? (lambda (n i) (fx= (fxcopy-bit-field n i (fx+ i 1) 1) (fxlogor (fxsll 1 i) n)))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (integer-length (most-positive-fixnum)))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+  (let ([p? (lambda (n i) (fx= (fxcopy-bit-field n i (fx+ i 3) #b110110101)
+                               (fxior (fxsll #b101 i) (fxcopy-bit n (fx+ i 1) 0))))])
+    (let g ([j 1000])
+      (or (fx= j 0)
+          (let ([n (+ (random (+ (- (most-positive-fixnum)
+                                    (most-negative-fixnum))
+                                 1))
+                      (most-negative-fixnum))])
+            (let f ([i 0])
+              (if (fx= i (fx- (integer-length (most-positive-fixnum)) 3))
+                  (g (fx- j 1))
+                  (and (p? n i) (f (fx+ i 1)))))))))
+
+  (test-cp0-expansion eqv? '(fxcopy-bit-field 0 2 3 0) 0)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field 0 2 3 -1) 4)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field -1 2 3 0) -5)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field -1 0 3 0) -8)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field 0 0 3 -1) 7)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field #b10101010 3 4 0) #b10100010)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field #b10101010 4 5 0) #b10101010)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field #b10101010 0 4 0) #b10100000)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field #b10101010 0 4 #b0101) #b10100101)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field 0 2 3 1) 4)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field -1 2 3 1) -1)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field #b10101010 3 4 1) #b10101010)
+  (test-cp0-expansion eqv? '(fxcopy-bit-field #b10101010 4 5 1) #b10111010)
+)
+
+(mat fxdiv-and-mod
+ ; fxdiv-and-mod
+  (error? (fxdiv-and-mod 17 3.0))
+  (error? (fxdiv-and-mod 3.0 17))
+  (error? (fxdiv-and-mod 'a 17))
+  (error? (fxdiv-and-mod 17 '(a)))
+  (error? (fxdiv-and-mod 17 0))
+  (error? (fxdiv-and-mod -17 0))
+  (error? (fxdiv-and-mod (most-negative-fixnum) -1))
+ ; fxdiv
+  (error? (fxdiv 17 3.0))
+  (error? (fxdiv 3.0 17))
+  (error? (fxdiv 'a 17))
+  (error? (fxdiv 17 '(a)))
+  (error? (fxdiv 17 0))
+  (error? (fxdiv -17 0))
+  (error? (fxdiv (most-negative-fixnum) -1))
+ ; fxmod
+  (error? (fxmod 17 3.0))
+  (error? (fxmod 3.0 17))
+  (error? (fxmod 'a 17))
+  (error? (fxmod 17 '(a)))
+  (error? (fxmod 17 0))
+  (error? (fxmod -17 0))
+ ; no overflow for fxmod:
+  (eqv? (fxmod (most-negative-fixnum) -1) 0)
+ ; fxdiv-and-mod
+  (begin
+    (define $d&m fxdiv-and-mod)
+    (define ($dmpair x y)
+      (and (not (fx= y 0)) (call-with-values (lambda () ($d&m x y)) cons)))
+    (define ($dmpairs x y)
+      (list ($dmpair x y) ($dmpair (- x) y) ($dmpair x (- y)) ($dmpair (- x) (- y))
+            ($dmpair y x) ($dmpair (- y) x) ($dmpair y (- x)) ($dmpair (- y) (- x))))
+    #t)
+  (equal?
+    ($dmpairs 0 5)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  (equal?
+    ($dmpairs 15 37)
+    '((0 . 15) (-1 . 22) (0 . 15) (1 . 22) (2 . 7) (-3 . 8) (-2 . 7) (3 . 8)))
+  (equal?
+    ($dmpairs 24 8)
+    '((3 . 0) (-3 . 0) (-3 . 0) (3 . 0) (0 . 8) (-1 . 16) (0 . 8) (1 . 16)))
+ ; fxdiv with fxmod
+  (begin
+    (set! $d&m (lambda (x y) (values (fxdiv x y) (fxmod x y))))
+    #t)
+  (equal?
+    ($dmpairs 0 5)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  (equal?
+    ($dmpairs 15 37)
+    '((0 . 15) (-1 . 22) (0 . 15) (1 . 22) (2 . 7) (-3 . 8) (-2 . 7) (3 . 8)))
+  (equal?
+    ($dmpairs 24 8)
+    '((3 . 0) (-3 . 0) (-3 . 0) (3 . 0) (0 . 8) (-1 . 16) (0 . 8) (1 . 16)))
+  (equal?
+    (map (lambda (x) (fxdiv x 64))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 0 0 0 0 0 1 1 1 2 2))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxdiv ,x 64))))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 0 0 0 0 0 1 1 1 2 2))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxmod ,x 64))))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 32 33 63 0 1 63 0 1))
+  (equal?
+    (map (lambda (x) (let-values ([ls (fxdiv-and-mod x 64)]) ls))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '((0 0) (0 5) (0 31) (0 32) (0 33) (0 63) (1 0) (1 1) (1 63) (2 0) (2 1)))
+  (equal?
+    (map (lambda (x) (fxdiv x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 -1 -1 -1 -1 -1 -1 -2 -2 -2 -3))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxdiv ,x 64))))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 -1 -1 -1 -1 -1 -1 -2 -2 -2 -3))
+  (equal?
+    (map (lambda (x) (fxmod x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 59 33 32 31 1 0 63 1 0 63))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxmod ,x 64))))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 59 33 32 31 1 0 63 1 0 63))
+  (equal?
+    (map (lambda (x) (let-values ([ls (fxdiv-and-mod x 64)]) ls))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '((0 0) (-1 59) (-1 33) (-1 32) (-1 31) (-1 1) (-1 0) (-2 63) (-2 1) (-2 0) (-3 63)))
+)
+
+(mat fxdiv0-and-mod0
+ ; fxdiv0-and-mod0
+  (error? (fxdiv0-and-mod0 17 3.0))
+  (error? (fxdiv0-and-mod0 3.0 17))
+  (error? (fxdiv0-and-mod0 'a 17))
+  (error? (fxdiv0-and-mod0 17 '(a)))
+  (error? (fxdiv0-and-mod0 17 0))
+  (error? (fxdiv0-and-mod0 -17 0))
+  (error? (fxdiv0-and-mod0 (most-negative-fixnum) -1))
+ ; fxdiv0
+  (error? (fxdiv0 17 3.0))
+  (error? (fxdiv0 3.0 17))
+  (error? (fxdiv0 'a 17))
+  (error? (fxdiv0 17 '(a)))
+  (error? (fxdiv0 17 0))
+  (error? (fxdiv0 -17 0))
+  (error? (fxdiv0 (most-negative-fixnum) -1))
+ ; fxmod0
+  (error? (fxmod0 17 3.0))
+  (error? (fxmod0 3.0 17))
+  (error? (fxmod0 'a 17))
+  (error? (fxmod0 17 '(a)))
+  (error? (fxmod0 17 0))
+  (error? (fxmod0 -17 0))
+ ; no overflow for fxmod0:
+  (eqv? (fxmod0 (most-negative-fixnum) -1) 0)
+ ; fxdiv0-and-mod0
+  (begin
+    (define $d&m fxdiv0-and-mod0)
+    (define ($dmpair x y)
+      (and (not (fx= y 0)) (call-with-values (lambda () ($d&m x y)) cons)))
+    (define ($dmpairs x y)
+      (list ($dmpair x y) ($dmpair (- x) y) ($dmpair x (- y)) ($dmpair (- x) (- y))
+            ($dmpair y x) ($dmpair (- y) x) ($dmpair y (- x)) ($dmpair (- y) (- x))))
+    #t)
+  (equal?
+    ($dmpairs 0 5)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  (equal?
+    ($dmpairs 15 37)
+    '((0 . 15) (0 . -15) (0 . 15) (0 . -15)
+      (2 . 7) (-2 . -7) (-2 . 7) (2 . -7)))
+ ; fxdiv0 with fxmod0
+  (begin
+    (set! $d&m (lambda (x y) (values (fxdiv0 x y) (fxmod0 x y))))
+    #t)
+  (equal?
+    ($dmpairs 0 5)
+    '((0 . 0) (0 . 0) (0 . 0) (0 . 0) #f #f #f #f))
+  (equal?
+    ($dmpairs 15 37)
+    '((0 . 15) (0 . -15) (0 . 15) (0 . -15)
+      (2 . 7) (-2 . -7) (-2 . 7) (2 . -7)))
+  (equal?
+    (map (lambda (x) (fxdiv0 x 64))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 0 0 1 1 1 1 1 2 2 2))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxdiv0 ,x 64))))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 0 0 1 1 1 1 1 2 2 2))
+  (equal?
+    (map (lambda (x) (fxmod0 x 64))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 -32 -31 -1 0 1 -1 0 1))
+  (equal?
+    (map (lambda (x) 
+           (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+             (expand/optimize `(fxmod0 ,x 64))))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '(0 5 31 -32 -31 -1 0 1 -1 0 1))
+  (equal?
+    (map (lambda (x) (let-values ([ls (fxdiv0-and-mod0 x 64)]) ls))
+      '(0 5 31 32 33 63 64 65 127 128 129))
+    '((0 0) (0 5) (0 31) (1 -32) (1 -31) (1 -1) (1 0) (1 1) (2 -1) (2 0) (2 1)))
+  (equal?
+    (map (lambda (x) (fxdiv0 x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 0 0 0 -1 -1 -1 -1 -2 -2 -2))
+  (equal?
+    (map (lambda (x) (fxmod0 x 64))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '(0 -5 -31 -32 31 1 0 -1 1 0 -1))
+  (equal?
+    (map (lambda (x) (let-values ([ls (fxdiv0-and-mod0 x 64)]) ls))
+      '(0 -5 -31 -32 -33 -63 -64 -65 -127 -128 -129))
+    '((0 0) (0 -5) (0 -31) (0 -32) (-1 31) (-1 1) (-1 0) (-1 -1) (-2 1) (-2 0) (-2 -1)))
+)
+
+(mat fx+/carry
+  (error? (fx+/carry))
+  (error? (fx+/carry 1))
+  (error? (fx+/carry 1 2))
+  (error? (fx+/carry 1 2 3 4))
+  (error? (fx+/carry 1.0 2 3))
+  (error? (fx+/carry 1 2.0 3))
+  (error? (fx+/carry 1 2 3.0))
+  (error? (fx+/carry 1/2 2 3))
+  (error? (fx+/carry 1 2/3 3))
+  (error? (fx+/carry 1 2 3/4))
+  (error? (fx+/carry 'a 2 3))
+  (error? (fx+/carry 1 'b 3))
+  (error? (fx+/carry 1 2 'c))
+  (error? (fx+/carry (+ (greatest-fixnum) 1) 2 3))
+  (error? (fx+/carry 1 (+ (greatest-fixnum) 1) 3))
+  (error? (fx+/carry 1 2 (+ (greatest-fixnum) 1)))
+  (error? (fx+/carry (- (least-fixnum) 1) 2 3))
+  (error? (fx+/carry 1 (- (least-fixnum) 1) 3))
+  (error? (fx+/carry 1 2 (- (least-fixnum) 1)))
+  (let ()
+    (define (r6rs-fx+/carry fx1 fx2 fx3)
+      (let ([s (+ fx1 fx2 fx3)])
+        (values
+          (mod0 s (expt 2 (fixnum-width)))
+          (div0 s (expt 2 (fixnum-width))))))
+    (define-syntax eqv2?
+      (syntax-rules ()
+        [(_ x y)
+         (let-values ([(x1 x2) x] [(y1 y2) y])
+           (and (eqv? x1 y1) (eqv? x2 y2)))]))
+    (let ([m (- (+ (greatest-fixnum) 1) (least-fixnum))])
+      (define (mrandom) (- (+ (greatest-fixnum) 1) (random m)))
+      (let f ([n 1000])
+        (unless (fx= n 0)
+          (let ([x (mrandom)] [y (mrandom)] [z (mrandom)])
+            (unless (eqv2? (fx+/carry x y z) (r6rs-fx+/carry x y z))
+              (errorf #f "failed for ~s, ~s, ~s" x y z)))
+          (f (fx- n 1)))))
+    #t)
+  (let-values ([(r c) (fx+/carry 100 20 3)])
+    (and (= r 123) (= c 0)))
+  (equal?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(fx+/carry 100 20 3)))
+      '(#3%values 123 0))
+)
+
+(mat fx-/carry
+  (error? (fx-/carry))
+  (error? (fx-/carry 1))
+  (error? (fx-/carry 1 2))
+  (error? (fx-/carry 1 2 3 4))
+  (error? (fx-/carry 1.0 2 3))
+  (error? (fx-/carry 1 2.0 3))
+  (error? (fx-/carry 1 2 3.0))
+  (error? (fx-/carry 1/2 2 3))
+  (error? (fx-/carry 1 2/3 3))
+  (error? (fx-/carry 1 2 3/4))
+  (error? (fx-/carry 'a 2 3))
+  (error? (fx-/carry 1 'b 3))
+  (error? (fx-/carry 1 2 'c))
+  (error? (fx-/carry (+ (greatest-fixnum) 1) 2 3))
+  (error? (fx-/carry 1 (+ (greatest-fixnum) 1) 3))
+  (error? (fx-/carry 1 2 (+ (greatest-fixnum) 1)))
+  (error? (fx-/carry (- (least-fixnum) 1) 2 3))
+  (error? (fx-/carry 1 (- (least-fixnum) 1) 3))
+  (error? (fx-/carry 1 2 (- (least-fixnum) 1)))
+  (let ()
+    (define (r6rs-fx-/carry fx1 fx2 fx3)
+      (let ([s (- fx1 fx2 fx3)])
+        (values
+          (mod0 s (expt 2 (fixnum-width)))
+          (div0 s (expt 2 (fixnum-width))))))
+    (define-syntax eqv2?
+      (syntax-rules ()
+        [(_ x y)
+         (let-values ([(x1 x2) x] [(y1 y2) y])
+           (and (eqv? x1 y1) (eqv? x2 y2)))]))
+    (let ([m (- (+ (greatest-fixnum) 1) (least-fixnum))])
+      (define (mrandom) (- (+ (greatest-fixnum) 1) (random m)))
+      (let f ([n 1000])
+        (unless (fx= n 0)
+          (let ([x (mrandom)] [y (mrandom)] [z (mrandom)])
+            (unless (eqv2? (fx-/carry x y z) (r6rs-fx-/carry x y z))
+              (errorf #f "failed for ~s, ~s, ~s" x y z)))
+          (f (fx- n 1)))))
+    #t)
+  (let-values ([(r c) (fx-/carry 100 20 3)])
+    (and (= r 77) (= c 0)))
+  (equal?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(fx-/carry 100 20 3)))
+      '(#3%values 77 0))
+)
+
+(mat fx*/carry
+  (error? (fx*/carry))
+  (error? (fx*/carry 1))
+  (error? (fx*/carry 1 2))
+  (error? (fx*/carry 1 2 3 4))
+  (error? (fx*/carry 1.0 2 3))
+  (error? (fx*/carry 1 2.0 3))
+  (error? (fx*/carry 1 2 3.0))
+  (error? (fx*/carry 1/2 2 3))
+  (error? (fx*/carry 1 2/3 3))
+  (error? (fx*/carry 1 2 3/4))
+  (error? (fx*/carry 'a 2 3))
+  (error? (fx*/carry 1 'b 3))
+  (error? (fx*/carry 1 2 'c))
+  (error? (fx*/carry (+ (greatest-fixnum) 1) 2 3))
+  (error? (fx*/carry 1 (+ (greatest-fixnum) 1) 3))
+  (error? (fx*/carry 1 2 (+ (greatest-fixnum) 1)))
+  (error? (fx*/carry (- (least-fixnum) 1) 2 3))
+  (error? (fx*/carry 1 (- (least-fixnum) 1) 3))
+  (error? (fx*/carry 1 2 (- (least-fixnum) 1)))
+  (let ()
+    (define (r6rs-fx*/carry fx1 fx2 fx3)
+      (let ([s (+ (* fx1 fx2) fx3)])
+        (values
+          (mod0 s (expt 2 (fixnum-width)))
+          (div0 s (expt 2 (fixnum-width))))))
+    (define-syntax eqv2?
+      (syntax-rules ()
+        [(_ x y)
+         (let-values ([(x1 x2) x] [(y1 y2) y])
+           (and (eqv? x1 y1) (eqv? x2 y2)))]))
+    (let ([m (- (+ (greatest-fixnum) 1) (least-fixnum))])
+      (define (mrandom) (- (+ (greatest-fixnum) 1) (random m)))
+      (let f ([n 1000])
+        (unless (fx= n 0)
+          (let ([x (mrandom)] [y (mrandom)] [z (mrandom)])
+            (unless (eqv2? (fx*/carry x y z) (r6rs-fx*/carry x y z))
+              (errorf #f "failed for ~s, ~s, ~s" x y z)))
+          (f (fx- n 1)))))
+    #t)
+  (let-values ([(r c) (fx*/carry 100 20 3)])
+    (and (= r 2003) (= c 0)))
+  (equal?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(fx*/carry 100 20 3)))
+      '(#3%values 2003 0))
+)
+
+(mat fxrotate-bit-field
+  (error? (fxrotate-bit-field))
+  (error? (fxrotate-bit-field 0))
+  (error? (fxrotate-bit-field 0 0))
+  (error? (fxrotate-bit-field 0 0 0))
+  (error? (fxrotate-bit-field 0 0 0 0 0))
+  (error? (fxrotate-bit-field 'a 0 0 0))
+  (error? (fxrotate-bit-field 0 0.0 0 0))
+  (error? (fxrotate-bit-field 0 0 2.0 0))
+  (error? (fxrotate-bit-field 0 0 0 3/4))
+  (error? (fxrotate-bit-field 0 -1 0 0))
+  (error? (fxrotate-bit-field 0 0 -1 0))
+  (error? (fxrotate-bit-field 0 0 0 -1))
+  (error? (fxrotate-bit-field 0 -10 -5 0))
+  (error? (fxrotate-bit-field (+ (most-positive-fixnum) 1) 0 0 0))
+  (error? (fxrotate-bit-field (- (most-negative-fixnum) 1) 0 0 0))
+  (error? (fxrotate-bit-field 0 (fixnum-width) 0 0))
+  (error? (fxrotate-bit-field 0 (+ (most-positive-fixnum) 1) 0 0))
+  (error? (fxrotate-bit-field 0 (- (most-negative-fixnum) 1) 0 0))
+  (error? (fxrotate-bit-field 0 0 (fixnum-width) 0))
+  (error? (fxrotate-bit-field 0 0 (+ (most-positive-fixnum) 1) 0))
+  (error? (fxrotate-bit-field 0 0 (- (most-negative-fixnum) 1) 0))
+  (error? (fxrotate-bit-field 0 0 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxrotate-bit-field 0 0 0 (- (most-negative-fixnum) 1)))
+  (error? (fxrotate-bit-field 0 7 5 0))
+  (error? (fxrotate-bit-field 0 (+ (most-positive-fixnum) 1) (most-positive-fixnum) 0))
+  (error? (fxrotate-bit-field 0 (+ (most-positive-fixnum) 2) (+ (most-positive-fixnum) 1) 0))
+  (error? (fxrotate-bit-field 0 5 5 1))
+  (eqv? (fxrotate-bit-field #b10101010 5 5 0) #b10101010)
+  (eqv? (fxrotate-bit-field 0 0 1 0) 0)
+  (eqv? (fxrotate-bit-field -1 0 1 0) -1)
+  (eqv?
+    (fxrotate-bit-field #b101101011101111 2 7 3)
+    #b101101011111011)
+  (eqv?
+    (fxrotate-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1) 15)
+    (greatest-fixnum))
+  (eqv?
+    (fxrotate-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2))
+    (greatest-fixnum))
+  (eqv?
+    (fxrotate-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1) 15)
+    (least-fixnum))
+  (eqv?
+    (fxrotate-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2))
+    (least-fixnum))
+  (eqv?
+    (fxrotate-bit-field -1 0 (fx- (fixnum-width) 1) 15)
+    -1)
+  (eqv?
+    (fxrotate-bit-field -1 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2))
+    -1)
+  (let ()
+    (define (r6rs-bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
+      (let* ([n ei1]
+             [start ei2]
+             [end ei3]
+             [count ei4]
+             [width (- end start)])
+        (if (positive? width)
+            (let* ([count (mod count width)]
+                   [field0 (bitwise-bit-field n start end)]
+                   [field1 (bitwise-arithmetic-shift-left field0 count)]
+                   [field2 (bitwise-arithmetic-shift-right field0 (- width count))]
+                   [field (bitwise-ior field1 field2)])
+              (bitwise-copy-bit-field n start end field))
+            n)))
+    (do ([n 500 (fx- n 1)])
+        ((fx= n 0) #t)
+      (let ([x (random (+ (most-positive-fixnum) 1))])
+        (let ([i (random (fixnum-width))] [j (random (fixnum-width))])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (fx= i j)
+              (let ([k (random (fx- j i))])
+                (unless (and
+                          (= (fxrotate-bit-field x i j k)
+                             (r6rs-bitwise-rotate-bit-field x i j k))
+                          (= (fxrotate-bit-field (- x) i j k)
+                             (r6rs-bitwise-rotate-bit-field (- x) i j k)))
+                  (errorf #f "failed for ~s ~s ~s ~s" x i j k)))))))))
+  (test-cp0-expansion eqv? '(fxrotate-bit-field #b10101010 5 5 0) #b10101010)
+  (test-cp0-expansion eqv? '(fxrotate-bit-field 0 0 1 0) 0)
+  (test-cp0-expansion eqv? '(fxrotate-bit-field -1 0 1 0) -1)
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field #b101101011101111 2 7 3)
+    #b101101011111011)
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1) 15)
+    (greatest-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2))
+    (greatest-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1) 15)
+    (least-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2))
+    (least-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field -1 0 (fx- (fixnum-width) 1) 15)
+    -1)
+  (test-cp0-expansion eqv?
+    '(fxrotate-bit-field -1 0 (fx- (fixnum-width) 1) (fx- (fixnum-width) 2))
+    -1)
+)
+
+(mat fxreverse-bit-field
+  (error? (fxreverse-bit-field))
+  (error? (fxreverse-bit-field 0))
+  (error? (fxreverse-bit-field 0 0))
+  (error? (fxreverse-bit-field 0 0 0 0))
+  (error? (fxreverse-bit-field 'a 0 0))
+  (error? (fxreverse-bit-field 0 0.0 0))
+  (error? (fxreverse-bit-field 0 0 2.0))
+  (error? (fxreverse-bit-field 0 -1 0))
+  (error? (fxreverse-bit-field 0 0 -1))
+  (error? (fxreverse-bit-field 0 -10 -5))
+  (error? (fxreverse-bit-field (+ (most-positive-fixnum) 1) 0 0))
+  (error? (fxreverse-bit-field (- (most-negative-fixnum) 1) 0 0))
+  (error? (fxreverse-bit-field 0 (fixnum-width) 0))
+  (error? (fxreverse-bit-field 0 (+ (most-positive-fixnum) 1) 0))
+  (error? (fxreverse-bit-field 0 (- (most-negative-fixnum) 1) 0))
+  (error? (fxreverse-bit-field 0 0 (fixnum-width)))
+  (error? (fxreverse-bit-field 0 0 (+ (most-positive-fixnum) 1)))
+  (error? (fxreverse-bit-field 0 0 (- (most-negative-fixnum) 1)))
+  (error? (fxreverse-bit-field 0 7 5))
+  (eqv? (fxreverse-bit-field 0 0 10) 0)
+  (eqv? (fxreverse-bit-field -1 0 10) -1)
+  (eqv?
+    (fxreverse-bit-field #b101101011101111 2 7)
+    #b101101011101111)
+  (eqv?
+    (fxreverse-bit-field #b101101011101111 3 9)
+    #b101101101110111)
+  (eqv?
+    (fxreverse-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1))
+    (greatest-fixnum))
+  (eqv?
+    (fxreverse-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1))
+    (greatest-fixnum))
+  (eqv?
+    (fxreverse-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1))
+    (least-fixnum))
+  (eqv?
+    (fxreverse-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1))
+    (least-fixnum))
+  (eqv?
+    (fxreverse-bit-field -1 0 (fx- (fixnum-width) 1))
+    -1)
+  (eqv?
+    (fxreverse-bit-field -1 0 (fx- (fixnum-width) 1))
+    -1)
+  (let ()
+    (define (refimpl n start end)
+      (define (swap n i j)
+        (fxcopy-bit
+          (fxcopy-bit n i (fxbit-field n j (fx+ j 1)))
+          j (fxbit-field n i (fx+ i 1))))
+      (let ([end (fx- end 1)])
+        (if (fx>= start end)
+            n
+            (refimpl (swap n start end) (fx+ start 1) end))))
+    (do ([n 500 (fx- n 1)])
+        ((fx= n 0) #t)
+      (let ([x (random (+ (most-positive-fixnum) 1))])
+        (let ([i (random (fixnum-width))] [j (random (fixnum-width))])
+          (let-values ([(i j) (if (< i j) (values i j) (values j i))])
+            (unless (and
+                      (= (fxreverse-bit-field x i j)
+                         (refimpl x i j))
+                      (= (fxreverse-bit-field (- x) i j)
+                         (refimpl (- x) i j)))
+              (errorf #f "failed for ~s ~s ~s" x i j)))))))
+  (test-cp0-expansion eqv? '(fxreverse-bit-field 0 0 10) 0)
+  (test-cp0-expansion eqv? '(fxreverse-bit-field -1 0 10) -1)
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field #b101101011101111 2 7)
+    #b101101011101111)
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field #b101101011101111 3 9)
+    #b101101101110111)
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1))
+    (greatest-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field (greatest-fixnum) 0 (fx- (fixnum-width) 1))
+    (greatest-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1))
+    (least-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field (least-fixnum) 0 (fx- (fixnum-width) 1))
+    (least-fixnum))
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field -1 0 (fx- (fixnum-width) 1))
+    -1)
+  (test-cp0-expansion eqv?
+    '(fxreverse-bit-field -1 0 (fx- (fixnum-width) 1))
+    -1)
+)
diff --git a/mats/hash.ms b/mats/hash.ms
new file mode 100644
index 0000000..6d048a3
--- /dev/null
+++ b/mats/hash.ms
@@ -0,0 +1,3892 @@
+;;; hash.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(mat old-hash-table
+  (error? (get-hash-table '((a . b)) 'a #f))
+  (error? (put-hash-table! (list (cons 'a 'b)) 'a 'b))
+  (error? (remove-hash-table! (list (cons 'a 'b)) 'a))
+  (error? (hash-table-map '((a . b)) cons))
+  (error? (hash-table-for-each '((a . b)) cons))
+  (begin
+    (define $h-ht (make-hash-table))
+    (hash-table? $h-ht))
+  (not (hash-table? 3))
+  (not (hash-table? '$h-ht))
+  (null? (hash-table-map $h-ht list))
+  (eq? (let ([n 0])
+         (hash-table-for-each $h-ht (lambda (x y) (set! n (+ n 1))))
+         n)
+       0)
+  (equal?
+    (begin
+      (put-hash-table! $h-ht 'ham 'spam)
+      (hash-table-map $h-ht list))
+    '((ham spam)))
+  (error? ; wrong number of args
+    (hash-table-map $h-ht (lambda (x) x)))
+  (error? ; wrong number of args
+    (hash-table-for-each $h-ht (lambda (x) x)))
+  ((lambda (x y) (or (equal? x y) (equal? x (reverse y))))
+    (begin
+      (put-hash-table! $h-ht 'cram 'sham)
+      (hash-table-map $h-ht list))
+    '((ham spam) (cram sham)))
+  ((lambda (x y) (or (equal? x y) (equal? x (reverse y))))
+    (begin
+      (put-hash-table! $h-ht 'ham 'jam)
+      (hash-table-map $h-ht list))
+    '((ham jam) (cram sham)))
+  (eq? (get-hash-table $h-ht 'ham #f) 'jam)
+  (eq? (get-hash-table $h-ht 'cram #f) 'sham)
+  (eq? (get-hash-table $h-ht 'sham #f) #f)
+  (equal? (get-hash-table $h-ht 'jam "rats") "rats")
+  (eq? (let ([n 0])
+         (hash-table-for-each $h-ht (lambda (x y) (set! n (+ n 1))))
+         n)
+       2)
+  ((lambda (x y) (or (equal? x y) (equal? x (reverse y))))
+   (let ([keys '()] [vals '()])
+     (hash-table-for-each $h-ht
+       (lambda (k v)
+         (set! keys (cons k keys))
+         (set! vals (cons v vals))))
+     (map cons vals keys))
+   '((jam . ham) (sham . cram)))
+  (eq? (collect (collect-maximum-generation)) (void))
+  ((lambda (x y) (or (equal? x y) (equal? x (reverse y))))
+   (let ([keys '()] [vals '()])
+     (hash-table-for-each $h-ht
+       (lambda (k v)
+         (set! keys (cons k keys))
+         (set! vals (cons v vals))))
+     (map cons vals keys))
+   '((jam . ham) (sham . cram)))
+  (eq? (begin
+         (remove-hash-table! $h-ht 'ham)
+         (get-hash-table $h-ht 'ham 'gone!))
+       'gone!)
+  (equal?
+    (hash-table-map $h-ht list)
+    '((cram sham)))
+  (eq? (collect (collect-maximum-generation)) (void))
+  (equal?
+    (hash-table-map $h-ht list)
+    '((cram sham)))
+  (eq? (begin
+         (remove-hash-table! $h-ht 'ham)
+         (get-hash-table $h-ht 'ham 'gone!))
+       'gone!)
+  (equal?
+    (hash-table-map $h-ht list)
+    '((cram sham)))
+  (eq? (begin
+         (remove-hash-table! $h-ht 'sham)
+         (get-hash-table $h-ht 'ham 'never-there!))
+       'never-there!)
+  (equal?
+    (hash-table-map $h-ht list)
+    '((cram sham)))
+  (eq? (begin
+         (remove-hash-table! $h-ht 'cram)
+         (get-hash-table $h-ht 'cram 'gone-too!))
+       'gone-too!)
+  (null? (hash-table-map $h-ht list))
+
+ ; fasling out eq hash tables
+  (equal?
+    (let ([x (cons 'y '!)])
+      (define ht (make-hash-table))
+      (put-hash-table! ht x 'because)
+      (put-hash-table! ht 'foo "foo")
+      (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+        (fasl-write (list x ht) p)
+        (close-port p))
+      (let-values ([(x2 ht2)
+                    (apply values
+                      (call-with-port
+                        (open-file-input-port "testfile.ss")
+                        fasl-read))])
+        (list
+          (get-hash-table ht2 x2 #f)
+          (get-hash-table ht2 'foo #f))))
+    '(because "foo"))
+
+ ; weak hash table tests
+  (begin
+    (define $h-ht (make-hash-table #t))
+    (hash-table? $h-ht))
+  (null?
+    (begin
+      (put-hash-table! $h-ht (string #\a) 'yea!)
+      (collect (collect-maximum-generation))
+      (hash-table-map $h-ht cons)))
+  (eq? (let ([n 0])
+         (hash-table-for-each $h-ht (lambda (x y) (set! n (+ n 1))))
+         n)
+       0)
+  (let ([s (string #\a)])
+    (put-hash-table! $h-ht s 666)
+    (equal? (get-hash-table $h-ht s #f) 666))
+  (null?
+    (begin
+      (collect (collect-maximum-generation))
+      (hash-table-map $h-ht cons)))
+
+ ; make sure that nonweak hash tables are nonweak (explicit #f arg)
+  (begin
+    (define $h-ht (make-hash-table #f))
+    (hash-table? $h-ht))
+  (equal?
+    (begin
+      (put-hash-table! $h-ht (string #\a) "bc")
+      (collect (collect-maximum-generation))
+      (hash-table-map $h-ht string-append))
+    '("abc"))
+
+ ; make sure that nonweak hash tables are nonweak (implicit #f arg)
+  (begin
+    (define $h-ht (make-hash-table))
+    (hash-table? $h-ht))
+  (equal?
+    (begin
+      (put-hash-table! $h-ht (string #\a) "bc")
+      (collect (collect-maximum-generation))
+      (hash-table-map $h-ht string-append))
+    '("abc"))
+
+ ; stress tests
+  (let () ; nonweak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-hash-table))
+    (let* ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (= (length (hash-table-map ht (lambda (x y) x)))
+                    (- n (length drop)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (get-hash-table ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eq? (get-hash-table ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (put-hash-table! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (remove-hash-table! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (remove-hash-table! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+  (let () ; weak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-hash-table #t))
+    (let* ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (<= (length (hash-table-map ht (lambda (x y) x)))
+                     (- n (length drop)))
+                 (begin
+                   (collect (collect-maximum-generation))
+                   (= (length (hash-table-map ht (lambda (x y) x)))
+                      (length keep)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (get-hash-table ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eq? (get-hash-table ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (put-hash-table! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (remove-hash-table! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (remove-hash-table! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+)
+
+(mat tlc
+  (critical-section
+    (let ()
+      (define ht (make-eq-hashtable))
+      (define keyval '(a . b))
+      (define next 0)
+      (define tlc (#%$make-tlc ht keyval next))
+      (define tlc2 (#%$make-tlc ht keyval next))
+      (and
+        (#%$tlc? tlc)
+        (not (#%$tlc? keyval))
+        (eq? (#%$tlc-ht tlc) ht)
+        (eq? (#%$tlc-keyval tlc) keyval)
+        (eqv? (#%$tlc-next tlc) next)
+        (begin
+          (#%$set-tlc-next! tlc tlc2)
+          (eq? (#%$tlc-next tlc) tlc2)))))
+)
+
+(define $vector-andmap
+  (lambda (p . v*)
+    (apply andmap p (map vector->list v*))))
+
+(define $vector-append
+  (lambda v*
+    (list->vector (apply append (map vector->list v*)))))
+
+(define $vector-member?
+  (lambda (x v)
+    (let ([n (vector-length v)])
+      (let f ([i 0])
+        (and (not (fx= i n))
+          (or (equal? (vector-ref v i) x)
+              (f (fx+ i 1))))))))
+
+(define same-elements?
+  (lambda (v1 v2)
+    (let ([n (vector-length v1)])
+      (define (each-in? v1 v2)
+        (let f ([i 0])
+          (or (fx= i n)
+              (and ($vector-member? (vector-ref v1 i) v2)
+                   (f (fx+ i 1))))))
+      (and (fx= (vector-length v2) n)
+           (each-in? v1 v2)
+           (each-in? v2 v1)))))
+
+(define equal-entries?
+  (lambda (ht keys vals)
+    (define-syntax same-entries?
+      (syntax-rules ()
+        [(_ e1 keys2 vals2)
+         (let-values ([(keys1 vals1) e1])
+           (and
+            (same-elements? keys1 keys2)
+            (same-elements? vals1 vals2)))]))
+
+    (and
+     (same-elements? (hashtable-keys ht) keys)
+     (same-elements? (hashtable-values ht) vals)
+     (same-entries? (hashtable-entries ht) keys vals)
+     (same-elements? (hashtable-cells ht) (vector-map cons keys vals))
+
+     (same-elements? (r6rs:hashtable-keys ht) keys)
+     (same-entries? (r6rs:hashtable-entries ht) keys vals)
+
+     ;; Check requested sizes > hash table size
+     (andmap (lambda (size)
+               (and
+                (same-elements? (hashtable-keys ht size) keys)
+                (same-elements? (hashtable-values ht size) vals)
+                (same-entries? (hashtable-entries ht size) keys vals)
+                (same-elements? (hashtable-cells ht size) (vector-map cons keys vals))))
+             (list (add1 (hashtable-size ht))
+                   (expt 2 1000)))
+
+     ;; Make sure request of 0 always works:
+     (same-elements? (hashtable-keys ht 0) '#())
+     (same-elements? (hashtable-values ht 0) '#())
+     (same-entries? (hashtable-entries ht 0) '#() '#())
+     (same-elements? (hashtable-cells ht 0) '#())
+
+     (or
+      (< (hashtable-size ht) 2)
+      ;; Check request of size 2:
+      (let ([twos (lambda (v)
+                     (let i-loop ([i 0])
+                       (cond
+                        [(= i (vector-length v))
+                         '()]
+                        [else
+                         (let j-loop ([j (add1 i)])
+                           (cond
+                            [(= j (vector-length v))
+                             (i-loop (add1 i))]
+                            [else
+                             (cons (vector (vector-ref v i) (vector-ref v j))
+                                   (j-loop (add1 j)))]))])))])
+        (let ([keyss (twos keys)]
+              [valss (twos vals)])
+          (and
+           (let ([got-keys (hashtable-keys ht 2)])
+             (ormap (lambda (keys)
+                      (same-elements? got-keys keys))
+                    keyss))
+           (let ([got-vals (hashtable-values ht 2)])
+             (ormap (lambda (vals)
+                      (same-elements? got-vals vals))
+                    valss))
+           (let-values ([(got-keys got-vals) (hashtable-entries ht 2)])
+             (ormap (lambda (keys vals)
+                      (and (same-elements? got-keys keys)
+                           (same-elements? got-vals vals)))
+                    keyss valss))
+           (let ([got-cells (hashtable-cells ht 2)])
+             (ormap (lambda (keys vals)
+                      (same-elements? got-cells (vector-map cons keys vals)))
+                    keyss valss)))))))))
+
+(mat hashtable-arguments
+ ; make-eq-hashtable
+  (error? ; wrong argument count
+    (make-eq-hashtable 3 #t))
+  (error? ; invalid size
+    (make-eq-hashtable -1))
+  (error? ; invalid size
+    (make-eq-hashtable #t))
+  (error? ; invalid size
+    (make-eq-hashtable #f))
+ ; make-hashtable
+  (error? ; wrong argument count
+    (make-hashtable))
+  (error? ; wrong argument count
+    (make-hashtable equal-hash))
+  (error? ; wrong argument count
+    (make-hashtable equal-hash equal? 45 53))
+  (error? ; not a procedure
+    (make-hashtable 'a equal? 45))
+  (error? ; not a procedure
+    (make-hashtable equal-hash 'a 45))
+  (error? ; invalid size
+    (make-hashtable equal-hash equal? 'a))
+  (error? ; invalid size
+    (make-hashtable equal-hash equal? -45))
+  (error? ; invalid size
+    (make-hashtable equal-hash equal? 45.0))
+ ; make-eqv-hashtable
+  (error? ; wrong argument count
+    (make-eqv-hashtable 3 #t))
+  (error? ; invalid size
+    (make-eqv-hashtable -1))
+  (error? ; invalid size
+    (make-eqv-hashtable #t))
+  (error? ; invalid size
+    (make-eqv-hashtable #f))
+  (begin
+    (define $ht (make-eq-hashtable))
+    (define $imht (hashtable-copy $ht))
+    (define $ht2 (make-eq-hashtable 50))
+    (and (hashtable? $ht)
+         (eq-hashtable? $ht)
+         (hashtable-mutable? $ht)
+         (not (hashtable-weak? $ht))
+         (not (eq-hashtable-weak? $ht))
+         (not (hashtable-ephemeron? $ht))
+         (not (eq-hashtable-ephemeron? $ht))
+         (hashtable? $imht)
+         (eq-hashtable? $imht)
+         (not (hashtable-mutable? $imht))
+         (not (hashtable-weak? $imht))
+         (not (eq-hashtable-weak? $imht))
+         (not (hashtable-ephemeron? $imht))
+         (not (eq-hashtable-ephemeron? $imht))
+         (hashtable? $ht2)
+         (eq-hashtable? $ht2)
+         (hashtable-mutable? $ht2)
+         (not (hashtable-weak? $ht2))
+         (not (eq-hashtable-weak? $ht2))
+         (not (hashtable-ephemeron? $ht2))
+         (not (eq-hashtable-ephemeron? $ht2))))
+  (not (hashtable? 3))
+  (not (hashtable? (make-vector 3)))
+  (not (eq-hashtable? 3))
+  (not (eq-hashtable? (make-vector 3)))
+ ; hashtable?
+  (error? ; wrong argument count
+    (hashtable?))
+  (error? ; wrong argument count
+    (hashtable? $ht 3))
+  (error? ; wrong argument count
+    (eq-hashtable?))
+  (error? ; wrong argument count
+    (eq-hashtable? $ht 3))
+ ; hashtable-mutable?
+  (error? ; not a hashtable
+    (hashtable-mutable? (make-vector 3)))
+  (error? ; wrong argument count
+    (hashtable-mutable?))
+  (error? ; wrong argument count
+    (hashtable-mutable? $ht 3))
+ ; hashtable-size
+  (error? ; wrong argument count
+    (hashtable-size))
+  (error? ; wrong argument count
+    (hashtable-size $ht 3))
+  (error? ; not a hashtable
+    (hashtable-size 'hello))
+ ; hashtable-ref
+  (error? ; wrong argument count
+    (hashtable-ref))
+  (error? ; wrong argument count
+    (hashtable-ref $ht))
+  (error? ; wrong argument count
+    (hashtable-ref $ht 'a))
+  (error? ; wrong argument count
+    (hashtable-ref $ht 'a 'b 'c))
+  (error? ; not a hashtable
+    (hashtable-ref '(hash . table) 'a 'b))
+ ; hashtable-contains?
+  (error? ; wrong argument count
+    (hashtable-contains?))
+  (error? ; wrong argument count
+    (hashtable-contains? $ht))
+  (error? ; wrong argument count
+    (hashtable-contains? $ht 'a 'b))
+  (error? ; not a hashtable
+    (hashtable-contains? '(hash . table) 'a))
+ ; hashtable-set!
+  (error? ; wrong argument count
+    (hashtable-set!))
+  (error? ; wrong argument count
+    (hashtable-set! $ht))
+  (error? ; wrong argument count
+    (hashtable-set! $ht 'a))
+  (error? ; wrong argument count
+    (hashtable-set! $ht 'a 'b 'c))
+  (error? ; not a hashtable
+    (hashtable-set! '(hash . table) 'a 'b))
+  (error? ; hashtable not mutable
+    (hashtable-set! $imht 'a 'b))
+ ; hashtable-update!
+  (error? ; wrong argument count
+    (hashtable-update!))
+  (error? ; wrong argument count
+    (hashtable-update! $ht))
+  (error? ; wrong argument count
+    (hashtable-update! $ht 'a values))
+  (error? ; wrong argument count
+    (hashtable-update! $ht 'a values 'c 'd))
+  (error? ; not a hashtable
+    (hashtable-update! '(hash . table) 'a values 'b))
+  (error? ; hashtable not mutable
+    (hashtable-update! $imht 'a values 'b))
+  (error? ; not a procedure
+    (hashtable-update! $ht 'a "not a procedure" 'b))
+ ; hashtable-cell
+  (error? ; wrong argument count
+    (hashtable-cell))
+  (error? ; wrong argument count
+    (hashtable-cell $ht))
+  (error? ; wrong argument count
+    (hashtable-cell $ht 'a))
+  (error? ; wrong argument count
+    (hashtable-cell $ht 'a 'b 'c))
+  (error? ; not a hashtable
+    (hashtable-cell '(hash . table) 'a 'b))
+ ; hashtable-delete!
+  (error? ; wrong argument count
+    (hashtable-delete!))
+  (error? ; wrong argument count
+    (hashtable-delete! $ht))
+  (error? ; wrong argument count
+    (hashtable-delete! $ht 'a 'b))
+  (error? ; not a hashtable
+    (hashtable-delete! '(hash . table) 'a))
+  (error? ; hashtable not mutable
+    (hashtable-delete! $imht 'a))
+ ; hashtable-copy
+  (error? ; wrong argument count
+    (hashtable-copy))
+  (error? ; wrong argument count
+    (hashtable-copy $ht #t 17))
+  (error? ; not a hashtable
+    (hashtable-copy '(hash . table) #t))
+ ; hashtable-clear!
+  (error? ; wrong argument count
+    (hashtable-clear!))
+  (error? ; wrong argument count
+    (hashtable-clear! $ht 17 'foo))
+  (error? ; not a hashtable
+    (hashtable-clear! '(hash . table)))
+  (error? ; not a hashtable
+    (hashtable-clear! '(hash . table) 17))
+  (error? ; hashtable not mutable
+    (hashtable-clear! $imht))
+  (error? ; hashtable not mutable
+    (hashtable-clear! $imht 32))
+  (error? ; invalid size
+    (hashtable-clear! $ht #t))
+ ; hashtable-keys
+  (error? ; wrong argument count
+    (hashtable-keys))
+  (error? ; wrong argument count
+    (hashtable-keys $ht 72 43))
+  (error? ; not a hashtable
+    (hashtable-keys '(hash . table)))
+  (error? ; bad size
+    (hashtable-keys $ht -79))
+  (error? ; bad size
+    (hashtable-keys $ht 'not-an-unsigned-integer))
+  (error? ; wrong argument count
+    (r6rs:hashtable-keys))
+  (error? ; wrong argument count
+    (r6rs:hashtable-keys $ht 72))
+  (error? ; not a hashtable
+    (r6rs:hashtable-keys '(hash . table)))
+ ; hashtable-values
+  (error? ; wrong argument count
+    (hashtable-values))
+  (error? ; wrong argument count
+    (hashtable-values $ht 72 43))
+  (error? ; not a hashtable
+    (hashtable-values '(hash . table)))
+  (error? ; bad size
+    (hashtable-values $ht -79))
+  (error? ; bad size
+    (hashtable-values $ht 'not-an-unsigned-integer))
+ ; hashtable-entries
+  (error? ; wrong argument count
+    (hashtable-entries))
+  (error? ; wrong argument count
+    (hashtable-entries $ht 72 43))
+  (error? ; not a hashtable
+    (hashtable-entries '(hash . table)))
+  (error? ; bad size
+    (hashtable-entries $ht -79))
+  (error? ; bad size
+    (hashtable-entries $ht 'not-an-unsigned-integer))
+  (error? ; wrong argument count
+    (r6rs:hashtable-entries))
+  (error? ; wrong argument count
+    (r6rs:hashtable-entries $ht 72))
+  (error? ; not a hashtable
+    (r6rs:hashtable-entries '(hash . table)))
+ ; hashtable-cells
+  (error? ; wrong argument count
+    (hashtable-cells))
+  (error? ; wrong argument count
+    (hashtable-cells $ht 72 43))
+  (error? ; not a hashtable
+    (hashtable-cells '(hash . table)))
+  (error? ; bad size
+    (hashtable-cells $ht -79))
+  (error? ; bad size
+    (hashtable-cells $ht 'not-an-unsigned-integer))
+ ; hashtable-hash-function
+  (error? ; wrong argument count
+    (hashtable-hash-function))
+  (error? ; wrong argument count
+    (hashtable-hash-function $ht $ht))
+  (error? ; not a hsshtable
+    (hashtable-hash-function '(hash . table)))
+ ; hashtable-equivalence-function
+  (error? ; wrong argument count
+    (hashtable-equivalence-function))
+  (error? ; wrong argument count
+    (hashtable-equivalence-function $ht $ht))
+  (error? ; not a hsshtable
+    (hashtable-equivalence-function '(hash . table)))
+ ; hashtable-weak?
+  (error? ; wrong argument count
+    (hashtable-weak?))
+  (error? ; wrong argument count
+    (hashtable-weak? $ht 3))
+  (error? ; not a hashtable
+    (hashtable-weak? '(hash . table)))
+ ; hashtable-ephemeron?
+  (error? ; wrong argument count
+    (hashtable-ephemeron?))
+  (error? ; wrong argument count
+    (hashtable-ephemeron? $ht 3))
+  (error? ; not a hashtable
+    (hashtable-ephemeron? '(hash . table)))
+)
+
+(mat hash-return-value
+  ; hashtable-ref
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) "oops") equal?)])
+      (hashtable-ref ht 'any #f)))
+  #;(error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) -7) equal?)])
+      (hashtable-ref ht 'any #f)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 3.5) equal?)])
+      (hashtable-ref ht 'any #f)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)])
+      (hashtable-ref ht 'any #f)))
+  ; hashtable-contains?
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) "oops") equal?)])
+      (hashtable-contains? ht 'any)))
+  #;(error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) -7) equal?)])
+      (hashtable-contains? ht 'any)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 3.5) equal?)])
+      (hashtable-contains? ht 'any)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)])
+      (hashtable-contains? ht 'any)))
+  ; hashtable-set!
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) "oops") equal?)])
+      (hashtable-set! ht 'any 'spam)))
+  #;(error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) -7) equal?)])
+      (hashtable-set! ht 'any 'spam)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 3.5) equal?)])
+      (hashtable-set! ht 'any 'spam)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)])
+      (hashtable-set! ht 'any 'spam)))
+  ; hashtable-update!
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) "oops") equal?)])
+      (hashtable-update! ht 'any values 'spam)))
+  #;(error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) -7) equal?)])
+      (hashtable-update! ht 'any values 'spam)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 3.5) equal?)])
+      (hashtable-update! ht 'any values 'spam)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)])
+      (hashtable-update! ht 'any values 'spam)))
+  ; hashtable-cell
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) "oops") equal?)])
+      (hashtable-cell ht 'any 0)))
+  #;(error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) -7) equal?)])
+      (hashtable-cell ht 'any 0)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 3.5) equal?)])
+      (hashtable-cell ht 'any 0)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)])
+      (hashtable-cell ht 'any 0)))
+  ; hashtable-delete!
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) "oops") equal?)])
+      (hashtable-delete! ht 'any)))
+  #;(error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) -7) equal?)])
+      (hashtable-delete! ht 'any)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 3.5) equal?)])
+      (hashtable-delete! ht 'any)))
+  (error? ; invalid hash-function return value
+    (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)])
+      (hashtable-delete! ht 'any)))
+)
+
+(mat eq-hashtable-arguments
+ ; make-weak-eq-hashtable
+  (error? ; wrong argument count
+    (make-weak-eq-hashtable 3 #t))
+  (error? ; invalid size
+    (make-weak-eq-hashtable -1))
+  (error? ; invalid size
+    (make-weak-eq-hashtable #t))
+  (error? ; invalid size
+    (make-weak-eq-hashtable #f))
+ ; make-weak-eq-hashtable
+  (error? ; wrong argument count
+    (make-ephemeron-eq-hashtable 3 #t))
+  (error? ; invalid size
+    (make-ephemeron-eq-hashtable -1))
+  (error? ; invalid size
+    (make-ephemeron-eq-hashtable #t))
+  (error? ; invalid size
+    (make-ephemeron-eq-hashtable #f))
+  (begin
+    (define $wht (make-weak-eq-hashtable 50))
+    (define $eht (make-ephemeron-eq-hashtable 50))
+    (define $imht (hashtable-copy $wht))
+    (define $imeht (hashtable-copy $eht))
+    (define $wht2 (make-weak-eq-hashtable))
+    (define $eht2 (make-ephemeron-eq-hashtable))
+    (and (hashtable? $wht)
+         (hashtable? $eht)
+         (eq-hashtable? $wht)
+         (eq-hashtable? $eht)
+         (hashtable-weak? $wht)
+         (not (hashtable-ephemeron? $wht))
+         (hashtable-ephemeron? $eht)
+         (not (hashtable-weak? $eht))
+         (eq-hashtable-weak? $wht)
+         (not (eq-hashtable-ephemeron? $wht))
+         (eq-hashtable-ephemeron? $eht)
+         (not (eq-hashtable-weak? $eht))
+         (hashtable-mutable? $wht)
+         (hashtable-mutable? $eht)
+         (hashtable? $imht)
+         (hashtable? $imeht)
+         (eq-hashtable? $imht)
+         (eq-hashtable? $imeht)
+         (hashtable-weak? $imht)
+         (not (hashtable-ephemeron? $imht))
+         (hashtable-ephemeron? $imeht)
+         (not (hashtable-weak? $imeht))
+         (eq-hashtable-weak? $imht)
+         (not (eq-hashtable-ephemeron? $imht))
+         (eq-hashtable-ephemeron? $imeht)
+         (not (eq-hashtable-weak? $imeht))
+         (not (hashtable-mutable? $imht))
+         (not (hashtable-mutable? $imeht))
+         (hashtable? $wht2)
+         (hashtable? $eht2)
+         (eq-hashtable? $wht2)
+         (eq-hashtable? $eht2)
+         (hashtable-weak? $wht2)
+         (not (hashtable-ephemeron? $wht2))
+         (hashtable-ephemeron? $eht2)
+         (not (hashtable-weak? $eht2))
+         (eq-hashtable-weak? $wht2)
+         (not (eq-hashtable-ephemeron? $ht2))
+         (eq-hashtable-ephemeron? $eht2)
+         (not (eq-hashtable-weak? $eht2))
+         (hashtable-mutable? $wht2)
+         (hashtable-mutable? $eht2)))
+ ; eq-hashtable-ref
+  (error? ; wrong argument count
+    (eq-hashtable-ref))
+  (error? ; wrong argument count
+    (eq-hashtable-ref $wht))
+  (error? ; wrong argument count
+    (eq-hashtable-ref $wht 'a))
+  (error? ; wrong argument count
+    (eq-hashtable-ref $wht 'a 'b 'c))
+  (error? ; not a hashtable
+    (eq-hashtable-ref '(hash . table) 'a 'b))
+ ; eq-hashtable-contains?
+  (error? ; wrong argument count
+    (eq-hashtable-contains?))
+  (error? ; wrong argument count
+    (eq-hashtable-contains? $wht))
+  (error? ; wrong argument count
+    (eq-hashtable-contains? $wht 'a 'b))
+  (error? ; not a hashtable
+    (eq-hashtable-contains? '(hash . table) 'a))
+ ; eq-hashtable-set!
+  (error? ; wrong argument count
+    (eq-hashtable-set!))
+  (error? ; wrong argument count
+    (eq-hashtable-set! $wht))
+  (error? ; wrong argument count
+    (eq-hashtable-set! $wht 'a))
+  (error? ; wrong argument count
+    (eq-hashtable-set! $wht 'a 'b 'c))
+  (error? ; not a hashtable
+    (eq-hashtable-set! '(hash . table) 'a 'b))
+  (error? ; hashtable not mutable
+    (eq-hashtable-set! $imht 'a 'b))
+ ; eq-hashtable-update!
+  (error? ; wrong argument count
+    (eq-hashtable-update!))
+  (error? ; wrong argument count
+    (eq-hashtable-update! $wht))
+  (error? ; wrong argument count
+    (eq-hashtable-update! $wht 'a values))
+  (error? ; wrong argument count
+    (eq-hashtable-update! $wht 'a values 'c 'd))
+  (error? ; not a hashtable
+    (eq-hashtable-update! '(hash . table) 'a values 'b))
+  (error? ; hashtable not mutable
+    (eq-hashtable-update! $imht 'a values 'b))
+  (error? ; not a procedure
+    (eq-hashtable-update! $wht 'a "not a procedure" 'b))
+ ; eq-hashtable-delete!
+  (error? ; wrong argument count
+    (eq-hashtable-delete!))
+  (error? ; wrong argument count
+    (eq-hashtable-delete! $wht))
+  (error? ; wrong argument count
+    (eq-hashtable-delete! $wht 'a 'b))
+  (error? ; not a hashtable
+    (eq-hashtable-delete! '(hash . table) 'a))
+  (error? ; hashtable not mutable
+    (eq-hashtable-delete! $imht 'a))
+ ; eq-hashtable-cell
+  (error? ; wrong argument count
+    (eq-hashtable-cell))
+  (error? ; wrong argument count
+    (eq-hashtable-cell $wht))
+  (error? ; wrong argument count
+    (eq-hashtable-cell $wht 'a))
+  (error? ; wrong argument count
+    (eq-hashtable-cell $wht 'a 'b 'c))
+  (error? ; not a hashtable
+    (eq-hashtable-cell '(hash . table) 'a 'b))
+ ; eq-hashtable-weak?
+  (error? ; wrong argument count
+    (eq-hashtable-weak?))
+  (error? ; wrong argument count
+    (eq-hashtable-weak? $ht 3))
+  (error? ; not a hashtable
+    (eq-hashtable-weak? '(hash . table)))
+ ; eq-hashtable-ephemeron?
+  (error? ; wrong argument count
+    (eq-hashtable-ephemeron?))
+  (error? ; wrong argument count
+    (eq-hashtable-ephemeron? $ht 3))
+  (error? ; not a hashtable
+    (eq-hashtable-ephemeron? '(hash . table)))
+)
+
+(mat symbol-hashtable-arguments
+  (begin
+    (define $symht (make-hashtable symbol-hash eq? 50))
+    (define $imsymht (hashtable-copy $symht))
+    #t)
+ ; symbol-hashtable-ref
+  (error? ; wrong argument count
+    (symbol-hashtable-ref))
+  (error? ; wrong argument count
+    (symbol-hashtable-ref $symht))
+  (error? ; wrong argument count
+    (symbol-hashtable-ref $symht 'a))
+  (error? ; wrong argument count
+    (symbol-hashtable-ref $symht 'a 'b 'c))
+  (error? ; not a hashtable
+    (symbol-hashtable-ref '(hash . table) 'a 'b))
+  (error? ; not a symbol hashtable
+    (symbol-hashtable-ref $ht 'a 'b))
+  (error? ; not a symbol
+    (symbol-hashtable-ref $symht '(a) 'b))
+  (error? ; not a symbol
+    (hashtable-ref $symht '(a) 'b))
+ ; symbol-hashtable-contains?
+  (error? ; wrong argument count
+    (symbol-hashtable-contains?))
+  (error? ; wrong argument count
+    (symbol-hashtable-contains? $symht))
+  (error? ; wrong argument count
+    (symbol-hashtable-contains? $symht 'a 'b))
+  (error? ; not a hashtable
+    (symbol-hashtable-contains? '(hash . table) 'a))
+  (error? ; not a symbol hashtable
+    (symbol-hashtable-contains? $ht 'a))
+  (error? ; not a symbol
+    (symbol-hashtable-contains? $symht '(a)))
+  (error? ; not a symbol
+    (hashtable-contains? $symht '(a)))
+ ; symbol-hashtable-set!
+  (error? ; wrong argument count
+    (symbol-hashtable-set!))
+  (error? ; wrong argument count
+    (symbol-hashtable-set! $symht))
+  (error? ; wrong argument count
+    (symbol-hashtable-set! $symht 'a))
+  (error? ; wrong argument count
+    (symbol-hashtable-set! $symht 'a 'b 'c))
+  (error? ; not a hashtable
+    (symbol-hashtable-set! '(hash . table) 'a 'b))
+  (error? ; not a symbol hashtable
+    (symbol-hashtable-set! $ht 'a 'b))
+  (error? ; not a symbol
+    (symbol-hashtable-set! $symht '(a) 'b))
+  (error? ; not a symbol
+    (hashtable-set! $symht '(a) 'b))
+  (error? ; hashtable not mutable
+    (symbol-hashtable-set! $imsymht 'a 'b))
+ ; symbol-hashtable-update!
+  (error? ; wrong argument count
+    (symbol-hashtable-update!))
+  (error? ; wrong argument count
+    (symbol-hashtable-update! $symht))
+  (error? ; wrong argument count
+    (symbol-hashtable-update! $symht 'a values))
+  (error? ; wrong argument count
+    (symbol-hashtable-update! $symht 'a values 'c 'd))
+  (error? ; not a hashtable
+    (symbol-hashtable-update! '(hash . table) 'a values 'b))
+  (error? ; not a symbol hashtable
+    (symbol-hashtable-update! $ht 'a values 'b))
+  (error? ; not a symbol
+    (symbol-hashtable-update! $symht '(a) values 'b))
+  (error? ; not a symbol
+    (hashtable-update! $symht '(a) values 'b))
+  (error? ; hashtable not mutable
+    (symbol-hashtable-update! $imsymht 'a values 'b))
+  (error? ; not a procedure
+    (symbol-hashtable-update! $symht 'a "not a procedure" 'b))
+ ; symbol-hashtable-delete!
+  (error? ; wrong argument count
+    (symbol-hashtable-delete!))
+  (error? ; wrong argument count
+    (symbol-hashtable-delete! $symht))
+  (error? ; wrong argument count
+    (symbol-hashtable-delete! $symht 'a 'b))
+  (error? ; not a hashtable
+    (symbol-hashtable-delete! '(hash . table) 'a))
+  (error? ; not a symbol hashtable
+    (symbol-hashtable-delete! $ht 'a))
+  (error? ; not a symbol
+    (symbol-hashtable-delete! $symht '(a)))
+  (error? ; not a symbol
+    (hashtable-delete! $symht '(a)))
+  (error? ; hashtable not mutable
+    (symbol-hashtable-delete! $imsymht 'a))
+ ; symbol-hashtable-cell
+  (error? ; wrong argument count
+    (symbol-hashtable-cell))
+  (error? ; wrong argument count
+    (symbol-hashtable-cell $symht))
+  (error? ; wrong argument count
+    (symbol-hashtable-cell $symht 'a))
+  (error? ; wrong argument count
+    (symbol-hashtable-cell $symht 'a 'b 'c))
+  (error? ; not a hashtable
+    (symbol-hashtable-cell '(hash . table) 'a 'b))
+  (error? ; not a symbol hashtable
+    (symbol-hashtable-cell $ht 'a 'b))
+  (error? ; not a symbol
+    (symbol-hashtable-cell $symht '(a) 'b))
+  (error? ; not a symbol
+    (hashtable-cell $symht '(a) 'b))
+)
+
+(mat eqv-hashtable-arguments
+ ; make-weak-eqv-hashtable
+  (error? ; wrong argument count
+    (make-weak-eqv-hashtable 3 #t))
+  (error? ; invalid size
+    (make-weak-eqv-hashtable -1))
+  (error? ; invalid size
+    (make-weak-eqv-hashtable #t))
+  (error? ; invalid size
+    (make-weak-eqv-hashtable #f))
+ ; make-ephemeron-eqv-hashtable
+  (error? ; wrong argument count
+    (make-ephemeron-eqv-hashtable 3 #t))
+  (error? ; invalid size
+    (make-ephemeron-eqv-hashtable -1))
+  (error? ; invalid size
+    (make-ephemeron-eqv-hashtable #t))
+  (error? ; invalid size
+    (make-ephemeron-eqv-hashtable #f))
+)
+
+(mat nonweak-eq-hashtable
+  (begin
+    (define h (make-eq-hashtable 32))
+    (and (hashtable? h)
+         (eq-hashtable? h)
+         (hashtable-mutable? h)
+         (not (eq-hashtable-weak? h))
+         (not (eq-hashtable-ephemeron? h))
+         (not (hashtable-weak? h))
+         (not (hashtable-ephemeron? h))))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h 'a 'aval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 'b)
+       (hashtable-contains? h 'c))
+    '(#t #f #f))
+  (eqv? (hashtable-set! h 'b 'bval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 'b)
+       (hashtable-contains? h 'c))
+    '(#t #t #f))
+  (eqv? (hashtable-set! h 'c 'cval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 'b)
+       (hashtable-contains? h 'c))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#(b c a) '#(bval cval aval))
+  #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (b . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (b . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (b . bval) (c . cval)))
+  (equal? (hashtable-ref h 'a 1) 'aval)
+  (equal? (hashtable-ref h 'b #f) 'bval)
+  (equal? (hashtable-ref h 'c 'nope) 'cval)
+  (eqv? (hashtable-delete! h 'b) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#(a c) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (eq-hashtable? h2)
+         (hashtable-mutable? h2)
+         (not (hashtable-weak? h2))
+         (not (eq-hashtable-weak? h2))
+         (not (hashtable-ephemeron? h2))
+         (not (eq-hashtable-ephemeron? h2))))
+  (eq? (hashtable-hash-function h2) #f)
+  (eq? (hashtable-equivalence-function h2) eq?)
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h 'a 1)
+      (hashtable-ref h 'b #f)
+      (hashtable-ref h 'c 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 'a 1)
+      (hashtable-ref h2 'b #f)
+      (hashtable-ref h2 'c 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv?
+    (hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h 'q #f) 18)
+  (eqv?
+    (hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h 'q #f) 19)
+  (equal? (hashtable-size h) 1)
+ ; test hashtable-copy when some keys may have moved
+  (let ([t (parameterize ([collect-request-handler void])
+             (let ([h4a (make-eq-hashtable 32)]
+                   [k* (map list (make-list 100))])
+               (for-each (lambda (x) (hashtable-set! h4a x x)) k*)
+               (collect)
+              ; create copy after collection but before otherwise touching h4a
+               (let ([h4b (hashtable-copy h4a #t)])
+                 (andmap
+                   (lambda (k) (eq? (hashtable-ref h4b k #f) k))
+                   k*))))])
+    (collect)
+    t)
+
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-eq-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+)
+
+(mat weak-eq-hashtable
+  (begin
+    (define ka (list 'a))
+    (define kb (list 'b))
+    (define kc (list 'c))
+    (define kq (list 'q))
+    (define ky (list 'y))
+    (define kz (list 'z))
+    #t)
+  (begin
+    (define h (make-weak-eq-hashtable 32))
+    (and (hashtable? h)
+         (eq-hashtable? h)
+         (hashtable-mutable? h)
+         (hashtable-weak? h)
+         (eq-hashtable-weak? h)))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h ka 'aval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc))
+    '(#t #f #f))
+  (eqv? (hashtable-set! h kb 'bval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc))
+    '(#t #t #f))
+  (eqv? (hashtable-set! h kc 'cval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#((a) (b) (c)) '#(aval bval cval))
+  (andmap weak-pair? (vector->list (hashtable-cells h)))
+  #;(same-elements? (list->vector (hashtable-map h cons)) '#(((a) . aval) ((b) . bval) ((c) . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    '#(((a) . aval) ((b) . bval) ((c) . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    '#(((a) . aval) ((b) . bval) ((c) . cval)))
+  (equal? (hashtable-ref h ka 1) 'aval)
+  (equal? (hashtable-ref h kb #f) 'bval)
+  (equal? (hashtable-ref h kc 'nope) 'cval)
+  (eqv? (hashtable-delete! h kb) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#((a) (c)) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (eq-hashtable? h2)
+         (hashtable-mutable? h2)
+         (eq-hashtable-weak? h2)
+         (hashtable-weak? h2)))
+  (eq? (hashtable-hash-function h2) #f)
+  (eq? (hashtable-equivalence-function h2) eq?)
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h ka 1)
+      (hashtable-ref h kb #f)
+      (hashtable-ref h kc 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 ka 1)
+      (hashtable-ref h2 kb #f)
+      (hashtable-ref h2 kc 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 18)
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 19)
+  (equal? (hashtable-size h) 1)
+  (equal-entries? h '#((q)) '#(19))
+  (eqv?
+    (begin
+      (set! kq (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h))
+    0)
+  (equal-entries? h '#() '#())
+  #;(eqv? (hashtable-map h (lambda args (error #f "oops"))) '())
+  #;(eqv? (hashtable-for-each h (lambda args (error #f "oops"))) (void))
+  #;(eqv? (hashtable-for-each-cell h (lambda args (error #f "oops"))) (void))
+  (equal? (hashtable-ref h ky #f) #f)
+  (eqv?
+    (hashtable-set! h ky 'toad)
+    (void))
+  (equal? (hashtable-ref h ky #f) 'toad)
+  (equal? (hashtable-ref h kz #f) #f)
+  (eqv?
+    (hashtable-update! h kz list 'frog)
+    (void))
+  (equal? (hashtable-ref h kz #f) '(frog))
+  (equal-entries?
+    h
+    (vector kz ky)
+    (vector (hashtable-ref h kz #f) 'toad))
+  (eqv? (hashtable-ref h '(zippo) 'nil) 'nil)
+  (begin
+    (define h3 (hashtable-copy h2 #f))
+    (and (hashtable? h3)
+         (eq-hashtable? h3)
+         (not (hashtable-mutable? h3))
+         (eq-hashtable-weak? h3)
+         (hashtable-weak? h3)))
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (equal-entries? h3 '#((a) (c)) '#(aval cval))
+  (equal?
+    (begin
+      (set! ka (void))
+      (collect (collect-maximum-generation))
+      (list (hashtable-size h2) (hashtable-size h3)))
+    '(1 1))
+  (equal-entries? h2 '#((c)) '#(cval))
+  (equal-entries? h3 '#((c)) '#(cval))
+  (eqv?
+    (begin
+      (set! h3 (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h2))
+    1)
+  (equal-entries? h2 '#((c)) '#(cval))
+
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-eq-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+
+ ; test for proper shrinkage as objects are bwp'd
+ ; uses delete to trigger final shrinkage
+  (equal?
+    (let* ([ht (make-weak-eq-hashtable 32)]
+           [len (#%$hashtable-veclen ht)])
+      (hashtable-set! ht 'a 'b)
+      (for-each
+        (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+        (map (lambda (x) (map list (make-list 1000))) (make-list 100)))
+      (collect (collect-maximum-generation))
+      (hashtable-delete! ht 'a)
+      (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len)))
+    '(0 #t))
+
+  ; test that weak-hashtable values *do* make keys reachable
+  (let ([wk1 (list 1)]
+        [wk2 (list 2)]
+        [wk3 (list 3)]
+        [wk4 (list 4)]
+        [ht (make-weak-eq-hashtable)])
+    (hashtable-set! ht wk1 wk1)
+    (hashtable-set! ht wk2 wk1)
+    (hashtable-set! ht wk3 wk3)
+    (hashtable-set! ht wk4 wk2)
+    (collect (collect-maximum-generation))
+    (and
+     (equal-entries? ht '#((1) (2) (3) (4)) '#((1) (1) (3) (2)))
+     (equal? (hashtable-ref ht wk1 #f) wk1)
+     (equal? (hashtable-ref ht wk2 #f) wk1)
+     (equal? (hashtable-ref ht wk3 #f) wk3)
+     (equal? (hashtable-ref ht wk4 #f) wk2)
+     (begin
+       (set! wk1 #f)
+       (set! wk2 #f)
+       (set! wk3 #f)
+       (collect (collect-maximum-generation))
+       (and
+        (equal-entries? ht '#((1) (2) (3) (4)) '#((1) (1) (3) (2)))
+        (equal? (hashtable-ref ht wk4 #f) '(2))
+        (begin
+          (set! wk4 #f)
+          (collect (collect-maximum-generation))
+          (equal-entries? ht '#((1) (2) (3)) '#((1) (1) (3))))))))
+)
+
+(mat ephemeron-eq-hashtable
+  (begin
+    (define ka (list 'a)) ; will map to self  \ Doesn't do anything to check
+    (define kb (list 'b)) ; will map to kc \  | ephemeronness, but just in
+    (define kc (list 'c)) ; will map to kb /  / case.
+    (define kq (list 'q))
+    (define ky (list 'y))
+    (define kz (list 'z))
+    #t)
+  (begin
+    (define h (make-ephemeron-eq-hashtable 32))
+    (and (hashtable? h)
+         (eq-hashtable? h)
+         (hashtable-mutable? h)
+         (hashtable-ephemeron? h)
+         (eq-hashtable-ephemeron? h)))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h ka ka) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc))
+    '(#t #f #f))
+  (eqv? (hashtable-set! h kb kc) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc))
+    '(#t #t #f))
+  (eqv? (hashtable-set! h kc kb) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#((a) (b) (c)) '#((a) (c) (b)))
+  (andmap ephemeron-pair? (vector->list (hashtable-cells h)))
+  #;(same-elements? (list->vector (hashtable-map h cons)) '#(((a) . a) ((b) . c) ((c) . b)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    '#(((a) . a) ((b) . c) ((c) . b)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    '#(((a) . a) ((b) . c) ((c) . b)))
+  (equal? (hashtable-ref h ka 1) '(a))
+  (equal? (hashtable-ref h kb #f) '(c))
+  (equal? (hashtable-ref h kc 'nope) '(b))
+  (eqv? (hashtable-delete! h kb) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#((a) (c)) '#((a) (b)))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (eq-hashtable? h2)
+         (hashtable-mutable? h2)
+         (eq-hashtable-ephemeron? h2)
+         (hashtable-ephemeron? h2)))
+  (eq? (hashtable-hash-function h2) #f)
+  (eq? (hashtable-equivalence-function h2) eq?)
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#((a) (c)) '#((a) (b)))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h ka 1)
+      (hashtable-ref h kb #f)
+      (hashtable-ref h kc 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 ka 1)
+      (hashtable-ref h2 kb #f)
+      (hashtable-ref h2 kc 'nope))
+    '(2 (a) #f (b)))
+  (equal-entries? h2 '#((a) (c)) '#((a) (b)))
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 18)
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 19)
+  (equal? (hashtable-size h) 1)
+  (equal-entries? h '#((q)) '#(19))
+  (eqv?
+    (begin
+      (set! kq (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h))
+    0)
+  (equal-entries? h '#() '#())
+  #;(eqv? (hashtable-map h (lambda args (error #f "oops"))) '())
+  #;(eqv? (hashtable-for-each h (lambda args (error #f "oops"))) (void))
+  #;(eqv? (hashtable-for-each-cell h (lambda args (error #f "oops"))) (void))
+  (equal? (hashtable-ref h ky #f) #f)
+  (eqv?
+    (hashtable-set! h ky 'toad)
+    (void))
+  (equal? (hashtable-ref h ky #f) 'toad)
+  (equal? (hashtable-ref h kz #f) #f)
+  (eqv?
+    (hashtable-update! h kz list 'frog)
+    (void))
+  (equal? (hashtable-ref h kz #f) '(frog))
+  (equal-entries?
+    h
+    (vector kz ky)
+    (vector (hashtable-ref h kz #f) 'toad))
+  (eqv? (hashtable-ref h '(zippo) 'nil) 'nil)
+  (begin
+    (define h3 (hashtable-copy h2 #f))
+    (and (hashtable? h3)
+         (eq-hashtable? h3)
+         (not (hashtable-mutable? h3))
+         (eq-hashtable-ephemeron? h3)
+         (hashtable-ephemeron? h3)))
+  (equal-entries? h2 '#((a) (c)) '#((a) (b)))
+  (equal-entries? h3 '#((a) (c)) '#((a) (b)))
+  (equal?
+    (begin
+      (set! ka (void))
+      (collect (collect-maximum-generation))
+      (list (hashtable-size h2) (hashtable-size h3)))
+    '(1 1))
+  (equal-entries? h2 '#((c)) '#((b)))
+  (equal-entries? h3 '#((c)) '#((b)))
+  (eqv?
+    (begin
+      (set! h3 (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h2))
+    1)
+  (equal-entries? h2 '#((c)) '#((b)))
+
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-eq-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+
+ ; test for proper shrinkage as objects are bwp'd
+ ; uses delete to trigger final shrinkage
+  (equal?
+    (let* ([ht (make-ephemeron-eq-hashtable 32)]
+           [len (#%$hashtable-veclen ht)])
+      (hashtable-set! ht 'a 'b)
+      (for-each
+        (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+        (map (lambda (x) (map list (make-list 1000))) (make-list 100)))
+      (collect (collect-maximum-generation))
+      (hashtable-delete! ht 'a)
+      (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len)))
+    '(0 #t))
+
+  ; test that ephemeron-hashtable values don't make keys reachable
+  (let ([wk1 (list 1)]
+        [wk2 (list 2)]
+        [wk3 (list 3)]
+        [wk4 (list 4)]
+        [ht (make-ephemeron-eq-hashtable)])
+    (hashtable-set! ht wk1 wk1)
+    (hashtable-set! ht wk2 wk1)
+    (hashtable-set! ht wk3 wk3)
+    (hashtable-set! ht wk4 wk2)
+    (collect (collect-maximum-generation))
+    (and
+     (equal-entries? ht '#((1) (2) (3) (4)) '#((1) (1) (3) (2)))
+     (equal? (hashtable-ref ht wk1 #f) wk1)
+     (equal? (hashtable-ref ht wk2 #f) wk1)
+     (equal? (hashtable-ref ht wk3 #f) wk3)
+     (equal? (hashtable-ref ht wk4 #f) wk2)
+     (begin
+       (set! wk1 #f)
+       (set! wk2 #f)
+       (set! wk3 #f)
+       (collect (collect-maximum-generation))
+       (and
+        (equal-entries? ht '#((1) (2) (4)) '#((1) (1) (2)))
+        (equal? (hashtable-ref ht wk4 #f) '(2))
+        (begin
+          (set! wk4 #f)
+          (collect (collect-maximum-generation))
+          (equal-entries? ht '#() '#()))))))
+)
+
+(mat eq-hashtable-cell
+  (let ()
+    (define-record fribble (x))
+    (define random-object
+      (lambda (x)
+        (case (random 9)
+          [(0) (cons 'a 'b)]
+          [(1) (vector 'c)]
+          [(2) (string #\a #\b)]
+          [(3) (make-fribble 'q)]
+          [(4) (gensym)]
+          [(5) (open-output-string)]
+          [(6) (fxvector 15 55)]
+          [(7) (lambda () x)]
+          [else (box 'top)])))
+    (let ([ls1 (let f ([n 10000])
+                 (if (fx= n 0)
+                     '()
+                     (cons
+                       (cons (random-object 4) (random-object 7))
+                       (f (fx- n 1)))))]
+          [ht (make-eq-hashtable)]
+          [wht (make-weak-eq-hashtable)]
+          [eht (make-ephemeron-eq-hashtable)])
+      (let ([ls2 (map (lambda (a1) (eq-hashtable-cell ht (car a1) (cdr a1))) ls1)]
+            [ls3 (map (lambda (a1) (hashtable-cell wht (car a1) (cdr a1))) ls1)]
+            [ls4 (map (lambda (a1) (hashtable-cell eht (car a1) (cdr a1))) ls1)])
+        (unless (andmap (lambda (a1 a2 a3 a4)
+                          (and (eq? (car a1) (car a2))
+                               (eq? (car a2) (car a3))
+                               (eq? (car a2) (car a4))))
+                        ls1 ls2 ls3 ls4)
+          (errorf #f "keys are not eq"))
+        (unless (andmap (lambda (a1 a2 a3 a4)
+                          (and (eq? (cdr a1) (cdr a2))
+                               (eq? (cdr a2) (cdr a3))
+                               (eq? (cdr a2) (cdr a4))))
+                        ls1 ls2 ls3 ls4)
+          (errorf #f "values are not eq"))
+        (for-each (lambda (a1)
+                    (let ([o (random-object 3)])
+                      ;; Value refers to key:
+                      (hashtable-set! eht o (list o (car a1)))))
+                  ls1)
+        (for-each
+          (lambda (a1)
+            (when (fx< (random 10) 5)
+              (set-car! a1 #f)))
+          ls1)
+        (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)])
+          (unless (fx= i 0)
+            (collect)
+            (unless (andmap (lambda (a2 a3 a4) (and (eq? (car a2) (car a3)) (eq? (car a2) (car a4))))
+                            ls2 ls3 ls4)
+              (errorf #f "a2/a3/a4 keys not eq after collection"))
+            (unless (and (andmap (lambda (a3) (not (bwp-object? (car a3)))) ls3)
+                         (andmap (lambda (a4) (not (bwp-object? (car a4)))) ls4))
+              (errorf #f "keys have been bwp'd"))
+            (loop (fx- i 1))))
+        (for-each
+          (lambda (a2)
+            (hashtable-delete! ht (car a2))
+            (set-car! a2 #f))
+          ls2)
+        (unless (and (equal? (hashtable-keys ht) '#())
+                     (equal? (hashtable-values ht) '#())
+                     (zero? (hashtable-size ht)))
+          (errorf #f "ht has not been cleared out"))
+        (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)])
+          (unless (fx= i 0)
+            (collect)
+            (unless (andmap (lambda (a1 a3 a4)
+                              (or (not (car a1))
+                                  (and (eq? (car a1) (car a3))
+                                       (eq? (car a1) (car a4)))))
+                            ls1 ls3 ls4)
+              (errorf #f "a1/a3/a4 keys not eq after collection"))
+            (loop (fx- i 1))))
+        (for-each
+          (lambda (a1 a3 a4)
+            (unless (or (car a1)
+                        (and (bwp-object? (car a3))
+                             (bwp-object? (car a4))))
+              (errorf #f "~s has not been bwp'd I" (car a3))))
+          ls1 ls3 ls4)
+        (for-each (lambda (a1) (set-car! a1 #f)) ls1)
+        (collect (collect-maximum-generation))
+        (unless (and (andmap (lambda (a3) (bwp-object? (car a3))) ls3)
+                     (andmap (lambda (a4) (bwp-object? (car a4))) ls4))
+          (errorf #f "keys have not been bwp'd II"))
+        (unless (and (equal? (hashtable-keys wht) '#())
+                     (equal? (hashtable-values wht) '#())
+                     (zero? (hashtable-size wht)))
+          (errorf #f "wht has not been cleared out"))
+        (unless (and (equal? (hashtable-keys eht) '#())
+                     (equal? (hashtable-values eht) '#())
+                     (zero? (hashtable-size eht)))
+          (errorf #f "eht has not been cleared out"))))
+    #t)
+)
+
+(mat $nonweak-eq-hashtable
+  (begin
+    (define h (make-eq-hashtable 32))
+    (and (hashtable? h)
+         (eq-hashtable? h)
+         (hashtable-mutable? h)
+         (not (eq-hashtable-weak? h))
+         (not (hashtable-weak? h))
+         (not (eq-hashtable-ephemeron? h))
+         (not (hashtable-ephemeron? h))))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (eq-hashtable-set! h 'a 'aval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h 'a)
+       (eq-hashtable-contains? h 'b)
+       (eq-hashtable-contains? h 'c))
+    '(#t #f #f))
+  (eqv? (eq-hashtable-set! h 'b 'bval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h 'a)
+       (eq-hashtable-contains? h 'b)
+       (eq-hashtable-contains? h 'c))
+    '(#t #t #f))
+  (eqv? (eq-hashtable-set! h 'c 'cval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h 'a)
+       (eq-hashtable-contains? h 'b)
+       (eq-hashtable-contains? h 'c))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#(b c a) '#(bval cval aval))
+  (equal? (eq-hashtable-ref h 'a 1) 'aval)
+  (equal? (eq-hashtable-ref h 'b #f) 'bval)
+  (equal? (eq-hashtable-ref h 'c 'nope) 'cval)
+  (eqv? (eq-hashtable-delete! h 'b) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#(a c) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (eq-hashtable? h2)
+         (hashtable-mutable? h2)
+         (not (eq-hashtable-weak? h2))
+         (not (hashtable-weak? h2))))
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (eq-hashtable-ref h 'a 1)
+      (eq-hashtable-ref h 'b #f)
+      (eq-hashtable-ref h 'c 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (eq-hashtable-ref h2 'a 1)
+      (eq-hashtable-ref h2 'b #f)
+      (eq-hashtable-ref h2 'c 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv?
+    (eq-hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (eq-hashtable-ref h 'q #f) 18)
+  (eqv?
+    (eq-hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (eq-hashtable-ref h 'q #f) 19)
+  (equal? (hashtable-size h) 1)
+ ; test hashtable-copy when some keys may have moved
+  (let ([t (parameterize ([collect-request-handler void])
+             (let ([h4a (make-eq-hashtable 32)]
+                   [k* (map list (make-list 100))])
+               (for-each (lambda (x) (eq-hashtable-set! h4a x x)) k*)
+               (collect)
+              ; create copy after collection but before otherwise touching h4a
+               (let ([h4b (hashtable-copy h4a #t)])
+                 (andmap
+                   (lambda (k) (eq? (eq-hashtable-ref h4b k #f) k))
+                   k*))))])
+    (collect)
+    t)
+
+ ; test for proper shrinkage, etc.
+  (equal?
+    (let* ([ht (make-eq-hashtable)] [minlen (#%$hashtable-veclen ht)])
+      (define power-of-two? (lambda (n) (fx= (fxbit-count n) 1)))
+      (let f ([i 0])
+        (unless (fx= i (expt 2 17))
+          (let ([k (fx* i 2)])
+            (eq-hashtable-set! ht k i)
+            (f (fx+ i 1))
+            (assert (eq-hashtable-contains? ht k))
+            (assert (power-of-two? (#%$hashtable-veclen ht)))
+            (eq-hashtable-delete! ht k))))
+      (list (hashtable-size ht) (fx= (#%$hashtable-veclen ht) minlen)))
+    '(0 #t))
+
+  (equal?
+    (let ([ht (make-eq-hashtable 32)])
+      (define power-of-two? (lambda (n) (fx= (fxbit-count n) 1)))
+      (let f ([i 0])
+        (unless (fx= i (expt 2 17))
+          (let ([k (fx* i 2)])
+            (eq-hashtable-set! ht k i)
+            (f (fx+ i 1))
+            (assert (eq-hashtable-contains? ht k))
+            (assert (power-of-two? (#%$hashtable-veclen ht)))
+            (eq-hashtable-delete! ht k))))
+      (list (hashtable-size ht) (#%$hashtable-veclen ht)))
+    '(0 32))
+)
+
+(mat $weak-eq-hashtable
+  (begin
+    (define ka (list 'a))
+    (define kb (list 'b))
+    (define kc (list 'c))
+    (define kq (list 'q))
+    (define ky (list 'y))
+    (define kz (list 'z))
+    #t)
+  (begin
+    (define h (make-weak-eq-hashtable 32))
+    (and (hashtable? h)
+         (eq-hashtable? h)
+         (hashtable-mutable? h)
+         (eq-hashtable-weak? h)
+         (hashtable-weak? h)))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (eq-hashtable-set! h ka 'aval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h ka)
+       (eq-hashtable-contains? h kb)
+       (eq-hashtable-contains? h kc))
+    '(#t #f #f))
+  (eqv? (eq-hashtable-set! h kb 'bval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h ka)
+       (eq-hashtable-contains? h kb)
+       (eq-hashtable-contains? h kc))
+    '(#t #t #f))
+  (eqv? (eq-hashtable-set! h kc 'cval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h ka)
+       (eq-hashtable-contains? h kb)
+       (eq-hashtable-contains? h kc))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#((a) (b) (c)) '#(aval bval cval))
+  (andmap weak-pair? (vector->list (hashtable-cells h)))
+  (equal? (eq-hashtable-ref h ka 1) 'aval)
+  (equal? (eq-hashtable-ref h kb #f) 'bval)
+  (equal? (eq-hashtable-ref h kc 'nope) 'cval)
+  (eqv? (eq-hashtable-delete! h kb) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#((a) (c)) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (eq-hashtable? h2)
+         (hashtable-mutable? h2)
+         (hashtable-weak? h2)
+         (eq-hashtable-weak? h2)))
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (eq-hashtable-ref h ka 1)
+      (eq-hashtable-ref h kb #f)
+      (eq-hashtable-ref h kc 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (eq-hashtable-ref h2 ka 1)
+      (eq-hashtable-ref h2 kb #f)
+      (eq-hashtable-ref h2 kc 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (eqv?
+    (eq-hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (eq-hashtable-ref h kq #f) 18)
+  (eqv?
+    (eq-hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (eq-hashtable-ref h kq #f) 19)
+  (equal? (hashtable-size h) 1)
+  (equal-entries? h '#((q)) '#(19))
+  (eqv?
+    (begin
+      (set! kq (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h))
+    0)
+  (equal-entries? h '#() '#())
+  (equal? (eq-hashtable-ref h ky #f) #f)
+  (eqv?
+    (eq-hashtable-set! h ky 'toad)
+    (void))
+  (equal? (eq-hashtable-ref h ky #f) 'toad)
+  (equal? (eq-hashtable-ref h kz #f) #f)
+  (eqv?
+    (eq-hashtable-update! h kz list 'frog)
+    (void))
+  (equal? (eq-hashtable-ref h kz #f) '(frog))
+  (equal-entries?
+    h
+    (vector kz ky)
+    (vector (eq-hashtable-ref h kz #f) 'toad))
+  (eqv? (eq-hashtable-ref h '(zippo) 'nil) 'nil)
+  (begin
+    (define h3 (hashtable-copy h2 #f))
+    (and (hashtable? h3)
+         (eq-hashtable? h3)
+         (not (hashtable-mutable? h3))
+         (eq-hashtable-weak? h3)
+         (hashtable-weak? h3)))
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (equal-entries? h3 '#((a) (c)) '#(aval cval))
+  (equal?
+    (begin
+      (set! ka (void))
+      (collect (collect-maximum-generation))
+      (list (hashtable-size h2) (hashtable-size h3)))
+    '(1 1))
+  (equal-entries? h2 '#((c)) '#(cval))
+  (equal-entries? h3 '#((c)) '#(cval))
+  (eqv?
+    (begin
+      (set! h3 (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h2))
+    1)
+  (equal-entries? h2 '#((c)) '#(cval))
+
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-eq-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (eq-hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+
+ ; test for proper shrinkage as objects are bwp'd
+ ; uses delete to trigger final shrinkage
+  (equal?
+    (let* ([ht (make-weak-eq-hashtable 32)]
+           [len (#%$hashtable-veclen ht)])
+      (eq-hashtable-set! ht 'a 'b)
+      (for-each
+        (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*))
+        (map (lambda (x) (map list (make-list 1000))) (make-list 100)))
+      (collect (collect-maximum-generation))
+      (eq-hashtable-delete! ht 'a)
+      (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len)))
+    '(0 #t))
+  )
+
+(mat $ephemeron-eq-hashtable
+  (begin
+    (define ka (list 'a))
+    (define kb (list 'b))
+    (define kc (list 'c))
+    (define kq (list 'q))
+    (define ky (list 'y))
+    (define kz (list 'z))
+    #t)
+  (begin
+    (define h (make-ephemeron-eq-hashtable 32))
+    (and (hashtable? h)
+         (eq-hashtable? h)
+         (hashtable-mutable? h)
+         (eq-hashtable-ephemeron? h)
+         (hashtable-ephemeron? h)))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (eq-hashtable-set! h ka 'aval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h ka)
+       (eq-hashtable-contains? h kb)
+       (eq-hashtable-contains? h kc))
+    '(#t #f #f))
+  (eqv? (eq-hashtable-set! h kb 'bval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h ka)
+       (eq-hashtable-contains? h kb)
+       (eq-hashtable-contains? h kc))
+    '(#t #t #f))
+  (eqv? (eq-hashtable-set! h kc 'cval) (void))
+  (equal?
+    (list
+       (eq-hashtable-contains? h ka)
+       (eq-hashtable-contains? h kb)
+       (eq-hashtable-contains? h kc))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#((a) (b) (c)) '#(aval bval cval))
+  (andmap ephemeron-pair? (vector->list (hashtable-cells h)))
+  (equal? (eq-hashtable-ref h ka 1) 'aval)
+  (equal? (eq-hashtable-ref h kb #f) 'bval)
+  (equal? (eq-hashtable-ref h kc 'nope) 'cval)
+  (eqv? (eq-hashtable-delete! h kb) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#((a) (c)) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (eq-hashtable? h2)
+         (hashtable-mutable? h2)
+         (hashtable-ephemeron? h2)
+         (eq-hashtable-ephemeron? h2)))
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (eq-hashtable-ref h ka 1)
+      (eq-hashtable-ref h kb #f)
+      (eq-hashtable-ref h kc 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (eq-hashtable-ref h2 ka 1)
+      (eq-hashtable-ref h2 kb #f)
+      (eq-hashtable-ref h2 kc 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (eqv?
+    (eq-hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (eq-hashtable-ref h kq #f) 18)
+  (eqv?
+    (eq-hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (eq-hashtable-ref h kq #f) 19)
+  (equal? (hashtable-size h) 1)
+  (equal-entries? h '#((q)) '#(19))
+  (eqv?
+    (begin
+      (set! kq (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h))
+    0)
+  (equal-entries? h '#() '#())
+  (equal? (eq-hashtable-ref h ky #f) #f)
+  (eqv?
+    (eq-hashtable-set! h ky 'toad)
+    (void))
+  (equal? (eq-hashtable-ref h ky #f) 'toad)
+  (equal? (eq-hashtable-ref h kz #f) #f)
+  (eqv?
+    (eq-hashtable-update! h kz list 'frog)
+    (void))
+  (equal? (eq-hashtable-ref h kz #f) '(frog))
+  (equal-entries?
+    h
+    (vector kz ky)
+    (vector (eq-hashtable-ref h kz #f) 'toad))
+  (eqv? (eq-hashtable-ref h '(zippo) 'nil) 'nil)
+  (begin
+    (define h3 (hashtable-copy h2 #f))
+    (and (hashtable? h3)
+         (eq-hashtable? h3)
+         (not (hashtable-mutable? h3))
+         (eq-hashtable-ephemeron? h3)
+         (hashtable-ephemeron? h3)))
+  (equal-entries? h2 '#((a) (c)) '#(aval cval))
+  (equal-entries? h3 '#((a) (c)) '#(aval cval))
+  (equal?
+    (begin
+      (set! ka (void))
+      (collect (collect-maximum-generation))
+      (list (hashtable-size h2) (hashtable-size h3)))
+    '(1 1))
+  (equal-entries? h2 '#((c)) '#(cval))
+  (equal-entries? h3 '#((c)) '#(cval))
+  (eqv?
+    (begin
+      (set! h3 (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h2))
+    1)
+  (equal-entries? h2 '#((c)) '#(cval))
+
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-eq-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (eq-hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+
+ ; test for proper shrinkage as objects are bwp'd
+ ; uses delete to trigger final shrinkage
+  (equal?
+    (let* ([ht (make-ephemeron-eq-hashtable 32)]
+           [len (#%$hashtable-veclen ht)])
+      (eq-hashtable-set! ht 'a 'b)
+      (for-each
+        (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*))
+        (map (lambda (x) (map list (make-list 1000))) (make-list 100)))
+      (collect (collect-maximum-generation))
+      (eq-hashtable-delete! ht 'a)
+      (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len)))
+    '(0 #t))
+)
+
+(mat eq-strange
+  (begin
+    (define $ht (make-eq-hashtable))
+    (define $wht (make-weak-eq-hashtable))
+    (define $eht (make-ephemeron-eq-hashtable))
+    (and (hashtable? $ht)
+         (eq-hashtable? $ht)
+         (hashtable? $wht)
+         (eq-hashtable? $wht)
+         (hashtable? $eht)
+         (eq-hashtable? $eht)))
+  (eqv? (hashtable-set! $ht #f 75) (void))
+  (eqv? (hashtable-ref $ht #f 80) 75)
+  (eqv? (hashtable-set! $wht #f 75) (void))
+  (eqv? (hashtable-ref $wht #f 80) 75)
+  (eqv? (hashtable-set! $eht #f 75) (void))
+  (eqv? (hashtable-ref $eht #f 80) 75)
+  (eqv? (hashtable-set! $ht #!bwp "hello") (void))
+  (equal? (hashtable-ref $ht #!bwp "goodbye") "hello")
+  (eqv? (hashtable-set! $wht #!bwp "hello") (void))
+  (and (member (hashtable-ref $wht #!bwp "goodbye") '("hello" "goodbye")) #t)
+  (eqv? (hashtable-set! $eht #!bwp "hello") (void))
+  (and (member (hashtable-ref $eht #!bwp "goodbye") '("hello" "goodbye")) #t)
+ ; make sure that association isn't added before procedure is called
+  (equal?
+    (begin
+      (hashtable-update! $ht 'cupie
+        (lambda (x) (hashtable-ref $ht 'cupie (cons 'barbie x)))
+        'doll)
+      (hashtable-ref $ht 'cupie 'oops))
+   '(barbie . doll))
+  (equal?
+    (begin
+      (hashtable-update! $wht 'cupie
+        (lambda (x) (hashtable-ref $wht 'cupie (cons 'barbie x)))
+        'doll)
+      (hashtable-ref $wht 'cupie 'oops))
+   '(barbie . doll))
+  (equal?
+    (begin
+      (hashtable-update! $eht 'cupie
+        (lambda (x) (hashtable-ref $eht 'cupie (cons 'barbie x)))
+        'doll)
+      (hashtable-ref $eht 'cupie 'oops))
+   '(barbie . doll))
+)
+
+(mat eq-hashtable-stress
+ ; stress tests
+  (let () ; nonweak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-eq-hashtable 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (= (hashtable-size ht) (- n (length drop)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+  (let () ; weak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-weak-eq-hashtable 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (<= (hashtable-size ht) (- n (length drop)))
+                 (begin
+                   (collect (collect-maximum-generation))
+                   (= (hashtable-size ht) (length keep)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+  (let () ; ephemeron
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-ephemeron-eq-hashtable 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (<= (hashtable-size ht) (- n (length drop)))
+                 (begin
+                   (collect (collect-maximum-generation))
+                   (= (hashtable-size ht) (length keep)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+)
+
+(mat nonweak-eqv-hashtable
+  (begin
+    (define h (make-eqv-hashtable 32))
+    (and (hashtable? h)
+         (not (eq-hashtable? h))
+         (hashtable-mutable? h)
+         (not (hashtable-weak? h))
+         (not (hashtable-ephemeron? h))))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eqv?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h 'a 'aval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 3.4)
+       (hashtable-contains? h 'c))
+    '(#t #f #f))
+  (eqv? (hashtable-set! h 3.4 'bval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 3.4)
+       (hashtable-contains? h 'c))
+    '(#t #t #f))
+  (eqv? (hashtable-set! h 'c 'cval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 3.4)
+       (hashtable-contains? h 'c))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#(3.4 c a) '#(bval cval aval))
+  #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (3.4 . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (3.4 . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (3.4 . bval) (c . cval)))
+  (equal? (hashtable-ref h 'a 1) 'aval)
+  (equal? (hashtable-ref h 3.4 #f) 'bval)
+  (equal? (hashtable-ref h 'c 'nope) 'cval)
+  (eqv? (hashtable-delete! h 3.4) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#(a c) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (hashtable-mutable? h2)
+         (not (hashtable-weak? h2))
+         (not (hashtable-ephemeron? h2))))
+  (eq? (hashtable-hash-function h2) #f)
+  (eq? (hashtable-equivalence-function h2) eqv?)
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h 'a 1)
+      (hashtable-ref h 3.4 #f)
+      (hashtable-ref h 'c 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 'a 1)
+      (hashtable-ref h2 3.4 #f)
+      (hashtable-ref h2 'c 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv?
+    (hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h 'q #f) 18)
+  (eqv?
+    (hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h 'q #f) 19)
+  (equal? (hashtable-size h) 1)
+ ; test hashtable-copy when some keys may have moved
+  (let ([t (parameterize ([collect-request-handler void])
+             (let ([h4a (make-eqv-hashtable 32)]
+                   [k* (map list (make-list 100))])
+               (for-each (lambda (x) (hashtable-set! h4a x x)) k*)
+               (collect)
+              ; create copy after collection but before otherwise touching h4a
+               (let ([h4b (hashtable-copy h4a #t)])
+                 (andmap
+                   (lambda (k) (eqv? (hashtable-ref h4b k #f) k))
+                   k*))))])
+    (collect)
+    t)
+
+ ; test for proper shrinkage
+  (equal?
+    (let ([ht (make-eqv-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (call-with-values (lambda () (#%$hashtable-veclen ht)) cons))
+    '(32 . 32))
+)
+
+(mat weak-eqv-hashtable
+  (begin
+    (define ka (list 'a))
+    (define kb (list 'b))
+    (define kc (list 'c))
+    (define kq (list 'q))
+    (define ky (list 'y))
+    (define kz (list 'z))
+    (define km -5.75)
+    (define kn 17)
+    (define ko (+ (most-positive-fixnum) 5))
+    #t)
+  (begin
+    (define h (make-weak-eqv-hashtable 32))
+    (and (hashtable? h)
+         (not (eq-hashtable? h))
+         (hashtable-mutable? h)
+         (hashtable-weak? h)))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eqv?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h ka 'aval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #f #f #f #f #f))
+  (eqv? (hashtable-set! h kb 'bval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #f #f #f #f))
+  (eqv? (hashtable-set! h kc 'cval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #f #f #f))
+  (eqv? (hashtable-set! h km 'mval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #t #f #f))
+  (eqv? (hashtable-set! h kn 'nval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #t #t #f))
+  (eqv? (hashtable-set! h ko 'oval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #t #t #t))
+  (equal? (hashtable-size h) 6)
+  (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval))
+  #;(same-elements?
+    (list->vector (hashtable-map h cons))
+    `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval)))
+  #;(same-elements?
+    (let ([v (make-vector 6)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval)))
+  #;(same-elements?
+    (let ([v (make-vector 6)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval)))
+  (eq? (hashtable-ref h ka 1) 'aval)
+  (eq? (hashtable-ref h kb #f) 'bval)
+  (eq? (hashtable-ref h kc 'nope) 'cval)
+  (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval)
+  (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval)
+  (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval)
+  (eqv? (hashtable-delete! h kb) (void))
+  (equal? (hashtable-size h) 5)
+  (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (hashtable-mutable? h2)
+         (hashtable-weak? h2)))
+  (eq? (hashtable-hash-function h2) #f)
+  (eq? (hashtable-equivalence-function h2) eqv?)
+  (equal? (hashtable-size h2) 5)
+  (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h ka 1)
+      (hashtable-ref h kb #f)
+      (hashtable-ref h kc 'nope)
+      (hashtable-ref h km 'nope)
+      (hashtable-ref h kn 'nope)
+      (hashtable-ref h ko 'nope))
+   '(0 1 #f nope nope nope nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 ka 1)
+      (hashtable-ref h2 kb #f)
+      (hashtable-ref h2 kc 'nope)
+      (hashtable-ref h2 (- (+ km 1) 1) 'nope)
+      (hashtable-ref h2 (- (+ kn 1) 1) 'nope)
+      (hashtable-ref h2 (- (+ ko 1) 1) 'nope))
+    '(5 aval #f cval mval nval oval))
+  (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 18)
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 19)
+  (equal? (hashtable-size h) 1)
+  (equal-entries? h '#((q)) '#(19))
+  (eqv?
+    (begin
+      (set! kq (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h))
+    0)
+  (equal-entries? h '#() '#())
+  (equal? (hashtable-ref h ky #f) #f)
+  (eqv?
+    (hashtable-set! h ky 'toad)
+    (void))
+  (equal? (hashtable-ref h ky #f) 'toad)
+  (equal? (hashtable-ref h kz #f) #f)
+  (eqv?
+    (hashtable-update! h kz list 'frog)
+    (void))
+  (equal? (hashtable-ref h kz #f) '(frog))
+  (equal-entries?
+    h
+    (vector kz ky)
+    (vector (hashtable-ref h kz #f) 'toad))
+  (eqv? (hashtable-ref h '(zippo) 'nil) 'nil)
+  (begin
+    (define h3 (hashtable-copy h2 #f))
+    (and (hashtable? h3)
+         (not (hashtable-mutable? h3))
+         (hashtable-weak? h3)))
+  (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (equal?
+    (begin
+      (set! ka (void))
+      (set! km (void))
+      (set! kn (void))
+      (set! ko (void))
+      (collect (collect-maximum-generation))
+      (list (hashtable-size h2) (hashtable-size h3)))
+    '(4 4))
+  (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval))
+  (equal-entries? h3 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval))
+  (eqv?
+    (begin
+      (set! h3 (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h2))
+    4)
+  (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval))
+
+ ; test for proper shrinkage
+  (equal?
+    (let ([ht (make-eqv-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (call-with-values (lambda () (#%$hashtable-veclen ht)) cons))
+    '(32 . 32))
+
+ ; test for proper shrinkage as objects are bwp'd
+ ; uses delete to trigger final shrinkage
+  (equal?
+    (let ([ht (make-weak-eqv-hashtable 32)])
+      (hashtable-set! ht 'a 'b)
+      (for-each
+        (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+        (map (lambda (x) (map list (make-list 1000))) (make-list 100)))
+      (collect (collect-maximum-generation))
+      (hashtable-delete! ht 'a)
+      (list (hashtable-size ht)
+            (let-values ([(n1 n2) (#%$hashtable-veclen ht)])
+              (= n1 n2 32))))
+    '(0 #t))
+  )
+
+(mat ephemeron-eqv-hashtable
+  (begin
+    (define ka (list 'a))
+    (define kb (list 'b))
+    (define kc (list 'c))
+    (define kq (list 'q))
+    (define ky (list 'y))
+    (define kz (list 'z))
+    (define km -5.75)
+    (define kn 17)
+    (define ko (+ (most-positive-fixnum) 5))
+    #t)
+  (begin
+    (define h (make-ephemeron-eqv-hashtable 32))
+    (and (hashtable? h)
+         (not (eq-hashtable? h))
+         (hashtable-mutable? h)
+         (hashtable-ephemeron? h)))
+  (eq? (hashtable-hash-function h) #f)
+  (eq? (hashtable-equivalence-function h) eqv?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h ka 'aval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #f #f #f #f #f))
+  (eqv? (hashtable-set! h kb 'bval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #f #f #f #f))
+  (eqv? (hashtable-set! h kc 'cval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #f #f #f))
+  (eqv? (hashtable-set! h km 'mval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #t #f #f))
+  (eqv? (hashtable-set! h kn 'nval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #t #t #f))
+  (eqv? (hashtable-set! h ko 'oval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h ka)
+       (hashtable-contains? h kb)
+       (hashtable-contains? h kc)
+       (hashtable-contains? h km)
+       (hashtable-contains? h kn)
+       (hashtable-contains? h ko))
+    '(#t #t #t #t #t #t))
+  (equal? (hashtable-size h) 6)
+  (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval))
+  #;(same-elements?
+    (list->vector (hashtable-map h cons))
+    `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval)))
+  #;(same-elements?
+    (let ([v (make-vector 6)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval)))
+  #;(same-elements?
+    (let ([v (make-vector 6)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval)))
+  (eq? (hashtable-ref h ka 1) 'aval)
+  (eq? (hashtable-ref h kb #f) 'bval)
+  (eq? (hashtable-ref h kc 'nope) 'cval)
+  (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval)
+  (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval)
+  (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval)
+  (eqv? (hashtable-delete! h kb) (void))
+  (equal? (hashtable-size h) 5)
+  (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (hashtable-mutable? h2)
+         (hashtable-ephemeron? h2)))
+  (eq? (hashtable-hash-function h2) #f)
+  (eq? (hashtable-equivalence-function h2) eqv?)
+  (equal? (hashtable-size h2) 5)
+  (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h ka 1)
+      (hashtable-ref h kb #f)
+      (hashtable-ref h kc 'nope)
+      (hashtable-ref h km 'nope)
+      (hashtable-ref h kn 'nope)
+      (hashtable-ref h ko 'nope))
+   '(0 1 #f nope nope nope nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 ka 1)
+      (hashtable-ref h2 kb #f)
+      (hashtable-ref h2 kc 'nope)
+      (hashtable-ref h2 (- (+ km 1) 1) 'nope)
+      (hashtable-ref h2 (- (+ kn 1) 1) 'nope)
+      (hashtable-ref h2 (- (+ ko 1) 1) 'nope))
+    '(5 aval #f cval mval nval oval))
+  (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 18)
+  (eqv?
+    (hashtable-update! h kq
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h kq #f) 19)
+  (equal? (hashtable-size h) 1)
+  (equal-entries? h '#((q)) '#(19))
+  (eqv?
+    (begin
+      (set! kq (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h))
+    0)
+  (equal-entries? h '#() '#())
+  (equal? (hashtable-ref h ky #f) #f)
+  (eqv?
+    (hashtable-set! h ky 'toad)
+    (void))
+  (equal? (hashtable-ref h ky #f) 'toad)
+  (equal? (hashtable-ref h kz #f) #f)
+  (eqv?
+    (hashtable-update! h kz list 'frog)
+    (void))
+  (equal? (hashtable-ref h kz #f) '(frog))
+  (equal-entries?
+    h
+    (vector kz ky)
+    (vector (hashtable-ref h kz #f) 'toad))
+  (eqv? (hashtable-ref h '(zippo) 'nil) 'nil)
+  (begin
+    (define h3 (hashtable-copy h2 #f))
+    (and (hashtable? h3)
+         (not (hashtable-mutable? h3))
+         (hashtable-ephemeron? h3)))
+  (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval))
+  (equal?
+    (begin
+      (set! ka (void))
+      (set! km (void))
+      (set! kn (void))
+      (set! ko (void))
+      (collect (collect-maximum-generation))
+      (list (hashtable-size h2) (hashtable-size h3)))
+    '(4 4))
+  (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval))
+  (equal-entries? h3 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval))
+  (eqv?
+    (begin
+      (set! h3 (void))
+      (collect (collect-maximum-generation))
+      (hashtable-size h2))
+    4)
+  (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval))
+
+ ; test for proper shrinkage
+  (equal?
+    (let ([ht (make-eqv-hashtable 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (map list (make-list 1000)))
+                        (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (call-with-values (lambda () (#%$hashtable-veclen ht)) cons))
+    '(32 . 32))
+
+ ; test for proper shrinkage as objects are bwp'd
+ ; uses delete to trigger final shrinkage
+  (equal?
+    (let ([ht (make-ephemeron-eqv-hashtable 32)])
+      (hashtable-set! ht 'a 'b)
+      (for-each
+        (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+        (map (lambda (x) (map list (make-list 1000))) (make-list 100)))
+      (collect (collect-maximum-generation))
+      (hashtable-delete! ht 'a)
+      (list (hashtable-size ht)
+            (let-values ([(n1 n2) (#%$hashtable-veclen ht)])
+              (= n1 n2 32))))
+    '(0 #t))
+)
+
+(mat eqv-hashtable-cell
+  (let ()
+    (define-record fribble (x))
+    (define random-object
+      (lambda (x)
+        (case (random 9)
+          [(0) (cons 'a 3.4)]
+          [(1) (vector 'c)]
+          [(2) (string #\a #\b)]
+          [(3) (make-fribble 'q)]
+          [(4) (gensym)]
+          [(5) (open-output-string)]
+          [(6) (fxvector 15 55)]
+          [(7) (lambda () x)]
+          [else (box 'top)])))
+    (let ([ls1 (let f ([n 10000])
+                 (if (fx= n 0)
+                     '()
+                     (cons
+                       (cons (random-object 4) (random-object 7))
+                       (f (fx- n 1)))))]
+          [ht (make-eqv-hashtable)]
+          [wht (make-weak-eqv-hashtable)]
+          [eht (make-ephemeron-eqv-hashtable)])
+      (let ([ls2 (map (lambda (a1) (hashtable-cell ht (car a1) (cdr a1))) ls1)]
+            [ls3 (map (lambda (a1) (hashtable-cell wht (car a1) (cdr a1))) ls1)]
+            [ls4 (map (lambda (a1) (hashtable-cell eht (car a1) (cdr a1))) ls1)])
+        (unless (andmap (lambda (a1 a2 a3 a4)
+                          (and (eqv? (car a1) (car a2))
+                               (eqv? (car a2) (car a3))
+                               (eqv? (car a2) (car a4))))
+                        ls1 ls2 ls3 ls4)
+          (errorf #f "keys are not eqv"))
+        (unless (andmap (lambda (a1 a2 a3 a4)
+                          (and (eqv? (cdr a1) (cdr a2))
+                               (eqv? (cdr a2) (cdr a3))
+                               (eqv? (cdr a2) (cdr a4))))
+                        ls1 ls2 ls3 ls4)
+          (errorf #f "values are not eqv"))
+        (for-each (lambda (a1)
+                    (let ([o (random-object 3)])
+                      ;; Value refers to key:
+                      (hashtable-set! eht o (list o (car a1)))))
+                  ls1)
+        (for-each
+          (lambda (a1)
+            (when (fx< (random 10) 5)
+              (set-car! a1 #f)))
+          ls1)
+        (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)])
+          (unless (fx= i 0)
+            (collect)
+            (unless (andmap (lambda (a2 a3 a4) (and (eqv? (car a2) (car a3)) (eqv? (car a2) (car a4))))
+                            ls2 ls3 ls4)
+              (errorf #f "a2/a3/a4 keys not eqv after collection"))
+            (unless (and (andmap (lambda (a3) (not (bwp-object? (car a3)))) ls3)
+                         (andmap (lambda (a4) (not (bwp-object? (car a4)))) ls4))
+              (errorf #f "keys have been bwp'd"))
+            (loop (fx- i 1))))
+        (for-each
+          (lambda (a2)
+            (hashtable-delete! ht (car a2))
+            (set-car! a2 #f))
+          ls2)
+        (unless (and (equal? (hashtable-keys ht) '#())
+                     (equal? (hashtable-values ht) '#())
+                     (zero? (hashtable-size ht)))
+          (errorf #f "ht has not been cleared out"))
+        (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)])
+          (unless (fx= i 0)
+            (collect)
+            (unless (andmap (lambda (a1 a3 a4)
+                              (or (not (car a1))
+                                  (and (eqv? (car a1) (car a3))
+                                       (eqv? (car a1) (car a4)))))
+                            ls1 ls3 ls4)
+              (errorf #f "a1/a3/a4 keys not eqv after collection"))
+            (loop (fx- i 1))))
+        (for-each
+          (lambda (a1 a3 a4)
+            (unless (or (car a1)
+                        (and (bwp-object? (car a3))
+                             (bwp-object? (car a4))))
+              (errorf #f "~s has not been bwp'd I" (car a3))))
+          ls1 ls3 ls4)
+        (for-each (lambda (a1) (set-car! a1 #f)) ls1)
+        (collect (collect-maximum-generation))
+        (unless (and (andmap (lambda (a3) (bwp-object? (car a3))) ls3)
+                     (andmap (lambda (a4) (bwp-object? (car a4))) ls4))
+          (errorf #f "keys have not been bwp'd II"))
+        (unless (and (equal? (hashtable-keys wht) '#())
+                     (equal? (hashtable-values wht) '#())
+                     (zero? (hashtable-size wht)))
+          (errorf #f "wht has not been cleared out"))
+        (unless (and (equal? (hashtable-keys eht) '#())
+                     (equal? (hashtable-values eht) '#())
+                     (zero? (hashtable-size eht)))
+          (errorf #f "eht has not been cleared out"))))
+    #t)
+  )
+
+(mat eqv-strange
+  (begin
+    (define $ht (make-eqv-hashtable))
+    (define $wht (make-weak-eqv-hashtable))
+    (define $eht (make-weak-eqv-hashtable))
+    (and (hashtable? $ht)
+         (hashtable? $wht)
+         (hashtable? $eht)))
+  (eqv? (hashtable-set! $ht #f 75) (void))
+  (eqv? (hashtable-ref $ht #f 80) 75)
+  (eqv? (hashtable-set! $wht #f 75) (void))
+  (eqv? (hashtable-ref $wht #f 80) 75)
+  (eqv? (hashtable-set! $eht #f 75) (void))
+  (eqv? (hashtable-ref $eht #f 80) 75)
+  (eqv? (hashtable-set! $ht #!bwp "hello") (void))
+  (equal? (hashtable-ref $ht #!bwp "goodbye") "hello")
+  (eqv? (hashtable-set! $wht #!bwp "hello") (void))
+  (eqv? (hashtable-set! $eht #!bwp "hello") (void))
+  (and (member (hashtable-ref $wht #!bwp "goodbye") '("hello" "goodbye")) #t)
+  (and (member (hashtable-ref $eht #!bwp "goodbye") '("hello" "goodbye")) #t)
+ ; make sure that association isn't added before procedure is called
+  (equal?
+    (begin
+      (hashtable-update! $ht 'cupie
+        (lambda (x) (hashtable-ref $ht 'cupie (cons 'barbie x)))
+        'doll)
+      (hashtable-ref $ht 'cupie 'oops))
+   '(barbie . doll))
+  (equal?
+    (begin
+      (hashtable-update! $wht 'cupie
+        (lambda (x) (hashtable-ref $wht 'cupie (cons 'barbie x)))
+        'doll)
+      (hashtable-ref $wht 'cupie 'oops))
+   '(barbie . doll))
+  (equal?
+    (begin
+      (hashtable-update! $eht 'cupie
+        (lambda (x) (hashtable-ref $eht 'cupie (cons 'barbie x)))
+        'doll)
+      (hashtable-ref $eht 'cupie 'oops))
+   '(barbie . doll))
+)
+
+(mat eqv-hashtable-stress
+ ; stress tests
+  (let () ; nonweak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-eqv-hashtable 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (= (hashtable-size ht) (- n (length drop)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eqv? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+  (let () ; weak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-weak-eqv-hashtable 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (<= (hashtable-size ht) (- n (length drop)))
+                 (begin
+                   (collect (collect-maximum-generation))
+                   (= (hashtable-size ht) (length keep)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eqv? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+  (let () ; ephemeron
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-ephemeron-eqv-hashtable 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (<= (hashtable-size ht) (- n (length drop)))
+                 (begin
+                   (collect (collect-maximum-generation))
+                   (= (hashtable-size ht) (length keep)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (cond
+                               [(string? k) k]
+                               [(pair? k) (car k)]
+                               [(vector? k) (vector-ref k 0)])))
+                         keep)
+                 (andmap (lambda (k) (eqv? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (case (pick '(string pair vector))
+                         [(string) s]
+                         [(pair) (list s)]
+                         [(vector) (vector s)])])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+
+)
+
+(mat symbol-hashtable
+  (let ([ht (make-hashtable symbol-hash eq?)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eq?)))
+  (let ([ht (make-hashtable symbol-hash eqv?)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eqv?)))
+  (let ([ht (make-hashtable symbol-hash equal?)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) equal?)))
+  (let ([ht (make-hashtable symbol-hash symbol=?)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) symbol=?)))
+  (let ([ht (make-hashtable symbol-hash eq? 17)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eq?)))
+  (let ([ht (make-hashtable symbol-hash eqv? 17)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eqv?)))
+  (let ([ht (make-hashtable symbol-hash equal? 17)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) equal?)))
+  (let ([ht (make-hashtable symbol-hash symbol=? 17)])
+    (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) symbol=?)))
+  (begin
+    (define h (make-hashtable symbol-hash eq? 32))
+    (and (hashtable? h)
+         (symbol-hashtable? h)
+         (hashtable-mutable? h)
+         (not (eq-hashtable? h))
+         (not (hashtable-weak? h))
+         (not (hashtable-ephemeron? h))))
+  (eq? (hashtable-hash-function h) symbol-hash)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (hashtable-set! h 'a 'aval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 'b)
+       (hashtable-contains? h 'c))
+    '(#t #f #f))
+  (eqv? (hashtable-set! h 'b 'bval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 'b)
+       (hashtable-contains? h 'c))
+    '(#t #t #f))
+  (eqv? (hashtable-set! h 'c 'cval) (void))
+  (equal?
+    (list
+       (hashtable-contains? h 'a)
+       (hashtable-contains? h 'b)
+       (hashtable-contains? h 'c))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#(b c a) '#(bval cval aval))
+  #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (b . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (b . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (b . bval) (c . cval)))
+  (equal? (hashtable-ref h 'a 1) 'aval)
+  (equal? (hashtable-ref h 'b #f) 'bval)
+  (equal? (hashtable-ref h 'c 'nope) 'cval)
+  (eqv? (hashtable-delete! h 'b) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#(a c) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (symbol-hashtable? h2)
+         (hashtable-mutable? h2)
+         (not (hashtable-weak? h2))
+         (not (hashtable-ephemeron? h2))
+         (not (eq-hashtable? h2))))
+  (eq? (hashtable-hash-function h2) symbol-hash)
+  (eq? (hashtable-equivalence-function h2) eq?)
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (hashtable-ref h 'a 1)
+      (hashtable-ref h 'b #f)
+      (hashtable-ref h 'c 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (hashtable-ref h2 'a 1)
+      (hashtable-ref h2 'b #f)
+      (hashtable-ref h2 'c 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv?
+    (hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h 'q #f) 18)
+  (eqv?
+    (hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (hashtable-ref h 'q #f) 19)
+  (equal? (hashtable-size h) 1)
+ ; test hashtable-copy when some keys may have moved
+ ; symbol hashes don't change, but keeping test adapted from eq-hashtable mats anyway
+  (let ([t (parameterize ([collect-request-handler void])
+             (let ([h4a (make-hashtable symbol-hash eqv? 32)]
+                   [k* (list-head (oblist) 100)])
+               (for-each (lambda (x) (hashtable-set! h4a x x)) k*)
+               (collect)
+              ; create copy after collection but before otherwise touching h4a
+               (let ([h4b (hashtable-copy h4a #t)])
+                 (andmap
+                   (lambda (k) (eq? (hashtable-ref h4b k #f) k))
+                   k*))))])
+    (collect)
+    t)
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-hashtable symbol-hash equal? 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (list-head (oblist) 1000)) (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+)
+
+(mat $symbol-hashtable
+  (begin
+    (define h (make-hashtable symbol-hash eq? 32))
+    (and (hashtable? h)
+         (symbol-hashtable? h)
+         (hashtable-mutable? h)
+         (not (eq-hashtable? h))
+         (not (hashtable-weak? h))
+         (not (hashtable-ephemeron? h))))
+  (eq? (hashtable-hash-function h) symbol-hash)
+  (eq? (hashtable-equivalence-function h) eq?)
+  (equal? (hashtable-size h) 0)
+  (equal-entries? h '#() '#())
+  (eqv? (symbol-hashtable-set! h 'a 'aval) (void))
+  (equal?
+    (list
+       (symbol-hashtable-contains? h 'a)
+       (symbol-hashtable-contains? h 'b)
+       (symbol-hashtable-contains? h 'c))
+    '(#t #f #f))
+  (eqv? (symbol-hashtable-set! h 'b 'bval) (void))
+  (equal?
+    (list
+       (symbol-hashtable-contains? h 'a)
+       (symbol-hashtable-contains? h 'b)
+       (symbol-hashtable-contains? h 'c))
+    '(#t #t #f))
+  (eqv? (symbol-hashtable-set! h 'c 'cval) (void))
+  (equal?
+    (list
+       (symbol-hashtable-contains? h 'a)
+       (symbol-hashtable-contains? h 'b)
+       (symbol-hashtable-contains? h 'c))
+    '(#t #t #t))
+  (equal? (hashtable-size h) 3)
+  (equal-entries? h '#(b c a) '#(bval cval aval))
+  #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (b . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (b . bval) (c . cval)))
+  #;(same-elements?
+    (let ([v (make-vector 3)] [i 0])
+      (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    '#((a . aval) (b . bval) (c . cval)))
+  (equal? (symbol-hashtable-ref h 'a 1) 'aval)
+  (equal? (symbol-hashtable-ref h 'b #f) 'bval)
+  (equal? (symbol-hashtable-ref h 'c 'nope) 'cval)
+  (eqv? (symbol-hashtable-delete! h 'b) (void))
+  (equal? (hashtable-size h) 2)
+  (equal-entries? h '#(a c) '#(aval cval))
+  (begin
+    (define h2 (hashtable-copy h #t))
+    (and (hashtable? h2)
+         (symbol-hashtable? h2)
+         (hashtable-mutable? h2)
+         (not (hashtable-weak? h2))
+         (not (hashtable-ephemeron? h2))
+         (not (eq-hashtable? h2))))
+  (eq? (hashtable-hash-function h2) symbol-hash)
+  (eq? (hashtable-equivalence-function h2) eq?)
+  (equal? (hashtable-size h2) 2)
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv? (hashtable-clear! h 4) (void))
+  (equal?
+    (list
+      (hashtable-size h)
+      (symbol-hashtable-ref h 'a 1)
+      (symbol-hashtable-ref h 'b #f)
+      (symbol-hashtable-ref h 'c 'nope))
+   '(0 1 #f nope))
+  (equal-entries? h '#() '#())
+  (equal?
+    (list
+      (hashtable-size h2)
+      (symbol-hashtable-ref h2 'a 1)
+      (symbol-hashtable-ref h2 'b #f)
+      (symbol-hashtable-ref h2 'c 'nope))
+    '(2 aval #f cval))
+  (equal-entries? h2 '#(a c) '#(aval cval))
+  (eqv?
+    (symbol-hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (symbol-hashtable-ref h 'q #f) 18)
+  (eqv?
+    (symbol-hashtable-update! h 'q
+      (lambda (x) (+ x 1))
+      17)
+    (void))
+  (equal? (symbol-hashtable-ref h 'q #f) 19)
+  (equal? (hashtable-size h) 1)
+  (let ([g (gensym)] [s "feisty"])
+    (let ([a (symbol-hashtable-cell h g s)])
+      (and (pair? a)
+           (eq? (car a) g)
+           (eq? (cdr a) s)
+           (begin
+             (hashtable-set! h g 'feisty)
+             (eq? (cdr a) 'feisty))
+           (begin
+             (set-cdr! a (list "feisty"))
+             (equal? (hashtable-ref h g #f) '("feisty"))))))
+ ; test hashtable-copy when some keys may have moved
+ ; symbol hashes don't change, but keeping test adapted from eq-hashtable mats anyway
+  (let ([t (parameterize ([collect-request-handler void])
+             (let ([h4a (make-hashtable symbol-hash eqv? 32)]
+                   [k* (list-head (oblist) 100)])
+               (for-each (lambda (x) (symbol-hashtable-set! h4a x x)) k*)
+               (collect)
+              ; create copy after collection but before otherwise touching h4a
+               (let ([h4b (hashtable-copy h4a #t)])
+                 (andmap
+                   (lambda (k) (eq? (symbol-hashtable-ref h4b k #f) k))
+                   k*))))])
+    (collect)
+    t)
+ ; test for proper shrinkage
+  (eqv?
+    (let ([ht (make-hashtable symbol-hash equal? 32)])
+      (for-each
+        (lambda (k*) (for-each (lambda (k) (symbol-hashtable-delete! ht k)) k*))
+        (let ([k** (map (lambda (x) (list-head (oblist) 1000)) (make-list 100))])
+          (for-each
+            (lambda (k*) (map (lambda (k) (symbol-hashtable-set! ht k 75)) k*))
+            k**)
+          k**))
+      (#%$hashtable-veclen ht))
+    32)
+)
+
+(mat symbol-hashtable-stress
+ ; stress tests
+  (let () ; nonweak
+    (define pick
+      (lambda (ls)
+        (list-ref ls (random (length ls)))))
+    (define ht (make-hashtable symbol-hash eq? 4))
+    (let ([ls (remq '|| (oblist))] [n 50000])
+      (let f ([i 0] [keep '()] [drop '()])
+        (if (= i n)
+            (and (= (hashtable-size ht) (- n (length drop)))
+                 (andmap (lambda (k)
+                           (string=?
+                             (symbol->string (hashtable-ref ht k #f))
+                             (symbol->string k)))
+                         keep)
+                 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no))
+                         drop))
+            (let* ([x (pick ls)] [s (string-copy (symbol->string x))])
+              (let ([k (gensym s)])
+                (hashtable-set! ht k x)
+                (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)])
+                  (if (= (modulo i 17) 5)
+                      (let ([k (pick keep)])
+                        (hashtable-delete! ht k)
+                        (let ([drop (cons k drop)])
+                          (when (= (random 5) 3)
+                            (hashtable-delete! ht (pick drop)))
+                          (f (+ i 1) (remq k keep) drop)))
+                      (f (+ i 1) keep drop)))))))))
+)
+
+(mat generic-hashtable
+  (begin
+    (define $ght-keys1 '#(a b c d e f g))
+    (define $ght-vals1 '#(1 3 5 7 9 11 13))
+    (define $ght (make-hashtable equal-hash equal? 8))
+    (vector-for-each
+      (lambda (x i) (hashtable-set! $ght x i))
+      $ght-keys1
+      $ght-vals1)
+    (hashtable? $ght))
+  (not (eq-hashtable? $ght))
+  (eq? (hashtable-hash-function $ght) equal-hash)
+  (eq? (hashtable-equivalence-function $ght) equal?)
+  (eq? (hashtable-mutable? $ght) #t)
+  (not (hashtable-weak? $ght))
+  (not (hashtable-ephemeron? $ght))
+  (eqv? (hashtable-size $ght) (vector-length $ght-keys1))
+  (eqv? (#%$hashtable-veclen $ght) 8)
+  (equal-entries? $ght $ght-keys1 $ght-vals1)
+  (begin
+    (define $ght-keys2 '#((a . b) (1 . 2) 3/4 3.4 3.5 1e23 #e1e50 1+1i 3+3.2i -15 #e1e-50 #1=(a . #1#) (#2=(#2# b c))))
+    (define $ght-vals2 '#(a b c d e f g h i j k l m))
+    (vector-for-each
+      (lambda (x i) (hashtable-set! $ght x i))
+      $ght-keys2
+      $ght-vals2)
+    (eq? (hashtable-size $ght) (+ (vector-length $ght-keys1) (vector-length $ght-keys2))))
+  (> (#%$hashtable-veclen $ght) 8)
+  (equal-entries? $ght ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2))
+  #;(same-elements?
+    (list->vector (hashtable-map $ght cons))
+    (vector-map cons ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2)))
+  #;(same-elements?
+    (let ([v (make-vector (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))] [i 0])
+      (hashtable-for-each $ght (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1))))
+      v)
+    (vector-map cons ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2)))
+  #;(same-elements?
+    (let ([v (make-vector (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))] [i 0])
+      (hashtable-for-each-cell $ght (lambda (a) (vector-set! v i a) (set! i (fx+ i 1))))
+      v)
+    (vector-map cons ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2)))
+  ($vector-andmap
+    (lambda (k v) (equal? (hashtable-ref $ght k #f) v))
+    $ght-keys1
+    $ght-vals1)
+  ($vector-andmap
+    (lambda (k v) (equal? (hashtable-ref $ght k #f) v))
+    $ght-keys2
+    $ght-vals2)
+  ($vector-andmap
+    (lambda (k v) (equal? (hashtable-ref $ght k #f) v))
+    '#((a . b) (1 . 2) 3/4 3.4 3.5 1e23 #e1e50 1+1i 3+3.2i -15 #e1e-50 #3=(a . #3#) (#4=(#4# b c)))
+    $ght-vals2)
+  ($vector-andmap
+    (lambda (k) (hashtable-contains? $ght k))
+    $ght-keys1)
+  ($vector-andmap
+    (lambda (k) (hashtable-contains? $ght k))
+    $ght-keys2)
+  (not (hashtable-contains? $ght '(not a key)))
+  (eq? (hashtable-ref $ght '(not a key) 'not-a-key) 'not-a-key)
+  (begin
+    (define $ght2 (hashtable-copy $ght))
+    (and (hashtable? $ght2)
+         (not (hashtable-mutable? $ght2))
+         (not (hashtable-weak? $ght2))
+         (not (hashtable-ephemeron? $ght2))))
+  (eq? (hashtable-hash-function $ght) equal-hash)
+  (eq? (hashtable-equivalence-function $ght) equal?)
+  (begin
+    (define $ght3 (hashtable-copy $ght #t))
+    (and (hashtable? $ght3)
+         (hashtable-mutable? $ght3)
+         (not (hashtable-weak? $ght3))
+         (not (hashtable-ephemeron? $ght3))))
+  (eq? (hashtable-hash-function $ght) equal-hash)
+  (eq? (hashtable-equivalence-function $ght) equal?)
+  (begin
+    (vector-for-each
+      (lambda (k) (hashtable-delete! $ght k))
+      $ght-keys1)
+    #t)
+  (equal-entries? $ght $ght-keys2 $ght-vals2)
+  (eqv? (hashtable-size $ght) (vector-length $ght-keys2))
+  (begin
+    (vector-for-each
+      (lambda (k) (hashtable-delete! $ght k))
+      $ght-keys2)
+    #t)
+  (equal-entries? $ght '#() '#())
+  (eqv? (hashtable-size $ght) 0)
+  (eqv? (#%$hashtable-veclen $ght) 8)
+ ; make sure copies are unaffected by deletions
+  (eq? (hashtable-size $ght2) (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))
+  (equal-entries? $ght2 ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2))
+  (eq? (hashtable-size $ght3) (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))
+  (equal-entries? $ght3 ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2))
+  (begin
+    (hashtable-clear! $ght3)
+    (and
+      (eqv? (hashtable-size $ght3) 0)
+      (eqv? (hashtable-size $ght2) (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))))
+  (error? ; not mutable
+    (hashtable-clear! $ght2))
+  (error? ; not mutable
+    (hashtable-delete! $ght2 (vector-ref $ght-keys2 0)))
+  (error? ; not mutable
+    (hashtable-update! $ght2 (vector-ref $ght-keys2 0)
+      (lambda (x) (cons x x))
+      'oops))
+  (error? ; not mutable
+    (hashtable-update! $ght2 '(not a key)
+      (lambda (x) (cons x x))
+      'oops))
+  (eqv?
+    (hashtable-update! $ght3 '(a . b)
+      (lambda (x) (+ x 15))
+      17)
+    (void))
+  (eqv?
+    (hashtable-update! $ght3 '(a . b)
+      (lambda (x) (+ x 29))
+      17)
+    (void))
+  (eqv?
+    (hashtable-update! $ght3 1e23
+      (lambda (x) (- x 5))
+      19)
+    (void))
+  (equal?
+    (let ([a (hashtable-cell $ght3 '(a . b) 17)])
+      (set-cdr! a (+ (cdr a) 100))
+      a)
+    '((a . b) . 161))
+  (equal?
+    (let ([a (hashtable-cell $ght3 #vu8(1 2 3) 'bv)])
+      (set-cdr! a (cons (cdr a) 'vb))
+      a)
+    '(#vu8(1 2 3) . (bv . vb)))
+  (equal-entries? $ght3 '#((a . b) 1e23 #vu8(1 2 3)) '#(161 14 (bv . vb)))
+  (let () ; carl's test program, with a few additions
+    (define cov:prof-hash
+      (lambda (V)
+        (* (vector-ref V 0) (vector-ref V 1) (vector-ref V 2))))
+    (define cov:prof-equal?
+      (lambda (V W)
+        (let ((rv (and (= (vector-ref V 0) (vector-ref W 0))
+                       (= (vector-ref V 1) (vector-ref W 1))
+                       (= (vector-ref V 2) (vector-ref W 2)))))
+          rv)))
+    (define make-random-vector-key
+      (lambda ()
+        (vector (random 20000) (random 100) (random 1000))))
+    (define test-hash
+      (lambda (n)
+        (let ([ht (make-hashtable cov:prof-hash cov:prof-equal?)])
+          (let loop ([i 0])
+            (let ([str (make-random-vector-key)])
+              (hashtable-set! ht str i)
+              (hashtable-update! ht str (lambda (x) (* x 2)) -1)
+              (let ([a (hashtable-cell ht str 'a)]) (set-cdr! a (- (cdr a))))
+              (cond
+                [(= i n) (= (hashtable-size ht) 1000)]
+                [(and (hashtable-contains? ht str)
+                      (= (hashtable-ref ht str #f) (* i -2)))
+                 (when (= (hashtable-size ht) 1000)
+                   (hashtable-delete! ht str))
+                 (loop (+ i 1))]
+                [else (errorf 'test-hash "hashtable failure for key ~s" str)]))))))
+    (test-hash 100000))
+)
+
+(mat hash-functions
+ ; equal-hash
+  (error? ; wrong argument count
+    (equal-hash))
+  (error? ; wrong argument count
+    (equal-hash 0 0))
+ ; symbol-hash
+  (error? ; wrong argument count
+    (symbol-hash))
+  (error? ; wrong argument count
+    (symbol-hash 'a 'a))
+  (error? ; not a symbol
+    (symbol-hash "hello"))
+ ; string-hash
+  (error? ; wrong argument count
+    (string-hash))
+  (error? ; wrong argument count
+    (string-hash 'a 'a))
+  (error? ; not a string
+    (string-hash 'hello))
+ ; string-ci-hash
+  (error? ; wrong argument count
+    (string-ci-hash))
+  (error? ; wrong argument count
+    (string-ci-hash 'a 'a))
+  (error? ; not a string
+    (string-ci-hash 'hello))
+  (let ([hc (equal-hash '(a b c))])
+    (and (integer? hc)
+         (exact? hc)
+         (>= hc 0)
+         (= (equal-hash '(a b c)) hc)))
+  (let ([hc (string-hash "hello")])
+    (and (integer? hc)
+         (exact? hc)
+         (>= hc 0)
+         (= (string-hash "hello") hc)))
+  (let ([hc (string-ci-hash "hello")])
+    (and (integer? hc)
+         (exact? hc)
+         (>= hc 0)
+         (= (string-ci-hash "HelLo") hc)))
+  (let f ([ls (oblist)])
+    (define okay?
+      (lambda (x)
+        (let ([hc (symbol-hash x)])
+          (and (integer? hc)
+               (exact? hc)
+               (>= hc 0)
+               (= (symbol-hash x) hc)))))
+    (and (okay? (car ls))
+         (let g ([ls ls] [n 10])
+           (or (null? ls)
+               (if (= n 0)
+                   (f ls)
+                   (g (cdr ls) (- n 1)))))))
+ ; adapted from Flatt's r6rs tests for string-ci=?
+  (eqv? (string-ci-hash "z") (string-ci-hash "Z"))
+  (not (eqv? (string-ci-hash "z") (string-ci-hash "a")))
+  (eqv? (string-ci-hash "Stra\xDF;e") (string-ci-hash "Strasse"))
+  (eqv? (string-ci-hash "Stra\xDF;e") (string-ci-hash "STRASSE"))
+  (eqv? (string-ci-hash "\x39E;\x391;\x39F;\x3A3;") (string-ci-hash "\x3BE;\x3B1;\x3BF;\x3C2;"))
+  (eqv? (string-ci-hash "\x39E;\x391;\x39F;\x3A3;") (string-ci-hash "\x3BE;\x3B1;\x3BF;\x3C3;"))
+)
+
+(mat fasl-eq-hashtable
+ ; fasling out eq hash tables
+  (equal?
+    (let ([x (cons 'y '!)])
+      (define ht (make-eq-hashtable))
+      (eq-hashtable-set! ht x 'because)
+      (eq-hashtable-set! ht 'foo "foo")
+      (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+        (fasl-write (list x ht) p)
+        (close-port p))
+      (let-values ([(x2 ht2)
+                    (apply values
+                      (call-with-port
+                        (open-file-input-port "testfile.ss")
+                        fasl-read))])
+        (list
+          (eq-hashtable-weak? ht2)
+          (eq-hashtable-ephemeron? ht2)
+          (eq-hashtable-ref ht2 x2 #f)
+          (eq-hashtable-ref ht2 'foo #f))))
+    '(#f #f because "foo"))
+ ; fasling out weak eq hash table
+  (equal?
+    (with-interrupts-disabled
+      (let ([x (cons 'y '!)])
+        (define ht (make-weak-eq-hashtable))
+        (eq-hashtable-set! ht x 'because)
+        (eq-hashtable-set! ht 'foo "foo")
+        (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+          (fasl-write (list x ht) p)
+          (close-port p))
+        (let-values ([(x2 ht2)
+                      (apply values
+                        (call-with-port
+                          (open-file-input-port "testfile.ss")
+                          fasl-read))])
+          (list
+            (eq-hashtable-weak? ht2)
+            (eq-hashtable-ephemeron? ht2)
+            (eq-hashtable-ref ht2 x2 #f)
+            (eq-hashtable-ref ht2 'foo #f)))))
+    '(#t #f because "foo"))
+  (equal?
+    (let ([ht2 (cadr (call-with-port
+                       (open-file-input-port "testfile.ss")
+                       fasl-read))])
+      (collect (collect-maximum-generation))
+      (list
+        (hashtable-keys ht2)
+        (eq-hashtable-ref ht2 'foo #f)))
+    '(#(foo) "foo"))
+ ; fasling out ephemeron eq hash table
+  (equal?
+    (with-interrupts-disabled
+      (let ([x (cons 'y '!)])
+        (define ht (make-ephemeron-eq-hashtable))
+        (eq-hashtable-set! ht x 'because)
+        (eq-hashtable-set! ht 'foo "foo")
+        (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+          (fasl-write (list x ht) p)
+          (close-port p))
+        (let-values ([(x2 ht2)
+                      (apply values
+                        (call-with-port
+                          (open-file-input-port "testfile.ss")
+                          fasl-read))])
+          (list
+            (eq-hashtable-weak? ht2)
+            (eq-hashtable-ephemeron? ht2)
+            (eq-hashtable-ref ht2 x2 #f)
+            (eq-hashtable-ref ht2 'foo #f)))))
+    '(#f #t because "foo"))
+  (equal?
+    (let ([ht2 (cadr (call-with-port
+                       (open-file-input-port "testfile.ss")
+                       fasl-read))])
+      (collect (collect-maximum-generation))
+      (list
+        (hashtable-keys ht2)
+        (eq-hashtable-ref ht2 'foo #f)))
+    '(#(foo) "foo"))
+ ; fasling eq hash tables via compile-file
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(module ($feh-ls $feh-ht)
+             (define-syntax ls
+               (let ([ls '(1 2 3)])
+                 (lambda (x)
+                   #`(quote #,(datum->syntax #'* ls)))))
+             (define $feh-ls ls)
+             (define $feh-ht
+               (let ()
+                 (define-syntax a
+                   (let ([ht (make-eq-hashtable)])
+                     (eq-hashtable-set! ht 'q 'p)
+                     (eq-hashtable-set! ht ls (cdr ls))
+                     (eq-hashtable-set! ht (cdr ls) (cddr ls))
+                     (eq-hashtable-set! ht (cddr ls) ls)
+                     (lambda (x) #`(quote #,(datum->syntax #'* ht)))))
+                 a)))))
+      'replace)
+    (compile-file "testfile")
+    (load "testfile.so")
+    #t)
+  (eq? (eq-hashtable-ref $feh-ht 'q #f) 'p)
+  (eq? (eq-hashtable-ref $feh-ht $feh-ls #f) (cdr $feh-ls))
+  (eq? (eq-hashtable-ref $feh-ht (cdr $feh-ls) #f) (cddr $feh-ls))
+  (eq? (eq-hashtable-ref $feh-ht (cddr $feh-ls) #f) $feh-ls)
+  (begin
+    (eq-hashtable-set! $feh-ht 'p 'r)
+    #t)
+  (eq? (eq-hashtable-ref $feh-ht 'p #f) 'r)
+  (begin
+    (eq-hashtable-set! $feh-ht 'q 'not-p)
+    #t)
+  (eq? (eq-hashtable-ref $feh-ht 'q #f) 'not-p)
+)
+
+(mat fasl-symbol-hashtable
+ ; fasling out symbol hash tables
+  (equal?
+    (let ()
+      (define ht (make-hashtable symbol-hash eq?))
+      (symbol-hashtable-set! ht 'why? 'because)
+      (symbol-hashtable-set! ht 'foo "foo")
+      (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+        (fasl-write ht p)
+        (close-port p))
+      (let ([ht2 (call-with-port (open-file-input-port "testfile.ss") fasl-read)])
+        (list
+          (symbol-hashtable-ref ht2 'why? #f)
+          (symbol-hashtable-ref ht2 'foo #f))))
+    '(because "foo"))
+  (#%$fasl-file-equal? "testfile.ss" "testfile.ss")
+  (eqv? (strip-fasl-file "testfile.ss" "testfile1.ss" (fasl-strip-options)) (void))
+  (#%$fasl-file-equal? "testfile.ss" "testfile1.ss")
+  (equal?
+    (let ([ht2 (call-with-port (open-file-input-port "testfile1.ss" (file-options compressed)) fasl-read)])
+      (list
+        (symbol-hashtable-ref ht2 'why? #f)
+        (symbol-hashtable-ref ht2 'foo #f)))
+    '(because "foo"))
+  (begin
+    (call-with-port (open-file-output-port "testfile1.ss" (file-options replace))
+      (lambda (p)
+        (fasl-write (call-with-port (open-file-input-port "testfile.ss") fasl-read) p)))
+    #t)
+  (#%$fasl-file-equal? "testfile.ss" "testfile1.ss")
+  (#%$fasl-file-equal? "testfile1.ss" "testfile.ss")
+  (begin
+    (call-with-port (open-file-output-port "testfile1.ss" (file-options replace))
+      (lambda (p)
+        (let ([ht (call-with-port (open-file-input-port "testfile.ss") fasl-read)])
+          (symbol-hashtable-set! ht 'why? 'why-not?)
+          (fasl-write ht p))))
+    #t)
+  (not (#%$fasl-file-equal? "testfile.ss" "testfile1.ss"))
+  (not (#%$fasl-file-equal? "testfile1.ss" "testfile.ss"))
+  (begin
+    (call-with-port (open-file-output-port "testfile1.ss" (file-options replace))
+      (lambda (p)
+        (let ([ht (call-with-port (open-file-input-port "testfile.ss") fasl-read)])
+          (symbol-hashtable-set! ht (gensym) 'foiled)
+          (fasl-write ht p))))
+    #t)
+  (not (#%$fasl-file-equal? "testfile.ss" "testfile1.ss"))
+  (not (#%$fasl-file-equal? "testfile1.ss" "testfile.ss"))
+
+ ; fasling symbol hash tables via compile-file
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(define $fsh-ht
+             (let ()
+               (define-syntax a
+                 (let ([ht (make-hashtable symbol-hash symbol=?)])
+                   (symbol-hashtable-set! ht 'q 'p)
+                   (symbol-hashtable-set! ht 'p 's)
+                   (let ([g (gensym "hello")])
+                     (symbol-hashtable-set! ht g g)
+                     (symbol-hashtable-set! ht 'g g))
+                   (lambda (x) #`(quote #,(datum->syntax #'* ht)))))
+               a))))
+      'replace)
+    (compile-file "testfile")
+    (load "testfile.so")
+    #t)
+  (eq? (symbol-hashtable-ref $fsh-ht 'q #f) 'p)
+  (eq? (symbol-hashtable-ref $fsh-ht 'p #f) 's)
+  (let ([g (symbol-hashtable-ref $fsh-ht 'g #f)])
+    (eq? (symbol-hashtable-ref $fsh-ht g #f) g))
+  (eq? (symbol-hashtable-ref $fsh-ht 'spam #f) #f)
+  (begin
+    (symbol-hashtable-set! $fsh-ht 'p 'r)
+    #t)
+  (eq? (symbol-hashtable-ref $fsh-ht 'p #f) 'r)
+  (begin
+    (symbol-hashtable-set! $fsh-ht 'q 'not-p)
+    #t)
+  (eq? (symbol-hashtable-ref $fsh-ht 'q #f) 'not-p)
+)
+
+(mat fasl-other-hashtable
+ ; can't fasl out other kinds of hashtables
+  (error?
+    (let ([x (cons 'y '!)])
+      (define ht (make-eqv-hashtable))
+      (hashtable-set! ht x 'because)
+      (hashtable-set! ht 'foo "foo")
+      (hashtable-set! ht 3.1415 "pi")
+      (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+        (with-exception-handler
+          (lambda (c) (close-port p) (raise-continuable c))
+          (lambda () (fasl-write (list x ht) p))))))
+  (error?
+    (let ([x (cons 'y '!)])
+      (define ht (make-hashtable string-hash string=?))
+      (hashtable-set! ht "hello" 'goodbye)
+      (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+        (with-exception-handler
+          (lambda (c) (close-port p) (raise-continuable c))
+          (lambda () (fasl-write (list x ht) p))))))
+)
+
+(mat ht
+  (begin
+    (display-string (separate-eval `(parameterize ([source-directories
+                                                     (list
+                                                       ,*mats-dir*
+                                                       ,(format "~a/../s" *mats-dir*)
+                                                       ,(format "~a/../../s" *mats-dir*))])
+                                      (load "ht.ss"))))
+    #t)
+)
diff --git a/mats/ht.ss b/mats/ht.ss
new file mode 100644
index 0000000..27597dc
--- /dev/null
+++ b/mats/ht.ss
@@ -0,0 +1,149 @@
+#! ../bin/scheme --script
+
+;;; ht.ss
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+#;(optimize-level 3)
+(collect-request-handler void)
+
+(module M (eqht symht gen-set eq-set sym-set gen-ref eq-ref
+           sym-ref print-htstats)
+  (define (eqht) (make-eq-hashtable))
+  (define (symht) (make-hashtable symbol-hash eq?))
+  (define refsym* (oblist))
+  (define setsym*
+    (fold-left
+      (lambda (ls x i) (if (fx< (modulo i 10) 1) ls (cons x ls)))
+      '()
+      refsym*
+      (enumerate refsym*)))
+  (define gen-set
+    (lambda (ht n)
+      (do ([n n (fx- n 1)])
+          ((fx= n 0) ht)
+        (for-each
+          (lambda (x) (hashtable-set! ht x (list n)))
+          setsym*))))
+  (define eq-set
+    (lambda (ht n)
+      (do ([n n (fx- n 1)])
+          ((fx= n 0) ht)
+        (for-each
+          (lambda (x) (eq-hashtable-set! ht x (list n)))
+          setsym*))))
+  (define sym-set
+    (lambda (ht n)
+      (do ([n n (fx- n 1)])
+          ((fx= n 0) ht)
+        (for-each
+          (lambda (x) (symbol-hashtable-set! ht x (list n)))
+          setsym*))))
+  (define maybe-car (lambda (x) (and x (car x))))
+  (define gen-ref
+    (lambda (ht n)
+      (let f ([n n] [x #f])
+        (if (fx= n 0)
+            x
+            (do ([sym* refsym* (cdr sym*)]
+                 [x x (maybe-car (hashtable-ref ht (car sym*) #f))])
+                ((null? sym*) (f (fx- n 1) x)))))))
+  (define eq-ref
+    (lambda (ht n)
+      (let f ([n n] [x #f])
+        (if (fx= n 0)
+            x
+            (do ([sym* refsym* (cdr sym*)]
+                 [x x (maybe-car (eq-hashtable-ref ht (car sym*) #f))])
+                ((null? sym*) (f (fx- n 1) x)))))))
+  (define sym-ref
+    (lambda (ht n)
+      (let f ([n n] [x #f])
+        (if (fx= n 0)
+            x
+            (do ([sym* refsym* (cdr sym*)]
+                 [x x (maybe-car (symbol-hashtable-ref ht (car sym*) #f))])
+                ((null? sym*) (f (fx- n 1) x)))))))
+  (define print-htstats
+    (let ()
+      (include "hashtable-types.ss")
+      (lambda (ht)
+        (let ([ls** (map (if (eq-ht? ht)
+                             (lambda (b)
+                               (do ([b b (#%$tlc-next b)]
+                                    [ls '() (cons
+                                              (car (#%$tlc-keyval b))
+                                              ls)])
+                                   ((fixnum? b) ls)))
+                             (lambda (ls) (map car ls)))
+                         (vector->list (ht-vec ht)))])
+          (let* ([n* (map length ls**)] [len (length n*)])
+            (printf "min = ~d, max = ~d, avg = ~,2f, med = ~d, stddev = ~,2f\n"
+              (apply min n*) (apply max n*) (/ (apply + n*) len)
+              (list-ref (sort < n*) (quotient len 2))
+              (let* ([mu (/ (apply + n*) len)])
+                (sqrt
+                  (/ (apply + (map (lambda (n) (expt (- n mu) 2)) n*))
+                     len))))
+            (printf
+              "a max-size bucket: ~s\n"
+              (let ([n (apply max n*)])
+                (cdr (find
+                       (lambda (n.ls) (= (car n.ls) n))
+                       (map cons n* ls**)))))))))))
+
+(collect 0 1)
+
+(let ()
+  (import M)
+  (define millis
+    (lambda (t)
+      (+ (* (time-second t) 1000)
+         (round (/ (time-nanosecond t) 1000000)))))
+  (define runs 10)
+  (define iterations 1000)
+  (define-syntax run
+    (syntax-rules ()
+      [(_ ?set ?ref ?make-ht)
+       (let ([set ?set] [ref ?ref] [make-ht ?make-ht])
+         (let loop ([runs runs] [st 0] [rt 0])
+           (if (fx= runs 0)
+               (begin
+                 (printf "(time (~s ~s ~d) ~d)\n" '?set '?make-ht
+                   iterations st)
+                 (printf "(time (~s ~s ~d) ~d)\n" '?ref '?make-ht
+                   iterations rt))
+               (let ([ht (make-ht)])
+                 (let* ([st (begin
+                              (collect 0 1)
+                              (let ([t (current-time 'time-process)])
+                                (set ht iterations)
+                                (let ([t (time-difference
+                                           (current-time 'time-process)
+                                           t)])
+                                  (+ st (millis t)))))]
+                        [rt (begin
+                              (collect 0 1)
+                              (let ([t (current-time 'time-process)])
+                                (ref ht iterations)
+                                (let ([t (time-difference
+                                           (current-time 'time-process)
+                                           t)])
+                                  (+ rt (millis t)))))])
+                   (when (= runs 1) (print-htstats ht))
+                   (loop (fx- runs 1) st rt))))))]))
+  (run gen-set gen-ref eqht)
+  (run gen-set gen-ref symht)
+  (run eq-set eq-ref eqht)
+  (run sym-set sym-ref symht))
diff --git a/mats/ieee.ms b/mats/ieee.ms
new file mode 100644
index 0000000..b31e520
--- /dev/null
+++ b/mats/ieee.ms
@@ -0,0 +1,774 @@
+;;; 5_3.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define <<
+   (case-lambda
+      [(x y)
+       (and (flonum? x)
+            (flonum? y)
+            (if (and (fl= x 0.0) (fl= y 0.0))
+                (fl< (fl/ 1.0 x) (fl/ 1.0 y))
+                (fl< x y)))]
+      [(x y z)
+       (and (<< x y) (<< y z))]))
+
+(mat inexact
+   (== (inexact 0) +0.0)
+   (== (inexact #e+1e-400) +0.0)
+   (== (inexact #e-1e-400) -0.0)
+   (== (inexact #e+1e+400) +inf.0)
+   (== (inexact #e-1e+400) -inf.0)
+   (== (inexact #e+1e-5000) +0.0)
+   (== (inexact #e-1e-5000) -0.0)
+   (== (inexact #e+1e+5000) +inf.0)
+   (== (inexact #e-1e+5000) -inf.0)
+
+  ; make sure inexact rounds to even whenever exactly half way to next
+  ; (assuming 52-bit mantissa + hidden bit)
+  ; ratios
+   (fl= (inexact (+ (ash 1 52) 0/2)) #x10000000000000.0)
+   (fl= (inexact (+ (ash 1 52) 1/2)) #x10000000000000.0)
+   (fl= (inexact (+ (ash 1 52) 2/2)) #x10000000000001.0)
+   (fl= (inexact (+ (ash 1 52) 3/2)) #x10000000000002.0)
+   (fl= (inexact (+ (ash 1 52) 4/2)) #x10000000000002.0)
+   (fl= (inexact (+ (ash 1 52) 5/2)) #x10000000000002.0)
+  ; integers
+   (fl= (inexact (* (+ (ash 1 52) 0/2) 2)) #x20000000000000.0)
+   (fl= (inexact (* (+ (ash 1 52) 1/2) 2)) #x20000000000000.0)
+   (fl= (inexact (* (+ (ash 1 52) 2/2) 2)) #x20000000000002.0)
+   (fl= (inexact (* (+ (ash 1 52) 3/2) 2)) #x20000000000004.0)
+   (fl= (inexact (* (+ (ash 1 52) 4/2) 2)) #x20000000000004.0)
+   (fl= (inexact (* (+ (ash 1 52) 5/2) 2)) #x20000000000004.0)
+   (fl= (inexact (ash (* (+ (ash 1 52) 0/2) 2) 40)) #x200000000000000000000000.0)
+   (fl= (inexact (ash (* (+ (ash 1 52) 1/2) 2) 40)) #x200000000000000000000000.0)
+   (fl= (inexact (ash (* (+ (ash 1 52) 2/2) 2) 40)) #x200000000000020000000000.0)
+   (fl= (inexact (ash (* (+ (ash 1 52) 3/2) 2) 40)) #x200000000000040000000000.0)
+   (fl= (inexact (ash (* (+ (ash 1 52) 4/2) 2) 40)) #x200000000000040000000000.0)
+   (fl= (inexact (ash (* (+ (ash 1 52) 5/2) 2) 40)) #x200000000000040000000000.0)
+  ; make sure inexact rounds up when more than half way to next
+  ; (assuming 52-bit mantissa + hidden bit)
+  ; ratios
+   (fl= (inexact (+ (ash 1 52) 0/2 1/4)) #x10000000000000.0)
+   (fl= (inexact (+ (ash 1 52) 1/2 1/4)) #x10000000000001.0)
+   (fl= (inexact (+ (ash 1 52) 2/2 1/4)) #x10000000000001.0)
+   (fl= (inexact (+ (ash 1 52) 3/2 1/4)) #x10000000000002.0)
+   (fl= (inexact (+ (ash 1 52) 4/2 1/4)) #x10000000000002.0)
+   (fl= (inexact (+ (ash 1 52) 5/2 1/4)) #x10000000000003.0)
+   (fl= (inexact (+ (ash 1 52) 1/2 1/8)) #x10000000000001.0)
+   (fl= (inexact (+ (ash 1 52) 3/2 1/8)) #x10000000000002.0)
+   (fl= (inexact (+ (ash 1 52) 1/2 (expt 2 -80))) #x10000000000001.0)
+   (fl= (inexact (+ (ash 1 52) 3/2 (expt 2 -80))) #x10000000000002.0)
+  ; integers
+   (fl= (inexact (* (+ (ash 1 52) 0/2 1/4) 4)) #x40000000000000.0)
+   (fl= (inexact (* (+ (ash 1 52) 1/2 1/4) 4)) #x40000000000004.0)
+   (fl= (inexact (* (+ (ash 1 52) 2/2 1/4) 4)) #x40000000000004.0)
+   (fl= (inexact (* (+ (ash 1 52) 3/2 1/4) 4)) #x40000000000008.0)
+   (fl= (inexact (* (+ (ash 1 52) 4/2 1/4) 4)) #x40000000000008.0)
+   (fl= (inexact (* (+ (ash 1 52) 5/2 1/4) 4)) #x4000000000000C.0)
+   (fl= (inexact (* (+ (ash 1 52) 1/2 1/8) 8)) #x80000000000008.0)
+   (fl= (inexact (* (+ (ash 1 52) 3/2 1/8) 8)) #x80000000000010.0)
+   (fl= (inexact (* (+ (ash 1 52) 1/2 (expt 2 -80)) (expt 2 80)))
+        #x1000000000000100000000000000000000.0)
+   (fl= (inexact (* (+ (ash 1 52) 3/2 (expt 2 -80)) (expt 2 80)))
+        #x1000000000000200000000000000000000.0)
+   ; verify fix for incorrect input of 2.2250738585072011e-308 reported by leppie
+   ; 2.2250738585072011e-308 falls right on the edge between normalized and denormalized numbers,
+   ; and should not be rounded up to a normalized number
+   (equal?
+     (number->string (string->number "2.2250738585072011e-308"))
+     "2.225073858507201e-308|52")
+   (equal?
+     (decode-float (string->number "2.2250738585072011e-308"))
+     '#(#b1111111111111111111111111111111111111111111111111111 -1074 1))
+   ; similar case in binary...
+   (equal?
+     (decode-float (string->number "#b1.111111111111111111111111111111111111111111111111111011e-1111111111"))
+     '#(#b1111111111111111111111111111111111111111111111111111 -1074 1))
+   (equal?
+     (number->string (string->number "#b1.111111111111111111111111111111111111111111111111111011e-1111111111"))
+     "2.225073858507201e-308|52")
+   ; slightly higher number should be rounded up
+   (equal?
+     (number->string (string->number "2.2250738585072012e-308"))
+     "2.2250738585072014e-308")
+   (equal?
+     (number->string (string->number "#b1.111111111111111111111111111111111111111111111111111100e-1111111111"))
+     "2.2250738585072014e-308")
+)
+
+(mat exact
+   (error? (exact (nan)))
+   (error? (exact +inf.0))
+   (error? (exact -inf.0))
+   (eq? (exact +0.0) 0)
+   (eq? (exact -0.0) 0)
+)
+
+(mat ==
+   (== 1.0 1.0)
+   (== -1.0 -1.0)
+   (not (== -1.0 +1.0))
+   (not (== +1.0 -1.0))
+   (== 0.0 0.0)
+   (== -0.0 -0.0)
+   (not (== -0.0 +0.0))
+   (not (== +0.0 -0.0))
+   (== +inf.0 +inf.0)
+   (== -inf.0 -inf.0)
+   (not (== -inf.0 +inf.0))
+   (not (== +inf.0 -inf.0))
+   (== (nan) (nan))
+   (not (== +inf.0 (nan)))
+   (not (== (nan) -inf.0))
+   (not (== 0.0 0.0-0.0i))
+   (== +e +e)
+   (== -e -e)
+   (not (== +e +0.0))
+   (not (== -e -0.0))
+ )
+
+(mat <<
+   (<< -1.0 1.0)
+   (not (<< +1.0 -1.0))
+   (not (<< 0.0 0.0))
+   (<< -0.0 +0.0)
+   (not (<< +0.0 -0.0))
+   (<< -inf.0 +inf.0)
+   (not (<< +inf.0 -inf.0))
+   (not (<< (nan) (nan)))
+   (not (<< (nan) +0.0))
+   (not (<< +0.0 (nan)))
+   (<< -e +0.0 +e)
+   (<< -e -0.0 +e)
+   (not (<< +e +e))
+   (not (<< -e -e))
+ )
+
+(mat fl=
+   (let ((n (read (open-input-string "+nan.0"))))
+     (not (fl= n n)))
+   (not (fl= (nan)))
+   (not (fl= (nan) +inf.0))
+   (not (fl= (nan) -inf.0))
+   (not (fl= (nan) (nan)))
+   (not (fl= (nan) 0.0))
+   (fl= +inf.0 +inf.0)
+   (fl= -inf.0 -inf.0)
+   (not (fl= -inf.0 +inf.0))
+   (fl= +0.0 -0.0)
+ )
+
+(mat fl<
+   (not (fl< (nan)))
+   (not (fl< (nan) (nan)))
+   (not (fl< (nan) 0.0))
+   (not (fl< 0.0 (nan)))
+   (fl< -inf.0 0.0)
+ )
+
+(mat fl>
+   (not (fl> (nan)))
+   (not (fl> (nan) (nan)))
+   (not (fl> (nan) 0.0))
+   (not (fl> 0.0 (nan)))
+   (fl> +inf.0 -inf.0)
+   (fl> +inf.0 0.0)
+   (not (fl> +0.0 -0.0))
+ )
+
+(mat fl<=
+   (not (fl<= (nan)))
+   (not (fl<= (nan) (nan)))
+   (not (fl<= (nan) 0.0))
+   (not (fl<= 0.0 (nan)))
+ )
+
+(mat fl>=
+   (not (fl>= (nan)))
+   (not (fl>= (nan) (nan)))
+   (not (fl>= (nan) 0.0))
+   (not (fl>= 0.0 (nan)))
+ )
+
+(mat fl-
+   (== (fl- +0.0) -0.0)
+   (== (fl- -0.0) +0.0)
+   (== (fl- +inf.0) -inf.0)
+   (== (fl- -inf.0) +inf.0)
+   (== (fl- (nan)) (nan))
+   (== (fl- -0.0 -0.0) +0.0)
+   (== (fl- +0.0 -0.0) +0.0)
+   (== (fl- -0.0 +0.0) -0.0)
+   (== (fl- +0.0 +0.0) +0.0)
+   (andmap
+     (lambda (a)
+       (andmap
+         (lambda (b)
+           (andmap
+             (lambda (c) (== (fl- a b c) (fl- (fl- a b) c)))
+             '(0.0 -0.0)))
+         '(0.0 -0.0)))
+     '(0.0 -0.0))
+   (let ()
+     (define-syntax ff
+       (syntax-rules ()
+         [(_ k1 k2) (lambda (x) (eqv? (fl- k1 x k2) (fl- (fl- k1 x) k2)))]))
+     (andmap
+       (lambda (p) (and (p +0.0) (p -0.0)))
+       (list (ff +0.0 +0.0) (ff +0.0 -0.0) (ff -0.0 +0.0) (ff -0.0 -0.0))))
+   (error? (fl- 3.0 5.4 'a))
+   (error? (fl- 'a 3.0 5.4))
+   (error? (fl- 3.0 'a 5.4))
+   (== (fl- 5.0 4.0 3.0 2.0) -4.0)
+   (== (fl- 5.0 4.0 3.0 2.0 1.0 0.0 -1.0 -2.0) -2.0)
+   (begin
+     (define ($fl-f x y) (fl- -0.0 x y))
+     (procedure? $fl-f))
+   (== ($fl-f 3.0 4.0) -7.0)
+   (== (fl- 1e30 1e30 7.0) -7.0)
+ )
+
+(mat +
+  ; just in case we're ever tempted to combine nested generic arithmetic operators...
+  (begin
+    (define f1a (lambda (x) (= (+ x 2) (+ (+ x 1) 1))))
+    (define f1b (lambda (x) (= (+ (+ x 1) 1) x)))
+    (define f2 (lambda (x) (= (- (+ x 1e308) 1e308) +inf.0)))
+    #t)
+  (f1a 0)
+  (not (f1a (inexact (expt 2 53))))
+  (not (f1b 0))
+  (f1b (inexact (expt 2 53)))
+  (not (f2 (inexact 0)))
+  (f2 +inf.0)
+  (not (f2 +nan.0))
+  (f2 1e308)
+ )
+
+(mat -
+   (== (- +0.0) -0.0)
+   (== (- -0.0) +0.0)
+   (== (- +inf.0) -inf.0)
+   (== (- -inf.0) +inf.0)
+   (== (- (nan)) (nan))
+   (== (- -0.0 -0.0) +0.0)
+   (== (- +0.0 -0.0) +0.0)
+   (== (- -0.0 +0.0) -0.0)
+   (== (- +0.0 +0.0) +0.0)
+   (andmap
+     (lambda (a)
+       (andmap
+         (lambda (b)
+           (andmap
+             (lambda (c) (== (- a b c) (- (- a b) c)))
+             '(0.0 -0.0)))
+         '(0.0 -0.0)))
+     '(0.0 -0.0))
+   (error? (- 3.0 5.4 'a))
+   (error? (- 'a 3.0 5.4))
+   (error? (- 3.0 'a 5.4))
+   (== (- 1e30 1e30 7.0) -7.0)
+   (begin
+     (define $ieee-foo
+       (lambda (x)
+         (- x 1e30 7.0)))
+     #t)
+   (== ($ieee-foo 1e30) -7.0)
+ )
+
+(mat fl+
+   (== (fl+ -0.0 -0.0) -0.0)
+   (== (fl+ +0.0 -0.0) +0.0)
+   (== (fl+ -0.0 +0.0) +0.0)
+   (== (fl+ +0.0 +0.0) +0.0)
+ )
+
+(mat fl*
+   (== (fl* -1.0 +0.0) -0.0)
+   (== (fl* -1.0 -0.0) +0.0)
+   (== (fl* +1.0 +0.0) +0.0)
+   (== (fl* +1.0 -0.0) -0.0)
+ )
+
+(mat fl/
+   (== (fl/ +0.0) +inf.0)
+   (== (fl/ -0.0) -inf.0)
+   (== (fl/ +inf.0) +0.0)
+   (== (fl/ -inf.0) -0.0)
+   (== (fl/ (nan)) (nan))
+   (== (fl/ +1.0 +0.0) +inf.0)
+   (== (fl/ +1.0 -0.0) -inf.0)
+   (== (fl/ -1.0 +0.0) -inf.0)
+   (== (fl/ -1.0 -0.0) +inf.0)
+   (== (fl/ +0.0 +0.0) (nan))
+   (== (fl/ +0.0 -0.0) (nan))
+   (== (fl/ -0.0 +0.0) (nan))
+   (== (fl/ -0.0 -0.0) (nan))
+   (andmap
+     (lambda (a)
+       (andmap
+         (lambda (b)
+           (andmap
+             (lambda (c) (== (fl/ a b c) (fl/ (fl/ a b) c)))
+             '(1e300 1e250)))
+         '(1e300 1e250)))
+     '(1e300 1e250))
+   (error? (fl/ 3.0 5.4 'a))
+   (error? (fl/ 'a 3.0 5.4))
+   (error? (fl/ 3.0 'a 5.4))
+   (== (fl/ 16.0 2.0 -2.0 2.0) -2.0)
+   (== (fl/ 16.0 2.0 -2.0 2.0 4.0 1.0 -1.0) 0.5)
+   (== (fl/ 1e300 1e300 1e300) 1e-300)
+ )
+
+(mat /
+   (== (/ +0.0) +inf.0)
+   (== (/ -0.0) -inf.0)
+   (== (/ +inf.0) +0.0)
+   (== (/ -inf.0) -0.0)
+   (== (/ (nan)) (nan))
+   (== (/ +1.0 +0.0) +inf.0)
+   (== (/ +1.0 -0.0) -inf.0)
+   (== (/ -1.0 +0.0) -inf.0)
+   (== (/ -1.0 -0.0) +inf.0)
+   (== (/ +0.0 +0.0) (nan))
+   (== (/ +0.0 -0.0) (nan))
+   (== (/ -0.0 +0.0) (nan))
+   (== (/ -0.0 -0.0) (nan))
+   (andmap
+     (lambda (a)
+       (andmap
+         (lambda (b)
+           (andmap
+             (lambda (c) (== (/ a b c) (/ (/ a b) c)))
+             '(1e300 1e250)))
+         '(1e300 1e250)))
+     '(1e300 1e250))
+   (error? (/ 3.0 5.4 'a))
+   (error? (/ 'a 3.0 5.4))
+   (error? (/ 3.0 'a 5.4))
+   (== (fl/ 1e300 1e300 1e300) 1e-300)
+ )
+
+(mat expt
+   (== (expt +0.0 +0.0) +1.0)
+   (== (expt -0.0 +0.0) +1.0)
+   (== (expt +0.0 -0.0) +1.0)
+   (== (expt -0.0 -0.0) +1.0)
+   (== (expt +1.0 +0.0) +1.0)
+   (== (expt -1.0 +0.0) +1.0)
+   (== (expt +0.0 +1.0) +0.0)
+   (== (expt -0.0 +1.0) -0.0)
+   (== (expt -0.0 +2.0) +0.0)
+   (== (expt -0.0 +3.0) -0.0)
+   (== (expt +inf.0 +0.0) +1.0)
+   (== (expt +inf.0 +1.0) +inf.0)
+   (== (expt -inf.0 +0.0) +1.0)
+   (== (expt -inf.0 +1.0) -inf.0)
+   (== (expt +inf.0 +inf.0) +inf.0)
+   (== (expt +inf.0 -inf.0) +0.0)
+   (== (expt -inf.0 +inf.0) +inf.0)
+   (== (expt -inf.0 -inf.0) +0.0)
+   (== (expt +inf.0 +.5) +inf.0)
+   (== (expt (nan) +.5) (nan))
+   (== (expt +.5 (nan)) (nan))
+   (== (expt (nan) (nan)) (nan))
+   (== (expt (nan) +0.0) +1.0)
+   (== (expt +0.0 (nan)) (nan))
+   (== (expt +0.0 (nan)) (nan))
+   (== (expt +inf.0+2i 2) +inf.0+0.0i)
+   (== (let ([n (expt 2 32)]) (expt 2 (make-rectangular n n))) -inf.0+inf.0i)
+ )
+
+(mat magnitude
+   (== (magnitude -0.0) 0.0)
+   (== (magnitude 0.0) 0.0)
+   (== (magnitude 0.0-0.0i) 0.0)
+   (== (magnitude -1.0) 1.0)
+   (== (magnitude 1.0) 1.0)
+   (== (magnitude 0.0+1.0i) 1.0)
+   (== (magnitude +inf.0) +inf.0)
+   (== (magnitude -inf.0) +inf.0)
+   (== (magnitude +inf.0+inf.0i) +inf.0)
+   (== (magnitude +inf.0+2.0i) +inf.0)
+   (== (magnitude +2.0+inf.0i) +inf.0)
+   (== (magnitude (nan)) (nan))
+   (== (magnitude (make-rectangular (nan) (nan))) (nan))
+   (== (magnitude (make-rectangular +0.0 (nan))) (nan))
+   (<< +0.0 (magnitude (make-rectangular +e +e)))
+   (<< +0.0 (magnitude (make-rectangular -e -e)))
+ )
+
+(mat sqrt
+   ; from Kahan
+   (== (sqrt -0.0) +0.0+0.0i)
+   (== (sqrt -4.0) +0.0+2.0i)
+   (== (sqrt -inf.0) +0.0+inf.0i)
+   (== (sqrt 0.0+inf.0i) +inf.0+inf.0i)
+   (== (sqrt 4.0+inf.0i) +inf.0+inf.0i)
+   (== (sqrt +inf.0+inf.0i) +inf.0+inf.0i)
+   (== (sqrt -0.0+inf.0i) +inf.0+inf.0i)
+   (== (sqrt -4.0+inf.0i) +inf.0+inf.0i)
+   (== (sqrt -inf.0+inf.0i) +inf.0+inf.0i)
+   (== (sqrt 0.0-inf.0i) +inf.0-inf.0i)
+   (== (sqrt 4.0-inf.0i) +inf.0-inf.0i)
+   (== (sqrt +inf.0-inf.0i) +inf.0-inf.0i)
+   (== (sqrt -0.0-inf.0i) +inf.0-inf.0i)
+   (== (sqrt -4.0-inf.0i) +inf.0-inf.0i)
+   (== (sqrt -inf.0-inf.0i) +inf.0-inf.0i)
+   (== (sqrt (make-rectangular (nan) +0.0)) (make-rectangular (nan)(nan)))
+   (== (sqrt (make-rectangular 0.0 (nan))) (make-rectangular (nan) (nan)))
+   (== (sqrt (make-rectangular (nan) (nan))) (make-rectangular (nan) (nan)))
+   (== (sqrt +inf.0+0.0i) +inf.0+0.0i)
+   (== (sqrt +inf.0+4.0i) +inf.0+0.0i)
+   (== (sqrt +inf.0-0.0i) +inf.0-0.0i)
+   (== (sqrt +inf.0-4.0i) +inf.0-0.0i)
+   (== (sqrt (make-rectangular +inf.0 (nan))) (make-rectangular +inf.0 (nan)))
+   (== (sqrt -inf.0+0.0i) +0.0+inf.0i)
+   (== (sqrt -inf.0+4.0i) +0.0+inf.0i)
+   (== (sqrt -inf.0-0.0i) +0.0-inf.0i)
+   (== (sqrt -inf.0-4.0i) +0.0-inf.0i)
+   (let ([z (sqrt (make-rectangular -inf.0 (nan)))])
+      (and (== (real-part z) (nan)) (== (abs (imag-part z)) +inf.0)))
+   ; others
+   (== (sqrt +0.0) +0.0)
+   (== (sqrt +1.0) +1.0)
+   (== (sqrt +4.0) +2.0)
+   (== (sqrt +inf.0) +inf.0)
+   (== (sqrt +0.0+0.0i) +0.0+0.0i)
+   (== (sqrt +1.0+0.0i) +1.0+0.0i)
+   (== (sqrt +4.0+0.0i) +2.0+0.0i)
+   (== (sqrt +inf.0+0.0i) +inf.0+0.0i)
+   (== (sqrt -0.0+0.0i) +0.0+0.0i)
+   (== (sqrt -1.0+0.0i) +0.0+1.0i)
+   (== (sqrt -4.0+0.0i) +0.0+2.0i)
+   (== (sqrt -inf.0+0.0i) +0.0+inf.0i)
+   (== (sqrt -0.0-0.0i) +0.0-0.0i)
+   (== (sqrt -1.0-0.0i) +0.0-1.0i)
+   (== (sqrt -inf.0-0.0i) +0.0-inf.0i)
+   (== (sqrt +0.0-0.0i) +0.0-0.0i)
+   (== (sqrt +1.0-0.0i) +1.0-0.0i)
+   (== (sqrt +inf.0-0.0i) +inf.0-0.0i)
+   (== (sqrt (nan)) (nan))
+ )
+
+(mat exp
+   (== (exp +0.0) +1.0)
+   (== (exp -0.0) +1.0)
+   (== (exp +inf.0) +inf.0)
+   (== (exp -inf.0) +0.0)
+   (== (exp (nan)) (nan))
+   (== (exp +0.0+0.0i) +1.0+0.0i)
+   (== (exp -0.0-0.0i) +1.0-0.0i)
+  ; if exp treats x+0.0i the same as x:
+   (== (exp +inf.0+0.0i) +inf.0+0.0i)
+  ; otherwise:
+   #;(== (exp +inf.0+0.0i) +inf.0+nan.0i)
+   (== (exp +inf.0-0.0i) +inf.0-0.0i)
+   (== (exp -inf.0+0.0i) 0.0+0.0i)
+   (== (exp -inf.0-0.0i) 0.0-0.0i)
+  ; if exp treats x+0.0i the same as x:
+   (== (exp (make-rectangular (nan) +0.0)) (make-rectangular (nan) +0.0))
+  ; otherwise:
+   #;(== (exp (make-rectangular (nan) +0.0)) (make-rectangular (nan) (nan)))
+  ; if exp treats x+0.0i the same as x:
+   (== (exp (make-rectangular (nan) -0.0)) (make-rectangular (nan) -0.0))
+  ; otherwise:
+   #;(== (exp (make-rectangular (nan) -0.0)) (make-rectangular (nan) (nan)))
+   (~= (exp 700.0+.75i) 7.421023049046266e303+6.913398801654868e303i)
+   (~= (exp 700.0-.75i) 7.421023049046266e303-6.913398801654868e303i)
+   (== (exp 800.0+.75i) +inf.0+inf.0i)
+   (== (exp 800.0-.75i) +inf.0-inf.0i)
+   (== (exp 800.0+1e-200i) +inf.0+2.7263745721125063e147i)
+   (== (exp 800.0-1e-200i) +inf.0-2.7263745721125063e147i)
+   (== (exp +inf.0+1.0i) +inf.0+inf.0i)
+   (== (exp +inf.0+2.0i) -inf.0+inf.0i)
+   (== (exp +inf.0+3.0i) -inf.0+inf.0i)
+   (== (exp +inf.0+4.0i) -inf.0-inf.0i)
+   (== (exp +inf.0+123.0i) -inf.0-inf.0i)
+ )
+
+(mat log
+   (== (log 0.0) -inf.0)
+   (== (log 1.0) 0.0)
+   (== (log +inf.0) +inf.0)
+
+   (== (log -0.0) (make-rectangular -inf.0 +pi))
+   (== (log -1.0) (make-rectangular 0.0 +pi))
+   (== (log -inf.0) (make-rectangular +inf.0 +pi))
+
+   (== (log +1.0i) (make-rectangular 0.0 +pi/2))
+   (== (log -1.0i) (make-rectangular 0.0 -pi/2))
+
+   (== (log -0.0+0.0i) (make-rectangular -inf.0 +pi))
+   (== (log -0.0-0.0i) (make-rectangular -inf.0 -pi))
+   (== (log +0.0+0.0i) -inf.0+0.0i)
+   (== (log +0.0-0.0i) -inf.0-0.0i)
+
+   (== (log +1.0+0.0i) 0.0+0.0i)
+   (== (log -1.0+0.0i) (make-rectangular 0.0 +pi))
+   (== (log +1.0-0.0i) 0.0-0.0i)
+   (== (log -1.0-0.0i) (make-rectangular 0.0 -pi))
+ )
+
+(mat fllog
+   (== (log 0.0) -inf.0)
+   (== (log 1.0) 0.0)
+   (== (log +inf.0) +inf.0)
+
+   (== (log -0.0) (make-rectangular -inf.0 +pi))
+   (== (log -1.0) (make-rectangular 0.0 +pi))
+   (== (log -inf.0) (make-rectangular +inf.0 +pi))
+
+   (== (log +1.0i) (make-rectangular 0.0 +pi/2))
+   (== (log -1.0i) (make-rectangular 0.0 -pi/2))
+
+   (== (log -0.0+0.0i) (make-rectangular -inf.0 +pi))
+   (== (log -0.0-0.0i) (make-rectangular -inf.0 -pi))
+   (== (log +0.0+0.0i) -inf.0+0.0i)
+   (== (log +0.0-0.0i) -inf.0-0.0i)
+
+   (== (log +1.0+0.0i) 0.0+0.0i)
+   (== (log -1.0+0.0i) (make-rectangular 0.0 +pi))
+   (== (log +1.0-0.0i) 0.0-0.0i)
+   (== (log -1.0-0.0i) (make-rectangular 0.0 -pi))
+)
+
+(mat sin
+   (== (sin +0.0) +0.0)
+   (== (sin -0.0) -0.0)
+   (== (sin +inf.0) (nan))
+   (== (sin -inf.0) (nan))
+   (== (sin (nan)) (nan))
+ )
+
+(mat cos
+   (== (cos +0.0) +1.0)
+   (== (cos -0.0) +1.0)
+   (== (cos +inf.0) (nan))
+   (== (cos -inf.0) (nan))
+   (== (cos (nan)) (nan))
+ )
+
+(mat tan
+   (== (tan +0.0) +0.0)
+   (== (tan -0.0) -0.0)
+   (== (tan +inf.0) (nan))
+   (== (tan -inf.0) (nan))
+   (== (tan (nan)) (nan))
+   (== (tan -0.0+0.0i) -0.0+0.0i)
+ )
+
+(mat asin
+   (== (asin +0.0) +0.0)
+   (== (asin -0.0) -0.0)
+   (== (asin +1.0) +pi/2)
+   (== (asin -1.0) -pi/2)
+   (== (asin (nan)) (nan))
+   (== (asin -0.0+0.0i) -0.0+0.0i)
+ )
+
+(mat acos
+   (== (acos +1.0) +0.0)
+   (== (acos -1.0) +pi)
+   (== (acos +0.0) +pi/2)
+   (== (acos -0.0) +pi/2)
+   (== (acos (nan)) (nan))
+ )
+
+(mat atan
+   ; cases from Steele (CLtL)
+   (== (atan +0.0 +e) +0.0)
+   (== (atan +0.0 +inf.0) +0.0)
+   (<< +0.0 (atan +e +e) +pi/2)
+   (<< +0.0 (atan +inf.0 +inf.0) +pi/2)
+   (== (atan +e +0.0) +pi/2)
+   (== (atan +inf.0 +0.0) +pi/2)
+   (== (atan +e -0.0) +pi/2)
+   (== (atan +inf.0 -0.0) +pi/2)
+   (<< +pi/2 (atan +e -e) +pi)
+   (<< +pi/2 (atan +inf.0 -inf.0) +pi)
+   (== (atan +0.0 -e) +pi)
+   (== (atan +0.0 -inf.0) +pi)
+   (== (atan -0.0 -e) -pi)             ; Steele erroneously says +pi
+   (== (atan -0.0 -inf.0) -pi)         ; Steele erroneously says +pi
+   (<< -pi (atan -e -e) -pi/2)
+   (<< -pi (atan -inf.0 -inf.0) -pi/2)
+   (== (atan -e +0.0) -pi/2)
+   (== (atan -e -0.0) -pi/2)
+   (== (atan -inf.0 +0.0) -pi/2)
+   (== (atan -inf.0 -0.0) -pi/2)
+   (<< -pi/2 (atan -e +e) -0.0)
+   (<< -pi/2 (atan -inf.0 +inf.0) -0.0)
+   (== (atan -0.0 +e) -0.0)
+   (== (atan -0.0 +inf.0) -0.0)
+   (== (atan +0.0 +0.0) +0.0)
+   (== (atan -0.0 +0.0) -0.0)
+   (== (atan +0.0 -0.0) +pi)
+   (== (atan -0.0 -0.0) -pi)
+
+   (== (atan -inf.0) -pi/2)
+   (== (atan +inf.0) +pi/2)
+   (== (atan +0.0) +0.0)
+   (== (atan -0.0) -0.0)
+   (if (memq (machine-type) '(i3qnx ti3qnx))
+       (~= (atan +1.0) +pi/4)
+       (== (atan +1.0) +pi/4))
+   (== (atan -1.0) -pi/4)
+   (== (atan (nan)) (nan))
+   (== (atan -0.0+0.0i) -0.0+0.0i)
+)
+
+(mat sinh
+   (== (sinh 0.0) 0.0)
+   (== (sinh -0.0) -0.0)
+   (== (sinh +inf.0) +inf.0)
+   (== (sinh -inf.0) -inf.0)
+   (== (sinh (nan)) (nan))
+   (== (sinh -0.0+0.0i) -0.0+0.0i)
+ )
+
+(mat cosh
+   (== (cosh 0.0) 1.0)
+   (== (cosh -0.0) 1.0)
+   (== (cosh +inf.0) +inf.0)
+   (== (cosh -inf.0) +inf.0)
+   (== (cosh (nan)) (nan))
+ )
+
+(mat tanh
+   (== (tanh 0.0) 0.0)
+   (== (tanh -0.0) -0.0)
+   (== (tanh +inf.0) +1.0)
+   (== (tanh -inf.0) -1.0)
+   (== (tanh (nan)) (nan))
+   (== (tanh -0.0+0.0i) -0.0+0.0i)
+ )
+
+(mat asinh
+   (== (asinh 0.0) 0.0)
+   (== (asinh -0.0) -0.0)
+   (== (asinh +inf.0) +inf.0)
+   (== (asinh -inf.0) -inf.0)
+   (== (asinh (nan)) (nan))
+   (== (asinh -0.0+0.0i) -0.0+0.0i)
+ )
+
+(mat acosh
+   (== (acosh 1.0) 0.0)
+   (== (acosh +inf.0) +inf.0)
+   (== (acosh (nan)) (nan))
+ )
+
+(mat atanh
+   (== (atanh 0.0) 0.0)
+   (== (atanh -0.0) -0.0)
+   (== (atanh +1.0) +inf.0)
+   (== (atanh -1.0) -inf.0)
+   (== (atanh (nan)) (nan))
+   (== (atanh -0.0+0.0i) -0.0+0.0i)
+   (== (atanh -0.0+0.0i) -0.0+0.0i)
+ )
+
+(mat flonum->fixnum
+   (error? (flonum->fixnum +inf.0))
+   (error? (flonum->fixnum -inf.0))
+   (error? (flonum->fixnum (nan)))
+   (eq? (flonum->fixnum -0.0) 0)
+ )
+
+(mat fllp
+  (error? (fllp 3))
+  (eqv? (fllp 0.0) 0)
+  (eqv? (fllp 1.0) 2046)
+  (eqv? (fllp -1.0) 2046)
+  (eqv? (fllp 1.5) 2047)
+  (eqv? (fllp -1.5) 2047)
+  (and (memv (fllp +nan.0) '(4094 4095)) #t)
+  (eqv? (fllp +inf.0) 4094)
+  (eqv? (fllp -inf.0) 4094)
+  (eqv?
+    (fllp #b1.1111111111111111111111111111111111111111111111111111e1111111111)
+    4093)
+  (eqv? (fllp #b1.0e-1111111110) 2)
+  (or (eqv? #b.1e-1111111110 0.0)
+      (eqv? (fllp #b.1e-1111111110) 1))
+  (eqv? (fllp #b.01e-1111111110) 0)
+ )
+
+(mat fp-output
+  (equal? (number->string 1e23) "1e23")
+  (equal? (number->string 4.450147717014403e-308) "4.450147717014403e-308")
+  (equal? (number->string 1.1665795231290236e-302) "1.1665795231290236e-302")
+ ; fp printing algorithm always rounds up on ties
+  (equal? (number->string 3.6954879760742188e-6) "3.6954879760742188e-6")
+  (equal? (number->string 5.629499534213123e14) "5.629499534213123e14")
+ )
+
+(mat string->number
+  (equal? (string->number "+1e-400") +0.0)
+  (equal? (string->number "-1e-400") -0.0)
+  (equal? (string->number "+1e+400") +inf.0)
+  (equal? (string->number "-1e+400") -inf.0)
+  (equal? (string->number "+1e-5000") +0.0)
+  (equal? (string->number "-1e-5000") -0.0)
+  (equal? (string->number "+1e+5000") +inf.0)
+  (equal? (string->number "-1e+5000") -inf.0)
+  (equal? (string->number "+1e-50000") +0.0)
+  (equal? (string->number "-1e-50000") -0.0)
+  (equal? (string->number "+1e+50000") +inf.0)
+  (equal? (string->number "-1e+50000") -inf.0)
+  (equal? (string->number "+1e-500000") +0.0)
+  (equal? (string->number "-1e-500000") -0.0)
+  (equal? (string->number "+1e+500000") +inf.0)
+  (equal? (string->number "-1e+500000") -inf.0)
+
+  (equal? (string->number "#b1e-10000110010") 5e-324)
+  (equal? (string->number "5e-324") 5e-324)
+  (equal? (string->number "#b-1e-10000110010") -5e-324)
+  (equal? (string->number "-5e-324") -5e-324)
+  (equal? (string->number "#b1e-10000110010") (inexact (* 5 (expt 10 -324))))
+  (equal? (string->number "5e-324") (inexact (* 5 (expt 10 -324))))
+  (equal? (string->number "#b-1e-10000110010") (inexact (* -5 (expt 10 -324))))
+  (equal? (string->number "-5e-324") (inexact (* -5 (expt 10 -324))))
+
+  (if (memq (machine-type) '(a6nt ta6nt)) ; tolerably inaccurate
+      (equal? (string->number "#b1e-10000110100") 0.0)
+      (equal? (string->number "#b1e-10000110011") 0.0))
+  (if (memq (machine-type) '(a6nt ta6nt)) ; tolerably inaccurate
+      (equal? (string->number "#b-1e-10000110100") -0.0)
+      (equal? (string->number "#b-1e-10000110011") -0.0))
+  (equal? (string->number "5e-325") 0.0)
+  (equal? (string->number "-5e-325") -0.0)
+
+  (equal? (string->number "1.7976931348623157e308") 1.7976931348623157e308)
+  (equal? (string->number "-1.7976931348623157e308") -1.7976931348623157e308)
+  (equal? (string->number "#b1.1111111111111111111111111111111111111111111111111111e1111111111") 1.7976931348623157e308)
+  (equal? (string->number "#b-1.1111111111111111111111111111111111111111111111111111e1111111111") -1.7976931348623157e308)
+  (equal? (string->number "1.7976931348623157e308") (inexact (* 9007199254740991 (expt 2 971))))
+  (equal? (string->number "-1.7976931348623157e308") (inexact (* -9007199254740991 (expt 2 971))))
+  (equal? (string->number "#b1.1111111111111111111111111111111111111111111111111111e1111111111") (inexact (* 9007199254740991 (expt 2 971))))
+  (equal? (string->number "#b-1.1111111111111111111111111111111111111111111111111111e1111111111") (inexact (* -9007199254740991 (expt 2 971))))
+
+  (equal? (string->number "#b1.11111111111111111111111111111111111111111111111111111e1111111111") +inf.0)
+  (equal? (string->number "#b-1.11111111111111111111111111111111111111111111111111111e1111111111") -inf.0)
+  (equal? (string->number "1.7976931348623159e308") +inf.0)
+  (equal? (string->number "-1.7976931348623159e308") -inf.0)
+
+  (equal? (string->number "1e100000000000000000000") +inf.0)
+  (equal? (string->number "-1e100000000000000000000") -inf.0)
+  (equal? (string->number "1e-100000000000000000000") 0.0)
+  (equal? (string->number "-1e-100000000000000000000") -0.0)
+)
diff --git a/mats/io.ms b/mats/io.ms
new file mode 100644
index 0000000..38d1a4c
--- /dev/null
+++ b/mats/io.ms
@@ -0,0 +1,5008 @@
+;;; io.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define (native-string->bytevector s)
+  (string->bytevector s (native-transcoder)))
+
+; convert uses of custom-port-warning? to warning? if custom-port warnings
+; are enabled in io.ss
+(define (custom-port-warning? x) #t)
+
+(define prettytest.ss (format "~a/prettytest.ss" *mats-dir*))
+
+(mat port-operations
+  (error? (close-port cons))
+  ; the following several clauses test various open-file-output-port options
+  (let ([p (open-file-output-port "testfile.ss" (file-options no-fail))])
+    (and (port? p) (output-port? p) (begin (close-port p) #t)))
+  (error? ; file already exists
+    (open-file-output-port "testfile.ss"))
+  (error? ; file already exists
+    (open-file-output-port "testfile.ss" (file-options compressed)))
+  (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
+    (and (port? p) (output-port? p) (begin (close-port p) #t)))
+  (let ([p (open-file-output-port "testfile.ss" (file-options no-fail))])
+    (and (port? p) (output-port? p) (begin (close-port p) #t)))
+  (let ([p (open-file-output-port "testfile.ss" (file-options no-fail))])
+    (put-bytevector p (native-string->bytevector "\"hello"))
+    (close-port p)
+    (let ([p (open-file-output-port "testfile.ss" (file-options no-fail no-truncate append))])
+      (put-bytevector p (native-string->bytevector " there\""))
+      (close-port p)
+      (let ([p (open-file-input-port "testfile.ss")])
+        (and (equal? (get-bytevector-all p) (native-string->bytevector "\"hello there\""))
+             (eof-object? (get-u8 p))
+             (begin (close-port p)
+                    #t)))))
+  (let ([p (let loop () (if (file-exists? "testfile.ss")
+                            (begin (delete-file "testfile.ss" #f) (loop))
+                            (open-file-output-port "testfile.ss")))])
+    (for-each (lambda (x)
+                (put-bytevector p (native-string->bytevector x))
+                (put-bytevector p (native-string->bytevector " ")))
+              '("a" "b" "c" "d" "e"))
+    (put-bytevector p (native-string->bytevector "\n"))
+    (close-port p)
+    #t)
+  (equal? (let ([p (open-file-input-port "testfile.ss")])
+            (let f ([x (get-u8 p)])
+              (if (eof-object? x)
+                  (begin (close-port p) '())
+                  (cons (integer->char x) (f (get-u8 p))))))
+          (if (eq? (native-eol-style) 'crlf)
+              '(#\a #\space #\b #\space #\c #\space
+                #\d #\space #\e #\space #\return #\newline)
+              '(#\a #\space #\b #\space #\c #\space
+                #\d #\space #\e #\space #\newline)))
+  (error? (call-with-port 3 values))
+  (error? (call-with-port (current-input-port) 'a))
+  (equal? (call-with-values
+              (lambda ()
+                (call-with-port
+                 (open-file-output-port "testfile.ss" (file-options replace))
+                 (lambda (p)
+                   (for-each (lambda (c) (put-u8 p (char->integer c)))
+                             (string->list "a b c d e"))
+                   (values 1 2 3))))
+            list)
+          '(1 2 3))
+  (equal? (call-with-port
+           (open-file-input-port "testfile.ss")
+           (lambda (p)
+             (list->string
+              (let f ()
+                (let ([c (get-u8 p)])
+                  (if (eof-object? c)
+                      '()
+                      (begin (unget-u8 p c)
+                             (let ([c (get-u8 p)])
+                               (cons (integer->char c) (f))))))))))
+          "a b c d e")
+  (equal? (call-with-port
+           (open-file-input-port "testfile.ss")
+           (lambda (p)
+             (list->string
+              (let f ()
+                (let ([c (get-u8 p)])
+                  (unget-u8 p c)
+                  (if (eof-object? c)
+                      (begin
+                        (unless (and (eof-object? (lookahead-u8 p))
+                                     (port-eof? p)
+                                     (eof-object? (get-u8 p)))
+                          (errorf #f "unget of eof apparently failed"))
+                        '())
+                      (let ([c (get-u8 p)])
+                        (cons (integer->char c) (f)))))))))
+          "a b c d e")
+  (andmap (lambda (p)
+            (equal? (call-with-port
+                     p
+                     (lambda (p)
+                       (list->string
+                        (let f ()
+                          (let ([c (lookahead-u8 p)])
+                            (if (eof-object? c)
+                                '()
+                                (let ([c (get-u8 p)])
+                                  (cons (integer->char c) (f)))))))))
+                    "a b c d e"))
+          (list (open-file-input-port "testfile.ss")
+                (open-bytevector-input-port '#vu8(97 32 98 32 99 32 100 32 101))
+                (open-bytevector-input-port (bytevector->immutable-bytevector '#vu8(97 32 98 32 99 32 100 32 101)))))
+  ; test various errors related to input ports
+  (begin (set! ip (open-file-input-port "testfile.ss"))
+         (and (port? ip) (input-port? ip)))
+  (error? ; unget can only follow get
+    (unget-u8 ip 40))
+  (eqv? (get-u8 ip) (char->integer #\a))
+  (begin (unget-u8 ip (char->integer #\a)) (eqv? (get-u8 ip) (char->integer #\a)))
+  (error? (put-u8 ip (char->integer #\a)))
+  (error? (put-bytevector ip #vu8()))
+  (error? (flush-output-port ip))
+  (begin (close-port ip) #t)
+  (begin (close-port ip) #t)
+  (error? (port-eof? ip))
+  (error? (input-port-ready? ip))
+  (error? (get-u8? ip))
+  (error? (lookahead-u8? ip))
+  (error? (unget-u8? ip))
+  (error? (get-bytevector-n ip 1))
+  (error? (get-bytevector-n! ip (make-bytevector 10) 0 10))
+  (error? (get-bytevector-some ip))
+  (error? (get-bytevector-all ip))
+  ; test various errors related to output ports
+  (begin (set! op (open-file-output-port "testfile.ss" (file-options replace)))
+         (and (port? op) (output-port? op)))
+  (error? (input-port-ready? op))
+  (error? (lookahead-u8 op))
+  (error? (get-u8 op))
+  (error? (unget-u8 op 40))
+  (error? (get-bytevector-n op 1))
+  (error? (get-bytevector-n! op (make-bytevector 10) 0 10))
+  (error? (get-bytevector-some op))
+  (error? (get-bytevector-all op))
+  (begin (close-port op) #t)
+  (begin (close-port op) #t)
+  (error? (put-u8 op (char->integer #\a)))
+  (error? (put-bytevector op #vu8(1)))
+  (error? (flush-output-port op))
+
+  (let ([s (native-string->bytevector "hi there, mom!")])
+    (let ([ip (open-bytevector-input-port s)])
+      (let-values ([(op op-ex) (open-bytevector-output-port)])
+        (do ([c (get-u8 ip) (get-u8 ip)])
+            ((eof-object? c)
+             (equal? (op-ex) s))
+             (unget-u8 ip c)
+             (put-u8 op (get-u8 ip))))))
+
+  (error? (eof-object #!eof))
+  (eq? (call-with-port (open-bytevector-input-port #vu8()) get-u8) #!eof)
+  (eq? (call-with-port (open-bytevector-input-port #vu8()) get-u8) (eof-object))
+  (eq? (eof-object) #!eof)
+  (let ([s (native-string->bytevector "hi there, mom!")])
+    (equal?
+      (call-with-port (open-bytevector-input-port s)
+        (lambda (i)
+          (call-with-bytevector-output-port
+            (lambda (o)
+              (do ([c (get-u8 i) (get-u8 i)])
+                  ((eof-object? c))
+                (unget-u8 i c)
+                (put-u8 o (get-u8 i)))))))
+      s))
+
+  ; the following makes sure that call-with-port closes the at least on
+  ; systems which restrict the number of open ports to less than 2048
+  (let ([filename "testfile.ss"])
+    (let loop ((i 2048))
+      (or (zero? i)
+          (begin
+            (call-with-port
+             (open-file-output-port filename (file-options replace))
+             (lambda (p) (put-u8 p (quotient i 256)) (put-u8 p (modulo i 256))))
+            (and (eq? (call-with-port
+                       (open-file-input-port filename)
+                       (lambda (p)
+                         (let* ([hi (get-u8 p)]
+                                [lo (get-u8 p)])
+                           (+ (* 256 hi) lo))))
+                      i)
+                 (loop (- i 1)))))))
+  (begin
+    (close-input-port #%$console-input-port)
+    (not (port-closed? #%$console-input-port)))
+  (begin
+    (close-output-port #%$console-output-port)
+    (not (port-closed? #%$console-output-port)))
+ )
+
+(mat port-operations1
+  (error? ; incorrect number of arguments
+    (open-file-input-port))
+  (error? ; furball is not a string
+    (open-file-input-port 'furball))
+  (error? ; not a file-options object
+    (open-file-input-port "testfile.ss" '()))
+  (error? ; not a valid buffer mode
+    (open-file-input-port "testfile.ss" (file-options) 17))
+  (error? ; not a transcoder
+    (open-file-input-port "testfile.ss" (file-options) (buffer-mode block) 'wow))
+  (error? ; incorrect number of arguments
+    (open-file-input-port "testfile.ss" (file-options) (buffer-mode block) #f 'now?))
+  (error? ; cannot open
+    (open-file-input-port "/probably/not/a/good/path"))
+  (error? ; cannot open
+    (open-file-input-port "/probably/not/a/good/path" (file-options compressed)))
+  (error? ; invalid options
+    (open-file-input-port "testfile.ss" (file-options uncompressed)))
+  (error? ; invalid options
+    (open-file-input-port "testfile.ss" (file-options truncate)))
+  (error? ; incorrect number of arguments
+    (open-file-output-port))
+  (error? ; furball is not a string
+    (open-file-output-port 'furball))
+  (error? ; not a file-options object
+    (open-file-output-port "testfile.ss" '(no-create)))
+  (error? ; not a valid buffer mode
+    (open-file-output-port "testfile.ss" (file-options) 17))
+  (error? ; not a transcoder
+    (open-file-output-port "testfile.ss" (file-options) (buffer-mode block) 'wow))
+  (error? ; incorrect number of arguments
+    (open-file-output-port "testfile.ss" (file-options) (buffer-mode block) #f 'now?))
+  (error? ; cannot open
+    (open-file-output-port "/probably/not/a/good/path"))
+  (error? ; invalid options
+    (open-file-output-port "testfile.ss" (file-options uncompressed)))
+  (error? ; invalid options
+    (open-file-output-port "testfile.ss" (file-options truncate)))
+  (error? ; incorrect number of arguments
+    (open-file-input/output-port))
+  (error? ; furball is not a string
+    (open-file-input/output-port 'furball))
+  (error? ; not a file-options object
+    (open-file-input/output-port "testfile.ss" '(no-create)))
+  (error? ; not a valid buffer mode
+    (open-file-input/output-port "testfile.ss" (file-options) 17))
+  (error? ; not a transcoder
+    (open-file-input/output-port "testfile.ss" (file-options) (buffer-mode block) 'wow))
+  (error? ; incorrect number of arguments
+    (open-file-input/output-port "testfile.ss" (file-options) (buffer-mode block) #f 'now?))
+  (error? ; cannot open
+    (open-file-input/output-port "/probably/not/a/good/path"))
+  (error? ; invalid options
+    (open-file-input/output-port "testfile.ss" (file-options uncompressed)))
+  (error? ; invalid options
+    (open-file-input/output-port "testfile.ss" (file-options truncate)))
+  (begin (delete-file "testfile.ss") #t)
+  (error? ; no such file
+    (open-file-input-port "testfile.ss"))
+  (error? ; no such file
+    (open-file-output-port "testfile.ss" (file-options no-create)))
+  (error? ; no such file
+    (open-file-input/output-port "testfile.ss" (file-options no-create)))
+  (begin (mkdir "testfile.ss") #t)
+  (guard (c [(and (i/o-filename-error? c)
+                  (equal? (i/o-error-filename c) "testfile.ss"))])
+    (open-file-output-port "testfile.ss" (file-options no-create)))
+  (guard (c [(and (i/o-filename-error? c)
+                  (equal? (i/o-error-filename c) "testfile.ss"))])
+    (open-file-input/output-port "testfile.ss" (file-options no-create)))
+  (begin (delete-directory "testfile.ss") #t)
+  (begin
+    (define $ppp (open-file-input/output-port "testfile.ss" (file-options replace)))
+    (and (input-port? $ppp) (output-port? $ppp) (port? $ppp)))
+  (error? (set-port-length! $ppp -3))
+  (error? (set-port-length! $ppp 'all-the-way))
+  (eof-object?
+   (begin
+     (set-port-length! $ppp 0)
+     (set-port-position! $ppp 0)
+     (put-bytevector $ppp (native-string->bytevector "hello"))
+     (flush-output-port $ppp)
+     (get-u8 $ppp)))
+  (equal? (begin (set-port-position! $ppp 0) (get-bytevector-all $ppp))
+          (native-string->bytevector "hello"))
+  (eqv? (begin
+          (put-bytevector $ppp (native-string->bytevector "goodbye\n"))
+          (truncate-port $ppp 9)
+          (port-position $ppp))
+        9)
+  (eof-object? (get-u8 $ppp))
+  (eqv? (begin (set-port-position! $ppp 0) (port-position $ppp)) 0)
+  (equal? (get-bytevector-all $ppp) (native-string->bytevector "hellogood"))
+  (eqv? (begin
+          (put-bytevector $ppp (native-string->bytevector "byebye\n"))
+          (truncate-port $ppp 0)
+          (port-position $ppp))
+        0)
+  (eof-object? (get-u8 $ppp))
+  (eof-object?
+   (begin
+     (close-port $ppp)
+     (let ([ip (open-file-input-port "testfile.ss")])
+       (let ([c (get-u8 ip)])
+         (close-port $ppp)
+         (close-port ip)
+         c))))
+  (error?
+   (let ([ip (open-file-input-port "testfile.ss")])
+     (dynamic-wind
+         void
+         (lambda () (truncate-port ip))
+         (lambda () (close-port ip)))))
+  (error? (truncate-port 'animal-crackers))
+  (error? (truncate-port))
+  (error? (truncate-port $ppp))
+  (let-values ([(op get) (open-bytevector-output-port)])
+    (and (= (port-position op) 0)
+         (= (port-length op) 0)
+         (do ([i 4000 (fx- i 1)])
+             ((fx= i 0) #t)
+           (put-bytevector op (string->utf8 "hello")))
+         (= (port-length op) 20000)
+         (= (port-position op) 20000)
+         (begin (set-port-position! op 5000) #t)
+         (= (port-position op) 5000)
+         (= (port-length op) 20000)
+         (begin (truncate-port op) #t)
+         (= (port-position op) 0)
+         (= (port-length op) 0)
+         (begin (truncate-port op 17) #t)
+         (= (port-position op) 17)
+         (= (port-length op) 17)
+         (begin (put-bytevector op (string->utf8 "okay")) #t)
+         (= (port-position op) 21)
+         (= (port-length op) 21)
+         (let ([bv (get)])
+           (and (= (char->integer #\o) (bytevector-u8-ref bv 17))
+                (= (char->integer #\k) (bytevector-u8-ref bv 18))
+                (= (char->integer #\a) (bytevector-u8-ref bv 19))
+                (= (char->integer #\y) (bytevector-u8-ref bv 20))))
+         (= (port-position op) 0)
+         (= (port-length op) 0)
+         (begin (put-u8 op (char->integer #\a))
+                (put-u8 op (char->integer #\newline))
+                #t)
+         (= (port-position op) 2)
+         (equal? (get) (string->utf8 "a\n"))))
+  (let ([ip (open-bytevector-input-port (native-string->bytevector "beam me up, scotty!"))]
+        [bv (make-bytevector 10)])
+    (and (= (port-position ip) 0)
+         (= (port-length ip) 19)
+         (not (eof-object? (lookahead-u8 ip)))
+         (equal? (get-bytevector-n ip 4) (native-string->bytevector "beam"))
+         (= (port-position ip) 4)
+         (not (eof-object? (lookahead-u8 ip)))
+         (equal? (get-bytevector-n! ip bv 0 10) 10)
+         (equal? bv (native-string->bytevector " me up, sc"))
+         (= (port-position ip) 14)
+         (equal? (get-bytevector-n! ip bv 0 10) 5)
+         (equal? bv (native-string->bytevector "otty!p, sc"))
+         (= (port-position ip) 19)
+         (eof-object? (lookahead-u8 ip))
+         (eof-object? (get-u8 ip))
+         (eof-object? (get-bytevector-n! ip bv 0 10))
+         (= (get-bytevector-n! ip bv 0 0) 0) ;; TODO: check w/ Kent about this
+         (begin
+           (set-port-position! ip 10)
+           (= (port-position ip) 10))
+         (equal? (get-bytevector-n! ip bv 0 10) 9)
+         (equal? bv (native-string->bytevector ", scotty!c"))))
+)
+
+(mat port-operations2
+  (equal?
+    (let* ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode none))]
+           [ip (open-file-input-port "testfile.ss")])
+      (put-u8 op 97)
+      (let* ([b1 (get-u8 ip)] [b2 (get-u8 ip)])
+        (put-u8 op 98)
+        (let* ([b3 (get-u8 ip)] [b4 (get-u8 ip)])
+          (put-u8 op 99)
+          (let ([b5 (get-u8 ip)])
+            (close-port op)
+              (let ([b6 (get-u8 ip)])
+                (close-port ip)
+                (list b1 b2 b3 b4 b5 b6))))))
+    '(97 #!eof 98 #!eof 99 #!eof))
+  (equal?
+    (let* ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode none))]
+           [ip (open-file-input-port "testfile.ss")])
+      (let ([eof1? (port-eof? ip)])
+        (put-u8 op 97)
+       ; the port-eof? call above buffers the eof, so b1 should be #!eof
+        (let* ([b1 (get-u8 ip)] [b2 (get-u8 ip)])
+          (put-u8 op 98)
+          (let* ([eof2? (port-eof? ip)] [b3 (get-u8 ip)])
+            (let ([b4 (get-u8 ip)])
+              (put-u8 op 99)
+              (let* ([b5 (get-u8 ip)])
+                (close-port op)
+                (let* ([b6 (get-u8 ip)] [eof3? (port-eof? ip)])
+                  (close-port ip)
+                  (list eof1? b1 b2 eof2? b3 b4 b5 b6 eof3?))))))))
+    '(#t #!eof 97 #f 98 #!eof 99 #!eof #t))
+  (equal?
+   ; following assumes block buffering really doesn't cause any writes until
+   ; at least after a few bytes have been written
+    (let* ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode block))]
+           [ip (open-file-input-port "testfile.ss")])
+      (put-u8 op 97)
+      (let ([b1 (get-u8 ip)])
+        (put-u8 op 98)
+        (let ([b2 (get-u8 ip)])
+          (close-port op)
+          (let* ([b3 (get-u8 ip)] [b4 (get-u8 ip)] [b5 (get-u8 ip)])
+            (close-port ip)
+            (list b1 b2 b3 b4 b5)))))
+    '(#!eof #!eof 97 98 #!eof))
+ ; test switching between input and output modes
+ ; should be adapted for textual ports
+  (equal?
+    (begin
+      (call-with-port
+        (open-file-output-port "testfile.ss" (file-options replace))
+        (lambda (p) (put-bytevector p #vu8(1 2 3 4 5))))
+      (let ([iop (open-file-input/output-port "testfile.ss"
+                   (file-options no-fail no-truncate))])
+        (let ([b1 (get-u8 iop)])
+          (put-u8 iop 17)
+          (let ([b2 (get-u8 iop)])
+            (close-port iop)
+            (list b1 b2
+              (call-with-port
+                (open-file-input-port "testfile.ss")
+                get-bytevector-all))))))
+    '(1 3 #vu8(1 17 3 4 5)))
+ ; test switching between input and output modes
+ ; old implementation is broken---uncomment for new implementation
+ ; and move to set of mats testing convenience i/o
+  #;(equal?
+    (begin
+      (with-output-to-file "testfile.ss"
+        (lambda () (display "hi there"))
+        'replace)
+      (let ([iop (open-input-output-file "testfile.ss")])
+        (let ([c1 (read-char iop)])
+          (write-char #\! iop)
+          (let ([c2 (read-char iop)])
+            (close-port iop)
+            (list c1 c2
+              (with-input-from-file "testfile.ss"
+                (lambda ()
+                  (list->string
+                    (let f ()
+                      (let ([c (read-char)])
+                        (if (eof-object? c)
+                            '()
+                            (cons c (f)))))))))))))
+    '(#\h #\space "h! there"))
+  (equal?
+    (let-values ([(p g) (open-string-output-port)])
+      (fresh-line p)
+      (fresh-line p)
+      (display "hello" p)
+      (fresh-line p)
+      (fresh-line p)
+      (newline p)
+      (fresh-line p)
+      (display "goodbye" p)
+      (newline p)
+      (fresh-line p)
+      (g))
+    "hello\n\ngoodbye\n")
+ ; check for bug fix in transcoded-port-put-some
+  (let f ([n 1000])
+    (or (fx= n 0)
+        (begin
+          (let ([op (open-file-output-port "testfile.ss" (file-options replace)
+                      (buffer-mode line) (native-transcoder))])
+            (do ([i 1000 (- i 1)])
+                ((fx= i 0))
+              (display #!eof op))
+            (close-port op))
+          (and (equal? (call-with-port
+                         (open-file-input-port "testfile.ss" (file-options)
+                           (buffer-mode block) (native-transcoder))
+                         get-string-all)
+                       (apply string-append (make-list 1000 "#!eof")))
+               (f (- n 1))))))
+)
+
+(mat port-operations3
+  (error? (file-port? "not a port"))
+  (error? (port-file-descriptor 'oops))
+  (error? (port-file-descriptor (open-input-string "hello")))
+  (or (threaded?) (file-port? (console-input-port)))
+  (or (threaded?) (file-port? (console-output-port)))
+  (not (file-port? (open-input-string "hello")))
+  (or (threaded?) (= (port-file-descriptor (console-input-port)) 0))
+  (or (threaded?) (= (port-file-descriptor (console-output-port)) 1))
+  (> (let ([ip (open-input-file prettytest.ss)])
+       (let ([n (and (file-port? ip) (port-file-descriptor ip))])
+         (close-port ip)
+         n))
+     1)
+  (> (let ([ip (open-input-file prettytest.ss 'compressed)])
+       (let ([n (and (file-port? ip) (port-file-descriptor ip))])
+         (close-port ip)
+         n))
+     1)
+  (> (let ([op (open-output-file "testfile.ss" '(replace))])
+       (let ([n (and (file-port? op) (port-file-descriptor op))])
+         (close-port op)
+         n))
+     1)
+  (> (let ([op (open-output-file "testfile.ss" '(replace compressed))])
+       (let ([n (and (file-port? op) (port-file-descriptor op))])
+         (close-port op)
+         n))
+     1)
+ )
+
+(if (embedded?)
+    (mat iconv-codec
+      (error? (errorf 'iconv-codec "-73 is not a string"))
+      (error? (errorf 'transcoded-port "unsupported encoding almost certainly bogus"))
+      (error? (errorf 'close-port "iconv CP1252 codec cannot encode #\\x3BB"))
+      (error? (errorf 'close-port "iconv CP1252 codec cannot encode #\\newline with eol-style ls"))
+      (error? (errorf 'close-port "latin-1 codec cannot encode #\\newline with eol-style ls")))
+    (mat iconv-codec
+      (error? ; invalid codec
+        (iconv-codec -73))
+      (error? ; unsupported encoding
+        (let ()
+          (define codec (iconv-codec "almost certainly bogus"))
+          (define transcoder
+            (make-transcoder codec
+              (eol-style none)
+              (error-handling-mode ignore)))
+          (define-values (bp get) (open-bytevector-output-port))
+          (define op (transcoded-port bp transcoder))
+          (newline op)
+          (close-port op)))
+      (let ()
+        (define codec (iconv-codec "UTF-8"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style none)
+            (error-handling-mode ignore)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (define p1)
+        (define p2)
+        (define p3)
+        (define p4)
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              (make-transcoder (utf-8-codec) (eol-style none)
+                                (error-handling-mode raise)))
+              (lambda (ip)
+                (set! p1 (port-position ip))
+                (let ([s (get-string-all ip)])
+                  (set! p2 (port-position ip))
+                  s)))
+            "\nhello l\x0;ambda:\n\x3bb;!\n")
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              (lambda (ip)
+                (set! p3 (port-position ip))
+                (let ([s (get-string-all ip)])
+                  (set! p4 (port-position ip))
+                  s)))
+            "\nhello l\x0;ambda:\n\x3bb;!\n")
+          (eq? p1 0)
+          (eq? p2 20)
+          (eq? p3 0)
+          (eq? p4 20)))
+      (let () ; same but eol-style lf
+        (define codec (iconv-codec "UTF-8"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style lf)
+            (error-handling-mode ignore)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (define p1)
+        (define p2)
+        (define p3)
+        (define p4)
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              (make-transcoder (utf-8-codec) (eol-style lf)
+                                (error-handling-mode raise)))
+              (lambda (ip)
+                (set! p1 (port-position ip))
+                (let ([s (get-string-all ip)])
+                  (set! p2 (port-position ip))
+                  s)))
+            "\nhello l\x0;ambda:\n\x3bb;!\n")
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              (lambda (ip)
+                (set! p3 (port-position ip))
+                (let ([s (get-string-all ip)])
+                  (set! p4 (port-position ip))
+                  s)))
+            "\nhello l\x0;ambda:\n\x3bb;!\n")
+          (eq? p1 0)
+          (eq? p2 20)
+          (eq? p3 0)
+          (eq? p4 20)))
+      (let () ; same but eol-style crlf
+        (define codec (iconv-codec "UTF-8"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style crlf)
+            (error-handling-mode ignore)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (define p1)
+        (define p2)
+        (define p3)
+        (define p4)
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              (make-transcoder (utf-8-codec) (eol-style crlf)
+                                (error-handling-mode raise)))
+              (lambda (ip)
+                (set! p1 (port-position ip))
+                (let ([s (get-string-all ip)])
+                  (set! p2 (port-position ip))
+                  s)))
+            "\nhello l\x0;ambda:\n\x3bb;!\n")
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              (lambda (ip)
+                (set! p3 (port-position ip))
+                (let ([s (get-string-all ip)])
+                  (set! p4 (port-position ip))
+                  s)))
+            "\nhello l\x0;ambda:\n\x3bb;!\n")
+          (eq? p1 0)
+          (eq? p2 23)
+          (eq? p3 0)
+          (eq? p4 23)))
+      (let ()
+        (define codec (iconv-codec "GB18030"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style none)
+            (error-handling-mode raise)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss")
+              get-bytevector-all)
+            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #xa6 #xcb #x21 #x0a))
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              get-string-all)
+            "\nhello l\x0;ambda:\n\x3bb;!\n")))
+      (let ()
+        (define codec (iconv-codec "CP1252"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style none)
+            (error-handling-mode replace)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss")
+              get-bytevector-all)
+            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #x3f #x21 #x0a))
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              get-string-all)
+            "\nhello l\x0;ambda:\n?!\n")))
+      (let () ; same but eol-style lf
+        (define codec (iconv-codec "CP1252"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style lf)
+            (error-handling-mode replace)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss")
+              get-bytevector-all)
+            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #x3f #x21 #x0a))
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              get-string-all)
+            "\nhello l\x0;ambda:\n?!\n")))
+      (let () ; same but eol-style crlf
+        (define codec (iconv-codec "CP1252"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style crlf)
+            (error-handling-mode replace)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss")
+              get-bytevector-all)
+            #vu8(#x0d #x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0d #x0a #x3f #x21 #x0d #x0a))
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              get-string-all)
+            "\nhello l\x0;ambda:\n?!\n")))
+      (let ()
+        (define codec (iconv-codec "CP1252"))
+        (define transcoder
+          (make-transcoder codec
+            (eol-style none)
+            (error-handling-mode ignore)))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace)
+            (buffer-mode line)
+            transcoder))
+        (newline op)
+        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss")
+              get-bytevector-all)
+            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #x21 #x0a))
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss" (file-options)
+                              (buffer-mode block)
+                              transcoder)
+              get-string-all)
+            "\nhello l\x0;ambda:\n!\n")))
+      (error? ; encoding error
+        (let-values ([(bp get) (open-bytevector-output-port)])
+          (define codec (iconv-codec "CP1252"))
+          (define transcoder
+            (make-transcoder codec
+              (eol-style none)
+              (error-handling-mode raise)))
+          (define op (transcoded-port bp transcoder))
+          (newline op)
+          (display "hello l\x0;ambda: \x3bb;!\n" op)
+          (close-port op)))
+      (error? ; encoding error
+        (let-values ([(bp get) (open-bytevector-output-port)])
+          (define codec (iconv-codec "CP1252"))
+          (define transcoder
+            (make-transcoder codec
+              (eol-style ls)
+              (error-handling-mode raise)))
+          (define op (transcoded-port bp transcoder))
+          (newline op)
+          (close-port op)))
+      ; some (older?) versions of iconv don't handle unassigned code-page 1252
+      ; characters properly.  c'est la vie.
+      #;(let ()
+          (define bp (open-bytevector-input-port #vu8(#x80 #x81 #x82 #x8c #x8d #x8e #x8f #x90 #x91 #x9c #x9d #x9e)))
+          (define codec (iconv-codec "CP1252"))
+          (define transcoder
+            (make-transcoder codec
+              (eol-style none)
+              (error-handling-mode replace)))
+          (define ip (transcoded-port bp transcoder))
+          (equal?
+            (get-string-all ip)
+            "\x20ac;\xfffd;\x201a;\x0152;\xfffd;\x017d;\xfffd;\xfffd;\x2018;\x0153;\xfffd;\x017e;"))
+      #;(let ()
+          (define bp (open-bytevector-input-port #vu8(#x80 #x81 #x82 #x8c #x8d #x8e #x8f #x90 #x91 #x9c #x9d #x9e)))
+          (define codec (iconv-codec "CP1252"))
+          (define transcoder
+            (make-transcoder codec
+              (eol-style none)
+              (error-handling-mode ignore)))
+          (define ip (transcoded-port bp transcoder))
+          (equal?
+            (get-string-all ip)
+            "\x20ac;\x201a;\x0152;\x017d;\x2018;\x0153;\x017e;"))
+      #;(error? ; decoding error
+          (let ()
+            (define bp (open-bytevector-input-port #vu8(#x80 #x81 #x82 #x8c #x8d #x8e #x8f #x90 #x91 #x9c #x9d #x9e)))
+            (define codec (iconv-codec "CP1252"))
+            (define transcoder
+              (make-transcoder codec
+                (eol-style none)
+                (error-handling-mode raise)))
+            (define ip (transcoded-port bp transcoder))
+            (equal?
+              (get-string-all ip)
+              "\x20ac;\xfffd;\x201a;\x0152;\xfffd;\x017d;\xfffd;\xfffd;\x2018;\x0153;\xfffd;\x017e;")))
+      (let () ; SBCS CP1252
+        (define cp1252
+          '((#x00 #x0000) (#x01 #x0001) (#x02 #x0002) (#x03 #x0003)
+                          (#x04 #x0004) (#x05 #x0005) (#x06 #x0006) (#x07 #x0007)
+                          (#x08 #x0008) (#x09 #x0009) (#x0A #x000A) (#x0B #x000B)
+                          (#x0C #x000C) (#x0D #x000D) (#x0E #x000E) (#x0F #x000F)
+                          (#x10 #x0010) (#x11 #x0011) (#x12 #x0012) (#x13 #x0013)
+                          (#x14 #x0014) (#x15 #x0015) (#x16 #x0016) (#x17 #x0017)
+                          (#x18 #x0018) (#x19 #x0019) (#x1A #x001A) (#x1B #x001B)
+                          (#x1C #x001C) (#x1D #x001D) (#x1E #x001E) (#x1F #x001F)
+                          (#x20 #x0020) (#x21 #x0021) (#x22 #x0022) (#x23 #x0023)
+                          (#x24 #x0024) (#x25 #x0025) (#x26 #x0026) (#x27 #x0027)
+                          (#x28 #x0028) (#x29 #x0029) (#x2A #x002A) (#x2B #x002B)
+                          (#x2C #x002C) (#x2D #x002D) (#x2E #x002E) (#x2F #x002F)
+                          (#x30 #x0030) (#x31 #x0031) (#x32 #x0032) (#x33 #x0033)
+                          (#x34 #x0034) (#x35 #x0035) (#x36 #x0036) (#x37 #x0037)
+                          (#x38 #x0038) (#x39 #x0039) (#x3A #x003A) (#x3B #x003B)
+                          (#x3C #x003C) (#x3D #x003D) (#x3E #x003E) (#x3F #x003F)
+                          (#x40 #x0040) (#x41 #x0041) (#x42 #x0042) (#x43 #x0043)
+                          (#x44 #x0044) (#x45 #x0045) (#x46 #x0046) (#x47 #x0047)
+                          (#x48 #x0048) (#x49 #x0049) (#x4A #x004A) (#x4B #x004B)
+                          (#x4C #x004C) (#x4D #x004D) (#x4E #x004E) (#x4F #x004F)
+                          (#x50 #x0050) (#x51 #x0051) (#x52 #x0052) (#x53 #x0053)
+                          (#x54 #x0054) (#x55 #x0055) (#x56 #x0056) (#x57 #x0057)
+                          (#x58 #x0058) (#x59 #x0059) (#x5A #x005A) (#x5B #x005B)
+                          (#x5C #x005C) (#x5D #x005D) (#x5E #x005E) (#x5F #x005F)
+                          (#x60 #x0060) (#x61 #x0061) (#x62 #x0062) (#x63 #x0063)
+                          (#x64 #x0064) (#x65 #x0065) (#x66 #x0066) (#x67 #x0067)
+                          (#x68 #x0068) (#x69 #x0069) (#x6A #x006A) (#x6B #x006B)
+                          (#x6C #x006C) (#x6D #x006D) (#x6E #x006E) (#x6F #x006F)
+                          (#x70 #x0070) (#x71 #x0071) (#x72 #x0072) (#x73 #x0073)
+                          (#x74 #x0074) (#x75 #x0075) (#x76 #x0076) (#x77 #x0077)
+                          (#x78 #x0078) (#x79 #x0079) (#x7A #x007A) (#x7B #x007B)
+                          (#x7C #x007C) (#x7D #x007D) (#x7E #x007E) (#x7F #x007F)
+                          (#x80 #x20AC) (#x82 #x201A) (#x83 #x0192) (#x84 #x201E)
+                          (#x85 #x2026) (#x86 #x2020) (#x87 #x2021) (#x88 #x02C6)
+                          (#x89 #x2030) (#x8A #x0160) (#x8B #x2039) (#x8C #x0152)
+                          (#x8E #x017D) (#x91 #x2018) (#x92 #x2019) (#x93 #x201C)
+                          (#x94 #x201D) (#x95 #x2022) (#x96 #x2013) (#x97 #x2014)
+                          (#x98 #x02DC) (#x99 #x2122) (#x9A #x0161) (#x9B #x203A)
+                          (#x9C #x0153) (#x9E #x017E) (#x9F #x0178) (#xA0 #x00A0)
+                          (#xA1 #x00A1) (#xA2 #x00A2) (#xA3 #x00A3) (#xA4 #x00A4)
+                          (#xA5 #x00A5) (#xA6 #x00A6) (#xA7 #x00A7) (#xA8 #x00A8)
+                          (#xA9 #x00A9) (#xAA #x00AA) (#xAB #x00AB) (#xAC #x00AC)
+                          (#xAD #x00AD) (#xAE #x00AE) (#xAF #x00AF) (#xB0 #x00B0)
+                          (#xB1 #x00B1) (#xB2 #x00B2) (#xB3 #x00B3) (#xB4 #x00B4)
+                          (#xB5 #x00B5) (#xB6 #x00B6) (#xB7 #x00B7) (#xB8 #x00B8)
+                          (#xB9 #x00B9) (#xBA #x00BA) (#xBB #x00BB) (#xBC #x00BC)
+                          (#xBD #x00BD) (#xBE #x00BE) (#xBF #x00BF) (#xC0 #x00C0)
+                          (#xC1 #x00C1) (#xC2 #x00C2) (#xC3 #x00C3) (#xC4 #x00C4)
+                          (#xC5 #x00C5) (#xC6 #x00C6) (#xC7 #x00C7) (#xC8 #x00C8)
+                          (#xC9 #x00C9) (#xCA #x00CA) (#xCB #x00CB) (#xCC #x00CC)
+                          (#xCD #x00CD) (#xCE #x00CE) (#xCF #x00CF) (#xD0 #x00D0)
+                          (#xD1 #x00D1) (#xD2 #x00D2) (#xD3 #x00D3) (#xD4 #x00D4)
+                          (#xD5 #x00D5) (#xD6 #x00D6) (#xD7 #x00D7) (#xD8 #x00D8)
+                          (#xD9 #x00D9) (#xDA #x00DA) (#xDB #x00DB) (#xDC #x00DC)
+                          (#xDD #x00DD) (#xDE #x00DE) (#xDF #x00DF) (#xE0 #x00E0)
+                          (#xE1 #x00E1) (#xE2 #x00E2) (#xE3 #x00E3) (#xE4 #x00E4)
+                          (#xE5 #x00E5) (#xE6 #x00E6) (#xE7 #x00E7) (#xE8 #x00E8)
+                          (#xE9 #x00E9) (#xEA #x00EA) (#xEB #x00EB) (#xEC #x00EC)
+                          (#xED #x00ED) (#xEE #x00EE) (#xEF #x00EF) (#xF0 #x00F0)
+                          (#xF1 #x00F1) (#xF2 #x00F2) (#xF3 #x00F3) (#xF4 #x00F4)
+                          (#xF5 #x00F5) (#xF6 #x00F6) (#xF7 #x00F7) (#xF8 #x00F8)
+                          (#xF9 #x00F9) (#xFA #x00FA) (#xFB #x00FB) (#xFC #x00FC)
+                          (#xFD #x00FD) (#xFE #x00FE) (#xFF #x00FF)))
+        (define transcoder
+          (make-transcoder (iconv-codec "CP1252")
+            (eol-style none)
+            (error-handling-mode raise)))
+        (define ls
+          (append cp1252
+            (let ([v (list->vector cp1252)])
+              (let f ([n 100000])
+                (if (fx= n 0)
+                    '()
+                    (cons
+                      (vector-ref v (random (vector-length v)))
+                      (f (fx- n 1))))))))
+        (define s (apply string (map integer->char (map cadr ls))))
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace) (buffer-mode block)
+            transcoder))
+        #;(put-string op s)
+        (let loop ([i 0] [n (string-length s)])
+          (unless (fx= n 0)
+            (let ([k (fx+ (random n) 1)])
+              (put-string op s i k)
+              (loop (fx+ i k) (fx- n k)))))
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss")
+              get-bytevector-all)
+            (apply bytevector (map car ls)))
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss"
+                              (file-options) (buffer-mode block)
+                              transcoder)
+              #;get-string-all
+              (lambda (ip)
+                (let ([t (make-string (string-length s))])
+                  (let loop ([i 0] [n (string-length s)])
+                    (unless (fx= n 0)
+                      (let ([k (fx+ (random n) 1)])
+                        (get-string-n! ip t i k)
+                        (loop (fx+ i k) (fx- n k)))))
+                  t)))
+            s)))
+      (let () ; MBCS UTF-8
+        (define transcoder
+          (make-transcoder (iconv-codec "UTF-8")
+            (eol-style none)
+            (error-handling-mode raise)))
+        (define ls1
+          (let f ([i 0])
+            (if (fx= i #x11000)
+                '()
+                (if (fx= i #xD800)
+                    (f #xE000)
+                    (cons i (f (fx+ i 1)))))))
+        (define ls2
+          (let f ([n 1000000])
+            (if (fx= n 0)
+                '()
+                (cons
+                  (let ([n (random (- #x110000 (- #xE000 #xD800)))])
+                    (if (<= #xD800 n #xDFFF)
+                        (+ n (- #xE000 #xD800))
+                        n))
+                  (f (fx- n 1))))))
+        (define s (apply string (map integer->char (append ls1 ls2))))
+        #;(define s (apply string (map integer->char ls1)))
+        #;(define s "hello\x1447A;")
+        (define op
+          (open-file-output-port "testfile.ss"
+            (file-options replace) (buffer-mode block)
+            transcoder))
+        #;(put-string op s)
+        (let loop ([i 0] [n (string-length s)])
+          (unless (fx= n 0)
+            (let ([k (fx+ (random n) 1)])
+              (put-string op s i k)
+              (loop (fx+ i k) (fx- n k)))))
+        (close-port op)
+        (and
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss"
+                              (file-options) (buffer-mode block)
+                              (make-transcoder (utf-8-codec) (eol-style none)
+                                (error-handling-mode raise)))
+              get-string-all)
+            s)
+          (equal?
+            (call-with-port (open-file-input-port "testfile.ss"
+                              (file-options) (buffer-mode block)
+                              transcoder)
+              #;get-string-all
+              (lambda (ip)
+                (let ([t (make-string (string-length s))])
+                  (let loop ([i 0] [n (string-length s)])
+                    (unless (fx= n 0)
+                      (let ([k (fx+ (random n) 1)])
+                        (get-string-n! ip t i k)
+                        (loop (fx+ i k) (fx- n k)))))
+                  t)))
+            s)))
+      (error? ; encoding error
+        (let ()
+          (define transcoder
+            (make-transcoder (latin-1-codec)
+              (eol-style ls)
+              (error-handling-mode raise)))
+          (define-values (bp get) (open-bytevector-output-port))
+          (define op (transcoded-port bp transcoder))
+          (newline op)
+          (close-port op)))
+      ; NB: keep this last among the iconv-codec mats
+      ; close any files left open by failing iconv tests.  this is particularly
+      ; important on windows when the iconv dll isn't available and where keeping
+      ; file open can prevent it from being reopened.
+      (begin (collect (collect-maximum-generation)) #t)
+      ))
+
+(mat port-operations4
+  (begin
+    (define po4-tx (make-transcoder (latin-1-codec) (eol-style none) (error-handling-mode raise)))
+    #t)
+  (transcoder? po4-tx)
+  (not (transcoder? (latin-1-codec)))
+  (eq? (call-with-port 
+         (open-file-output-port "testfile.ss" (file-options replace)
+           (buffer-mode block) po4-tx)
+         (lambda (op) (put-string op "hi there")))
+       (void))
+ ; binary input port
+  (begin
+    (define po4-p (open-file-input-port "testfile.ss"))
+    #t)
+  (and (input-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
+  (error? (put-string po4-p "hello"))
+  (error? (put-bytevector po4-p #vu8(100)))
+  (error? (get-string-all po4-p))
+  (error? (get-char po4-p))
+  (error? (lookahead-char po4-p))
+  (fixnum? (port-file-descriptor po4-p))
+  (port-has-port-position? po4-p)
+  (eqv? (port-position po4-p) 0)
+  (port-has-set-port-position!? po4-p)
+  (eq? (set-port-position! po4-p 3) (void))
+  (eqv? (port-position po4-p) 3)
+  (equal? (get-bytevector-n po4-p 5) (string->bytevector "there" po4-tx))
+  (eof-object? (get-bytevector-n po4-p 1))
+  (port-has-port-length? po4-p)
+  (eqv? (port-length po4-p) 8)
+  (not (port-has-set-port-length!? po4-p))
+  (error? (set-port-length! po4-p 7))
+  (eq? (close-port po4-p) (void))
+ ; textual input port
+  (begin
+    (define po4-p
+      (open-file-input-port "testfile.ss" (file-options)
+        (buffer-mode block) po4-tx))
+    #t)
+  (and (input-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
+  (error? (put-string po4-p "hello"))
+  (error? (put-bytevector po4-p #vu8(100)))
+  (error? (get-bytevector-all po4-p))
+  (error? (get-u8 po4-p))
+  (error? (lookahead-u8 po4-p))
+  (fixnum? (port-file-descriptor po4-p))
+  (port-has-port-position? po4-p)
+  (eqv? (port-position po4-p) 0)
+  (port-has-set-port-position!? po4-p)
+  (eqv? (set-port-position! po4-p 3) (void))
+  (eqv? (port-position po4-p) 3)
+  (equal? (get-string-n po4-p 5) "there")
+  (eof-object? (get-string-n po4-p 1))
+  (port-has-port-length? po4-p)
+  (eqv? (port-length po4-p) 8)
+  (not (port-has-set-port-length!? po4-p))
+  (error? (set-port-length! po4-p 7))
+  (eq? (close-port po4-p) (void))
+ ; binary output port
+  (begin
+    (define po4-p
+      (open-file-output-port "testfile.ss" (file-options replace)))
+    #t)
+  (and (output-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
+  (error? (get-string-all po4-p))
+  (error? (get-char po4-p))
+  (error? (lookahead-char po4-p))
+  (error? (get-bytevector-all po4-p))
+  (error? (get-u8 po4-p))
+  (error? (lookahead-u8 po4-p))
+  (error? (put-string po4-p "hello"))
+  (fixnum? (port-file-descriptor po4-p))
+  (port-has-port-position? po4-p)
+  (eqv? (port-position po4-p) 0)
+  (port-has-set-port-position!? po4-p)
+  (eq? (set-port-position! po4-p 3) (void))
+  (eqv? (port-position po4-p) 3)
+  (eq? (put-bytevector po4-p (string->bytevector "123456" po4-tx)) (void))
+  (port-has-port-length? po4-p)
+  (eqv? (port-length po4-p) 9)
+  (port-has-set-port-length!? po4-p)
+  (eq? (set-port-length! po4-p 7) (void))
+  (eq? (set-port-position! po4-p 0) (void))
+  (eq? (put-bytevector po4-p (string->bytevector "abcd" po4-tx)) (void))
+  (eq? (close-port po4-p) (void))
+  (equal?
+    (call-with-port
+      (open-file-input-port "testfile.ss" (file-options)
+        (buffer-mode block) po4-tx)
+      get-string-all)
+    "abcd234")
+ ; textual output port
+  (begin
+    (define po4-p
+      (open-file-output-port "testfile.ss" (file-options replace)
+        (buffer-mode block) po4-tx))
+    #t)
+  (and (output-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
+  (error? (get-string-all po4-p))
+  (error? (get-char po4-p))
+  (error? (lookahead-char po4-p))
+  (error? (get-bytevector-all po4-p))
+  (error? (get-u8 po4-p))
+  (error? (lookahead-u8 po4-p))
+  (error? (put-bytevector po4-p #vu8()))
+  (fixnum? (port-file-descriptor po4-p))
+  (port-has-port-position? po4-p)
+  (eqv? (port-position po4-p) 0)
+  (port-has-set-port-position!? po4-p)
+  (eq? (set-port-position! po4-p 3) (void))
+  (eqv? (port-position po4-p) 3)
+  (eq? (put-string po4-p "abcdef") (void))
+  (port-has-port-length? po4-p)
+  (eqv? (port-length po4-p) 9)
+  (port-has-set-port-length!? po4-p)
+  (eq? (set-port-length! po4-p 7) (void))
+  (eq? (set-port-position! po4-p 0) (void))
+  (eq? (put-string po4-p "1234") (void))
+  (eq? (close-port po4-p) (void))
+  (equal?
+    (call-with-port
+      (open-file-input-port "testfile.ss" (file-options)
+        (buffer-mode block) po4-tx)
+      get-string-all)
+    "1234bcd")
+ ; binary input/output port
+  (begin
+    (define po4-p
+      (open-file-input/output-port "testfile.ss" (file-options replace)))
+    #t)
+  (and (output-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
+  (and (input-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
+  (fixnum? (port-file-descriptor po4-p))
+  (port-has-port-position? po4-p)
+  (eqv? (port-position po4-p) 0)
+  (port-has-set-port-position!? po4-p)
+  (eq? (set-port-position! po4-p 3) (void))
+  (eqv? (port-position po4-p) 3)
+  (eq? (put-bytevector po4-p (string->bytevector "foobar" po4-tx)) (void))
+  (port-has-port-length? po4-p)
+  (eqv? (port-length po4-p) 9)
+  (port-has-set-port-length!? po4-p)
+  (eq? (set-port-length! po4-p 7) (void))
+  (eq? (set-port-position! po4-p 0) (void))
+  (eq? (put-bytevector po4-p (string->bytevector "4321" po4-tx)) (void))
+  (equal? (get-bytevector-all po4-p) (string->bytevector "oob" po4-tx))
+  (eq? (set-port-position! po4-p 0) (void))
+  (equal? (get-bytevector-all po4-p) (string->bytevector "4321oob" po4-tx))
+  (eq? (close-port po4-p) (void))
+  (equal?
+    (call-with-port
+      (open-file-input-port "testfile.ss" (file-options)
+        (buffer-mode block) po4-tx)
+      get-string-all)
+    "4321oob")
+ ; textual input/output port
+  (begin
+    (define po4-p
+      (open-file-input/output-port "testfile.ss" (file-options replace)
+        (buffer-mode block) po4-tx))
+    #t)
+  (and (output-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
+  (and (input-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
+  (fixnum? (port-file-descriptor po4-p))
+  (port-has-port-position? po4-p)
+  (eqv? (port-position po4-p) 0)
+  (port-has-set-port-position!? po4-p)
+  (eq? (set-port-position! po4-p 3) (void))
+  (eqv? (port-position po4-p) 3)
+  (eq? (put-string po4-p "abcdef") (void))
+  (port-has-port-length? po4-p)
+  (eqv? (port-length po4-p) 9)
+  (port-has-set-port-length!? po4-p)
+  (eq? (set-port-length! po4-p 7) (void))
+  (eq? (set-port-position! po4-p 0) (void))
+  (eq? (put-string po4-p "1234") (void))
+  (equal? (get-string-all po4-p) "bcd")
+  (eq? (set-port-position! po4-p 0) (void))
+  (equal? (get-string-all po4-p) "1234bcd")
+  (eq? (close-port po4-p) (void))
+  (equal?
+    (call-with-port
+      (open-file-input-port "testfile.ss" (file-options)
+        (buffer-mode block) po4-tx)
+      get-string-all)
+    "1234bcd")
+)
+
+(mat get-line
+  (error? ; not a port
+    (get-line "current-input-port"))
+  (error? ; not a port
+    (get-line 3))
+  (error? ; not a textual input port
+    (get-line (open-bytevector-input-port #vu8(1 2 3 4 5))))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "hello from line 1!\n")
+        (display (make-string 1017 #\a))
+        (display " hello from line 2!\n")
+        (display "goodbye from (incomplete) line 3!"))
+      'replace)
+    (define $tip (open-input-file "testfile.ss"))
+    #t)
+  (equal? (get-line $tip) "hello from line 1!")
+  (equal? (get-line $tip) (format "~a hello from line 2!" (make-string 1017 #\a)))
+  (equal? (get-line $tip) "goodbye from (incomplete) line 3!")
+  (eof-object? (get-line $tip))
+  (eqv? (close-port $tip) (void))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (display "hello from line 1!\n")
+        (display "\n")
+        (display "goodbye from (complete) line 3!\n"))
+      'replace)
+    (define $tip (open-input-file "testfile.ss"))
+    #t)
+  (equal? (get-line $tip) "hello from line 1!")
+  (equal? (get-line $tip) "")
+  (equal? (get-line $tip) "goodbye from (complete) line 3!")
+  (eof-object? (get-line $tip))
+  (eqv? (close-port $tip) (void))
+)
+
+(mat low-level-port-operations
+  (<= (textual-port-input-index (console-input-port))
+      (textual-port-input-size (console-input-port))
+      (string-length (textual-port-input-buffer (console-input-port))))
+  (<= (textual-port-input-count (console-input-port))
+      (string-length (textual-port-input-buffer (console-input-port))))
+  (<= (textual-port-output-index (console-output-port))
+      (textual-port-output-size (console-output-port))
+      (string-length (textual-port-output-buffer (console-output-port))))
+  (<= (textual-port-output-count (console-output-port))
+      (string-length (textual-port-output-buffer (console-output-port))))
+  (begin
+    (define $tip (open-string-input-port "hello"))
+    (define $top (let-values ([(op get) (open-string-output-port)]) (set-textual-port-output-buffer! op "hello") op))
+    (define $bip (open-bytevector-input-port #vu8(1 2 3 4 5)))
+    (define $bop (let-values ([(op get) (open-bytevector-output-port)]) (set-binary-port-output-buffer! op #vu8(1 2 3 4 5)) op))
+    #t)
+  ; textual input
+  (andmap (lambda (str)
+            (equal?
+             (let ([ip (open-string-input-port str)])
+               (let ([buffer0 (textual-port-input-buffer ip)]
+                     [index0 (textual-port-input-index ip)]
+                     [size0 (textual-port-input-size ip)]
+                     [count0 (textual-port-input-count ip)])
+                 (read-char ip)
+                 (list
+                  (list buffer0 index0 size0 count0)
+                  (list
+                   (textual-port-input-buffer ip)
+                   (textual-port-input-index ip)
+                   (textual-port-input-size ip)
+                   (textual-port-input-count ip)))))
+             '(("hello" 0 5 5) ("hello" 1 5 4))))
+          (list "hello"
+                (string->immutable-string "hello")))
+  (equal?
+    (let ([ip (open-string-input-port "hello")])
+      (let ([buffer0 (textual-port-input-buffer ip)]
+            [index0 (textual-port-input-index ip)]
+            [size0 (textual-port-input-size ip)]
+            [count0 (textual-port-input-count ip)])
+        (read-char ip)
+        (set-textual-port-input-buffer! ip "goodbye")
+        (read-char ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (textual-port-input-buffer ip)
+            (textual-port-input-index ip)
+            (textual-port-input-size ip)
+            (textual-port-input-count ip)))))
+    '(("hello" 0 5 5) ("goodbye" 1 7 6)))
+  (equal?
+    (let ([ip (open-string-input-port "hello")])
+      (let ([buffer0 (textual-port-input-buffer ip)]
+            [index0 (textual-port-input-index ip)]
+            [size0 (textual-port-input-size ip)]
+            [count0 (textual-port-input-count ip)])
+        (read-char ip)
+        (set-textual-port-input-size! ip 4)
+        (read-char ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (textual-port-input-buffer ip)
+            (textual-port-input-index ip)
+            (textual-port-input-size ip)
+            (textual-port-input-count ip)))))
+    '(("hello" 0 5 5) ("hello" 1 4 3)))
+  (equal?
+    (let ([ip (open-string-input-port "hello")])
+      (let ([buffer0 (textual-port-input-buffer ip)]
+            [index0 (textual-port-input-index ip)]
+            [size0 (textual-port-input-size ip)]
+            [count0 (textual-port-input-count ip)])
+        (read-char ip)
+        (set-textual-port-input-index! ip 4)
+        (read-char ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (textual-port-input-buffer ip)
+            (textual-port-input-index ip)
+            (textual-port-input-size ip)
+            (textual-port-input-count ip)))))
+    '(("hello" 0 5 5) ("hello" 5 5 0)))
+  (error? ; not a textual input port
+    (textual-port-input-buffer $top))
+  (error? ; not a textual input port
+    (textual-port-input-buffer $bip))
+  (error? ; not a textual input port
+    (textual-port-input-buffer $bop))
+  (error? ; not a textual input port
+    (textual-port-input-buffer 75))
+  (error? ; not a textual input port
+    (textual-port-input-index $top))
+  (error? ; not a textual input port
+    (textual-port-input-index $bip))
+  (error? ; not a textual input port
+    (textual-port-input-index $bop))
+  (error? ; not a textual input port
+    (textual-port-input-index 75))
+  (error? ; not a textual input port
+    (textual-port-input-size $top))
+  (error? ; not a textual input port
+    (textual-port-input-size $bip))
+  (error? ; not a textual input port
+    (textual-port-input-size $bop))
+  (error? ; not a textual input port
+    (textual-port-input-size 75))
+  (error? ; not a textual input port
+    (textual-port-input-count $top))
+  (error? ; not a textual input port
+    (textual-port-input-count $bip))
+  (error? ; not a textual input port
+    (textual-port-input-count $bop))
+  (error? ; not a textual input port
+    (textual-port-input-count 75))
+  (error? ; not a textual input port
+    (set-textual-port-input-buffer! $top ""))
+  (error? ; not a textual input port
+    (set-textual-port-input-buffer! $bip ""))
+  (error? ; not a textual input port
+    (set-textual-port-input-buffer! $bop ""))
+  (error? ; not a textual input port
+    (set-textual-port-input-buffer! 75 ""))
+  (error? ; not a textual input port
+    (set-textual-port-input-index! $top 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-index! $bip 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-index! $bop 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-index! 75 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-size! $top 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-size! $bip 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-size! $bop 0))
+  (error? ; not a textual input port
+    (set-textual-port-input-size! 75 0))
+  (error? ; not a string
+    (set-textual-port-input-buffer! $tip #vu8(1 2 3)))
+  (error? ; not a string
+    (set-textual-port-input-buffer! $tip 0))
+  (error? ; invalid index
+    (set-textual-port-input-index! $tip "hello"))
+  (error? ; invalid index
+    (set-textual-port-input-index! $tip -1))
+  (error? ; invalid index
+    (set-textual-port-input-index! $tip 6))
+  (error? ; invalid size
+    (set-textual-port-input-size! $tip "hello"))
+  (error? ; invalid size
+    (set-textual-port-input-size! $tip -1))
+  (error? ; invalid size
+    (set-textual-port-input-size! $tip 6))
+  ; textual output
+  (equal?
+    (let ([op (make-output-port (lambda args (error #f "oops")) (make-string 10 #\$))])
+      (let ([buffer0 (string-copy (textual-port-output-buffer op))]
+            [index0 (textual-port-output-index op)]
+            [size0 (textual-port-output-size op)]
+            [count0 (textual-port-output-count op)])
+        (display "hey!" op)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (textual-port-output-buffer op)
+            (textual-port-output-index op)
+            (textual-port-output-size op)
+            (textual-port-output-count op)))))
+    '(("$$$$$$$$$$" 0 10 10)
+      ("hey!$$$$$$" 4 10 6)))
+  (equal?
+    (let-values ([(op get) (open-string-output-port)])
+      (let ([buffer (make-string 8 #\$)])
+        (set-textual-port-output-buffer! op buffer)
+        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
+              [index0 (textual-port-output-index op)]
+              [size0 (textual-port-output-size op)]
+              [count0 (textual-port-output-count op)])
+          (display "yo!" op)
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (textual-port-output-buffer op)
+              (textual-port-output-index op)
+              (textual-port-output-size op)
+              (textual-port-output-count op))))))
+    '("yo!$$$$$"
+      ("$$$$$$$$" 0 8 8)
+      ("yo!$$$$$" 3 8 5)))
+  (equal?
+    (let-values ([(op get) (open-string-output-port)])
+      (let ([buffer (make-string 8 #\$)])
+        (set-textual-port-output-buffer! op buffer)
+        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
+              [index0 (textual-port-output-index op)]
+              [size0 (textual-port-output-size op)]
+              [count0 (textual-port-output-count op)])
+          (display "yo" op)
+          (set-textual-port-output-buffer! op (string #\a #\b #\c))
+          (display "!?" op)
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (textual-port-output-buffer op)
+              (textual-port-output-index op)
+              (textual-port-output-size op)
+              (textual-port-output-count op))))))
+    '("yo$$$$$$"
+      ("$$$$$$$$" 0 8 8)
+      ("!?c" 2 3 1)))
+  (equal?
+    (let-values ([(op get) (open-string-output-port)])
+      (let ([buffer (make-string 8 #\$)])
+        (set-textual-port-output-buffer! op buffer)
+        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
+              [index0 (textual-port-output-index op)]
+              [size0 (textual-port-output-size op)]
+              [count0 (textual-port-output-count op)])
+          (display "yo" op)
+          (set-textual-port-output-index! op 4)
+          (display "!?" op)
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (textual-port-output-buffer op)
+              (textual-port-output-index op)
+              (textual-port-output-size op)
+              (textual-port-output-count op))))))
+    '("yo$$!?$$"
+      ("$$$$$$$$" 0 8 8)
+      ("yo$$!?$$" 6 8 2)))
+  (equal?
+    (let-values ([(op get) (open-string-output-port)])
+      (let ([buffer (make-string 8 #\$)])
+        (set-textual-port-output-buffer! op buffer)
+        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
+              [index0 (textual-port-output-index op)]
+              [size0 (textual-port-output-size op)]
+              [count0 (textual-port-output-count op)])
+          (display "yo" op)
+          (set-textual-port-output-size! op 4)
+          (display "!?" op)
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (textual-port-output-buffer op)
+              (textual-port-output-index op)
+              (textual-port-output-size op)
+              (textual-port-output-count op))))))
+    '("!?$$$$$$"
+      ("$$$$$$$$" 0 8 8)
+      ("!?$$$$$$" 2 4 2)))
+  (error? ; not a textual output port
+    (textual-port-output-buffer $tip))
+  (error? ; not a textual output port
+    (textual-port-output-buffer $bip))
+  (error? ; not a textual output port
+    (textual-port-output-buffer $bop))
+  (error? ; not a textual output port
+    (textual-port-output-buffer 75))
+  (error? ; not a textual output port
+    (textual-port-output-index $tip))
+  (error? ; not a textual output port
+    (textual-port-output-index $bip))
+  (error? ; not a textual output port
+    (textual-port-output-index $bop))
+  (error? ; not a textual output port
+    (textual-port-output-index 75))
+  (error? ; not a textual output port
+    (textual-port-output-size $tip))
+  (error? ; not a textual output port
+    (textual-port-output-size $bip))
+  (error? ; not a textual output port
+    (textual-port-output-size $bop))
+  (error? ; not a textual output port
+    (textual-port-output-size 75))
+  (error? ; not a textual output port
+    (textual-port-output-count $tip))
+  (error? ; not a textual output port
+    (textual-port-output-count $bip))
+  (error? ; not a textual output port
+    (textual-port-output-count $bop))
+  (error? ; not a textual output port
+    (textual-port-output-count 75))
+  (error? ; not a textual output port
+    (set-textual-port-output-buffer! $tip ""))
+  (error? ; not a textual output port
+    (set-textual-port-output-buffer! $bip ""))
+  (error? ; not a textual output port
+    (set-textual-port-output-buffer! $bop ""))
+  (error? ; not a textual output port
+    (set-textual-port-output-buffer! 75 ""))
+  (error? ; not a textual output port
+    (set-textual-port-output-index! $tip 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-index! $bip 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-index! $bop 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-index! 75 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-size! $tip 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-size! $bip 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-size! $bop 0))
+  (error? ; not a textual output port
+    (set-textual-port-output-size! 75 0))
+  (error? ; not a string
+    (set-textual-port-output-buffer! $top #vu8(1 2 3)))
+  (error? ; not a string
+    (set-textual-port-output-buffer! $top 0))
+  (error? ; invalid index
+    (set-textual-port-output-index! $top "hello"))
+  (error? ; invalid index
+    (set-textual-port-output-index! $top -1))
+  (error? ; invalid index
+    (set-textual-port-output-index! $top 6))
+  (error? ; invalid size
+    (set-textual-port-output-size! $top "hello"))
+  (error? ; invalid size
+    (set-textual-port-output-size! $top -1))
+  (error? ; invalid size
+    (set-textual-port-output-size! $top 6))
+  ; binary input
+  (equal?
+    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
+      (let ([buffer0 (binary-port-input-buffer ip)]
+            [index0 (binary-port-input-index ip)]
+            [size0 (binary-port-input-size ip)]
+            [count0 (binary-port-input-count ip)])
+        (get-u8 ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (binary-port-input-buffer ip)
+            (binary-port-input-index ip)
+            (binary-port-input-size ip)
+            (binary-port-input-count ip)))))
+    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "hello") 1 5 4)))
+  (equal?
+    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
+      (let ([buffer0 (binary-port-input-buffer ip)]
+            [index0 (binary-port-input-index ip)]
+            [size0 (binary-port-input-size ip)]
+            [count0 (binary-port-input-count ip)])
+        (get-u8 ip)
+        (set-binary-port-input-buffer! ip (string->utf8 "goodbye"))
+        (get-u8 ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (binary-port-input-buffer ip)
+            (binary-port-input-index ip)
+            (binary-port-input-size ip)
+            (binary-port-input-count ip)))))
+    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "goodbye") 1 7 6)))
+  (equal?
+    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
+      (let ([buffer0 (binary-port-input-buffer ip)]
+            [index0 (binary-port-input-index ip)]
+            [size0 (binary-port-input-size ip)]
+            [count0 (binary-port-input-count ip)])
+        (get-u8 ip)
+        (set-binary-port-input-size! ip 3)
+        (get-u8 ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (binary-port-input-buffer ip)
+            (binary-port-input-index ip)
+            (binary-port-input-size ip)
+            (binary-port-input-count ip)))))
+    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "hello") 1 3 2)))
+  (equal?
+    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
+      (let ([buffer0 (binary-port-input-buffer ip)]
+            [index0 (binary-port-input-index ip)]
+            [size0 (binary-port-input-size ip)]
+            [count0 (binary-port-input-count ip)])
+        (get-u8 ip)
+        (set-binary-port-input-index! ip 3)
+        (get-u8 ip)
+        (list
+          (list buffer0 index0 size0 count0)
+          (list
+            (binary-port-input-buffer ip)
+            (binary-port-input-index ip)
+            (binary-port-input-size ip)
+            (binary-port-input-count ip)))))
+    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "hello") 4 5 1)))
+  (error? ; not a binary input port
+    (binary-port-input-buffer $tip))
+  (error? ; not a binary input port
+    (binary-port-input-buffer $top))
+  (error? ; not a binary input port
+    (binary-port-input-buffer $bop))
+  (error? ; not a binary input port
+    (binary-port-input-buffer 75))
+  (error? ; not a binary input port
+    (binary-port-input-index $tip))
+  (error? ; not a binary input port
+    (binary-port-input-index $top))
+  (error? ; not a binary input port
+    (binary-port-input-index $bop))
+  (error? ; not a binary input port
+    (binary-port-input-index 75))
+  (error? ; not a binary input port
+    (binary-port-input-size $tip))
+  (error? ; not a binary input port
+    (binary-port-input-size $top))
+  (error? ; not a binary input port
+    (binary-port-input-size $bop))
+  (error? ; not a binary input port
+    (binary-port-input-size 75))
+  (error? ; not a binary input port
+    (binary-port-input-count $tip))
+  (error? ; not a binary input port
+    (binary-port-input-count $top))
+  (error? ; not a binary input port
+    (binary-port-input-count $bop))
+  (error? ; not a binary input port
+    (binary-port-input-count 75))
+  (error? ; not a binary input port
+    (set-binary-port-input-buffer! $tip ""))
+  (error? ; not a binary input port
+    (set-binary-port-input-buffer! $top ""))
+  (error? ; not a binary input port
+    (set-binary-port-input-buffer! $bop ""))
+  (error? ; not a binary input port
+    (set-binary-port-input-buffer! 75 ""))
+  (error? ; not a binary input port
+    (set-binary-port-input-index! $tip 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-index! $top 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-index! $bop 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-index! 75 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-size! $tip 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-size! $top 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-size! $bop 0))
+  (error? ; not a binary input port
+    (set-binary-port-input-size! 75 0))
+  (error? ; not a bytevector
+    (set-binary-port-input-buffer! $bip "hello"))
+  (error? ; not a bytevector
+    (set-binary-port-input-buffer! $bip 0))
+  (error? ; invalid index
+    (set-binary-port-input-index! $bip #vu8(1 2 3)))
+  (error? ; invalid index
+    (set-binary-port-input-index! $bip -1))
+  (error? ; invalid index
+    (set-binary-port-input-index! $bip 6))
+  (error? ; invalid size
+    (set-binary-port-input-size! $bip #vu8(1 2 3)))
+  (error? ; invalid size
+    (set-binary-port-input-size! $bip -1))
+  (error? ; invalid size
+    (set-binary-port-input-size! $bip 6))
+  ; binary output
+  (equal?
+    (let-values ([(op get) (open-bytevector-output-port)])
+      (let ([buffer (string->utf8 "hello")])
+        (set-binary-port-output-buffer! op buffer)
+        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
+              [index0 (binary-port-output-index op)]
+              [size0 (binary-port-output-size op)]
+              [count0 (binary-port-output-count op)])
+          (put-u8 op (char->integer #\j))
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (binary-port-output-buffer op)
+              (binary-port-output-index op)
+              (binary-port-output-size op)
+              (binary-port-output-count op))))))
+    `(,(string->utf8 "jello")
+      (,(string->utf8 "hello") 0 5 5)
+      (,(string->utf8 "jello") 1 5 4)))
+  (equal?
+    (let-values ([(op get) (open-bytevector-output-port)])
+      (let ([buffer (string->utf8 "hello")])
+        (set-binary-port-output-buffer! op buffer)
+        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
+              [index0 (binary-port-output-index op)]
+              [size0 (binary-port-output-size op)]
+              [count0 (binary-port-output-count op)])
+          (put-u8 op (char->integer #\j))
+          (set-binary-port-output-buffer! op (bytevector 1 2 3 4 5 6))
+          (put-u8 op 31)
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (binary-port-output-buffer op)
+              (binary-port-output-index op)
+              (binary-port-output-size op)
+              (binary-port-output-count op))))))
+    `(,(string->utf8 "jello")
+      (,(string->utf8 "hello") 0 5 5)
+      (#vu8(31 2 3 4 5 6) 1 6 5)))
+  (equal?
+    (let-values ([(op get) (open-bytevector-output-port)])
+      (let ([buffer (string->utf8 "hello")])
+        (set-binary-port-output-buffer! op buffer)
+        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
+              [index0 (binary-port-output-index op)]
+              [size0 (binary-port-output-size op)]
+              [count0 (binary-port-output-count op)])
+          (put-u8 op (char->integer #\j))
+          (set-binary-port-output-index! op 4)
+          (put-u8 op (char->integer #\y))
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (binary-port-output-buffer op)
+              (binary-port-output-index op)
+              (binary-port-output-size op)
+              (binary-port-output-count op))))))
+    `(,(string->utf8 "jelly")
+      (,(string->utf8 "hello") 0 5 5)
+      (,(string->utf8 "jelly") 5 5 0)))
+  (equal?
+    (let-values ([(op get) (open-bytevector-output-port)])
+      (let ([buffer (string->utf8 "hello")])
+        (set-binary-port-output-buffer! op buffer)
+        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
+              [index0 (binary-port-output-index op)]
+              [size0 (binary-port-output-size op)]
+              [count0 (binary-port-output-count op)])
+          (put-u8 op (char->integer #\j))
+          (set-binary-port-output-size! op 4)
+          (put-u8 op (char->integer #\b))
+          (list
+            buffer
+            (list buffer0 index0 size0 count0)
+            (list
+              (binary-port-output-buffer op)
+              (binary-port-output-index op)
+              (binary-port-output-size op)
+              (binary-port-output-count op))))))
+    `(,(string->utf8 "bello")
+      (,(string->utf8 "hello") 0 5 5)
+      (,(string->utf8 "bello") 1 4 3)))
+  (error? ; not a binary output port
+    (binary-port-output-buffer $tip))
+  (error? ; not a binary output port
+    (binary-port-output-buffer $top))
+  (error? ; not a binary output port
+    (binary-port-output-buffer $bip))
+  (error? ; not a binary output port
+    (binary-port-output-buffer 75))
+  (error? ; not a binary output port
+    (binary-port-output-index $tip))
+  (error? ; not a binary output port
+    (binary-port-output-index $top))
+  (error? ; not a binary output port
+    (binary-port-output-index $bip))
+  (error? ; not a binary output port
+    (binary-port-output-index 75))
+  (error? ; not a binary output port
+    (binary-port-output-size $tip))
+  (error? ; not a binary output port
+    (binary-port-output-size $top))
+  (error? ; not a binary output port
+    (binary-port-output-size $bip))
+  (error? ; not a binary output port
+    (binary-port-output-size 75))
+  (error? ; not a binary output port
+    (binary-port-output-count $tip))
+  (error? ; not a binary output port
+    (binary-port-output-count $top))
+  (error? ; not a binary output port
+    (binary-port-output-count $bip))
+  (error? ; not a binary output port
+    (binary-port-output-count 75))
+  (error? ; not a binary output port
+    (set-binary-port-output-buffer! $tip ""))
+  (error? ; not a binary output port
+    (set-binary-port-output-buffer! $top ""))
+  (error? ; not a binary output port
+    (set-binary-port-output-buffer! $bip ""))
+  (error? ; not a binary output port
+    (set-binary-port-output-buffer! 75 ""))
+  (error? ; not a binary output port
+    (set-binary-port-output-index! $tip 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-index! $top 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-index! $bip 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-index! 75 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-size! $tip 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-size! $top 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-size! $bip 0))
+  (error? ; not a binary output port
+    (set-binary-port-output-size! 75 0))
+  (error? ; not a string
+    (set-binary-port-output-buffer! $bop "hello"))
+  (error? ; not a string
+    (set-binary-port-output-buffer! $bop 0))
+  (error? ; invalid index
+    (set-binary-port-output-index! $bop #vu8(1 2 3)))
+  (error? ; invalid index
+    (set-binary-port-output-index! $bop -1))
+  (error? ; invalid index
+    (set-binary-port-output-index! $bop 6))
+  (error? ; invalid size
+    (set-binary-port-output-size! $bop #vu8(1 2 3)))
+  (error? ; invalid size
+    (set-binary-port-output-size! $bop -1))
+  (error? ; invalid size
+    (set-binary-port-output-size! $bop 6))
+  (begin
+    (define $handler-standin (#%$port-handler (open-string-input-port "hi")))
+    #t)
+  (let ([name "foo"] [ib "hey!"])
+    (let ([p (#%$make-textual-input-port name $handler-standin ib)])
+      (and (port? p)
+           (textual-port? p)
+           (not (binary-port? p))
+           (input-port? p)
+           (not (output-port? p))
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) #f)
+           (eq? (textual-port-input-buffer p) ib)
+           (eqv? (textual-port-input-size p) (string-length ib))
+           (eqv? (textual-port-input-index p) 0)
+           (eqv? (textual-port-input-count p) (string-length ib)))))
+  (let ([name "foo"] [info "info"] [ib "hey!"])
+    (let ([p (#%$make-textual-input-port name $handler-standin ib info)])
+      (and (port? p)
+           (textual-port? p)
+           (not (binary-port? p))
+           (input-port? p)
+           (not (output-port? p))
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) info)
+           (eq? (textual-port-input-buffer p) ib)
+           (eqv? (textual-port-input-size p) (string-length ib))
+           (eqv? (textual-port-input-index p) 0)
+           (eqv? (textual-port-input-count p) (string-length ib)))))
+  (let ([name "foo"] [ob "hey!"])
+    (let ([p (#%$make-textual-output-port name $handler-standin ob)])
+      (and (port? p)
+           (textual-port? p)
+           (not (binary-port? p))
+           (not (input-port? p))
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) #f)
+           (eq? (textual-port-output-buffer p) ob)
+           (eqv? (textual-port-output-size p) (string-length ob))
+           (eqv? (textual-port-output-index p) 0)
+           (eqv? (textual-port-output-count p) (string-length ob)))))
+  (let ([name "foo"] [info "info"] [ob "hey!"])
+    (let ([p (#%$make-textual-output-port name $handler-standin ob info)])
+      (and (port? p)
+           (textual-port? p)
+           (not (binary-port? p))
+           (not (input-port? p))
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) info)
+           (eq? (textual-port-output-buffer p) ob)
+           (eqv? (textual-port-output-size p) (string-length ob))
+           (eqv? (textual-port-output-index p) 0)
+           (eqv? (textual-port-output-count p) (string-length ob)))))
+  (let ([name "foo"] [ib "hay!"] [ob "hey!"])
+    (let ([p (#%$make-textual-input/output-port name $handler-standin ib ob)])
+      (and (port? p)
+           (textual-port? p)
+           (not (binary-port? p))
+           (input-port? p)
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) #f)
+           (eq? (textual-port-input-buffer p) ib)
+           (eqv? (textual-port-input-size p) (string-length ib))
+           (eqv? (textual-port-input-index p) 0)
+           (eqv? (textual-port-input-count p) (string-length ib))
+           (eq? (textual-port-output-buffer p) ob)
+           (eqv? (textual-port-output-size p) (string-length ob))
+           (eqv? (textual-port-output-index p) 0)
+           (eqv? (textual-port-output-count p) (string-length ob)))))
+  (let ([name "foo"] [info "info"] [ib "hay!"] [ob "hey!"])
+    (let ([p (#%$make-textual-input/output-port name $handler-standin ib ob info)])
+      (and (port? p)
+           (textual-port? p)
+           (not (binary-port? p))
+           (input-port? p)
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) info)
+           (eq? (textual-port-input-buffer p) ib)
+           (eqv? (textual-port-input-size p) (string-length ib))
+           (eqv? (textual-port-input-index p) 0)
+           (eqv? (textual-port-input-count p) (string-length ib))
+           (eq? (textual-port-output-buffer p) ob)
+           (eqv? (textual-port-output-size p) (string-length ob))
+           (eqv? (textual-port-output-index p) 0)
+           (eqv? (textual-port-output-count p) (string-length ob)))))
+  (let ([name "foo"] [ib #vu8(1 2 3 4)])
+    (let ([p (#%$make-binary-input-port name $handler-standin ib)])
+      (and (port? p)
+           (not (textual-port? p))
+           (binary-port? p)
+           (input-port? p)
+           (not (output-port? p))
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) #f)
+           (eq? (binary-port-input-buffer p) ib)
+           (eqv? (binary-port-input-size p) (bytevector-length ib))
+           (eqv? (binary-port-input-index p) 0)
+           (eqv? (binary-port-input-count p) (bytevector-length ib)))))
+  (let ([name "foo"] [info "info"] [ib #vu8(1 2 3 4)])
+    (let ([p (#%$make-binary-input-port name $handler-standin ib info)])
+      (and (port? p)
+           (not (textual-port? p))
+           (binary-port? p)
+           (input-port? p)
+           (not (output-port? p))
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) info)
+           (eq? (binary-port-input-buffer p) ib)
+           (eqv? (binary-port-input-size p) (bytevector-length ib))
+           (eqv? (binary-port-input-index p) 0)
+           (eqv? (binary-port-input-count p) (bytevector-length ib)))))
+  (let ([name "foo"] [ob #vu8(1 2 3 4)])
+    (let ([p (#%$make-binary-output-port name $handler-standin ob)])
+      (and (port? p)
+           (not (textual-port? p))
+           (binary-port? p)
+           (not (input-port? p))
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) #f)
+           (eq? (binary-port-output-buffer p) ob)
+           (eqv? (binary-port-output-size p) (bytevector-length ob))
+           (eqv? (binary-port-output-index p) 0)
+           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
+  (let ([name "foo"] [info "info"] [ob #vu8(1 2 3 4)])
+    (let ([p (#%$make-binary-output-port name $handler-standin ob info)])
+      (and (port? p)
+           (not (textual-port? p))
+           (binary-port? p)
+           (not (input-port? p))
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) info)
+           (eq? (binary-port-output-buffer p) ob)
+           (eqv? (binary-port-output-size p) (bytevector-length ob))
+           (eqv? (binary-port-output-index p) 0)
+           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
+  (let ([name "foo"] [ib #vu8(4 3 2 1)] [ob #vu8(1 2 3 4)])
+    (let ([p (#%$make-binary-input/output-port name $handler-standin ib ob)])
+      (and (port? p)
+           (not (textual-port? p))
+           (binary-port? p)
+           (input-port? p)
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) #f)
+           (eq? (binary-port-input-buffer p) ib)
+           (eqv? (binary-port-input-size p) (bytevector-length ib))
+           (eqv? (binary-port-input-index p) 0)
+           (eqv? (binary-port-input-count p) (bytevector-length ib))
+           (eq? (binary-port-output-buffer p) ob)
+           (eqv? (binary-port-output-size p) (bytevector-length ob))
+           (eqv? (binary-port-output-index p) 0)
+           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
+  (let ([name "foo"] [info "info"] [ib #vu8(4 3 2 1)] [ob #vu8(1 2 3 4)])
+    (let ([p (#%$make-binary-input/output-port name $handler-standin ib ob info)])
+      (and (port? p)
+           (not (textual-port? p))
+           (binary-port? p)
+           (input-port? p)
+           (output-port? p)
+           (eq? (port-name p) name)
+           (eq? (#%$port-handler p) $handler-standin)
+           (eq? (#%$port-info p) info)
+           (eq? (binary-port-input-buffer p) ib)
+           (eqv? (binary-port-input-size p) (bytevector-length ib))
+           (eqv? (binary-port-input-index p) 0)
+           (eqv? (binary-port-input-count p) (bytevector-length ib))
+           (eq? (binary-port-output-buffer p) ob)
+           (eqv? (binary-port-output-size p) (bytevector-length ob))
+           (eqv? (binary-port-output-index p) 0)
+           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
+ )
+
+(mat file-buffer-size
+  (let ([x (file-buffer-size)])
+    (and (fixnum? x) (> x 0)))
+  (error? (file-buffer-size 1024 15))
+  (error? (file-buffer-size 'shoe))
+  (error? (file-buffer-size 0))
+  (error? (file-buffer-size -15))
+  (error? (file-buffer-size (+ (most-positive-fixnum) 1)))
+  (error? (file-buffer-size 1024.0))
+  (parameterize ([file-buffer-size (* (file-buffer-size) 2)])
+    (let ([ip (open-file-input-port prettytest.ss)])
+      (let ([n (bytevector-length (binary-port-input-buffer ip))])
+        (close-input-port ip)
+        (eqv? n (file-buffer-size)))))
+)
+
+(mat custom-port-buffer-size
+  (let ([x (custom-port-buffer-size)])
+    (and (fixnum? x) (> x 0)))
+  (error? (custom-port-buffer-size 1024 15))
+  (error? (custom-port-buffer-size 'shoe))
+  (error? (custom-port-buffer-size 0))
+  (error? (custom-port-buffer-size -15))
+  (error? (custom-port-buffer-size (+ (most-positive-fixnum) 1)))
+  (error? (custom-port-buffer-size 1024.0))
+  (parameterize ([custom-port-buffer-size (* (custom-port-buffer-size) 2)])
+    (let ([q #f])
+      (let ([ip (make-custom-textual-input-port "foo"
+                  (lambda (str s c) (set! q c) 0)
+                  #f #f #f)])
+        (read-char ip)
+        (= q (custom-port-buffer-size)))))
+)
+
+(mat compress-parameters
+  (error? ; unsupported format
+    (compress-format 'foo))
+  (error? ; unsupported format
+    (compress-format "gzip"))
+  (eq? (compress-format) 'lz4)
+  (eq? (parameterize ([compress-format 'gzip]) (compress-format)) 'gzip)
+  (eq? (parameterize ([compress-format 'lz4]) (compress-format)) 'lz4)
+  (error? ; unsupported level
+    (compress-level 'foo))
+  (error? ; unsupported level
+    (compress-level 1))
+  (eq? (compress-level) 'medium)
+  (eq? (parameterize ([compress-level 'low]) (compress-level)) 'low)
+  (eq? (parameterize ([compress-level 'medium]) (compress-level)) 'medium)
+  (eq? (parameterize ([compress-level 'high]) (compress-level)) 'high)
+  (eq? (parameterize ([compress-level 'maximum]) (compress-level)) 'maximum)
+  (begin
+    (define (fnlength ifn) (call-with-port (open-file-input-port ifn) port-length))
+    (define (compress-file ifn ofn fmt lvl)
+      (call-with-port (open-file-input-port ifn)
+        (lambda (ip)
+          (call-with-port (parameterize ([compress-format fmt] [compress-level lvl])
+                            (open-file-output-port ofn (file-options compressed replace)))
+            (lambda (op) (put-bytevector op (get-bytevector-all ip))))))
+      (fnlength ofn))
+    (define (compress-file-test fmt)
+      (let ([orig (fnlength prettytest.ss)]
+            [low (compress-file prettytest.ss "testfile.ss" fmt 'low)]
+            [medium (compress-file prettytest.ss "testfile.ss" fmt 'medium)]
+            [high (compress-file prettytest.ss "testfile.ss" fmt 'high)]
+            [maximum (compress-file prettytest.ss "testfile.ss" fmt 'maximum)])
+        (define-syntax test1
+          (syntax-rules ()
+            [(_ level)
+             (unless (< level orig) (errorf #f "~s ~s did not compress" fmt 'level))]))
+        (define-syntax test2
+          (syntax-rules ()
+            [(_ level1 level2)
+             (unless (<= level2 level1) (errorf #f "~s ~s did worse than ~s" fmt 'level2 'level1))]))
+        (test1 low)
+        (test1 medium)
+        (test1 high)
+        (test1 maximum)
+        (test2 low medium)
+        (test2 medium high)
+        (test2 high maximum)
+        (unless (< maximum low) (errorf #f "~s maximum didn't do better than low" fmt))))
+    (compress-file-test 'lz4)
+    (compress-file-test 'gzip)
+    #t)
+)
+
+(mat compression
+  (parameters [compress-format 'gzip 'lz4] [compress-level 'low 'medium 'high 'maximum])
+  (and (memq (compress-format) '(gzip lz4)) #t)
+  (and (memq (compress-level) '(low medium high maximum)) #t)
+  (let ()
+    (define cp
+      (lambda (src dst)
+        (define buf-size 4096)
+        (let ([buf (make-bytevector buf-size)])
+          (call-with-port dst
+            (lambda (op)
+              (call-with-port src
+                (lambda (ip)
+                  (let loop ()
+                    (let ([n (get-bytevector-n! ip buf 0 buf-size)])
+                      (unless (eof-object? n)
+                        (put-bytevector op buf 0 n)
+                        (loop)))))))))))
+
+    (define cmp
+      (lambda (src1 src2)
+        (define buf-size 4096)
+        (let ([buf1 (make-bytevector buf-size)]
+              [buf2 (make-bytevector buf-size)])
+          (call-with-port src1
+            (lambda (ip1)
+              (call-with-port src2
+                (lambda (ip2)
+                  (let loop ()
+                    (let ([n1 (get-bytevector-n! ip1 buf1 0 buf-size)]
+                          [n2 (get-bytevector-n! ip2 buf2 0 buf-size)])
+                      (if (eof-object? n1)
+                          (eof-object? n2)
+                          (and (= n1 n2)
+                               (let test ([i 0])
+                                 (or (= i n1)
+                                     (and (= (bytevector-u8-ref buf1 i)
+                                             (bytevector-u8-ref buf2 i))
+                                          (test (+ 1 i)))))
+                               (loop))))))))))))
+    (and
+     (cmp (open-file-input-port prettytest.ss)
+          (open-file-input-port prettytest.ss))
+     (cmp (open-file-input-port prettytest.ss (file-options compressed))
+          (open-file-input-port prettytest.ss))
+     (cmp (open-file-input-port prettytest.ss)
+          (open-file-input-port prettytest.ss (file-options compressed)))
+     (cmp (open-file-input-port prettytest.ss (file-options compressed))
+          (open-file-input-port prettytest.ss (file-options compressed)))
+     (begin
+       (cp (open-file-input-port prettytest.ss)
+           (open-file-output-port "testfile.ss" (file-options replace compressed)))
+       #t)
+     (cmp (open-file-input-port "testfile.ss" (file-options compressed))
+          (open-file-input-port prettytest.ss))
+     (not (cmp (open-file-input-port "testfile.ss")
+               (open-file-input-port prettytest.ss)))
+     (begin
+       (cp (open-file-input-port prettytest.ss)
+           (open-file-output-port "testfile.ss" (file-options no-fail no-truncate append compressed)))
+       #t)
+     (not (cmp (open-file-input-port "testfile.ss" (file-options compressed))
+               (open-file-input-port prettytest.ss)))))
+  ; test workaround for bogus gzclose error return for empty input files
+  (and
+   (eqv? (call-with-port
+          (open-file-output-port "testfile.ss" (file-options replace))
+          (lambda (x) (void)))
+         (void))
+   (eof-object? (call-with-port
+                 (open-file-input-port "testfile.ss" (file-options compressed))
+                 get-u8)))
+  (begin
+    (let ([op (open-file-output-port "testfile.ss" (file-options replace))])
+      (put-bytevector op #vu8(#x23 #x88 #x09 #x72 #xf3 #x72))
+      (port-file-compressed! op)
+      (put-bytevector op #vu8(#x93 #x21 #x88 #xe7 #x67))
+      (let ([op (transcoded-port op (native-transcoder))])
+        (display "hello!\n" op)
+        (close-port op)))
+    #t)
+  (equal?
+    (let ([ip (open-file-input-port "testfile.ss")])
+      (let ([bv1 (get-bytevector-n ip 6)])
+        (port-file-compressed! ip)
+        (let ([bv2 (get-bytevector-n ip 5)])
+          (let ([ip (transcoded-port ip (native-transcoder))])
+            (let ([s (get-string-all ip)])
+              (close-port ip)
+              (list bv1 bv2 s))))))
+    '(#vu8(#x23 #x88 #x09 #x72 #xf3 #x72)
+      #vu8(#x93 #x21 #x88 #xe7 #x67)
+      "hello!\n"))
+  (not
+    (equal?
+      (let ([ip (open-file-input-port "testfile.ss")])
+        (let ([bv1 (get-bytevector-n ip 6)])
+          (let ([bv2 (get-bytevector-n ip 5)])
+            (close-port ip)
+            (list bv1 bv2))))
+      '(#vu8(#x23 #x88 #x09 #x72 #xf3 #x72)
+        #vu8(#x93 #x21 #x88 #xe7 #x67))))
+  (begin
+    (let ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode block) (native-transcoder))])
+      (put-string op "uncompressed string")
+      (port-file-compressed! op)
+      (put-string op "compressed string")
+      (close-port op))
+    #t)
+  (equal?
+    (let ([ip (open-file-input-port "testfile.ss" (file-options) (buffer-mode block) (native-transcoder))])
+      (let ([s1 (get-string-n ip (string-length "uncompressed string"))])
+        (port-file-compressed! ip)
+        (let ([s2 (get-string-all ip)])
+          (close-port ip)
+          (list s1 s2))))
+    '("uncompressed string" "compressed string"))
+  (error? ; not a file port
+    (call-with-string-output-port port-file-compressed!))
+  (error? ; input/output ports aren't supported
+    (let ([iop (open-file-input/output-port "testfile.ss" (file-options replace))])
+      (guard (c [else (close-port iop) (raise c)])
+        (port-file-compressed! iop))))
+  (begin
+    (let ([op (open-file-output-port "testfile.ss" (file-options compressed replace) (buffer-mode block) (native-transcoder))])
+      (port-file-compressed! op)
+      (put-string op "compressed string")
+      (close-port op))
+    #t)
+  (equal?
+    (let ([ip (open-file-input-port "testfile.ss" (file-options compressed) (buffer-mode block) (native-transcoder))])
+      (port-file-compressed! ip)
+      (let ([s (get-string-all ip)])
+        (close-port ip)
+        s))
+    '"compressed string")
+)
+
+(mat bytevector-input-port
+  (error? ; incorrect number of arguments
+    (open-bytevector-input-port))
+  (error? ; not a bytevector
+    (open-bytevector-input-port '#(1 2 3 4)))
+  (error? ; none is not a transcoder
+    (open-bytevector-input-port #vu8(1 2 3 4) 'none))
+  (error? ; incorrect number of arguments
+    (open-bytevector-input-port #vu8(1 2 3 4) #f 'none))
+  (let ()
+    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
+    (and (eq? (get-u8 x) 1)
+         (eq? (get-u8 x) 2)
+         (eq? (get-u8 x) 3)
+         (eq? (get-u8 x) 4)
+         (eq? (get-u8 x) (eof-object))))
+  (let ()
+    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
+    (and (port-has-port-position? x)
+         (eq? (port-position x) 0)
+         (eq? (get-u8 x) 1)
+         (eq? (port-position x) 1)
+         (eq? (get-u8 x) 2)
+         (eq? (port-position x) 2)
+         (eq? (get-u8 x) 3)
+         (eq? (port-position x) 3)
+         (eq? (get-u8 x) 4)
+         (eq? (port-position x) 4)
+         (eq? (get-u8 x) #!eof)
+         (eq? (port-position x) 4)
+         (eq? (get-u8 x) #!eof)
+         (eq? (port-position x) 4)
+         (eq? (get-u8 x) #!eof)
+         (eq? (port-position x) 4)))
+  (let ()
+    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
+    (and (port-has-set-port-position!? x)
+         (eq? (port-position x) 0)
+         (eq? (get-u8 x) 1)
+         (eq? (port-position x) 1)
+         (eq? (get-u8 x) 2)
+         (eq? (port-position x) 2)
+         (begin (set-port-position! x 0) #t)
+         (eq? (get-u8 x) 1)
+         (begin (set-port-position! x 4) #t)
+         (eq? (get-u8 x) #!eof)))
+  (error? (set-port-position! (open-bytevector-input-port #vu8(1 2 3 4)) -1))
+  (error? (set-port-position! (open-bytevector-input-port #vu8(1 2 3 4)) 5))
+
+  (let ()
+    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
+    (and (eq? (lookahead-u8 x) 1)
+         (eq? (lookahead-u8 x) 1)
+         (eq? (lookahead-u8 x) 1)
+         (eq? (get-u8 x) 1)
+         (eq? (lookahead-u8 x) 2)
+         (eq? (get-u8 x) 2)
+         (eq? (lookahead-u8 x) 3)
+         (eq? (get-u8 x) 3)
+         (eq? (lookahead-u8 x) 4)
+         (eq? (get-u8 x) 4)
+         (eq? (lookahead-u8 x) #!eof)
+         (eq? (get-u8 x) #!eof)
+         (eq? (lookahead-u8 x) #!eof)
+         (eq? (get-u8 x) #!eof)))
+  (eq? (buffer-mode none) 'none)
+  (eq? (buffer-mode line) 'line)
+  (eq? (buffer-mode block) 'block)
+  (error? (buffer-mode bar))
+  (error? (buffer-mode 'none))
+  (eq? (buffer-mode? 'none) #t)
+  (eq? (buffer-mode? 'line) #t)
+  (eq? (buffer-mode? 'block) #t)
+  (eq? (buffer-mode? 'foo) #f)
+)
+
+(mat bytevector-output-port
+  (error? ; not a transcoder
+    (open-bytevector-output-port 'oops))
+  (error? ; incorrect number of arguments
+    (open-bytevector-output-port #f 'none))
+)
+
+(mat custom-binary-ports
+  (begin
+    (define $cp-ip
+      (let ([pos 0])
+        (make-custom-binary-input-port "foo"
+          (lambda (bv s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda () pos)
+          (lambda (x) (set! pos x))
+          #f)))
+    #t)
+  (eq? (port-position $cp-ip) 0)
+  (error? ; cannot unget
+    (unget-u8 $cp-ip 255))
+  (begin (unget-u8 $cp-ip (eof-object)) #t)
+  (port-eof? $cp-ip)
+  (eof-object? (lookahead-u8 $cp-ip))
+  (eof-object? (get-u8 $cp-ip))
+  (equal?
+    (get-bytevector-n $cp-ip 10)
+    #vu8(0 1 2 3 4 5 6 7 8 9))
+  (eqv? (port-position $cp-ip) 10)
+  (eqv? (get-u8 $cp-ip) 10)
+  (begin (set-port-position! $cp-ip 256000) #t)
+  (eqv? (get-u8 $cp-ip) 0)
+  (eqv? (port-position $cp-ip) 256001)
+  (error? ; not a binary output port
+    (put-u8 $cp-ip 255))
+  (not (port-has-port-length? $cp-ip))
+  (not (port-has-set-port-length!? $cp-ip))
+  (not (port-has-port-nonblocking?? $cp-ip))
+  (not (port-has-set-port-nonblocking!? $cp-ip))
+  (error? ; not supported
+    (port-length $cp-ip))
+  (error? ; not supported
+    (set-port-length! $cp-ip 50))
+  (error? ; not supported
+    (port-nonblocking? $cp-ip))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-ip #t))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-ip #f))
+  (begin
+    (define $cp-op
+      (let ([pos 0])
+        (make-custom-binary-output-port "foo"
+          (lambda (bv s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          (lambda () pos)
+          (lambda (x) (set! pos x))
+          (lambda () (printf "closed\n")))))
+    #t)
+  (eq? (port-position $cp-op) 0)
+  (error? ; not a binary input port
+    (unget-u8 $cp-op 255))
+  (not (port-has-port-length? $cp-op))
+  (not (port-has-set-port-length!? $cp-op))
+  (not (port-has-port-nonblocking?? $cp-op))
+  (not (port-has-set-port-nonblocking!? $cp-op))
+  (error? ; not supported
+    (port-length $cp-op))
+  (error? ; not supported
+    (set-port-length! $cp-op 50))
+  (error? ; not supported
+    (port-nonblocking? $cp-op))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-op #t))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-op #f))
+  (begin (put-u8 $cp-op 255) #t)
+  (eqv? (port-position $cp-op) 1)
+  (begin (set-port-position! $cp-op 17) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-bytevector $cp-op #vu8(17 18 19 20))
+        (put-bytevector $cp-op #vu8(20 21 22 23 24 25) 1)
+        (put-bytevector $cp-op #vu8(24 25 26 27 28 29) 1 4)))
+    "")
+  (equal? ; in our current implementation...
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-op))))
+    "pos = 30\n")
+  (equal? ; ... actual flush won't happen until here
+    (with-output-to-string
+      (lambda ()
+        (r6rs:flush-output-port $cp-op)))
+    "write 13\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-op))))
+    "pos = 30\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-bytevector $cp-op #vu8(17 18 19 20))
+        (put-bytevector $cp-op #vu8(20 21 22 23 24 25) 1)
+        (put-bytevector $cp-op #vu8(24 25 26 27 28 29) 1 4)))
+    "")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (close-port $cp-op)))
+    "write 13\nclosed\n")
+  (error? ; closed
+    (put-u8 $cp-op 0))
+  (error? ; closed
+    (put-bytevector $cp-op #vu8(3)))
+  (error? ; closed
+    (r6rs:flush-output-port $cp-op))
+  (begin
+    (define $cp-iop
+      (let ([pos 0])
+        (make-custom-binary-input/output-port "foo"
+          (lambda (bv s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (bv s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          (lambda () pos)
+          (lambda (x) (set! pos x))
+          (lambda () (printf "closed\n")))))
+    #t)
+  (eq? (port-position $cp-iop) 0)
+  (error? ; cannot unget
+    (unget-u8 $cp-iop 255))
+  (begin (unget-u8 $cp-iop (eof-object)) #t)
+  (port-eof? $cp-iop)
+  (eof-object? (lookahead-u8 $cp-iop))
+  (eof-object? (get-u8 $cp-iop))
+  (equal?
+    (get-bytevector-n $cp-iop 10)
+    #vu8(0 1 2 3 4 5 6 7 8 9))
+  (eqv? (port-position $cp-iop) 10)
+  (eqv? (lookahead-u8 $cp-iop) 10)
+  (eqv? (get-u8 $cp-iop) 10)
+  (begin (set-port-position! $cp-iop 256000) #t)
+  (eqv? (get-u8 $cp-iop) 0)
+  (eqv? (port-position $cp-iop) 256001)
+  (not (port-has-port-length? $cp-iop))
+  (not (port-has-set-port-length!? $cp-iop))
+  (not (port-has-port-nonblocking?? $cp-iop))
+  (not (port-has-set-port-nonblocking!? $cp-iop))
+  (error? ; not supported
+    (port-length $cp-iop))
+  (error? ; not supported
+    (set-port-length! $cp-iop 50))
+  (error? ; not supported
+    (port-nonblocking? $cp-iop))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-iop #t))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-iop #f))
+  (begin (put-u8 $cp-iop 255) #t)
+  (eqv? (port-position $cp-iop) 256002)
+  (begin (set-port-position! $cp-iop 17) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-bytevector $cp-iop #vu8(17 18 19 20))
+        (put-bytevector $cp-iop #vu8(20 21 22 23 24 25) 1)
+        (put-bytevector $cp-iop #vu8(24 25 26 27 28 29) 1 4)))
+    "")
+  (equal? ; in our current implementation...
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-iop))))
+    "pos = 30\n")
+  (equal? ; ... actual flush won't happen until here
+    (with-output-to-string
+      (lambda ()
+        (r6rs:flush-output-port $cp-iop)))
+    "write 13\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-iop))))
+    "pos = 30\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-bytevector $cp-iop #vu8(17 18 19 20))
+        (put-bytevector $cp-iop #vu8(20 21 22 23 24 25) 1)
+        (put-bytevector $cp-iop #vu8(24 25 26 27 28 29) 1 4)))
+    "")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (close-port $cp-iop)))
+    "write 13\nclosed\n")
+  (error? ; closed
+    (put-u8 $cp-iop 0))
+  (error? ; closed
+    (put-bytevector $cp-iop #vu8(3)))
+  (error? ; closed
+    (r6rs:flush-output-port $cp-iop))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0])
+        (make-custom-binary-input/output-port "foo"
+          (lambda (bv s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (bv s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          #f
+          (lambda (x) (set! pos x))
+          (lambda () (printf "closed\n")))))
+    #t)
+  (not (port-has-port-position? $cp-iop))
+  (error? ; operation not supported
+    (port-position $cp-iop))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-u8 $cp-iop 255))
+    #t)
+  (eqv? (get-u8 $cp-iop) 1)
+  (custom-port-warning? ; can't determine position for write
+    (put-u8 $cp-iop 255))
+  (begin (set-port-position! $cp-iop 50) #t)
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-u8 $cp-iop 255))
+    #t)
+  (eqv? (get-u8 $cp-iop) 51)
+  (custom-port-warning? ; can't determine position for write
+    (put-bytevector $cp-iop #vu8(17)))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0])
+        (make-custom-binary-input/output-port "foo"
+          (lambda (bv s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (bv s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          (lambda () pos)
+          #f
+          (lambda () (printf "closed\n")))))
+    #t)
+  (not (port-has-set-port-position!? $cp-iop))
+  (error? ; operation not supported
+    (set-port-position! $cp-iop 3))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-u8 $cp-iop 255))
+    #t)
+  (eqv? (get-u8 $cp-iop) 1)
+  (custom-port-warning? ; can't set position for write
+   ; convoluted because we want warning to return normally so that operation
+   ; is completed
+    (let ([hit? #f])
+      (with-exception-handler
+        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
+        (lambda () (put-u8 $cp-iop 255)))
+      (when hit? (raise hit?))))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-u8 $cp-iop 255))
+    #t)
+  (begin (get-u8 $cp-iop) #t) ; position undefined, so value undefined
+  (custom-port-warning? ; can't set position for write
+    (put-bytevector $cp-iop #vu8(17)))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0])
+        (make-custom-binary-input/output-port "foo"
+          (lambda (bv s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (bv s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          #f
+          #f
+          (lambda () (printf "closed\n")))))
+    #t)
+  (not (port-has-port-position? $cp-iop))
+  (error? ; operation not supported
+    (port-position $cp-iop))
+  (not (port-has-set-port-position!? $cp-iop))
+  (error? ; operation not supported
+    (set-port-position! $cp-iop 3))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-u8 $cp-iop 255))
+    #t)
+  (eqv? (get-u8 $cp-iop) 1)
+  (custom-port-warning? ; can't determine position for write
+   ; convoluted because we want warning to return normally so that operation
+   ; is completed
+    (let ([hit? #f])
+      (with-exception-handler
+        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
+        (lambda () (put-u8 $cp-iop 255)))
+      (when hit? (raise hit?))))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-u8 $cp-iop 255))
+    #t)
+  (begin (get-u8 $cp-iop) #t) ; position undefined, so value undefined
+  (custom-port-warning? ; can't determine position for write
+    (put-bytevector $cp-iop #vu8(17)))
+)
+
+(mat custom-textual-ports
+  (begin
+    (define $cp-ip
+      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
+        (make-custom-textual-input-port "foo"
+          (lambda (str s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda () pos)
+          (lambda (x) (set! pos x))
+          #f)))
+    #t)
+  (eq? (port-position $cp-ip) 0)
+  (error? ; cannot unget
+    (unget-char $cp-ip #\q))
+  (begin (unget-char $cp-ip (eof-object)) #t)
+  (port-eof? $cp-ip)
+  (eof-object? (lookahead-char $cp-ip))
+  (eof-object? (get-char $cp-ip))
+  (equal?
+    (get-string-n $cp-ip 10)
+    "0123456789")
+  (eqv? (port-position $cp-ip) 10)
+  (eqv? (get-char $cp-ip) #\a)
+  (begin (set-port-position! $cp-ip 36000) #t)
+  (eqv? (get-char $cp-ip) #\0)
+  (custom-port-warning? (port-position $cp-ip))
+  (error? ; not a textual output port
+    (put-char $cp-ip #\a))
+  (not (port-has-port-length? $cp-ip))
+  (not (port-has-set-port-length!? $cp-ip))
+  (not (port-has-port-nonblocking?? $cp-ip))
+  (not (port-has-set-port-nonblocking!? $cp-ip))
+  (error? ; not supported
+    (port-length $cp-ip))
+  (error? ; not supported
+    (set-port-length! $cp-ip 50))
+  (error? ; not supported
+    (port-nonblocking? $cp-ip))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-ip #t))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-ip #f))
+
+  (begin
+    (define $cp-op
+      (let ([pos 0])
+        (make-custom-textual-output-port "foo"
+          (lambda (str s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          (lambda () pos)
+          (lambda (x) (set! pos x))
+          (lambda () (printf "closed\n")))))
+    #t)
+  (eq? (port-position $cp-op) 0)
+  (error? ; not a textual output port
+    (unget-char $cp-op 255))
+  (not (port-has-port-length? $cp-op))
+  (not (port-has-set-port-length!? $cp-op))
+  (not (port-has-port-nonblocking?? $cp-op))
+  (not (port-has-set-port-nonblocking!? $cp-op))
+  (error? ; not supported
+    (port-length $cp-op))
+  (error? ; not supported
+    (set-port-length! $cp-op 50))
+  (error? ; not supported
+    (port-nonblocking? $cp-op))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-op #t))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-op #f))
+  (begin (put-char $cp-op #\$) #t)
+  (eqv? (port-position $cp-op) 1)
+  (begin (set-port-position! $cp-op 17) #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-string $cp-op "abcd")
+        (put-string $cp-op "defghi" 1)
+        (put-string $cp-op "hijklm" 1 4)))
+    "")
+  (equal? ; in our current implementation...
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-op))))
+    "write 13\npos = 30\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-op))))
+    "pos = 30\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-string $cp-op "abcd")
+        (put-string $cp-op "defghi" 1)
+        (put-string $cp-op "hijklm" 1 4)))
+    "")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (close-port $cp-op)))
+    "write 13\nclosed\n")
+  (error? ; closed
+    (put-char $cp-op #\$))
+  (error? ; closed
+    (put-string $cp-op "3"))
+  (error? ; closed
+    (r6rs:flush-output-port $cp-op))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
+        (make-custom-textual-input/output-port "foo"
+          (lambda (str s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (str s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          (lambda () pos)
+          (lambda (x) (set! pos x))
+          (lambda () (printf "closed\n")))))
+    #t)
+  (eq? (port-position $cp-iop) 0)
+  (error? ; cannot unget
+    (unget-char $cp-iop #\$))
+  (begin (unget-char $cp-iop (eof-object)) #t)
+  (port-eof? $cp-iop)
+  (eof-object? (lookahead-char $cp-iop))
+  (eof-object? (get-char $cp-iop))
+  (equal?
+    (get-string-n $cp-iop 10)
+    "0123456789")
+  (eqv? (port-position $cp-iop) 10)
+  (eqv? (get-char $cp-iop) #\a)
+  (begin (set-port-position! $cp-iop 36000) #t)
+  (eqv? (get-char $cp-iop) #\0)
+  (custom-port-warning? (port-position $cp-iop))
+  (not (port-has-port-length? $cp-iop))
+  (not (port-has-set-port-length!? $cp-iop))
+  (not (port-has-port-nonblocking?? $cp-iop))
+  (not (port-has-set-port-nonblocking!? $cp-iop))
+  (error? ; not supported
+    (port-length $cp-iop))
+  (error? ; not supported
+    (set-port-length! $cp-iop 50))
+  (error? ; not supported
+    (port-nonblocking? $cp-iop))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-iop #t))
+  (error? ; not supported
+    (set-port-nonblocking! $cp-iop #f))
+  (custom-port-warning? (put-char $cp-iop #\$))
+  (begin (set-port-position! $cp-iop 17) #t)
+  (eqv? (port-position $cp-iop) 17)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-string $cp-iop "abcd")
+        (put-string $cp-iop "defghi" 1)
+        (put-string $cp-iop "hijklm" 1 4)))
+    "")
+  (equal? ; in our current implementation...
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-iop))))
+    "write 13\npos = 30\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (printf "pos = ~s\n" (port-position $cp-iop))))
+    "pos = 30\n")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (put-string $cp-iop "abcd")
+        (put-string $cp-iop "defghi" 1)
+        (put-string $cp-iop "hijklm" 1 4)))
+    "")
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (close-port $cp-iop)))
+    "write 13\nclosed\n")
+  (error? ; closed
+    (put-char $cp-iop #\$))
+  (error? ; closed
+    (put-string $cp-iop "3"))
+  (error? ; closed
+    (r6rs:flush-output-port $cp-iop))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
+        (make-custom-textual-input/output-port "foo"
+          (lambda (str s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (str s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          #f
+          (lambda (x) (set! pos x))
+          (lambda () (printf "closed\n")))))
+    #t)
+  (not (port-has-port-position? $cp-iop))
+  (error? ; operation not supported
+    (port-position $cp-iop))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-char $cp-iop #\$))
+    #t)
+  (eqv? (get-char $cp-iop) #\1)
+  (custom-port-warning? ; can't determine position for write
+    (put-char $cp-iop #\$))
+  (begin (set-port-position! $cp-iop 50) #t)
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-char $cp-iop #\$))
+    #t)
+  (eqv? (get-char $cp-iop) #\f)
+  (custom-port-warning? ; can't determine position for write
+    (put-string $cp-iop "a"))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
+        (make-custom-textual-input/output-port "foo"
+          (lambda (str s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (str s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          (lambda () pos)
+          #f
+          (lambda () (printf "closed\n")))))
+    #t)
+  (not (port-has-set-port-position!? $cp-iop))
+  (error? ; operation not supported
+    (set-port-position! $cp-iop 3))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-char $cp-iop #\$))
+    #t)
+  (eqv? (get-char $cp-iop) #\1)
+  (custom-port-warning? ; can't set position for write
+   ; convoluted because we want warning to return normally so that operation
+   ; is completed
+    (let ([hit? #f])
+      (with-exception-handler
+        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
+        (lambda () (put-char $cp-iop #\$)))
+      (when hit? (raise hit?))))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-char $cp-iop #\$))
+    #t)
+  (begin (get-char $cp-iop) #t) ; position undefined, so value undefined
+  (custom-port-warning? ; can't set position for write
+    (put-string $cp-iop "a"))
+
+  (begin
+    (define $cp-iop
+      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
+        (make-custom-textual-input/output-port "foo"
+          (lambda (str s c)
+            (let loop ([i s])
+              (unless (eq? i (+ s c))
+                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
+                (loop (+ 1 i))))
+            (set! pos (+ pos c))
+            c)
+          (lambda (str s c)
+            (set! pos (+ pos c))
+            (printf "write ~s\n" c)
+            c)
+          #f
+          #f
+          (lambda () (printf "closed\n")))))
+    #t)
+  (not (port-has-port-position? $cp-iop))
+  (error? ; operation not supported
+    (port-position $cp-iop))
+  (not (port-has-set-port-position!? $cp-iop))
+  (error? ; operation not supported
+    (set-port-position! $cp-iop 3))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-char $cp-iop #\$))
+    #t)
+  (eqv? (get-char $cp-iop) #\1)
+  (custom-port-warning? ; can't determine position for write
+   ; convoluted because we want warning to return normally so that operation
+   ; is completed
+    (let ([hit? #f])
+      (with-exception-handler
+        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
+        (lambda () (put-char $cp-iop #\$)))
+      (when hit? (raise hit?))))
+  (begin
+    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
+      (put-char $cp-iop #\$))
+    #t)
+  (begin (get-char $cp-iop) #t) ; position undefined, so value undefined
+  (custom-port-warning? ; can't determine position for write
+    (put-string $cp-iop "a"))
+
+  (equal?
+    (let-values ([(sop get) (open-string-output-port)])
+      (define op
+        (make-custom-textual-output-port "foo"
+          (lambda (str s c)
+            (put-string sop str s c)
+            c)
+          #f #f #f))
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello")
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello")
+      (flush-output-port op)
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello\n")
+      (flush-output-port op)
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello\n")
+      (fresh-line op)
+      (close-port op)
+      (get))
+    "hello\nhello\nhello\nhello\n")
+
+  (equal?
+    (let-values ([(sop get) (open-string-output-port)])
+      (define op
+        (make-custom-textual-input/output-port "foo"
+          (lambda (str s c) (errorf #f "oops"))
+          (lambda (str s c)
+            (put-string sop str s c)
+            c)
+          #f #f #f))
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello")
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello")
+      (flush-output-port op)
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello\n")
+      (flush-output-port op)
+      (fresh-line op)
+      (fresh-line op)
+      (put-string op "hello\n")
+      (fresh-line op)
+      (close-port op)
+      (get))
+    "hello\nhello\nhello\nhello\n")
+)
+
+(mat compression-textual
+  (parameters [compress-format 'gzip 'lz4] [compress-level 'low 'medium 'high 'maximum])
+  (let ()
+    (define cp
+      (lambda (src dst)
+        (define buf-size 103)
+        (let ([buf (make-string buf-size)])
+          (call-with-port dst
+            (lambda (op)
+              (call-with-port src
+                (lambda (ip)
+                  (let loop ()
+                    (do ([i 0 (fx+ i 1)])
+                        ((fx= i buf-size))
+                      (let ([c (get-char ip)])
+                        (unless (eof-object? c) (put-char op c))))
+                    (let ([n (get-string-n! ip buf 0 buf-size)])
+                      (unless (eof-object? n)
+                        (put-string op buf 0 n)
+                        (loop)))))))))))
+    (define cmp
+      (lambda (src1 src2)
+        (define buf-size 128)
+        (let ([buf (make-string buf-size)])
+          (call-with-port src1
+            (lambda (ip1)
+              (call-with-port src2
+                (lambda (ip2)
+                  (let loop ([pos 0])
+                    (let ([n (get-string-n! ip1 buf 0 buf-size)])
+                      (if (eof-object? n)
+                          (unless (eof-object? (lookahead-char ip2)) (errorf #f "ip1 eof before ip2"))
+                          (if (eof-object? (lookahead-char ip2))
+                              (errorf #f "ip2 eof before ip1")
+                              (let test ([i 0] [pos pos])
+                                (if (= i n)
+                                    (loop pos)
+                                    (let ([c1 (string-ref buf i)] [c2 (get-char ip2)])
+                                      (if (char=? c1 c2)
+                                          (test (+ 1 i) (+ pos 1))
+                                          (errorf #f "ip1 c = ~s =/= ip2 c = ~s at pos ~s" c1 c2 pos))))))))))))))))
+    (define (in fn compressed? codec)
+      (open-file-input-port fn
+        (if compressed? (file-options compressed) (file-options))
+        (buffer-mode block)
+        (make-transcoder codec)))
+    (define (out fn compressed? codec)
+      (open-file-output-port fn
+        (if compressed? (file-options compressed replace) (file-options replace))
+        (buffer-mode block)
+        (make-transcoder codec)))
+    (time (cmp (in prettytest.ss #f (latin-1-codec)) (in prettytest.ss #f (latin-1-codec))))
+    (time (cmp (in prettytest.ss #t (latin-1-codec)) (in prettytest.ss #f (latin-1-codec))))
+    (time (cmp (in prettytest.ss #f (latin-1-codec)) (in prettytest.ss #t (latin-1-codec))))
+    (time (cmp (in prettytest.ss #t (latin-1-codec)) (in prettytest.ss #t (latin-1-codec))))
+    (time (cmp (in prettytest.ss #f (utf-8-codec)) (in prettytest.ss #f (utf-8-codec))))
+    (time (cmp (in prettytest.ss #t (utf-8-codec)) (in prettytest.ss #f (utf-8-codec))))
+    (time (cmp (in prettytest.ss #f (utf-8-codec)) (in prettytest.ss #t (utf-8-codec))))
+    (time (cmp (in prettytest.ss #t (utf-8-codec)) (in prettytest.ss #t (utf-8-codec))))
+    (cp (in prettytest.ss #f (latin-1-codec)) (out "testfile.ss" #t (latin-1-codec)))
+    (cmp (in prettytest.ss #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
+    (cmp (in prettytest.ss #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
+    (cmp (in prettytest.ss #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
+    (cmp (in prettytest.ss #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
+    (cp (in prettytest.ss #f (utf-8-codec)) (out "testfile.ss" #t (utf-8-codec)))
+    (cmp (in prettytest.ss #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
+    (cmp (in prettytest.ss #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
+    (cmp (in prettytest.ss #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
+    (cmp (in prettytest.ss #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
+    #t)
+  ; test workaround for bogus gzclose error return for empty input files
+  (and
+    (eqv? (call-with-port
+            (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode block) (native-transcoder))
+            (lambda (x) (void)))
+          (void))
+    (eof-object?
+      (call-with-port
+        (open-file-input-port "testfile.ss" (file-options compressed)
+          (buffer-mode block) (native-transcoder))
+        get-char)))
+)
+
+(mat string-ports
+  (let ()
+    (define pretty-test-string
+      (call-with-port
+        (open-file-input-port prettytest.ss
+          (file-options) (buffer-mode none) (native-transcoder))
+        get-string-all))
+    (define cp ; doesn't close the ports
+      (lambda (ip op)
+        (define buf-size 103)
+        (let ([buf (make-string buf-size)])
+          (let loop ()
+            (do ([i 0 (fx+ i 1)])
+                ((fx= i buf-size))
+              (let ([c (get-char ip)])
+                (unless (eof-object? c) (put-char op c))))
+            (let ([n (get-string-n! ip buf 0 buf-size)])
+              (unless (eof-object? n)
+                (put-string op buf 0 n)
+                (loop)))))))
+    (define cmp
+      (lambda (src1 src2)
+        (define buf-size 64)
+        (let ([buf (make-string buf-size)])
+          (call-with-port src1
+            (lambda (ip1)
+              (call-with-port src2
+                (lambda (ip2)
+                  (let loop ([pos 0])
+                    (let ([n (get-string-n! ip1 buf 0 buf-size)])
+                      (if (eof-object? n)
+                          (unless (eof-object? (lookahead-char ip2)) (errorf #f "ip1 eof before ip2"))
+                          (if (eof-object? (lookahead-char ip2))
+                              (errorf #f "ip2 eof before ip1")
+                              (let test ([i 0] [pos pos])
+                                (if (= i n)
+                                    (loop pos)
+                                    (let ([c1 (string-ref buf i)] [c2 (get-char ip2)])
+                                      (if (char=? c1 c2)
+                                          (test (+ 1 i) (+ pos 1))
+                                          (errorf #f "ip1 c = ~s =/= ip2 c = ~s at pos ~s" c1 c2 pos))))))))))))))))
+    (define (in fn compressed? codec)
+      (open-file-input-port fn
+        (if compressed? (file-options compressed) (file-options))
+        (buffer-mode block)
+        (make-transcoder codec)))
+    (define (out fn compressed? codec)
+      (open-file-output-port fn
+        (if compressed? (file-options compressed replace) (file-options replace))
+        (buffer-mode block)
+        (make-transcoder codec)))
+    (time (cmp (in prettytest.ss #f (latin-1-codec)) (open-string-input-port pretty-test-string)))
+    (time (cmp (open-string-input-port pretty-test-string) (in prettytest.ss #f (latin-1-codec))))
+    (let-values ([(op retrieve) (open-string-output-port)])
+      (cp (open-string-input-port pretty-test-string) op)
+      (cmp (in prettytest.ss #f (latin-1-codec)) (open-string-input-port (retrieve))))
+    #t)
+)
+
+(mat current-ports
+  (input-port? (current-input-port))
+  (textual-port? (current-input-port))
+  (not (output-port? (open-input-string "hello")))
+  (output-port? (current-output-port))
+  (textual-port? (current-output-port))
+  (output-port? (current-error-port))
+  (textual-port? (current-error-port))
+  (not (input-port? (open-output-string)))
+  (eq? (r6rs:current-input-port) (current-input-port))
+  (eq? (r6rs:current-output-port) (current-output-port))
+  (eq? (r6rs:current-error-port) (current-error-port))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (write (list
+                 (eq? (r6rs:current-input-port) (current-input-port))
+                 (eq? (r6rs:current-output-port) (current-output-port))
+                 (eq? (r6rs:current-error-port) (current-error-port))))))
+    "(#t #t #t)")
+  (error? (current-input-port (standard-input-port)))
+  (error? (current-output-port (standard-output-port)))
+  (error? (current-error-port (standard-output-port)))
+  (error? (current-input-port (open-output-string)))
+  (error? (current-output-port (open-input-string "")))
+  (error? (current-error-port (open-input-string "")))
+  (error? (console-input-port (standard-input-port)))
+  (error? (console-output-port (standard-output-port)))
+  (error? (console-error-port (standard-output-port)))
+  (error? (console-input-port (open-output-string)))
+  (error? (console-output-port (open-input-string "")))
+  (error? (console-error-port (open-input-string "")))
+)
+
+(mat current-transcoder
+  (transcoder? (current-transcoder))
+  (eqv? (current-transcoder) (native-transcoder))
+  (error? (current-transcoder (open-output-string)))
+  (parameterize ([current-transcoder (native-transcoder)])
+    (eqv? (current-transcoder) (native-transcoder)))
+  (parameterize ([current-transcoder (make-transcoder (utf-16le-codec))])
+    (with-output-to-file "testfile.ss" (lambda () (write '\x3bb;12345)) 'replace)
+    (file-exists? "testfile.ss"))
+  (parameterize ([current-transcoder (make-transcoder (utf-16le-codec))])
+    (with-input-from-file "testfile.ss"
+      (lambda ()
+        (and (eqv? (read) '\x3bb;12345) (eof-object? (read))))))
+  (equal?
+    (call-with-port (open-file-input-port "testfile.ss") get-bytevector-all)
+    #vu8(#xBB #x3 #x31 #x0 #x32 #x0 #x33 #x0 #x34 #x0 #x35 #x0))
+)
+
+(mat get/put-datum
+  (error? (get-datum))
+  (error? (get-datum (current-input-port) (current-input-port)))
+  (error? (get-datum (open-output-string)))
+  (error? (get-datum (open-bytevector-input-port #vu8())))
+  (call-with-port
+    (open-string-input-port "hey #;there dude!")
+    (lambda (p)
+      (and (eq? (get-datum p) 'hey)
+           (eqv? (get-char p) #\space)
+           (eq? (get-datum p) 'dude!)
+           (eof-object? (get-datum p)))))
+  (error? (put-datum))
+  (error? (put-datum (current-output-port)))
+  (error? (put-datum (current-output-port) 'a 'a))
+  (error? (put-datum (open-input-string "hello") 'a))
+  (error? (put-datum (let-values ([(p g) (open-bytevector-output-port)]) p) 'a))
+  (equal?
+    (let-values ([(p g) (open-string-output-port)])
+      (put-datum p '(this is))
+      (put-datum p "cool")
+      (put-datum p '(or (maybe . not)))
+      (g))
+    "(this is)\"cool\"(or (maybe . not))")
+  (call-with-port
+    (open-string-input-port "#3(a b c) #!r6rs #(d e) #!chezscheme #3(f g)")
+    (lambda (p)
+      (and
+        (equal? (get-datum p) '#(a b c))
+        (equal? (get-datum p) '#(d e))
+        (equal? (get-datum p) '#(f g g))
+        (equal? (get-datum p) #!eof))))
+ ; make sure that nel and ls are treated properly
+  (call-with-port
+    (open-string-input-port "#!r6rs \x85; \x2028; #\\x85 #\\x2028 \"\\x85; \\x2028;\"")
+    (lambda (p)
+      (and
+        (equal? (get-datum p) (integer->char #x85))
+        (equal? (get-datum p) (integer->char #x2028))
+        (equal? (get-datum p) (string (integer->char #x85) #\space (integer->char #x2028))))))
+  (equal?
+    (call-with-string-output-port
+      (lambda (p)
+        (put-char p #\x85)
+        (put-char p #\space)
+        (put-char p #\x2028)
+        (put-char p #\space)
+        (put-datum p #\x85)
+        (put-char p #\space)
+        (put-datum p #\x2028)
+        (put-char p #\space)
+        (put-datum p "\x85; \x2028;")))
+    "\x85; \x2028; #\\x85 #\\x2028 \"\\x85; \\x2028;\"")
+  (let ()
+    (define (rw? x1)
+      (let ([str (let-values ([(p e) (open-string-output-port)])
+                   (write x1 p)
+                   (e))])
+        (let ([x2 (read (open-string-input-port str))])
+          (equal? x1 x2))))
+    (and
+      (rw? "  \x85;  ")
+      (rw? "  \x2028;  ")
+      (rw? #\x85)
+      (rw? #\x2028)))
+)
+
+(mat utf-16-codec
+  (error? (r6rs:utf-16-codec #f))
+  (error? (utf-16-codec #f))
+ ; test decoding
+  (let ()
+    (define utf-16->string
+      (lambda (eol bv)
+        (let ([ip (transcoded-port
+                    (let ([n (bytevector-length bv)] [i 0])
+                      (make-custom-binary-input-port "foo"
+                        (lambda (buf start count)
+                          (let ([count (min (+ (random (min count 3)) 1) (fx- n i))])
+                            (bytevector-copy! bv i buf start count)
+                            (set! i (+ i count))
+                            count))
+                        (lambda () i)
+                        (lambda (p) (set! i p))
+                        #f))
+                    (make-transcoder (utf-16-codec) eol (error-handling-mode replace)))])
+          (call-with-string-output-port
+            (lambda (op)
+              (define (deref s) (if (eof-object? s) s (string-ref s 0)))
+              (let again ()
+                (let ([c (if (= (random 5) 3) (deref (get-string-n ip 1)) (get-char ip))])
+                  (if (eof-object? c)
+                      (let ([pos (port-position ip)])
+                        (unless (= pos (bytevector-length bv))
+                          (errorf #f "wrong pos ~s at eof" pos)))
+                      (begin (put-char op c) (again))))))))))
+    (define (big bv)
+      (let ([n (bytevector-length bv)])
+        (let ([newbv (make-bytevector (+ n 2))])
+          (bytevector-u8-set! newbv 0 #xfe)
+          (bytevector-u8-set! newbv 1 #xff)
+          (do ([i 0 (fx+ i 2)])
+              ((fx>= i (fx- n 1))
+               (unless (fx= i n)
+                 (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv i))))
+            (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv i))
+            (bytevector-u8-set! newbv (fx+ i 3) (bytevector-u8-ref bv (fx+ i 1))))
+          newbv)))
+    (define (little bv)
+      (let ([n (bytevector-length bv)])
+        (let ([newbv (make-bytevector (+ n 2))])
+          (bytevector-u8-set! newbv 0 #xff)
+          (bytevector-u8-set! newbv 1 #xfe)
+          (do ([i 0 (fx+ i 2)])
+              ((fx>= i (fx- n 1))
+               (unless (fx= i n)
+                 (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv i))))
+            (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv (fx+ i 1)))
+            (bytevector-u8-set! newbv (fx+ i 3) (bytevector-u8-ref bv i)))
+          newbv)))
+    (define (test eol bv s)
+      (do ([n 1000 (fx- n 1)])
+          ((fx= n 0))
+        (let ([seed (random-seed)])
+          (unless (and (equal? (utf-16->string eol bv) s)
+                       (equal? (utf-16->string eol (big bv)) s)
+                       (equal? (utf-16->string eol (little bv)) s))
+            (errorf #f "failed, seed = ~s, bv = ~s, s = ~s" seed bv s)))))
+    (test 'lf #vu8(#x00 #x61 #x00 #x0a) "a\n")
+    (test 'lf #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28) "a\n\n\n\n\n\n")
+    (test 'crlf #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28) "a\n\n\n\n\n\n")
+    (test 'none #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28) "a\r\n\r\x85;\r\r\n\r\x2028;")
+    (test 'lf #vu8(#x00 #x0a #xd8 #x00 #xdc #x00 #xdb #xff #xdf #xff #xdc #x00 #xd8 #x00 #x00 #x00 #x00) "\n\x10000;\x10ffff;\xfffd;\xfffd;\xfffd;")
+    #t)
+ ; test encoding
+  (let ()
+    (define string->utf-16
+      (lambda (eol s)
+        (let-values ([(op getbv)
+                      (let-values ([(bvop getbv) (open-bytevector-output-port)])
+                        (values
+                          (transcoded-port
+                            (let ([i 0])
+                              (make-custom-binary-output-port "foo"
+                                (lambda (buf start count)
+                                  (let ([count (random (min (fx+ count 1) 4))])
+                                    (put-bytevector bvop buf start count)
+                                    (set! i (+ i count))
+                                    count))
+                                (lambda () i)
+                                #f #f))
+                            (make-transcoder (utf-16be-codec) eol (error-handling-mode replace)))
+                          getbv))])
+          (let ([sip (open-string-input-port s)])
+            (define (deref s) (if (eof-object? s) s (string-ref s 0)))
+            (let again ()
+              (let ([c (get-char sip)])
+                (if (eof-object? c)
+                    (let ([pos (port-position op)])
+                      (close-port op)
+                      (let ([bv (getbv)])
+                        (unless (= pos (bytevector-length bv))
+                          (errorf #f "wrong pos ~s at eof" pos))
+                        bv))
+                    (begin
+                      (if (= (random 5) 3)
+                          (put-string op (string c))
+                          (put-char op c))
+                      (again)))))))))
+    (define (test eol s bv)
+      (do ([n 1000 (fx- n 1)])
+          ((fx= n 0))
+        (let ([seed (random-seed)])
+          (unless (equal? (string->utf-16 eol s) bv)
+            (errorf #f "failed, seed = ~s, s = ~s, bv = ~s" seed s bv)))))
+    (test 'lf "a\n" #vu8(#x00 #x61 #x00 #x0a))
+    (test 'crlf "a\n" #vu8(#x00 #x61 #x00 #x0d #x00 #x0a))
+    (test 'crnel "a\n" #vu8(#x00 #x61 #x00 #x0d #x00 #x85))
+    (test 'nel "a\n" #vu8(#x00 #x61 #x00 #x85))
+    (test 'ls "a\n" #vu8(#x00 #x61 #x20 #x28))
+    (test 'none "a\r\n\r\x85;\r\r\n\r\x2028;" #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28))
+    (test 'lf "a\x10000;\x10ffff;\n" #vu8(#x00 #x61 #xd8 #x00 #xdc #x00 #xdb #xff #xdf #xff #x00 #x0a))
+    #t)
+)
+
+(mat utf-16-BOMs
+  (let ()
+    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")                ; should write BOM
+        (set-port-position! iop n)                ; should actually position past BOM (position 2)
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 2)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))
+        (and
+          (eqv? n 0)
+          (eqv? (get-char iop) #\h)
+          (eqv? (port-position iop) 4)
+          (equal? (get-string-all iop) "ello\n")
+          (eqv? (port-position iop) 14)
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 2)
+          (put-string iop "something longer than hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))))
+  (let () ; same as preceding w/slightly different transcoder
+    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style lf) (error-handling-mode replace)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")                ; should write BOM
+        (set-port-position! iop n)                ; should actually position past BOM (position 2)
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 2)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))
+        (and
+          (eqv? n 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 2)
+          (put-string iop "something longer than hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
+    (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")                ; should write BOM
+        (set-port-position! iop n)                ; should actually position past BOM (position 2)
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 2)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16-tx))
+       ; lookahead-char should position port past the BOM
+        (define c (lookahead-char iop))
+        (define n (port-position iop))            ; should be 2
+        (and
+          (eqv? c #\h)
+          (eqv? n 2)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eq? (put-string iop "something longer than hello\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16be-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eqv? (get-char iop) #\xfeff)
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (get-char iop) #\xfeff)
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16le-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")                ; should not write BOM
+        (set-port-position! iop n)                ; should set to 0
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16le-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eq? n 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (eq? (put-string iop "something longer than hello\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16be-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")                ; should not write BOM
+        (set-port-position! iop n)                ; should set to 0
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16be-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eq? n 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (eq? (put-string iop "something longer than hello\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
+    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16be-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")                ; should not write BOM
+        (set-port-position! iop n)                ; should set to 0
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eq? n 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (eq? (put-string iop "something longer than hello\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "something longer than hello\n")
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
+    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16le-tx))
+        (define n0 (port-position iop))             ; should be 0
+        (put-char iop #\xfeff)                      ; insert explicit BOM
+        (let ()
+          (define n (port-position iop))            ; should be 0
+          (put-string iop "hello\n")                ; should not write BOM
+          (set-port-position! iop n)                ; should set to 0
+          (and
+            (eqv? n0 0)
+            (eqv? n 2)
+            (equal? (get-string-all iop) "hello\n")
+            (eq? (close-port iop) (void)))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position iop))
+        (and (equal? (get-string-all iop) "hello\n")
+             (begin
+               (set-port-position! iop n)
+               (put-string iop "hello again\n")
+               (set-port-position! iop n))
+             (and (equal? (get-string-all iop) "hello again\n")
+                  (eq? (close-port iop) (void)))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16le-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eqv? (get-char iop) #\xfeff)           ; BOM should still be there
+          (equal? (get-string-all iop) "hello again\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (eq? (put-string iop "hello yet again!\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello yet again!\n")   ; BOM is gone now
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
+    (define faux-utf-16-tx (make-transcoder (utf-16-codec 'little) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16le-tx))
+        (define n (port-position iop))            ; should be 0
+        (put-string iop "hello\n")
+        (set-port-position! iop n)
+        (and
+          (eqv? n 0)
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) faux-utf-16-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eqv? n 0)
+          (equal? (get-string-all iop) "hello\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (eq? (put-string iop "hello again\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello again\n")
+          (eq? (close-port iop) (void))))
+      (let ()
+        (define iop
+          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
+            (buffer-mode block) utf-16le-tx))
+        (define n (port-position iop))            ; should be 0
+        (and
+          (eqv? n 0)
+          (equal? (get-string-all iop) "hello again\n")
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (eq? (put-string iop "hello yet again!\n") (void))
+          (eq? (set-port-position! iop n) (void))
+          (eqv? (port-position iop) 0)
+          (equal? (get-string-all iop) "hello yet again!\n")
+          (eq? (close-port iop) (void))))))
+  (let ()
+    (define-syntax and
+      (let ()
+        (import scheme)
+        (syntax-rules ()
+          [(_ e ...)
+           (and (let ([x e]) (pretty-print x) x) ...)])))
+    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
+    (and
+      (let ()
+        (define op
+          (open-file-output-port "testfile.ss" (file-options replace)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position op))                  ; should be 0
+        (and
+          (eqv? n 0)
+          (eq? (put-string op "hello\n") (void))       ; should write BOM
+          (eq? (set-port-position! op n) (void))       ; should actually position past BOM (position 2)
+          (eqv? (port-position op) 2)
+          (eq? (put-string op "not hello\n") (void))   ; should not write (another) BOM
+          (eq? (close-port op) (void))))
+      (let ()
+        (define ip
+          (open-file-input-port "testfile.ss" (file-options)
+            (buffer-mode block) utf-16-tx))
+        (define n (port-position ip))                  ; should be 0
+        (define c (lookahead-char ip))                 ; should be #\n
+        (and
+          (eqv? n 0)
+          (eqv? c #\n)
+          (eqv? (port-position ip) 2)
+          (equal? (get-string-all ip) "not hello\n")
+          (eq? (set-port-position! ip 2) (void))
+          (equal? (get-string-all ip) "not hello\n")
+          (eq? (close-port ip) (void))))))
+)
+
+(mat encode/decode-consistency
+ ; verify that encoding/decoding is consistent (but not necessarily correct)
+ ; crank up loop bounds to stress test
+  (let ()
+    (define (random-string n)
+      (define (random-char) (integer->char (random 256)))
+      (let ([s (make-string n)])
+        (do ([i 0 (fx+ i 1)])
+            ((fx= i n))
+          (string-set! s i (random-char)))
+        s))
+    (define (check who s1 s2)
+      (unless (string=? s1 s2)
+        (errorf who "failed for ~a"
+          (parameterize ([print-unicode #f]) (format "~s" s1)))))
+    (time
+      (let ([latin-1-tx (make-transcoder (latin-1-codec) (eol-style none) (error-handling-mode raise))])
+        (do ([n 1000 (fx- n 1)])
+            ((fx= n 0) #t)
+          (let ([s (random-string (random 50))])
+            (check 'latin-1-test4 s (bytevector->string (string->bytevector s latin-1-tx) latin-1-tx)))))))
+  (let ()
+    (define (random-string n)
+      (define (random-char)
+        (integer->char
+          (let ([k (random (fx- #x110000 (fx- #xe000 #xd800)))])
+            (if (fx>= k #xd800)
+                (fx+ k (fx- #xe000 #xd800))
+                k))))
+      (let ([s (make-string n)])
+        (unless (fx= n 0)
+         ; don't let a BOM sneak in at first character
+          (string-set! s 0
+            (let f () (let ([c (random-char)]) (if (memv c '(#\xfeff #\xfffe)) (f) c))))
+          (do ([i 1 (fx+ i 1)])
+              ((fx= i n))
+            (string-set! s i (random-char))))
+        s))
+    (define (check who s1 s2)
+      (unless (string=? s1 s2)
+        (errorf who "failed for ~a"
+          (parameterize ([print-unicode #f]) (format "~s" s1)))))
+    (time
+      (let ()
+        (define utf-8-tx (make-transcoder (utf-8-codec) (eol-style none) (error-handling-mode raise)))
+        (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
+        (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
+        (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
+        (do ([n 1000 (fx- n 1)])
+            ((fx= n 0) #t)
+          (let ([s (random-string (random 50))])
+            (check 'utf-8-test1 s (utf8->string (string->utf8 s)))
+            (check 'utf-8-test2 s (utf8->string (string->bytevector s utf-8-tx)))
+            (check 'utf-8-test3 s (bytevector->string (string->utf8 s) utf-8-tx))
+            (check 'utf-8-test4 s (bytevector->string (string->bytevector s utf-8-tx) utf-8-tx))
+            (check 'utf-16-test1a s (utf16->string (string->utf16 s 'big) 'big))
+            (check 'utf-16-test1b s (utf16->string (string->utf16 s 'big) 'big #t))
+            (check 'utf-16-test2a s (utf16->string (string->bytevector s utf-16-tx) 'big))
+            (check 'utf-16-test2b s (utf16->string (string->bytevector s utf-16be-tx) 'big #t))
+            (check 'utf-16-test2c s (utf16->string (string->bytevector s utf-16le-tx) 'little #t))
+            (check 'utf-16-test3a s (bytevector->string (string->utf16 s 'big) utf-16-tx))
+            (check 'utf-16-test3b s (bytevector->string (string->utf16 s 'big) utf-16be-tx))
+            (check 'utf-16-test3c s (bytevector->string (string->utf16 s 'little) utf-16le-tx))
+            (check 'utf-16-test4a s (bytevector->string (string->bytevector s utf-16-tx) utf-16-tx))
+            (check 'utf-16-test4b s (bytevector->string (string->bytevector s utf-16le-tx) utf-16le-tx))
+            (check 'utf-16-test4c s (bytevector->string (string->bytevector s utf-16be-tx) utf-16be-tx))
+            (check 'utf-16-test5a s (utf16->string (string->utf16 s 'little) 'little))
+            (check 'utf-16-test5b s (utf16->string (string->utf16 s 'little) 'little #t))
+            (let* ([bv (string->bytevector s utf-16be-tx)]
+                   [bvn (bytevector-length bv)]
+                   [bv^ (make-bytevector (fx+ bvn 2))])
+             ; insert big-endian BOM
+              (bytevector-u8-set! bv^ 0 #xfe)
+              (bytevector-u8-set! bv^ 1 #xff)
+              (bytevector-copy! bv 0 bv^ 2 bvn)
+              (check 'utf-16-test6 s (utf16->string bv^ 'big))
+              (check 'utf-16-test7 s (bytevector->string bv^ utf-16-tx)))
+            (let* ([bv (string->utf16 s 'little)]
+                   [bvn (bytevector-length bv)]
+                   [bv^ (make-bytevector (fx+ bvn 2))])
+             ; insert little-endian BOM
+              (bytevector-u8-set! bv^ 0 #xff)
+              (bytevector-u8-set! bv^ 1 #xfe)
+              (bytevector-copy! bv 0 bv^ 2 bvn)
+              (check 'utf-16-test8 s (utf16->string bv^ 'little))
+              (check 'utf-16-test9 s (bytevector->string bv^ utf-16-tx)))
+          (check 'utf-32-test1a s (utf32->string (string->utf32 s 'big) 'big))
+          (check 'utf-32-test1a s (utf32->string (string->utf32 s 'big) 'big #t))
+          (check 'utf-32-test2a s (utf32->string (string->utf32 s 'little) 'little))
+          (check 'utf-32-test2b s (utf32->string (string->utf32 s 'little) 'little #f)))))))
+)
+
+(mat string<->bytevector-conversions
+ ; adapted with minor modifications from bv2string.sch, which is:
+ ;
+ ; Copyright 2007 William D Clinger.
+ ;
+ ; Permission to copy this software, in whole or in part, to use this
+ ; software for any lawful purpose, and to redistribute this software
+ ; is granted subject to the restriction that all copies made of this
+ ; software must include this copyright notice in full.
+ ;
+ ; I also request that you send me a copy of any improvements that you
+ ; make to this software so that they may be incorporated within it to
+ ; the benefit of the Scheme community.
+  (begin
+    (library (bv2string) (export main)
+      (import (rnrs base)
+              (rnrs unicode)
+              (rename (rnrs bytevectors)
+                (utf8->string rnrs:utf8->string)
+                (string->utf8 rnrs:string->utf8))
+              (rnrs control)
+              (rnrs io simple)
+              (rnrs mutable-strings))
+
+      ; Crude test rig, just for benchmarking.
+
+      (define utf8->string)
+      (define string->utf8)
+
+      (define (test name actual expected)
+        (if (not (equal? actual expected))
+            (error 'test name)))
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;
+      ; The R6RS doesn't specify exactly how many replacement
+      ; characters get generated by an encoding or decoding error,
+      ; so the results of some tests are compared by treating any
+      ; sequence of consecutive replacement characters the same as
+      ; a single replacement character.
+      ;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (string~? s1 s2)
+        (define (replacement? c)
+          (char=? c #\xfffd))
+        (define (canonicalized s)
+          (let loop ((rchars (reverse (string->list s)))
+                     (cchars '()))
+            (cond ((or (null? rchars) (null? (cdr rchars)))
+                   (list->string cchars))
+                  ((and (replacement? (car rchars))
+                        (replacement? (cadr rchars)))
+                   (loop (cdr rchars) cchars))
+                  (else
+                   (loop (cdr rchars) (cons (car rchars) cchars))))))
+        (string=? (canonicalized s1) (canonicalized s2)))
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;
+      ; Basic sanity tests, followed by stress tests on random inputs.
+      ;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (string-bytevector-tests
+               *random-stress-tests* *random-stress-test-max-size*)
+
+        (define (test-roundtrip bvec tostring tobvec)
+          (let* ((s1 (tostring bvec))
+                 (b2 (tobvec s1))
+                 (s2 (tostring b2)))
+            (test "round trip of string conversion" (string=? s1 s2) #t)))
+
+        ; This random number generator doesn't have to be good.
+        ; It just has to be fast.
+
+        (define random
+          (letrec ((random14
+                    (lambda (n)
+                      (set! x (mod (+ (* a x) c) (+ m 1)))
+                      (mod (div x 8) n)))
+                   (a 701)
+                   (x 1)
+                   (c 743483)
+                   (m 524287)
+                   (loop
+                    (lambda (q r n)
+                      (if (zero? q)
+                          (mod r n)
+                          (loop (div q 16384)
+                                (+ (* 16384 r) (random14 16384))
+                                n)))))
+            (lambda (n)
+              (if (< n 16384)
+                  (random14 n)
+                  (loop (div n 16384) (random14 16384) n)))))
+       
+        ; Returns a random bytevector of length up to n.
+
+        (define (random-bytevector n)
+          (let* ((n (random n))
+                 (bv (make-bytevector n)))
+            (do ((i 0 (+ i 1)))
+                ((= i n) bv)
+              (bytevector-u8-set! bv i (random 256)))))
+
+        ; Returns a random bytevector of even length up to n.
+
+        (define (random-bytevector2 n)
+          (let* ((n (random n))
+                 (n (if (odd? n) (+ n 1) n))
+                 (bv (make-bytevector n)))
+            (do ((i 0 (+ i 1)))
+                ((= i n) bv)
+              (bytevector-u8-set! bv i (random 256)))))
+
+        ; Returns a random bytevector of multiple-of-4 length up to n.
+
+        (define (random-bytevector4 n)
+          (let* ((n (random n))
+                 (n (* 4 (round (/ n 4))))
+                 (bv (make-bytevector n)))
+            (do ((i 0 (+ i 1)))
+                ((= i n) bv)
+              (bytevector-u8-set! bv i (random 256)))))
+
+        (test "utf-8, BMP"
+              (bytevector=? (string->utf8 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
+                            '#vu8(#x6b
+                                  #x7f
+                                  #b11000010 #b10000000
+                                  #b11011111 #b10111111
+                                  #b11100000 #b10100000 #b10000000
+                                  #b11101111 #b10111111 #b10111111))
+              #t)
+
+        (test "utf-8, supplemental"
+              (bytevector=? (string->utf8 "\x010000;\x10ffff;")
+                            '#vu8(#b11110000 #b10010000 #b10000000 #b10000000
+                                  #b11110100 #b10001111 #b10111111 #b10111111))
+              #t)
+
+        (test "utf-8, errors 1"
+              (string~? (utf8->string '#vu8(#x61                             ; a
+                                            #xc0 #x62                        ; ?b
+                                            #xc1 #x63                        ; ?c
+                                            #xc2 #x64                        ; ?d
+                                            #x80 #x65                        ; ?e
+                                            #xc0 #xc0 #x66                   ; ??f
+                                            #xe0 #x67                        ; ?g
+                                           ))
+                        "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e\xfffd;\xfffd;f\xfffd;g")
+              #t)
+
+        (test "utf-8, errors 2"
+              (string~? (utf8->string '#vu8(#xe0 #x80 #x80 #x68              ; ???h
+                                            #xe0 #xc0 #x80 #x69              ; ???i
+                                            #xf0 #x6a                        ; ?j
+                                           ))
+                        "\xfffd;\xfffd;\xfffd;h\xfffd;\xfffd;\xfffd;i\xfffd;j")
+              #t)
+
+        (test "utf-8, errors 3"
+              (string~? (utf8->string '#vu8(#x61                             ; a
+                                            #xf0 #x80 #x80 #x80 #x62         ; ????b
+                                            #xf0 #x90 #x80 #x80 #x63         ; .c
+                                           ))
+                        "a\xfffd;\xfffd;\xfffd;\xfffd;b\x10000;c")
+              #t)
+
+        (test "utf-8, errors 4"
+              (string~? (utf8->string '#vu8(#x61                             ; a
+                                            #xf0 #xbf #xbf #xbf #x64         ; .d
+                                            #xf0 #xbf #xbf #x65              ; ?e
+                                            #xf0 #xbf #x66                   ; ?f
+                                           ))
+                        "a\x3ffff;d\xfffd;e\xfffd;f")
+              #t)
+
+        (test "utf-8, errors 5"
+              (string~? (utf8->string '#vu8(#x61                             ; a
+                                            #xf4 #x8f #xbf #xbf #x62         ; .b
+                                            #xf4 #x90 #x80 #x80 #x63         ; ????c
+                                           ))
+
+                        "a\x10ffff;b\xfffd;\xfffd;\xfffd;\xfffd;c")
+              #t)
+
+        (test "utf-8, errors 6"
+              (string~? (utf8->string '#vu8(#x61                             ; a
+                                            #xf5 #x80 #x80 #x80 #x64         ; ????d
+                                           ))
+
+                        "a\xfffd;\xfffd;\xfffd;\xfffd;d")
+              #t)
+
+        ; ignores BOM signature
+        ; Officially, there is no BOM signature for UTF-8,
+        ; so this test is commented out.
+
+      #;(test "utf-8, BOM"
+              (string=? (utf8->string '#vu8(#xef #xbb #xbf #x61 #x62 #x63 #x64))
+                        "abcd")
+              #t)
+
+        (test-roundtrip (random-bytevector 10) utf8->string string->utf8)
+
+        (do ((i 0 (+ i 1)))
+            ((= i *random-stress-tests*))
+          (test-roundtrip (random-bytevector *random-stress-test-max-size*)
+                          utf8->string string->utf8))
+
+        (test "utf-16, BMP"
+              (bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
+                            '#vu8(#x00 #x6b
+                                  #x00 #x7f
+                                  #x00 #x80
+                                  #x07 #xff
+                                  #x08 #x00
+                                  #xff #xff))
+              #t)
+
+        (test "utf-16le, BMP"
+              (bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                                           'little)
+                            '#vu8(#x6b #x00
+                                  #x7f #x00
+                                  #x80 #x00
+                                  #xff #x07
+                                  #x00 #x08
+                                  #xff #xff))
+              #t)
+
+        (test "utf-16, supplemental"
+              (bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;")
+                            '#vu8(#xd8 #x00 #xdc #x00
+                                  #xdb #xb7 #xdc #xba
+                                  #xdb #xff #xdf #xff))
+              #t)
+
+        (test "utf-16le, supplemental"
+              (bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;" 'little)
+                            '#vu8(#x00 #xd8 #x00 #xdc
+                                  #xb7 #xdb #xba #xdc
+                                  #xff #xdb #xff #xdf))
+              #t)
+
+        (test "utf-16be"
+              (bytevector=? (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd")
+                            (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd" 'big))
+              #t)
+
+        (test "utf-16, errors 1"
+              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                        (utf16->string
+                         '#vu8(#x00 #x6b
+                               #x00 #x7f
+                               #x00 #x80
+                               #x07 #xff
+                               #x08 #x00
+                               #xff #xff)
+                         'big))
+              #t)
+
+        (test "utf-16, errors 2"
+              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                        (utf16->string
+                         '#vu8(#x00 #x6b
+                               #x00 #x7f
+                               #x00 #x80
+                               #x07 #xff
+                               #x08 #x00
+                               #xff #xff)
+                         'big #t))
+              #t)
+
+        (test "utf-16, errors 3"
+              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                        (utf16->string
+                         '#vu8(#xfe #xff     ; big-endian BOM
+                               #x00 #x6b
+                               #x00 #x7f
+                               #x00 #x80
+                               #x07 #xff
+                               #x08 #x00
+                               #xff #xff)
+                         'big))
+              #t)
+
+        (test "utf-16, errors 4"
+              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                        (utf16->string
+                         '#vu8(#x6b #x00
+                               #x7f #x00
+                               #x80 #x00
+                               #xff #x07
+                               #x00 #x08
+                               #xff #xff)
+                         'little #t))
+              #t)
+
+        (test "utf-16, errors 5"
+              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
+                        (utf16->string
+                         '#vu8(#xff #xfe     ; little-endian BOM
+                               #x6b #x00
+                               #x7f #x00
+                               #x80 #x00
+                               #xff #x07
+                               #x00 #x08
+                               #xff #xff)
+                         'big))
+              #t)
+
+        (let ((tostring        (lambda (bv) (utf16->string bv 'big)))
+              (tostring-big    (lambda (bv) (utf16->string bv 'big #t)))
+              (tostring-little (lambda (bv) (utf16->string bv 'little #t)))
+              (tobvec          string->utf16)
+              (tobvec-big      (lambda (s) (string->utf16 s 'big)))
+              (tobvec-little   (lambda (s) (string->utf16 s 'little))))
+
+          (do ((i 0 (+ i 1)))
+              ((= i *random-stress-tests*))
+            (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
+                            tostring tobvec)
+            (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
+                            tostring-big tobvec-big)
+            (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
+                            tostring-little tobvec-little)))
+
+        (test "utf-32"
+              (bytevector=? (string->utf32 "abc")
+                            '#vu8(#x00 #x00 #x00 #x61
+                                  #x00 #x00 #x00 #x62
+                                  #x00 #x00 #x00 #x63))
+              #t)
+
+        (test "utf-32be"
+              (bytevector=? (string->utf32 "abc" 'big)
+                            '#vu8(#x00 #x00 #x00 #x61
+                                  #x00 #x00 #x00 #x62
+                                  #x00 #x00 #x00 #x63))
+              #t)
+
+        (test "utf-32le"
+              (bytevector=? (string->utf32 "abc" 'little)
+                            '#vu8(#x61 #x00 #x00 #x00
+                                  #x62 #x00 #x00 #x00
+                                  #x63 #x00 #x00 #x00))
+              #t)
+
+        (test "utf-32, errors 1"
+              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)
+                         'big))
+              #t)
+
+        (test "utf-32, errors 2"
+              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)
+                         'big #t))
+              #t)
+
+        (test "utf-32, errors 3"
+              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#x00 #x00 #xfe #xff   ; big-endian BOM
+                               #x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)
+                         'big))
+              #t)
+
+        (test "utf-32, errors 4"
+              (string~? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#x00 #x00 #xfe #xff   ; big-endian BOM
+                               #x00 #x00 #x00 #x61
+                               #x00 #x00 #xd9 #x00
+                               #x00 #x00 #x00 #x62
+                               #x00 #x00 #xdd #xab
+                               #x00 #x00 #x00 #x63
+                               #x00 #x11 #x00 #x00
+                               #x00 #x00 #x00 #x64
+                               #x01 #x00 #x00 #x65
+                               #x00 #x00 #x00 #x65)
+                         'big #t))
+              #t)
+
+        (test "utf-32, errors 5"
+              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#x61 #x00 #x00 #x00
+                               #x00 #xd9 #x00 #x00
+                               #x62 #x00 #x00 #x00
+                               #xab #xdd #x00 #x00
+                               #x63 #x00 #x00 #x00
+                               #x00 #x00 #x11 #x00
+                               #x64 #x00 #x00 #x00
+                               #x65 #x00 #x00 #x01
+                               #x65 #x00 #x00 #x00)
+                         'little #t))
+              #t)
+
+        (test "utf-32, errors 6"
+              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#xff #xfe #x00 #x00   ; little-endian BOM
+                               #x61 #x00 #x00 #x00
+                               #x00 #xd9 #x00 #x00
+                               #x62 #x00 #x00 #x00
+                               #xab #xdd #x00 #x00
+                               #x63 #x00 #x00 #x00
+                               #x00 #x00 #x11 #x00
+                               #x64 #x00 #x00 #x00
+                               #x65 #x00 #x00 #x01
+                               #x65 #x00 #x00 #x00)
+                         'big))
+              #t)
+
+        (test "utf-32, errors 7"
+              (string~? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
+                        (utf32->string
+                         '#vu8(#xff #xfe #x00 #x00   ; little-endian BOM
+                               #x61 #x00 #x00 #x00
+                               #x00 #xd9 #x00 #x00
+                               #x62 #x00 #x00 #x00
+                               #xab #xdd #x00 #x00
+                               #x63 #x00 #x00 #x00
+                               #x00 #x00 #x11 #x00
+                               #x64 #x00 #x00 #x00
+                               #x65 #x00 #x00 #x01
+                               #x65 #x00 #x00 #x00)
+                         'little #t))
+              #t)
+
+        (let ((tostring        (lambda (bv) (utf32->string bv 'big)))
+              (tostring-big    (lambda (bv) (utf32->string bv 'big #t)))
+              (tostring-little (lambda (bv) (utf32->string bv 'little #t)))
+              (tobvec          string->utf32)
+              (tobvec-big      (lambda (s) (string->utf32 s 'big)))
+              (tobvec-little   (lambda (s) (string->utf32 s 'little))))
+
+          (do ((i 0 (+ i 1)))
+              ((= i *random-stress-tests*))
+            (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
+                            tostring tobvec)
+            (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
+                            tostring-big tobvec-big)
+            (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
+                            tostring-little tobvec-little)))
+
+      )
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;
+      ; Exhaustive tests.
+      ;
+      ; Tests string <-> bytevector conversion on strings
+      ; that contain every Unicode scalar value.
+      ;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (exhaustive-string-bytevector-tests)
+
+        ; Tests throughout an inclusive range.
+
+        (define (test-char-range lo hi tostring tobytevector)
+          (let* ((n (+ 1 (- hi lo)))
+                 (s (make-string n))
+                 (replacement-character (integer->char #xfffd)))
+            (do ((i lo (+ i 1)))
+                ((> i hi))
+              (let ((c (if (or (<= 0 i #xd7ff)
+                               (<= #xe000 i #x10ffff))
+                           (integer->char i)
+                           replacement-character)))
+                (string-set! s (- i lo) c)))
+            (test "test of long string conversion"
+                  (string=? (tostring (tobytevector s)) s) #t)))
+
+        (define (test-exhaustively name tostring tobytevector)
+         ;(display "Testing ")
+         ;(display name)
+         ;(display " conversions...")
+         ;(newline)
+          (test-char-range 0 #xffff tostring tobytevector)
+          (test-char-range #x10000 #x1ffff tostring tobytevector)
+          (test-char-range #x20000 #x2ffff tostring tobytevector)
+          (test-char-range #x30000 #x3ffff tostring tobytevector)
+          (test-char-range #x40000 #x4ffff tostring tobytevector)
+          (test-char-range #x50000 #x5ffff tostring tobytevector)
+          (test-char-range #x60000 #x6ffff tostring tobytevector)
+          (test-char-range #x70000 #x7ffff tostring tobytevector)
+          (test-char-range #x80000 #x8ffff tostring tobytevector)
+          (test-char-range #x90000 #x9ffff tostring tobytevector)
+          (test-char-range #xa0000 #xaffff tostring tobytevector)
+          (test-char-range #xb0000 #xbffff tostring tobytevector)
+          (test-char-range #xc0000 #xcffff tostring tobytevector)
+          (test-char-range #xd0000 #xdffff tostring tobytevector)
+          (test-char-range #xe0000 #xeffff tostring tobytevector)
+          (test-char-range #xf0000 #xfffff tostring tobytevector)
+          (test-char-range #x100000 #x10ffff tostring tobytevector))
+
+        ; Feel free to replace this with your favorite timing macro.
+
+        (define (timeit x) x)
+
+        (timeit (test-exhaustively "UTF-8" utf8->string string->utf8))
+
+        ; NOTE:  An unfortunate misunderstanding led to a late deletion
+        ; of single-argument utf16->string from the R6RS.  To get the
+        ; correct effect of single-argument utf16->string, you have to
+        ; use two arguments, as below.
+        ;
+        ;(timeit (test-exhaustively "UTF-16" utf16->string string->utf16))
+
+        (timeit (test-exhaustively "UTF-16"
+                                   (lambda (bv) (utf16->string bv 'big))
+                                   string->utf16))
+
+        ; NOTE:  To get the correct effect of two-argument utf16->string,
+        ; you have to use three arguments, as below.
+
+        (timeit (test-exhaustively "UTF-16BE"
+                                   (lambda (bv) (utf16->string bv 'big #t))
+                                   (lambda (s) (string->utf16 s 'big))))
+
+        (timeit (test-exhaustively "UTF-16LE"
+                                   (lambda (bv) (utf16->string bv 'little #t))
+                                   (lambda (s) (string->utf16 s 'little))))
+
+        ; NOTE:  An unfortunate misunderstanding led to a late deletion
+        ; of single-argument utf32->string from the R6RS.  To get the
+        ; correct effect of single-argument utf32->string, you have to
+        ; use two arguments, as below.
+        ;
+        ;(timeit (test-exhaustively "UTF-32" utf32->string string->utf32))
+
+        (timeit (test-exhaustively "UTF-32"
+                                   (lambda (bv) (utf32->string bv 'big))
+                                   string->utf32))
+
+        ; NOTE:  To get the correct effect of two-argument utf32->string,
+        ; you have to use three arguments, as below.
+
+        (timeit (test-exhaustively "UTF-32BE"
+                                   (lambda (bv) (utf32->string bv 'big #t))
+                                   (lambda (s) (string->utf32 s 'big))))
+
+        (timeit (test-exhaustively "UTF-32LE"
+                                   (lambda (bv) (utf32->string bv 'little #t))
+                                   (lambda (s) (string->utf32 s 'little)))))
+
+      (define (main p1 p2)
+        (set! utf8->string p1)
+        (set! string->utf8 p2)
+        (string-bytevector-tests 2 1000)
+        (exhaustive-string-bytevector-tests)))
+    #t)
+ ; first test w/built-in utf8->string and string->utf8
+  (begin
+    (let () (import (bv2string)) (main utf8->string string->utf8))
+    #t)
+ ; next test w/utf8->string and string->utf8 synthesized from utf-8-codec
+  (let ()
+    (define (utf8->string bv)
+      (get-string-all (open-bytevector-input-port bv
+                        (make-transcoder (utf-8-codec) 'none))))
+    (define (string->utf8 s)
+      (let-values ([(op get) (open-bytevector-output-port
+                               (make-transcoder (utf-8-codec) 'none))])
+        (put-string op s)
+        (get)))
+    (let () (import (bv2string)) (main utf8->string string->utf8))
+    #t)
+)
+
+(mat open-process-ports ; see also unix.ms (mat nonblocking ...)
+  (begin
+    (define ($check-port p xput-port? bt-port?)
+      (define-syntax err? 
+        (syntax-rules ()
+          [(_ e1 e2 ...) (guard (c [#t #t]) e1 e2 ... #f)]))
+      (unless (and (xput-port? p) (bt-port? p) (file-port? p))
+        (errorf #f "~s is not as it should be" p))
+      (let ([fd (port-file-descriptor p)])
+        (unless (fixnum? fd)
+          (errorf #f "unexpected file descriptor ~s" fd)))
+      (when (or (port-has-port-position? p)
+                (port-has-set-port-position!? p)
+                (port-has-port-length? p)
+                (port-has-set-port-length!? p))
+        (errorf #f "unexpected port-has-xxx results for ~s" p))
+      (unless (and (err? (port-position p))
+                   (err? (set-port-position! p 0))
+                   (err? (port-length p))
+                   (err? (set-port-length! p 0)))
+        (errorf #f "no error for getting/setting port position/length on ~s" p)))
+    (define $emit-dot
+      (let ([n 0])
+        (lambda ()
+          (display ".")
+          (set! n (modulo (+ n 1) 72))
+          (when (= n 0) (newline))
+          (flush-output-port))))
+    #t)
+ ; test binary ports
+  (let-values ([(to-stdin from-stdout from-stderr pid)
+                (open-process-ports (patch-exec-path $cat_flush))])
+    (define put-string
+      (lambda (bp s)
+        (put-bytevector bp (string->utf8 s))))
+    (define get-string-some
+      (lambda (bp)
+        (let ([x (get-bytevector-some bp)])
+          (if (eof-object? x) x (utf8->string x)))))
+    (define get-string-n
+      (lambda (bp n)
+        (let ([x (get-bytevector-n bp n)])
+          (if (eof-object? x) x (utf8->string x)))))
+    (dynamic-wind
+      void
+      (lambda ()
+        (put-string to-stdin "life in the fast lane\n")
+        (flush-output-port to-stdin)
+        (let f ()
+          ($check-port to-stdin output-port? binary-port?)
+          ($check-port from-stdout input-port? binary-port?)
+          ($check-port from-stderr input-port? binary-port?)
+          (when (input-port-ready? from-stderr)
+            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+          (if (input-port-ready? from-stdout)
+              (let ([s (get-string-n from-stdout 10)])
+                (unless (equal? s "life in th")
+                  (errorf #f "unexpected from-stdout string ~s" s)))
+              (begin
+                ($emit-dot)
+                (f))))
+        (let f ([all ""])
+          (unless (equal? all "e fast lane\n")
+            (when (input-port-ready? from-stderr)
+              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+            (let ([s (get-string-some from-stdout)])
+              ($emit-dot)
+              (f (string-append all s)))))
+        (and
+          (not (input-port-ready? from-stderr))
+          (not (input-port-ready? from-stdout))
+          (begin
+            (close-port to-stdin)
+            (let f ()
+              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
+                ($emit-dot)
+                (f)))
+            #t)))
+      (lambda ()
+        (close-port to-stdin)
+        (close-port from-stdout)
+        (close-port from-stderr))))
+ ; test binary ports w/buffer-mode none
+  (let-values ([(to-stdin from-stdout from-stderr pid)
+                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode none))])
+    (define put-string
+      (lambda (bp s)
+        (put-bytevector bp (string->utf8 s))))
+    (define get-string-some
+      (lambda (bp)
+        (let ([x (get-bytevector-some bp)])
+          (if (eof-object? x) x (utf8->string x)))))
+    (define get-string-n
+      (lambda (bp n)
+        (let ([x (get-bytevector-n bp n)])
+          (if (eof-object? x) x (utf8->string x)))))
+    (dynamic-wind
+      void
+      (lambda ()
+        ($check-port to-stdin output-port? binary-port?)
+        ($check-port from-stdout input-port? binary-port?)
+        ($check-port from-stderr input-port? binary-port?)
+        (put-string to-stdin "life in the fast lane\n")
+        (flush-output-port to-stdin)
+        (let f ()
+          (when (input-port-ready? from-stderr)
+            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+          (if (input-port-ready? from-stdout)
+              (let ([s (get-string-n from-stdout 10)])
+                (unless (equal? s "life in th")
+                  (errorf #f "unexpected from-stdout string ~s" s)))
+              (begin
+                ($emit-dot)
+                (f))))
+        (let f ([all ""])
+          (unless (equal? all "e fast lane\n")
+            (when (input-port-ready? from-stderr)
+              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+            (let ([s (get-string-some from-stdout)])
+              ($emit-dot)
+              (f (string-append all s)))))
+        (and
+          (not (input-port-ready? from-stderr))
+          (not (input-port-ready? from-stdout))
+          (begin
+            (close-port to-stdin)
+            (let f ()
+              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
+                ($emit-dot)
+                (f)))
+            #t)))
+      (lambda ()
+        (close-port to-stdin)
+        (close-port from-stdout)
+        (close-port from-stderr))))
+ ; test textual ports
+  (let-values ([(to-stdin from-stdout from-stderr pid)
+                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode block) (native-transcoder))])
+    (dynamic-wind
+      void
+      (lambda ()
+        ($check-port to-stdin output-port? textual-port?)
+        ($check-port from-stdout input-port? textual-port?)
+        ($check-port from-stderr input-port? textual-port?)
+        (put-string to-stdin "life in the fast lane\n")
+        (flush-output-port to-stdin)
+        (let f ()
+          (when (input-port-ready? from-stderr)
+            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+          (if (input-port-ready? from-stdout)
+              (let ([s (get-string-n from-stdout 10)])
+                (unless (equal? s "life in th")
+                  (errorf #f "unexpected from-stdout string ~s" s)))
+              (begin
+                ($emit-dot)
+                (f))))
+        (let f ([all ""])
+          (unless (equal? all "e fast lane\n")
+            (when (input-port-ready? from-stderr)
+              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+            (let ([s (get-string-some from-stdout)])
+              ($emit-dot)
+              (f (string-append all s)))))
+        (and
+          (not (input-port-ready? from-stderr))
+          (not (input-port-ready? from-stdout))
+          (begin
+            (close-port to-stdin)
+            (let f ()
+              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
+                ($emit-dot)
+                (f)))
+            #t)))
+      (lambda ()
+        (close-port to-stdin)
+        (close-port from-stdout)
+        (close-port from-stderr))))
+ ; test textual ports w/buffer-mode none
+  (let-values ([(to-stdin from-stdout from-stderr pid)
+                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode none) (native-transcoder))])
+    (dynamic-wind
+      void
+      (lambda ()
+        ($check-port to-stdin output-port? textual-port?)
+        ($check-port from-stdout input-port? textual-port?)
+        ($check-port from-stderr input-port? textual-port?)
+        (put-string to-stdin "life in the fast lane\n")
+        (flush-output-port to-stdin)
+        (let f ()
+          (when (input-port-ready? from-stderr)
+            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+          (if (input-port-ready? from-stdout)
+              (let ([s (get-string-n from-stdout 10)])
+                (unless (equal? s "life in th")
+                  (errorf #f "unexpected from-stdout string ~s" s)))
+              (begin
+                ($emit-dot)
+                (f))))
+        (let f ([all ""])
+          (unless (equal? all "e fast lane\n")
+            (when (input-port-ready? from-stderr)
+              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+            (let ([s (get-string-some from-stdout)])
+              ($emit-dot)
+              (f (string-append all s)))))
+        (and
+          (not (input-port-ready? from-stderr))
+          (not (input-port-ready? from-stdout))
+          (begin
+            (close-port to-stdin)
+            (let f ()
+              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
+                ($emit-dot)
+                (f)))
+            #t)))
+      (lambda ()
+        (close-port to-stdin)
+        (close-port from-stdout)
+        (close-port from-stderr))))
+ ; test textual ports w/buffer-mode line
+  (let-values ([(to-stdin from-stdout from-stderr pid)
+                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode line) (native-transcoder))])
+    (dynamic-wind
+      void
+      (lambda ()
+        ($check-port to-stdin output-port? textual-port?)
+        ($check-port from-stdout input-port? textual-port?)
+        ($check-port from-stderr input-port? textual-port?)
+        (put-string to-stdin "life in the fast lane\n")
+        (flush-output-port to-stdin)
+        (let f ()
+          (when (input-port-ready? from-stderr)
+            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+          (if (input-port-ready? from-stdout)
+              (let ([s (get-string-n from-stdout 10)])
+                (unless (equal? s "life in th")
+                  (errorf #f "unexpected from-stdout string ~s" s)))
+              (begin
+                ($emit-dot)
+                (f))))
+        (let f ([all ""])
+          (unless (equal? all "e fast lane\n")
+            (when (input-port-ready? from-stderr)
+              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
+            (let ([s (get-string-some from-stdout)])
+              ($emit-dot)
+              (f (string-append all s)))))
+        (and
+          (not (input-port-ready? from-stderr))
+          (not (input-port-ready? from-stdout))
+          (begin
+            (close-port to-stdin)
+            (let f ()
+              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
+                ($emit-dot)
+                (f)))
+            #t)))
+      (lambda ()
+        (close-port to-stdin)
+        (close-port from-stdout)
+        (close-port from-stderr))))
+)
+
+(mat to-fold-or-not-to-fold
+  (begin
+    (define ($readit cs? s)
+      (define (string-append* s1 . ls)
+        (let f ([s1 s1] [ls ls] [n 0])
+          (let ([n1 (string-length s1)])
+            (if (null? ls)
+                (let ([s (make-string (fx+ n n1))])
+                  (string-copy! s1 0 s n n1)
+                  s)
+                (let ([s (f (car ls) (cdr ls) (fx+ n n1 1))])
+                  (string-copy! s1 0 s n n1)
+                  (string-set! s (fx+ n n1) #\$)
+                  s)))))
+      (apply string-append*
+        (let ([sip (open-input-string s)])
+          (parameterize ([case-sensitive cs?])
+            (let f ()
+              (let ([x (get-datum sip)])
+                (if (eof-object? x)
+                    '()
+                    (cons (cond
+                            [(gensym? x)
+                             (string-append (symbol->string x) "%"
+                               (gensym->unique-string x))]
+                            [(symbol? x) (symbol->string x)]
+                            [(char? x) (string x)]
+                            [else (error 'string-append* "unexpected ~s" x)])
+                          (f)))))))))
+    #t)
+  (case-sensitive)
+  (equal?
+    ($readit #t "To be or NOT to bE")
+    "To$be$or$NOT$to$bE")
+  (equal?
+    ($readit #f "To be or NOT to bE")
+    "to$be$or$not$to$be")
+  (equal?
+    ($readit #t "To be #!no-fold-case or NOT #!fold-case to bE")
+    "To$be$or$NOT$to$be")
+  (equal?
+    ($readit #t "To be #!fold-case or NOT #!no-fold-case to bE")
+    "To$be$or$not$to$bE")
+  (equal?
+    ($readit #f "To be #!no-fold-case or NOT #!fold-case to bE")
+    "to$be$or$NOT$to$be")
+  (equal?
+    ($readit #f "To be #!fold-case or NOT #!no-fold-case to bE")
+    "to$be$or$not$to$bE")
+ ; check delimiting
+  (equal?
+    ($readit #f "To be#!fold-caseor NOT#!no-fold-caseto bE")
+    "to$be$or$not$to$bE")
+ ; verify case folding is not disabled when Unicode hex escape seen
+  (equal?
+    ($readit #t "ab\\x43;de")
+    "abCde")
+  (equal?
+    ($readit #f "ab\\x43;de")
+    "abcde")
+  (equal?
+    ($readit #t "#!fold-case ab\\x43;de")
+    "abcde")
+  (equal?
+    ($readit #f "#!fold-case ab\\x43;de")
+    "abcde")
+  (equal?
+    ($readit #t "#!no-fold-case ab\\x43;de")
+    "abCde")
+  (equal?
+    ($readit #f "#!no-fold-case ab\\x43;de")
+    "abCde")
+ ; verify case folding still works when string changes size
+  (equal?
+    ($readit #t "Stra\xDF;e #!no-fold-case Stra\xDF;e #!fold-case Stra\xDF;e")
+    "Stra\xDF;e$Stra\xDF;e$strasse")
+  (equal?
+    ($readit #f "Stra\xDF;e #!no-fold-case Stra\xDF;e #!fold-case Stra\xDF;e")
+    "strasse$Stra\xDF;e$strasse")
+  (equal?
+    ($readit #t "Stra\xDF;e #!fold-case Stra\xDF;e #!no-fold-case Stra\xDF;e")
+    "Stra\xDF;e$strasse$Stra\xDF;e")
+  (equal?
+    ($readit #f "Stra\xDF;e #!fold-case Stra\xDF;e #!no-fold-case Stra\xDF;e")
+    "strasse$strasse$Stra\xDF;e")
+  (equal?
+    ($readit #t "Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
+    "Aab CdE$abCD eFg$#Ab C$aB cd")
+ ; verify case folding is disabled when vertical bars or backslashes
+ ; (other than those for Unicode hex escapes) appear
+  (equal?
+    ($readit #f "Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
+    "Aab CdE$abCD eFg$#Ab C$aB cd")
+  (equal?
+    ($readit #t "#!fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
+    "Aab CdE$abCD eFg$#Ab C$aB cd")
+  (equal?
+    ($readit #f "#!fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
+    "Aab CdE$abCD eFg$#Ab C$aB cd")
+  (equal?
+    ($readit #t "#!no-fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
+    "Aab CdE$abCD eFg$#Ab C$aB cd")
+  (equal?
+    ($readit #f "#!no-fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
+    "Aab CdE$abCD eFg$#Ab C$aB cd")
+ ; verify proper case folding for gensyms
+  (equal?
+    ($readit #t "#{aBc DeF1}")
+    "aBc%DeF1")
+  (equal?
+    ($readit #f "#{aBc DeF2}")
+    "abc%def2")
+  (equal?
+    ($readit #t "#!fold-case #{aBc DeF3}")
+    "abc%def3")
+  (equal?
+    ($readit #f "#!fold-case #{aBc DeF4}")
+    "abc%def4")
+  (equal?
+    ($readit #t "#!no-fold-case #{aBc DeF5}")
+    "aBc%DeF5")
+  (equal?
+    ($readit #f "#!no-fold-case #{aBc DeF6}")
+    "aBc%DeF6")
+  (equal?
+    ($readit #t "#{aBc De\\F7}")
+    "aBc%DeF7")
+  (equal?
+    ($readit #f "#{aBc De\\F8}")
+    "abc%DeF8")
+  (equal?
+    ($readit #t "#!fold-case #{aBc De\\F9}")
+    "abc%DeF9")
+  (equal?
+    ($readit #f "#!fold-case #{aBc De\\F10}")
+    "abc%DeF10")
+  (equal?
+    ($readit #t "#!no-fold-case #{aBc De\\F11}")
+    "aBc%DeF11")
+  (equal?
+    ($readit #f "#!no-fold-case #{aBc De\\F12}")
+    "aBc%DeF12")
+  (equal?
+    ($readit #t "#{a\\Bc DeF13}")
+    "aBc%DeF13")
+  (equal?
+    ($readit #f "#{a\\Bc DeF14}")
+    "aBc%def14")
+  (equal?
+    ($readit #t "#!fold-case #{a\\Bc DeF15}")
+    "aBc%def15")
+  (equal?
+    ($readit #f "#!fold-case #{a\\Bc DeF16}")
+    "aBc%def16")
+  (equal?
+    ($readit #t "#!no-fold-case #{a\\Bc DeF17}")
+    "aBc%DeF17")
+  (equal?
+    ($readit #f "#!no-fold-case #{a\\Bc DeF18}")
+    "aBc%DeF18")
+  (equal?
+    ($readit #t "#{a\\Bc De\\F19}")
+    "aBc%DeF19")
+  (equal?
+    ($readit #f "#{a\\Bc De\\F20}")
+    "aBc%DeF20")
+  (equal?
+    ($readit #t "#!fold-case #{a\\Bc De\\F21}")
+    "aBc%DeF21")
+  (equal?
+    ($readit #f "#!fold-case #{a\\Bc De\\F22}")
+    "aBc%DeF22")
+  (equal?
+    ($readit #t "#!no-fold-case #{a\\Bc De\\F23}")
+    "aBc%DeF23")
+  (equal?
+    ($readit #f "#!no-fold-case #{a\\Bc De\\F24}")
+    "aBc%DeF24")
+  (equal?
+    ($readit #t "#\\newline")
+    "\n")
+  (equal?
+    ($readit #f "#\\newline")
+    "\n")
+  (equal?
+    ($readit #f "#!fold-case #\\newline")
+    "\n")
+  (equal?
+    ($readit #f "#!fold-case #\\newline")
+    "\n")
+  (equal?
+    ($readit #f "#!no-fold-case #\\newline")
+    "\n")
+  (equal?
+    ($readit #f "#!no-fold-case #\\newline")
+    "\n")
+  (error? ($readit #t "#\\newLine"))
+  (equal?
+    ($readit #f "#\\newLine")
+    "\n")
+  (equal?
+    ($readit #t "#!fold-case #\\newLine")
+    "\n")
+  (equal?
+    ($readit #f "#!fold-case #\\newLine")
+    "\n")
+  (error? ($readit #t "#!no-fold-case #\\newLine"))
+  (error? ($readit #f "#!no-fold-case #\\newLine"))
+)
diff --git a/mats/m4test.in b/mats/m4test.in
new file mode 100644
index 0000000..2fedcbd
--- /dev/null
+++ b/mats/m4test.in
@@ -0,0 +1,53 @@
+dnl m4test.in
+dnl Copyright 1984-2017 Cisco Systems, Inc.
+dnl 
+dnl Licensed under the Apache License, Version 2.0 (the "License");
+dnl you may not use this file except in compliance with the License.
+dnl You may obtain a copy of the License at
+dnl 
+dnl http://www.apache.org/licenses/LICENSE-2.0
+dnl 
+dnl Unless required by applicable law or agreed to in writing, software
+dnl distributed under the License is distributed on an "AS IS" BASIS,
+dnl WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+dnl See the License for the specific language governing permissions and
+dnl limitations under the License.
+dnl
+dnl a small excerpt from the delta 68k .m4 file that nonetheless strains
+dnl m4 pretty well.  use "make bullym4test.in" to test more fully, if you
+dnl have the time.
+
+changequote({,})
+
+dnl delta assembler does not support register masks; must convert to constant
+define(PUSHREGS,{moveml REGMASK({$1},{A7FIRST}),DEC(SP)})
+define(POPREGS,{moveml INC(SP),REGMASK({$1},{D0FIRST})})
+define(STOREREGS,{moveml REGMASK({$1},{D0FIRST}),{$2}})
+define(LOADREGS,{moveml {$2},REGMASK({$1},{D0FIRST})})
+define(REGMASK,{{&0x}HEXWORD(eval(REGMASK1({$1}/,0,{$2})))})
+define(REGMASK1,{
+  ifelse(
+    $2,len({$1}),
+      {0},
+    substr({$1},eval($2+2),1),-,
+      {REGRANGE(substr({$1},$2,1),
+                substr({$1},eval($2+1),1),
+                substr({$1},eval($2+4),1),
+                {$3}) +
+       REGMASK1({$1},eval($2+6),{$3})},
+      {$3(substr({$1},$2,1),substr({$1},eval($2+1),1)) +
+       REGMASK1({$1},eval($2+3),{$3})})})
+define(REGRANGE,{$4($1,$2)+ifelse($2,$3,{0},{REGRANGE($1,incr($2),$3,{$4})})})
+define(A7FIRST,{(2**(ifelse($1,D,15,7)-$2))})
+define(D0FIRST,{(2**(ifelse($1,A,8,0)+$2))})
+
+dnl used to pretty up register mask
+define(HEXLONG,{HEXIFY($1,0)})
+define(HEXWORD,{HEXIFY($1,4)})
+define(HEXBYTE,{HEXIFY($1,6)})
+define(HEXIFY,{ifelse($1,0,{substr(00000000,$2)},{HEXIFY(eval($1/16),incr($2)){}HEXDIGIT(eval($1%16))})})
+define(HEXDIGIT,{substr({0123456789abcdef},$1,1)})
+
+    PUSHREGS({D2-D7/A2-A6})
+
+    POPREGS({D2-D7/A2-A6})
diff --git a/mats/m4test.out b/mats/m4test.out
new file mode 100644
index 0000000..92ff6d5
--- /dev/null
+++ b/mats/m4test.out
@@ -0,0 +1,22 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+    moveml &0x3f3e,DEC(SP)
+
+    moveml INC(SP),&0x7cfc
diff --git a/mats/mat.ss b/mats/mat.ss
new file mode 100644
index 0000000..53acf0c
--- /dev/null
+++ b/mats/mat.ss
@@ -0,0 +1,578 @@
+;;; mat.ss
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;(eval-when (compile load eval) (current-expand sc-expand))
+(eval-when (compile) (optimize-level 2))
+
+(eval-when (load eval)
+  (define-syntax mat
+    (lambda (x)
+      (syntax-case x (parameters)
+        [(_ x (parameters [param val ...] ...) e ...)
+         #'(let f ([p* (list param ...)] [v** (list (list val ...) ...)])
+             (if (null? p*)
+                 (mat x e ...)
+                 (let ([p (car p*)])
+                   (for-each
+                     (lambda (v)
+                       (parameterize ([p v])
+                         (f (cdr p*) (cdr v**))))
+                     (car v**)))))]
+        [(_ x e ...)
+         (with-syntax ([(source ...)
+                        (map (lambda (clause)
+                               (let ([a (syntax->annotation clause)])
+                                 (and (annotation? a) (annotation-source a))))
+                             #'(e ...))])
+           #'(mat-run 'x '(e source) ...))]))))
+
+(define enable-cp0 (make-parameter #f))
+
+(define-syntax mat/cf
+  (syntax-rules (testfile)
+    [(_ (testfile ?path) expr ...)
+     (let* ([path ?path] [testfile.ss (format "~a.ss" path)] [testfile.so (format "~a.so" path)])
+       (with-output-to-file testfile.ss
+         (lambda () (begin (write 'expr) (newline)) ...)
+         'replace)
+       (parameterize ([generate-inspector-information #t])
+         (compile-file testfile.ss))
+       (load testfile.so)
+       #t)]
+    [(_ expr ...) (mat/cf (testfile "testfile") expr ...)]))
+
+(define mat-output (make-parameter (current-output-port)))
+
+(let ()
+
+(define mat-load
+  (lambda (in)
+    (call/cc
+      (lambda (k)
+        (parameterize ([reset-handler (lambda () (k #f))]
+                       [current-expand (current-expand)]
+                       [run-cp0
+                        (let ([default (run-cp0)])
+                          (lambda (cp0 x)
+                            (if (enable-cp0) (default cp0 x) x)))])
+          (with-exception-handler
+            (lambda (c)
+              (if (warning? c)
+                  (raise-continuable c)
+                  (begin
+                    (fprintf (mat-output) "Error reading mat input: ")
+                    (display-condition c (mat-output))
+                    (reset))))
+            (lambda () (load in))))))))
+
+(define mat-one-exp
+  (lambda (expect th sanitize-all?)
+    (define (sanitize-condition c)
+      (define sanitize
+        (lambda (arg)
+          (if sanitize-all?
+              (cond
+                [(port? arg) 'sanitized-port]
+                [else 'sanitized-unhandled-type])
+             ; go one level only to avoid getting bit by cyclic structures
+              (if (list? arg)
+                  (map sanitize1 arg)
+                  (sanitize1 arg)))))
+      (define sanitize1
+        (lambda (arg)
+         ; attempt to gloss over fixnum-size differences between
+         ; 32- and 64-bit versions
+          (cond
+            [(ftype-pointer? arg) ']
+            [(time? arg) '
    • 
+© 2005-2015 Cisco Systems, Inc.
    
+Licensed under the     Apache License Version 2.0.
    
+Revised April 2016 for Chez Scheme Version 9.3.4.
+